File Coverage

blib/lib/AutoRole.pm

Criterion	Covered	Total	%
statement	94	111	84.6
branch	51	66	77.2
condition	17	34	50.0
subroutine	8	8	100.0
pod			n/a
total	170	219	77.6

package AutoRole;

=head1 NAME

AutoRole - Compiletime OR runtime mixin of traits/roles/mixins/your-word-here.

$Id: AutoRole.pm,v 1.8 2011-10-06 16:55:06 paul Exp $

=cut

use strict;
use warnings;

$AutoRole::VERSION = '0.04';

sub import {
    my ($class, @args) = @_;
    my ($pkg, $file, $line) = caller;
    my ($module, $how, %list);

    while (@args) {
        my $item = shift(@args) || next;
        if    ($item eq 'class') { $module = shift(@args) || die "Missing class name at $file line $line\n"; next }
        elsif ($item eq 'how')   { $how    = shift(@args) || die "Missing how type at $file line $line\n";   next }
        elsif ($item =~ m{methods?}x) { $args[0] = [$args[0]] if ! ref $args[0]; next }

        if (ref $item) {
            if (ref $item eq 'ARRAY') { @list{ @$item } = @$item; next }
            if (ref $item eq 'Regexp') { $how = 'compile'; push @{ $list{'*'} }, $item; next }
            while (my ($k, $v) = each %$item) {
                next if ! $v;
                if ($k eq '*') { push @{ $list{'*'} }, ref($v) eq 'ARRAY' ? @$v : ref($v) ? $v : qr{.}x; next }
                $list{$k} = (ref($v) || $v =~ /^[^\W\d]\w+$/x) ? $v : $k;
            }
            next;
        }
        if ($item =~ /^(?:compile|autoload|autorequire)$/x) { $how = $item }
        elsif ($item eq '*') { push @{ $list{'*'} }, qr{.}x }
        elsif (! $module) { $module = $item }
        else { $list{$item} = $item }
    }

    die "Missing class name at $file line $line\n" if ! $module;
    (my $module_file = "$module.pm") =~ s{::}{/}xg;
    if (! scalar keys %list) {
        if (!$how || $how eq 'compile') { $list{'*'} = [qr{.}x] }
        else { die "Missing list of methods to load at $file line $line\n" }
    }
    $how ||= 'autorequire';
    no strict 'refs';

    my $star = delete $list{'*'};
    if ($star) {
        require $module_file;
        for my $k (grep {defined &{"${module}::$_"}} keys %{"${module}::"}) {
            $list{$k} ||= $k for grep {$k =~ $_} @$star;
        }
        die "No methods found matching @$star for loading at $file line $line\n"
            if ! scalar keys %list;
    }

    $how = 'compile' if $INC{$module_file};
    if ($how eq 'compile') {
        require $module_file;
    } elsif ($how eq 'autoload') {
        no warnings;
        my $ref  = ${"${pkg}::AUTOROLE"} ||= {};
        my $code = \&{"${pkg}::AUTOLOAD"};
        *{"${pkg}::AUTOLOAD"} = sub {
            my $dest = ($AutoRole::AUTOLOAD || ${"${pkg}::AUTOLOAD"} || q{}) =~ /::(.+)$/x ? $1 : return;
            if (exists $ref->{$dest}) {
                require $module_file;
                *{"${pkg}::$dest"} = $module->can($dest) || die "No such method as ${module}::$dest - $file line $line\n";
                goto &{"${pkg}::$dest"}; # avoid inserting ourselves into the stack
            }
            if ($code ||= $pkg->SUPER::can('AUTOLOAD')) {
                local ${"${pkg}::AUTOLOAD"} = "${pkg}::$dest";
                return $code->(@_);
            }
        };
    } elsif ($how ne 'autorequire') {
        die "How type \"$how\" is invalid at $file line $line\n";
    }

    foreach my $src (keys %list) {
        foreach my $dest (ref($list{$src}) ? @{ $list{$src} } : $list{$src}) {
            if (defined &{"${pkg}::$dest"}) {
                die "Method name conflict - ${pkg}::$dest already exists - $file line $line\n";
            } elsif (defined(${"${pkg}::AUTOROLE"}) && exists(${"${pkg}::AUTOROLE"}->{$dest})) {
                die "Method name conflict -- ${pkg}::$dest is already set to autoload - $file line $line\n";
            }

            if ($how eq 'compile') {
                *{"${pkg}::$dest"} = *{"${module}::$src"}{'CODE'};
            } elsif ($how eq 'autoload') {
                ${"${pkg}::AUTOROLE"}->{$dest} = $src;
            } else {
                *{"${pkg}::$dest"} = sub {
                    require $module_file;
                    no warnings;
                    *{"${pkg}::$dest"} = $module->can($src) || die "No such method as ${module}::$src - $file line $line\n";
                    goto &{"${pkg}::$dest"}; # avoid inserting ourselves into the stack
                };
            }
        }
    }
    return ($star && wantarray) ? [sort keys %list] : 1;
}

1;

__END__