File Coverage

blib/lib/Import/Into/As.pm

Criterion	Covered	Total	%
statement	63	63	100.0
branch	13	14	92.8
condition	1	3	33.3
subroutine	10	10	100.0
pod			n/a
total	87	90	96.6

package Import::Into::As;
use strict;
use warnings;

our $VERSION = '0.000003';

use Import::Into;
use Carp qw/croak/;

sub import::into::as {
    my $class = shift;
    my ($target, $rename, @args) = @_;

    # need to bump level by 1 for the call to import::into
    my $bump_level = 1;

    my ($dest, $level);
    if (ref $target) {
        $dest = $target->{package} if exists $target->{package};
        if (exists $target->{level}) {
            $level = $target->{level};
            $dest  ||= caller($level);
            $target->{level} += $bump_level;
        }
    }
    elsif ($target =~ m/^\d+$/) {
        $level = $target;
        $dest  = caller($level);
        $target += $bump_level;
    }
    else {
        $dest = $target;
    }

    croak "unable to find destination package!"
        unless $dest;

    # Stash away any current subs with names that conflict iwth new imports
    # that should be renamed. Also remove them form the namespace so that we
    # know if a sub gets put into the name that we put it there.
    my %old_subs;
    for my $name (keys %$rename) {
        $old_subs{$name} = $dest->can($name);
        _purge_sub($dest, $name);
    }

    # Do the import
    $class->import::into($target, @args);

    # Make a copy of all the subs that were imported, keyed by their new names
    my %new_subs = map { $rename->{$_} => $dest->can($_) } keys %$rename;

    # Restore original subs, purge imported names that should not be kept.
    for my $name (keys %$rename) {
        my $sub = $old_subs{$name};

        if ($sub) {
            no strict 'refs';
            no warnings 'redefine';
            *{"$dest\::$name"} = $sub;
        }
        else {
            _purge_sub($dest, $name);
        }
    }

    # Put the new subs in place under their new names
    no strict 'refs';
    *{"$dest\::$_"} = $new_subs{$_} for keys %new_subs;
}

sub _purge_sub {
    my ($dest, $name) = @_;
    no strict 'refs';

    local *GLOBCLONE = *{"$dest\::$name"};
    my $stash = \%{"${dest}\::"};
    delete $stash->{$name};
    for my $slot (qw/HASH SCALAR ARRAY IO FORMAT/) {
        *{"$dest\::$name"} = *GLOBCLONE{$slot} if defined *GLOBCLONE{$slot};
    }
}

1;


__END__