view release on metacpan or  search on metacpan

lib/Export/Lexical.pm  view on Meta::CPAN

use 5.010;
use strict;
use warnings;
use B;
use Carp;

our $VERSION = '0.0.6';

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;   ## no critic (ProhibitPunctuationVars, RequireLocalizedPunctuationVars)
            };
        }

        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;  ## no critic (ProhibitPunctuationVars, RequireLocalizedPunctuationVars)
                }
                else {
                    $^H{$key} = '';    ## no critic (ProhibitPunctuationVars, RequireLocalizedPunctuationVars)
                }
            };
        }
    }

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

            $modifier_for{$caller} = $modifier;
            next;
        }

        push @params, $modifier;
    }
}

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'; ## no critic (ProhibitNoWarnings)

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

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

            return _fail( $pkg, $sub ) if $hints->{$key} =~ /(?:^$)|(?:!$sub\b)/; # no $module
                                                                                  # no $module '$sub'

            goto $ref if $hints->{$key} =~ /(?:^1\b)|(?:\b$sub\b)/;               # use $module
                                                                                  # use $module '$sub'
        };
    }
}

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

    if ( defined $modifier_for{$pkg} ) {
        if ( $modifier_for{$pkg} eq ':silent' ) {
            return;
        }

        if ( $modifier_for{$pkg} eq ':warn' ) {
            carp "$pkg\::$sub not allowed here";
            return;