File Coverage

blib/lib/Class/ClassDecorator.pm

Criterion	Covered	Total	%
statement	60	65	92.3
branch	11	14	78.5
condition	1	3	33.3
subroutine	11	11	100.0
pod	0	2	0.0
total	83	95	87.3

package Class::ClassDecorator;

use strict;

use vars qw($VERSION);

$VERSION = 0.02;

use NEXT;

# Given a set of classes like Foo::Base, Foo::Bar, and Foo::Baz, we
# end up with a hierarchy like this:
#
#              Foo::Baz  Foo::Bar  Foo::Base
#                  \         |         /
#                   \        |        /
#        MadeBy::Class::ClassDecorator::Class000000000
#
# As long as all the top classes (excluding Foo::Base) use NEXT::
# instead of SUPER::, it works.
#

my %Cache;
sub decorate
{
    unless ( @_ > 1 )
    {
        require Carp;
        Carp::croak( "Cannot call decorate() function with only a single class name.\n" );
    }

    # class names should never have spaces in them
    my $key = join ' ', @_;

    return $Cache{decorate}{$key} if $Cache{decorate}{$key};

    my $name = _make_name();

    {
        no strict 'refs';
        @{"$name\::ISA"} = ( reverse @_ );

        *{"$name\::class_decorator_class"} = sub () { 1 };
    }

    return $Cache{decorate}{$key} = $name;
}

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

    my $key = join ' ', @_;

    return $Cache{hierarchy}{$key} if $Cache{hierarchy}{$key};

    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 $Cache{hierarchy}{$key} = $last;
}

my $Base = 'MadeBy::Class::ClassDecorator::Class';
my $Num = 0;

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::ClassDecorator\n"
            unless $class_to_call =~ /^MadeBy::Class::ClassDecorator/;

        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(@_);
}


1;

__END__