File Coverage

blib/lib/Exporter/Proxy.pm

Criterion	Covered	Total	%
statement	63	75	84.0
branch	18	40	45.0
condition	5	8	62.5
subroutine	12	15	80.0
pod			n/a
total	98	138	71.0

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

package Exporter::Proxy;

use v5.20;

use Carp;

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

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

our $VERSION    = '1.8';
$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   } || '';
    my $postproc    = delete $argz{ postfilter  } || '';
    my $inst_import = delete $argz{ import      } // 1;

    # 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
                };
            }
        }
    }

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

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

    undef &$exports;

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

        wantarray
        ?   @exportz
        : [ @exportz ]
    };

    $inst_import
    and
    do
    {
        my $import  = qualify_to_ref 'import',  $source;

        undef &$import;

        my $find_pre
        = $preproc
        ?   sub
            {
                $source->can( $preproc )
                or die "Unusable $source: cannot '$preproc'";
            }
        : $stub
        ;

        my $find_post
        = $postproc
        ?   sub
            {
                $source->can( $postproc )
                or die "Unusable $source: cannot '$postproc'";
            }
        : $stub
        ;

        *$import
        = sub
        {
            # these are delayed since the "use E::P" is
            # usually dealt with before the subs are defined
            # in the caller.

            state $pre_handler  = $find_pre->();
            state $post_handler = $find_post->();

            # 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
            if $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";
                }
            }

            goto &$post_handler
            if $post_handler;
        };
    };

    return
}

# keep require happy

1

__END__