Re: name for a module that implements dynamic inheritance?

[Dave Rolsky]

On Thu, 30 Oct 2003, Dave Rolsky wrote:

> First, I need a name.  I'm pretty sure this belongs under the Class::
> namespace, so here's a few I came up with:
>
>   Class::DynamicWrapper
>
>   Class::DynamicISA
>
>   Class::DynamicInheritance
>
>   Class::Chain

Well, I threw this together and it works, although I had to compromise and
make module do $self->super::foo in order to have custom dispatch, because
there is just no good way to make Perl do what I want that wouldn't be
absolutely hideous.

I'm attaching the code (temporarily called Class::DynamicWrapper) and the
test suite so people can see some examples, in case that helps.  WARNING:
This code does strange funky things, and may cause nausea, vomiting, or
migration to Python.

Note that I'm not wedded to _any_ of the names in here for packages or the
super::foo bits (it could be PARENT::foo or whatever), so I welcome
suggestions in that area.


-dave

/*=======================
House Absolute Consulting
www.houseabsolute.com
=======================*/


package Class::DynamicWrapper;

use strict;

use vars qw($VERSION);

$VERSION = 0.01;

my $base = 'MadeBy::Class::DynamicWrapper::Class';
my $num = 0;

# Given a set of classes like Foo::Base, Foo::Bar, and Foo::Baz, we
# end up with a hierarchy like this:
#
#              Foo::Base
#                 |
#        MadeBy::Class::DynamicWrapper::Class000000000
#                 |
#     Foo::Bar    |
#          \      |
#        MadeBy::Class::DynamicWrapper::Class000000001
#                 |
#     Foo::Baz    |
#          \      |
#        MadeBy::Class::DynamicWrapper::Class000000002
#
# Then with the strange jiggery-pokery in the super::AUTOLOAD method
# we arrange to dispatch calls to super::foo() made by Foo::Baz to
# MadeBy::Class::DynamicWrapper::Class000000001.  This latter class
# will either inherit foo() directly from Foo::Bar, or it will inherit
# it from Foo::Base.  Either way, the next relevant parent class is
# called.
#

sub hierarchy
{
    unless (@_)
    {
        require Carp;
        Carp::croak( "Cannot call hierarchy function with only a single class name.\n" 
);
    }

    my @parents;
    my @children;
    my $last;
    foreach my $class (@_)
    {
        my $name = _make_name();

        my @isa = ( $class, ( $last ? $last : () )  );

        {
            no strict 'refs';
            @{"$name\::ISA"} = @isa;
        }

        $last = $name;
    }

    return $last;
}

sub _make_name { sprintf( '%s%09d', $base, $num++ ) }

package super;

sub AUTOLOAD
{
    my $caller_class = caller();

    my $descendant_class = ref $_[0] || $_[0];

    my $class = $descendant_class;

    my $class_to_call;

    # I'm too lazy to write this in a saner way.  Basically we are
    # going up the inheritance tree looking at the "right" side
    while (1)
    {
        {
            no strict 'refs';
            $class_to_call = ${"$class\::ISA"}[1];
        }

        die "Cannot use super for classes not created by Class::DynamicWrapper\n"
            unless $class_to_call =~ /^MadeBy::Class::DynamicWrapper/;

        if ( $class_to_call->isa($caller_class) )
        {
            no strict 'refs';
            $class = ${"$class\::ISA"}[1];

            next;
        }

        last;
    }

    my $meth = join '::', $class_to_call, (split /::/, $super::AUTOLOAD)[1];

    return shift->$meth(@_);
}



-------------------------------------------------------------------------------

use strict;

use Class::DynamicWrapper;

use Test::More tests => 26;

{
    package Foo::Base;

    sub new { bless {}, shift }

    sub foo { 'base' }
}

{
    package Foo::Bar;

    sub foo { 'bar' }

    sub bar { 'also bar' }

    sub other { 'in bar' }
}

{
    package Foo::Baz;

    sub baz { 'baz' }

    sub other { 'in baz' }
}

{
    my $class = Class::DynamicWrapper::hierarchy( 'Foo::Base', 'Foo::Bar', 'Foo::Baz' 
);

    my $object = $class->new;

    foreach my $c ( qw( Foo::Base Foo::Bar Foo::Baz ) )
    {
        isa_ok( $object, $c );
    }

    foreach my $m ( qw( foo bar baz other ) )
    {
        can_ok( $object, $m );
    }

    is( $object->foo,   'bar' );
    is( $object->bar,   'also bar' );
    is( $object->baz,   'baz' );
    is( $object->other, 'in baz' );
}

{
    my $class = Class::DynamicWrapper::hierarchy( 'Foo::Base', 'Foo::Baz', 'Foo::Bar' 
);

    my $object = $class->new;

    foreach my $c ( qw( Foo::Base Foo::Bar Foo::Baz ) )
    {
        isa_ok( $object, $c );
    }

    foreach my $m ( qw( foo bar baz other ) )
    {
        can_ok( $object, $m );
    }

    is( $object->foo,   'bar' );
    is( $object->bar,   'also bar' );
    is( $object->baz,   'baz' );
    is( $object->other, 'in bar' );
}

{
    package Super::Base;

    sub new { bless {}, shift }

    sub meth { 'base' }
}

{
    package Super::Foo;

    sub new { bless {}, shift }

    sub meth { join ' ', 'foo', shift->super::meth() }
}

{
    package Super::Bar;

    sub new { bless {}, shift }

    sub meth { join ' ', 'bar', shift->super::meth() }
}

{
    my $class = Class::DynamicWrapper::hierarchy( 'Super::Base', 'Super::Foo', 
'Super::Bar' );

    is( $class->meth, 'bar foo base' );
}

{
    my $class = Class::DynamicWrapper::hierarchy( 'Super::Base', 'Super::Bar', 
'Super::Foo' );

    is( $class->meth, 'foo bar base' );
}

{
    package Super::Base;

    sub new { bless {}, shift }

    sub meth { 'base' }
}

{
    package Super::NoMeth;

    sub new { bless {}, shift }
}

{
    package Super::HasMeth;

    sub new { bless {}, shift }

    sub meth { join ' ', 'has', shift->super::meth() }
}

{
    my $class =
        Class::DynamicWrapper::hierarchy( 'Super::Base', 'Super::NoMeth', 
'Super::HasMeth' );

    is( $class->meth, 'has base' );
}

{
    my $class =
        Class::DynamicWrapper::hierarchy( 'Super::Base', 'Super::HasMeth', 
'Super::NoMeth' );

    is( $class->meth, 'has base' );
}