This is how this works:
1. I define all properties by name
2. All get/set methods are separated into get_<Name> and set_<Name>
3. The Utils::Properties helper class creates the <Name> method and a private <name> method (small cased), which eventually points to an element named {<name>}.
4. There's also a mechanism to index the properties (meaning $o->Names($i) = "My Name"), and the index values are being sent through an $o->Names_Index method, which returns the original @_ list.
Example:
$o->Names(10) = 10;
print @{$o->Names} . " elements";
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 $Deb
+ug;
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 $Deb
+ug;
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 `$fieldNam
+e'\n" if caller() ne $package;
shift->{$fieldName};
};
# Define index accessor method
*{$package."::$indexFieldName"} = sub {
die "Attempting to access private index field `$in
+dexFieldName'\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 constr
+uction time.
#####
if (exists $this->{$p}) {
#-- print STDERR "Property `$p' is already in
+itialized ($this->{$p})\n" if $Debug;
$placeHolder = $this->{$p};
}
$this->{$p} = \$placeHolder;
}
else {
# Field is being accessed directly.
}
}
return $this;
};
}
1;
A client class is:
package SuperTags::Tag;
use strict;
Utils::Properties::Register (
"Name",
"RegExp",
"Value",
"Values",
"NoValues",
"Levels",
"Position",
);
sub get_RegExp {
my $this = shift;
return $this->Name unless $this->regExp;
return $this->regExp;
}
sub get_Levels {
my $this = shift;
my ($index) = $this->Levels_Index;
if (defined $index) {
return $this->levels->[$index];
}
return $this->levels;
}
sub set_Levels {
my $this = shift;
my ($index) = $this->Levels_Index;
if (defined $index) {
$this->levels->[$index] = shift;
}
$this->levels = shift;
}
I'd like to know if there's ways to make it faster.
PerlDeveloper