File Coverage

blib/lib/Import/Box.pm

Criterion	Covered	Total	%
statement	46	48	95.8
branch	12	16	75.0
condition			n/a
subroutine	15	16	93.7
pod	2	2	100.0
total	75	82	91.4

package Import::Box;
use strict;
use warnings;

our $VERSION = '0.001';

use Scalar::Util();
use Carp();
use vars qw/$AUTOLOAD/;

my %STASHES;

sub __DEFAULT_AS { }
sub __DEFAULT_NS { }

# We do not want this methods to be accessible, so we are putting it in a
# lexical variable to use internally.
my $GEN_STASH = do {
    my $GEN = 'A';
    sub { __PACKAGE__ . '::__GEN_STASH__::' . shift(@_) . '::__' . ($GEN++) . '__' };
};

# We do not want this methods to be accessible, so we are putting it in a
# lexical variable to use internally.
my $IMPORT = sub {
    my $proto  = shift;
    my $caller = shift;

    return unless @_;

    my (%params, @loads);
    while (my $arg = shift) {
        if (substr($arg, 0, 1) eq '-') {
            $params{$arg} = shift;
        }
        else {
            my $args = ref($_[0]) ? shift : [];
            push @loads => [$arg, @$args];
        }
    }

    my ($stash, $class, $no_scope);
    if ($class = Scalar::Util::blessed($proto)) {
        Carp::croak("Params are not allowed when using import() as an object method: " . join(', ', keys %params))
            if keys %params;

        $stash = $$proto;
        $no_scope = 1;
    }
    else {
        $class = $proto;

        my $as = delete $params{'-as'} || $class->__DEFAULT_AS;
        Carp::croak(qq{No box name specified, and no default available, please specify with '-as => "BOXNAME"'})
            unless defined $as;

        my $from = delete $params{'-from'} || $caller->[0];
        $no_scope = delete $params{'-no_scope'};

        Carp::croak("Invalid params: " . join(', ', keys %params))
            if keys %params;

        $stash = $STASHES{$from}->{$as} ||= $GEN_STASH->($caller->[0]);
        bless(\$stash, $class) unless Scalar::Util::blessed(\$stash);

        unless ($caller->[0]->can($as)) {
            my $t = sub {
                return \$stash unless @_;

                my $meth = shift;

                my $sub = $stash->can($meth)
                    or Carp::croak("No such function: '$meth'");

                goto &$sub;
            };

            no strict 'refs';
            *{"$caller->[0]\::$as"} = $t;
        }
    }

    return unless @loads;

    my $header = qq{package $stash;\n#line $caller->[2] "$caller->[1]"};
    my $sub = $no_scope ? undef : eval qq{$header\nsub { shift\->import(\@_) };} || die $@;
    my $prefix = $class->__DEFAULT_NS;

    for my $set (@loads) {
        my ($mod, @args) = @$set;

        # Strip '+' prefix OR append module prefix
        unless ($mod =~ s/^\+//) {
            $mod = "$prefix\::$mod" if $prefix;
        }

        my $file = $mod;
        $file =~ s{::|'}{/}g;
        $file .= '.pm';
        require $file;

        if ($no_scope) {
            eval qq{$header\nBEGIN { \$mod\->import(\@args) }; 1} or die $@;
        }
        else {
            $sub->($mod, @args);
        }
    }
};

sub import {
    my $proto = shift;
    my @caller = caller(0);

    $proto->$IMPORT(\@caller, @_);
}

sub new {
    my $class = shift;
    my @caller = caller(0);

    my $stash = $GEN_STASH->($caller[0]);
    my $self = bless(\$stash, $class);

    $self->$IMPORT(\@caller, @_) if @_;

    return $self;
}

sub box {
    my $class = shift;
    my $stash = shift;
    my $self = bless(\$stash, $class);
    return $self;
}

# These methods need to instead call the stash version when called on an
# instance.
for my $meth (qw/new box/) {
    my $orig = __PACKAGE__->can($meth);

    my $new = sub {
        my ($proto) = @_;
        goto &$orig unless Scalar::Util::blessed($proto);

        my $sub = $proto->can($meth) or Carp::croak("No such function: '$meth'");
        goto &$sub;
    };

    no strict 'refs';
    no warnings 'redefine';
    *$meth = $new;
}

sub can {
    my $proto = shift;
    my $class = Scalar::Util::blessed($proto)
        or return $proto->SUPER::can(@_);

    my $stash = $$proto;
    return $stash->can(@_);
}

sub isa {
    my $proto = shift;
    return $proto->SUPER::isa(@_);
}

sub AUTOLOAD {
    my $meth = $AUTOLOAD;
    $meth =~ s/^.*:://g;

    return if $meth eq 'DESTROY';

    my $class = Scalar::Util::blessed($_[0])
        or Carp::croak(qq{Can't locate object method "$meth" via package "$_[0]"});

    # Need to shift self as the "methods" are actually functions imported into
    # the stash.
    my $self = shift @_;

    my $sub = $self->can($meth)
        or Carp::croak("No such function '$meth'");

    goto &$sub;
}

1;

__END__