File Coverage

blib/lib/Object/InsideOut/Autoload.pm

Criterion	Covered	Total	%
statement	82	89	92.1
branch	44	54	81.4
condition	14	27	51.8
subroutine	4	4	100.0
pod			n/a
total	144	174	82.7

package Object::InsideOut; {

use strict;
use warnings;
no warnings 'redefine';

# Handles :Automethods and foreign inheritance
sub AUTOLOAD
{
    my ($GBL, @args) = @_;
    push(@{$$GBL{'export'}}, 'AUTOLOAD');
    $$GBL{'init'} = 1;

    *Object::InsideOut::AUTOLOAD = sub
    {
        my $thing = $_[0];

        # Extract the class and method names from the fully-qualified name
        my ($class, $method) = our $AUTOLOAD =~ /(.*)::(.*)/;

        # Handle superclass calls
        my $super;
        if ($class =~ /::SUPER$/) {
            $class =~ s/::SUPER//;
            $super = 1;
        }

        my $heritage    = $$GBL{'heritage'};
        my $automethods = $$GBL{'sub'}{'auto'};

        # Find a something to handle the method call
        my ($code_type, $code_dir, %code_refs);
        foreach my $pkg (@{$$GBL{'tree'}{'bu'}{$class}}) {
            # Skip self's class if SUPER
            if ($super && $class eq $pkg) {
                next;
            }

            # Check with heritage objects/classes
            if (exists($$heritage{$pkg})) {
                my $objects = $$heritage{$pkg}{'obj'};
                my $classes = $$heritage{$pkg}{'cl'};
                if (Scalar::Util::blessed($thing)) {
                    if (exists($$objects{$$thing})) {
                        # Check objects
                        foreach my $obj (@{$$objects{$$thing}}) {
                            if (my $code = $obj->can($method)) {
                                shift;
                                unshift(@_, $obj);
                                goto $code;
                            }
                        }
                    } else {
                        # Check classes
                        foreach my $pkg (keys(%{$classes})) {
                            if (my $code = $pkg->can($method)) {
                                @_ = @_;   # Perl 5.8.5 bug workaround
                                goto $code;
                            }
                        }
                    }
                } else {
                    # Check classes
                    foreach my $pkg (keys(%{$classes})) {
                        if (my $code = $pkg->can($method)) {
                            shift;
                            unshift(@_, $pkg);
                            goto $code;
                        }
                    }
                }
            }

            # Check with Automethod
            if (my $automethod = $$automethods{$pkg}) {
                # Call the Automethod to get a code ref
                local $CALLER::_ = $_;
                local $_ = $method;
                local $SIG{'__DIE__'} = 'OIO::trap';
                if (my ($code, $ctype) = $automethod->(@_)) {
                    if (ref($code) ne 'CODE') {
                        # Delete defective automethod
                        delete($$automethods{$pkg});
                        # Not a code ref
                        OIO::Code->die(
                            'message' => ':Automethod did not return a code ref',
                            'Info'    => "NOTICE: The defective :Automethod in package '$pkg' has been DELETED!",
                            'Code'    => ":Automethod in package '$pkg' invoked for method '$method'");
                    }

                    if (defined($ctype)) {
                        my ($type, $dir) = $ctype =~ /(\w+)(?:[(]\s*(.*)\s*[)])?/;
                        if ($type && $type =~ /CUM/i) {
                            if ($code_type) {
                                $type = ':Cumulative';
                                $dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down';
                                if ($code_type ne $type || $code_dir ne $dir) {
                                    # Mixed types
                                    my ($pkg2) = keys(%code_refs);
                                    OIO::Code->die(
                                        'message' => 'Inconsistent code types returned by :Automethods',
                                        'Info'    => "Class '$pkg' returned type $type($dir), and class '$pkg2' returned type $code_type($code_dir)");
                                }
                            } else {
                                $code_type = ':Cumulative';
                                $code_dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down';
                            }
                            $code_refs{$pkg} = $code;
                            next;
                        }
                        if ($type && $type =~ /CHA/i) {
                            if ($code_type) {
                                $type = ':Chained';
                                $dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down';
                                if ($code_type ne $type || $code_dir ne $dir) {
                                    # Mixed types
                                    my ($pkg2) = keys(%code_refs);
                                    OIO::Code->die(
                                        'message' => 'Inconsistent code types returned by :Automethods',
                                        'Info'    => "Class '$pkg' returned type $type($dir), and class '$pkg2' returned type $code_type($code_dir)");
                                }
                            } else {
                                $code_type = ':Chained';
                                $code_dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down';
                            }
                            $code_refs{$pkg} = $code;
                            next;
                        }

                        # Unknown automethod code type
                        OIO::Code->die(
                            'message' => "Unknown :Automethod code type: $ctype",
                            'Info'    => ":Automethod in package '$pkg' invoked for method '$method'");
                    }

                    if ($code_type) {
                        # Mixed types
                        my ($pkg2) = keys(%code_refs);
                        OIO::Code->die(
                            'message' => 'Inconsistent code types returned by :Automethods',
                            'Info'    => "Class '$pkg' returned an 'execute immediately' type, and class '$pkg2' returned type $code_type($code_dir)");
                    }

                    # Just a one-shot - execute it
                    @_ = @_;   # Perl 5.8.5 bug workaround
                    goto $code;
                }
            }
        }

        if ($code_type) {
            my $tree = ($code_dir eq 'bottom up') ? $$GBL{'tree'}{'bu'} : $$GBL{'tree'}{'td'};
            my $code = ($code_type eq ':Cumulative')
                            ? create_CUMULATIVE($method, $tree, \%code_refs)
                            : create_CHAINED($method, $tree, \%code_refs);
            @_ = @_;   # Perl 5.8.5 bug workaround
            goto $code;
        }

        # Failed to AUTOLOAD
        my $type = ref($thing) ? 'object' : 'class';
        OIO::Method->die('message' => qq/Can't locate $type method "$method" via package "$class"/);
    };


    # Do the original call
    @_ = @args;
    goto &Object::InsideOut::AUTOLOAD;
}

}  # End of package's lexical scope


# Ensure correct versioning
($Object::InsideOut::VERSION eq '4.04')
    or die("Version mismatch\n");

# EOF