Tired of typing accessor methods myself, I wanted Perl to do that for me. The AUTOLOAD method below creates accessors for scalar attributes on the fly. Authorised accessors are listed in hash %ATTRIBUTE. A call to an unauthorised accessor will be handed over to an ancestor class if any. (Inspired by receipe 13.11 of the Cookbook). Supports multiple inheritance and generates the accessors in the right package.
package myTopAncestor;
use strict;
use vars qw/ %ATTRIBUTE $AUTOLOAD /;
%ATTRIBUTE = map { $_ => 1 } qw/ list of authorized accessors/;
#
# AUTOLOAD
#
# AUTOLOAD gets called whenever a non existing method is invoked. It r
+eceives
# whatever arguments the user intended to give the non-existing method
+, and
# the name of that method is store in package-global $AUTOLOAD. Our
# implementation generates accessor methods on demand, if they are a k
+ey in
# package-global %ATTRIBUTE.
#
sub AUTOLOAD {
my $self = shift;
(my $attr = $AUTOLOAD) =~ s/.*:://; # strip Package names, only th
+e method
return unless $attr =~ /[^A-Z]/; # don't handle DESTROY or all-
+cap methods
# Ask $self to recurse its ancestors and find out which one is wil
+ling to
# implement the accessor (if any)...
if ( my $class = $self->_class_of_attr($attr) ) {
# the accessor should be implemented as a method of class $cla
+ss
my $method = $class . "::$attr";
# Define the accessor as a closure
my $accessor = sub {
my $acc_self = shift;
($acc_self->{"_$attr"}, @_ && ($acc_self->{"_$attr"} = shi
+ft))[0];
};
# Import the newly created accessor into the appropriate packa
+ge
SYMBOL_TABLE_HACKERY: {
no strict 'refs';
*$method = $accessor;
}
# use the magical goto, so as to pretend that the new accessor
+ was
# called in the first place instead of AUTOLOAD
unshift @_, $self;
goto &$method;
} else {
# no ancestor wants to implement that
croak "Invalid attribute method $AUTOLOAD";
}
}
#
# _class_of_attr
#
# Returns the class name that is willing to implement the given access
+or
# method (i.e., has it in its %ATTRIBUTE hash), either the current cla
+ss or
# one of its ancestor.
# A class name can be given as second parameter so as to start searchi
+ng from
# that class up.
#
sub _class_of_attr {
my $self = shift;
my $attr = shift;
my $package = shift || ref($self); # start searching from current
+class or
# the one given as argument if
+any
# Determine the fully qualified name of hash to search in
my $attr_hash_name = $package . '::ATTRIBUTE';
no strict 'refs';
# try and find in the hash
if ( eval {exists $$attr_hash_name{$attr}} ) {
# return package name on success
return $package;
} else {
# Find the name of direct ancestor and resume the search
my @isa = eval { @{"${package}::ISA"} };
foreach my $super ( @isa ) {
my $class = eval { $self->_class_of_attr($attr, $super) };
return $class if $class;
}
croak $@ if $@;
}
}
