File Coverage

blib/lib/Export/Lexical.pm

Criterion	Covered	Total	%
statement	92	93	98.9
branch	12	20	60.0
condition	1	3	33.3
subroutine	16	16	100.0
pod			n/a
total	121	132	91.6

package Export::Lexical;

use 5.010;
use strict;
use version; our $VERSION = qv('0.0.4');

use B;
use Carp;

my %Exports_for  = ();
my %Modifier_for = ();  # e.g., $Modifier_for{$pkg} = 'silent'

sub MODIFY_CODE_ATTRIBUTES {
    my ( $package, $coderef, @attrs ) = @_;

    my @unused_attrs = ();

    while ( my $attr = shift @attrs ) {
        if ( $attr ~~ /^Export_?Lexical$/i ) {
            push @{ $Exports_for{$package} }, $coderef;
        }
        else {
            push @unused_attrs, $attr;
        }
    }

    return @unused_attrs;
}

sub import {
    my ($class) = @_;

    my $caller = caller;
    my $key    = _get_key($caller);
    my @params = ();

    {
        # Export our subroutines, if necessary.
        no strict 'refs';   ## no critic (ProhibitNoStrict)

        if ( !exists &{ $caller . '::MODIFY_CODE_ATTRIBUTES' } ) {
            *{ $caller . '::MODIFY_CODE_ATTRIBUTES' } = \&MODIFY_CODE_ATTRIBUTES;
        }

        if ( !exists &{ $caller . '::import' } ) {
            *{ $caller . '::import' } = sub {
                my ( $class, @args ) = @_;

                _export_all_to( $caller, scalar caller );

                $^H{$key} = @args ? ( join ',', @args ) : 1;
            };
        }

        if ( !exists &{ $caller . '::unimport' } ) {
            *{ $caller . '::unimport' } = sub {
                my ( $class, @args ) = @_;

                if ( @args ) {
                    # Leave the '1' on the front of the list from a previous 'use
                    # $module', as well as any subs previously imported.
                    $^H{$key} = join ',', $^H{$key}, map { "!$_" } @args;
                }
                else {
                    $^H{$key} = '';
                }
            };
        }
    }

    while ( my $_ = shift ) {
        if ( /^:(silent|warn)$/ ) {
            croak qq('$_' requested when '$Modifier_for{$caller}' already in use)
                if $Modifier_for{$caller};

            $Modifier_for{$caller} = $_;
            next;
        }

        push @params, $_;
    }
}

sub _export_all_to {
    my ( $from, $caller ) = @_;

    return if !exists $Exports_for{$from};

    for my $ref ( @{ $Exports_for{$from} } ) {
        my $obj = B::svref_2object($ref);
        my $pkg = $obj->GV->STASH->NAME;
        my $sub = $obj->GV->NAME;
        my $key = _get_key($pkg);

        no strict 'refs';       ## no critic (ProhibitNoStrict)
        no warnings 'redefine';

        next if exists &{ $caller . '::' . $sub };

        *{ $caller . '::' . $sub } = sub {
            my $hints = (caller(0))[10];

            given ( $hints->{$key} ) {
                my $re = qr/\b!$sub\b/;

                when ( '' )        { return _fail( $pkg, $sub ); }  # no $module
                when ( /!$sub\b/ ) { return _fail( $pkg, $sub ); }  # no $module '$sub'

                when ( /^1\b/ || /\b$sub\b/ ) { goto $ref; }        # use $module
                                                                    # use $module '$sub'
            }
        };
    }
}

sub _fail {
    my ( $pkg, $sub ) = @_;

    given ( $Modifier_for{$pkg} ) {
        when (':silent') { return }
        when (':warn')   { carp "$pkg\::$sub not allowed here" }

        croak "$pkg\::$sub not allowed here";
    }
}

sub _get_key {
    my ($pkg) = @_;

    return __PACKAGE__ . '/' . $pkg;
}

1;

__END__