This is probably wrong for a whole bunch of reasons that I'm not educated enough to understand, but it works. Another way to do something similar would be package attributes. I really didn't have a need to do this as I was getting by OK writing individual methods, but the problem started gnawing at me too much. It's a hack, so please point out all the ways it could be done better so I can learn.
This automethod takes standard array accessors and enables push_*, pop_*, shift_*, unshift_* methods. It also allows the creation of new fields upon using their set_/get_ accessors. If 'array' is part of the name of the new field, it will get a :Type('ARRAY') attribute and the new methods will be available for it.
This could not have been done without the excellent capabilities and docs in OIO. Thanks Mr. Hedden.
sub _automethod :Automethod {
my $self = $_[0];
my $class = ref($self) || $self;
my $method = $_;
# Get meta data
my $meta = $self->meta();
my $meth = $meta->get_methods();
my ($action, $array_name) = $method =~ /^(push|pop|shift|unshift)_(.*)$/;
if ($array_name)
{
# Requires standard accessors
if ($meth->{"set_$array_name"}{'type'} =~ /list|array/ )
{
$array_name = "get_".$array_name;
my $handler;
if ( $action eq 'push' )
{
$handler = sub {
my $self = shift;
return ( push( @{ $self->$array_name }, @_ ) );
};
}
elsif ( $action eq 'pop' )
{
$handler = sub {
my $self = shift;
return ( pop( @{ $self->$array_name } ) );
};
}
elsif ( $action eq 'shift' )
{
$handler = sub {
my $self = shift;
return ( shift (@{ $self->$array_name } ) );
};
}
elsif ( $action eq 'unshift' )
{
$handler = sub {
my $self = shift;
return ( unshift( @{ $self->$array_name }, @_ ) );
};
}
### OPTIONAL ###
# Install the handler so it gets called directly next time
# no strict refs;
*{$class.'::'.$method} = $handler;
################
return ($handler);
}
else
{
return; # Not an array or unrecognized.
}
}
# Extract desired field name from get_/set_ method name
my ($fld_name) = $method =~ /^[gs]et_(.*)$/;
if (! $fld_name)
{
return; # Not a recognized method
}
else
{
my $attr;
# If field name has array, then set type.
$attr = " :Type('ARRAY') " if ( $fld_name =~ /array/i );
# Create the field and its standard accessors
$class->create_field('@'.$fld_name, ":Std($fld_name)", $attr );
# Return code ref for newly created accessor
no strict 'refs';
return *{$class.'::'.$method}{'CODE'};
}
}
(2)
]
