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 $@;
    }
}
[download]