package Utils::Properties; use strict; use warnings; use Attribute::Handlers; #-- our $Debug = 0; sub TIESCALAR { my $proto = shift; my $class = ref $proto || $proto; my $this = shift; bless ($this, $class); #-- print STDERR "Tied up... [$this->{get} / $this->{set}]\n" if $Debug; return $this; } sub STORE { my $this = shift; &{$this->{set}} ($this->{object}, @_); } sub FETCH { my $this = shift; &{$this->{get}} ($this->{object}); } sub Register { my $package = caller (); #-- print STDERR "Importing into package `$package'...\n" if $Debug; return unless scalar (@_); my %info = (); my @properties = @_; for my $propertyName (@properties) { my $name = ucfirst ($propertyName); my $fieldName = lcfirst ($propertyName); my $indexFieldName = $name . "_Index"; $propertyName = $name; #-- print STDERR "Registering property `$name'...\n" if $Debug; my $default_getter = sub { return shift->{$fieldName}; }; my $default_setter = sub { my $this = shift; $this->{$fieldName} = shift; }; my ($getter, $setter); no strict 'refs'; if (defined &{$package."::get_$name"}) { $getter = \&{$package. "::get_$name"}; $info{$name}{IsTied} = 1; } else { $getter = $default_getter; } if (defined &{$package."::set_$name"}) { $setter = \&{$package. "::set_$name"}; $info{$name}{IsTied} = 1; } else { $setter = $default_setter; } if ($info{$name}{IsTied}) { #-- print STDERR "+- Property is tied\n" if $Debug; # Define private field accessor method *{$package."::$fieldName"} = sub : lvalue { die "Attempting to access private field `$fieldName'\n" if caller() ne $package; shift->{$fieldName}; }; # Define index accessor method *{$package."::$indexFieldName"} = sub { die "Attempting to access private index field `$indexFieldName'\n" if caller() ne $package; return @{shift->{$indexFieldName}}; }; # Define public property accessor method *{$package."::$name"} = sub : lvalue { my $this = shift; $this->{$indexFieldName} = \@_; ${$this->{$name}}; }; $info{$name}{fieldName} = $fieldName; $info{$name}{get} = $getter; $info{$name}{set} = $setter; $info{$name}{index} = \&{$package."::$indexFieldName"}; } else { #-- print STDERR "+- Property is not tied\n" if $Debug; *{$package."::$name"} = sub : lvalue { shift->{$name} }; } } #################### # Update constructor ### no strict 'refs'; no warnings; my $constructor = 0; if (defined &{$package . "::new"}) { $constructor = \&{$package . "::new"}; } *{$package . "::new"} = sub { my $this; if ($constructor) { $this = &{$constructor}; } else { my $proto = shift; my $class = ref $proto || $proto; $this = shift || {}; bless ($this, $class); } for my $p (@properties) { if (exists $info{$p}{IsTied}) { my $placeHolder; #-- print STDERR "Tying `$p' up... [$info{$p}{get} / $info{$p}{set}]\n" if $Debug; my $options = { object => $this }; $options->{get} = $info{$p}{get}; $options->{set} = $info{$p}{set}; tie $placeHolder, __PACKAGE__, $options; ############################################################## # Reinitialize the value, if initialized at construction time. ##### if (exists $this->{$p}) { #-- print STDERR "Property `$p' is already initialized ($this->{$p})\n" if $Debug; $placeHolder = $this->{$p}; } $this->{$p} = \$placeHolder; } else { # Field is being accessed directly. } } return $this; }; } 1;