File Coverage

blib/lib/OO/Closures.pm

Criterion	Covered	Total	%
statement	43	54	79.6
branch	13	26	50.0
condition	6	12	50.0
subroutine	8	9	88.8
pod	0	2	0.0
total	70	103	67.9

package OO::Closures;

use 5.006;

use strict;
use warnings;
no  warnings 'syntax';

our $VERSION = '2009110702';

sub import {
    my $my_package       = __PACKAGE__;
    my $foreign_package  =  caller;
    my $my_sub           = 'create_object';
    shift;
    my $foreign_sub      =  @_ ? shift : $my_sub;

    no strict 'refs';
    *{"${foreign_package}::$foreign_sub"} = \&{"${my_package}::$my_sub"};
}

sub croak {
    require Carp;
    goto &Carp::croak;
}

sub create_object {
    my ($methods, $ISA, $is_base) = @_;

    sub {
        my ($method, @args) = @_;
        my ($call_super, $class);

        if ($method =~ /^((?:[^:]+|:[^:])*)::(.*)/s) {
            $class  = $1;
            $method = $2;
        }

        if (exists   $methods -> {$method} && !defined $class) {
            return   $methods -> {$method} -> (@args) if
               ref   $methods -> {$method} eq 'CODE';
            return ${$methods -> {$method}} if
               ref   $methods -> {$method} eq 'SCALAR';
            die "Illegal method ($method) in object.\n";
        }

        my  @supers;
        if (defined $class && ($class ne 'SUPER' || exists $ISA -> {$class})) {
            unless (exists $ISA -> {$class}) {
                croak "No class ($class) found\n";
            }
            @supers = ($ISA -> {$class});
        }
        else {@supers = values %$ISA}

        # Go looking for the method in an inherited object.
        foreach my $super (@supers) {
            return eval {$super -> ($method => @args)} unless $@;
            croak $@ unless $@ =~ /^No such method/;
        }

        unless ($is_base) {
            # This is the base object. So, we'll look for AUTOLOAD.
            return $methods -> {AUTOLOAD} -> ($method => @args) if exists
                   $methods -> {AUTOLOAD} && !defined $class;

            # Check %ISA for AUTOLOAD.
            foreach my $super (@supers) {
                return eval {$super -> (AUTOLOAD => $method, @args)} unless $@;
                croak $@ unless $@ =~ /^No such method/;
            }
        }

        croak "No such method ($method) found";
    }
}


1;


__END__