[FWP] Aggregation and AUTOLOAD fun

[Ilmari Karonen <iltzu@sci.fi>]

Recently in comp.lang.perl.misc, in a thread named "Subclassing an opaque
class", I mentioned that I'd written a module for easily implementing
aggregation relationships between objects using method autoloading, but
had gotten stuck on finding a way to restart the recursive method lookup
after one AUTOLOAD method had been found.

Damian Conway replied with the following words:
> There is no way to restart the full recursive look-up.
> At least, not without some *seriously* arcane tricks with local typeglobs.

Of course, I took that as a challenge.  It turns out that the "seriously
arcane tricks" aren't all that tricky - just localize *AUTOLOAD:

  my ($method) = $AUTOLOAD =~ /.*::(.*)/;
  local *AUTOLOAD;
  return $_[0]->$method(@_);  # assumes you haven't shifted @_

Now, getting the rest of the module working robustly enough took some more
playing with local typeglobs, but the principle is the same.  The complete
module is included below.  It's use pretty much like base, except you pass
it names of instance variables (read: hash keys) that you must initialize
to contain object refs or class names:

  package MyClass;
  require OtherClass;
  use Aggregate qw/other/;
  sub new { bless {other => OtherClass->new()}; }

That's all the documentation there is so far.  I'll be adding some POD to
the module when I get a round tuit, but in the meantime I'd appreciate if
people would test it with the weirdest inheritance/aggregation heirarchies
they can think of and tell me if it breaks.  (Of course, if some other
autoloading class without the same restarting code is first in the lookup
sequence, it'll break and there's nothing I can do about it.)


package Aggregate;
use strict;
no strict 'refs';

sub import {
    my $class = shift;
    my $x = @{caller() . '::ISA'} + @{caller() . '::AGGREGATE'}; # avoid spurious warning
    push @{caller() . '::ISA'}, $class;
    push @{caller() . '::AGGREGATE'}, @_;
}

sub AUTOLOAD {
    use vars qw($AUTOLOAD);

    my $self = shift;
    my ($pkg, $method) = $AUTOLOAD =~ /(.*)::(.*)/;

    unless ($method eq 'DESTROY' or not ref $self) {
	foreach my $key (@{$pkg . '::AGGREGATE'}) {
	    my $stub = sub { my $self = shift; $self->{$key}->$method(@_); };

	    # temporarily install stub and call it
	    my @retval;
	    {   local *$AUTOLOAD = $stub;
		local $AUTOLOAD;
		if (wantarray) {
		    @retval = eval { $self->$stub(@_) };
		} else {
		    $retval[0] = eval { $self->$stub(@_) };
		}
	    };
	    next if $@ and $@ =~ /^Can\'t locate object method/;
	    die $@ if $@;

	    # permanently install stub
	    *$AUTOLOAD = $stub;
	    return wantarray ? @retval : $retval[0];
	}
    }

    # restart the method search
    local *AUTOLOAD;
    $self->$method(@_);
}

"That's all, folks!";
__END__


-- 
Ilmari Karonen - http://www.sci.fi/~iltzu/
"The screwdriver *is* the portable method."  -- Abigail in c.l.p.m



==== Want to unsubscribe from Fun With Perl?  Well, if you insist...
==== Send email to <fwp-request@technofile.org> with message _body_
====   unsubscribe