File Coverage

blib/lib/Exporter/Proxy.pm

Criterion	Covered	Total	%
statement	61	74	82.4
branch	14	30	46.6
condition	3	4	75.0
subroutine	13	16	81.2
pod			n/a
total	91	124	73.3

########################################################################
# housekeeping
########################################################################

package Exporter::Proxy;

use v5.12;
use strict;

use Carp;

use List::Util  qw( first           );
use Symbol      qw( qualify_to_ref  );

########################################################################
# package variables
########################################################################

our $VERSION    = '1.4';
$VERSION = eval $VERSION;

my $disp_list   = 'DISPATCH_OK';

########################################################################
# utility functions
########################################################################

########################################################################
# methods (public interface)
########################################################################

sub import
{
    state $stub = sub{};

    # discard this package.
    # left on the stack are assignment operators and
    # exported names.

    shift;

    # use "$source" avoid colliding with '$caller' in the
    # exported subs.

    my $source  = caller;
    my @exportz = grep { ! /=/ } @_;
    my %argz
    = map
    {
        split /=/, $_, 2
    }
    grep /=/, @_;

    # maybe carp about extraneous arguments here?

    my $disp    = delete $argz{ dispatch    } || '';
    my $preproc = delete $argz{ prefilter   } || '';

    # if a dispatcher is being used then it must
    # be exported. in most cases this will be the
    # only thing exported.

    if( $disp )
    {
        my $list    = qualify_to_ref $disp_list, $source;

        first { $disp eq $_ } @exportz
        or push @exportz, $disp;

        unless( $source->can( $disp ) )
        {
            my $sub = qualify_to_ref $disp, $source;
            my $can = qualify_to_ref $disp_list, $source;

            if( my $sanity = *{ $can }{ ARRAY } )
            {
                *$sub
                = sub
                {
                    my $op      = splice @_, 1, 1;

                    first { $op eq $_ } @$sanity
                    or do
                    {
                        local $"    = ' ';

                        confess "Bogus $disp: '$op' not in @$sanity"
                    };

                    # this could happen if someone plays with
                    # the symbol table after installing the sub.

                    my $handler = $source->can( $op )
                    or croak "Bogus $disp: $source cannot '$op'";

                    goto &$handler
                };
            }
            else
            {
                *$sub
                = sub
                {
                    my $op      = splice @_, 1, 1;

                    my $handler = $source->can( $op )
                    or croak "Bogus $disp: $source cannot '$op'";

                    goto &$handler
                };
            }
        }
    }

    my $pre_handler
    = do
    {
        if( $preproc )
        {
            sub
            {
                my $handler = $source->can( $preproc )
                or die "$source cannot '$preproc'\n";

                &$handler
            }
        }
        else
        {
            state $stub = sub{}
        }
    };

    @exportz
    or carp "Oddity: nothing requested for export!";

    my $exports = qualify_to_ref 'exports', $source;
    my $import  = qualify_to_ref 'import',  $source;

    undef &{ *$_ } for ( $exports, $import );

    *$exports
    = sub
    {
        # avoid giving away ref's to the closed-over
        # variable.

        wantarray
        ?   @exportz
        : [ @exportz ]
    };

    *$import
    = sub
    {
        # discard the package as first argument:
        # $pkg->import

        shift;

        my $caller  = caller;

        # allow the caller to pre-process the arguments.
        # notice this happens *before* ":noexport" is
        # processed.

        &$pre_handler;

        # empty list => use @exportz.
        # :noexport  => use empty list.

        if( first { ':noexport' eq $_ } @_ )
        {
            @_  = ();
        }
        elsif( @_ )
        {
            # nothing more for the moment.
        }
        else
        {
            @_  = @exportz;
        }

        # resolve these at runtime to account for
        # possible autoloading, etc.

        for my $arg ( @_ )
        {
            index $arg, ':'
            or next;

            if( first { $arg eq $_ }  @exportz )
            {
                my $source  = qualify_to_ref $arg, $source;
                my $install = qualify_to_ref $arg, $caller;

                *$install   = *$source;
            }
            else
            {
                die "Bogus $source: '$arg' not exported";
            }
        }
    };

    return
}

# keep require happy

1

__END__