# reform::implicit.pm
#
# Provides "self", "base" and "class" accessors to using classes.
# Written by Henning Koch <jaz@netalive.org>.
# Two methods stolen from Simon Cozens' rubyisms.pm.
package reform::implicit;
use strict;
use base 'Exporter';
our @EXPORT = ('self', 'base', 'class');
# Accessor to base class methods.
sub base
{
# $class is the package in which the method lies
# that just called base(). This might be the grandparent
# or grand-grandparent of self's class, so we may not
# deduce it from self.
my $class = (caller(0))[0];
reform::implicit::BaseCaller->new(self(1), $class);
}
# Accessor to the current package.
sub class
{
my $class = self(1);
ref $class and $class = ref $class;
$class;
}
# Accessor to the current instance.
# Stolen from Simon Cozens' rubyisms.pm.
sub self
{
my($uplevel) = @_;
my $call_pack = (caller($uplevel))[0];
# So we're looking for the first thing that ISA $call_pack
my $level = 1;
while (caller($level))
{
my @their_args = DB::uplevel_args($level);
if (ref $their_args[0]
and eval { $their_args[0]->isa($call_pack) })
{
return $their_args[0];
}
$level++;
}
# Well, hey, maybe it's a class method.
return $call_pack;
}
# Gets the arguments of a subroutine call some frames up.
# Stolen from Simon Cozens' rubyisms.pm.
package DB;
sub uplevel_args { my @foo = caller($_[0]+1); return @DB::args };
# Object on which the base accessor works.
package reform::implicit::BaseCaller;
# Pre-reform style constructor.
sub new
{
my($class, $object, $calling_class) = @_;
# $class is the package in which the method lies
# that just called base().
# We may NOT get $class from $object if we ever want to
# use base more than one level of inheritance up.
my $self = { object => $object,
class => $calling_class };
bless($self, $class);
$self;
}
# Since the BaseCaller has no other methods itself, all
# method calls to the base calls should land here.
sub AUTOLOAD
{
my $self = shift;
our ($AUTOLOAD);
my $method = $AUTOLOAD;
$method =~ /(\w+)$/;
$method = $1;
return if $method eq 'DESTROY';
my $object = $self->{object};
my $class = $self->{class}; # may be parent of $object (see above)
# print "OBJECT: $object\n";
# print "CALLING: $class\n";
# print "\$object->$class\:\:SUPER\:\:$method(\@_)\n";
my @re = eval "\$object->$class\:\:SUPER\:\:$method(\@_)";
$@ and die "Error calling base method: $@";
return @re;
}
1;