File Coverage

blib/lib/pkg.pm

Criterion	Covered	Total	%
statement	83	99	83.8
branch	45	60	75.0
condition	17	23	73.9
subroutine	8	11	72.7
pod			n/a
total	153	193	79.2

package pkg;

use 5.10.1;
use strict;
use warnings;

our $VERSION = '0.04';

my %opt_nargs = (
    alias     => { n => 0, name => 'alias',   value => 1, tag => 1 },
    noalias   => { n => 0, name => 'alias',   value => 0 },
    strip     => { n => 1, name => 'alias',   tag   => 1 },
    require   => { n => 0, name => 'require', value => 1 },
    norequire => { n => 0, name => 'require', value => 0 },
);

my %mopt_nargs = (
    as           => { n => 1 },
    import       => { n => 0, last => 1 },
    require      => { n => 0, name => 'require', value => 1 },
    norequire    => { n => 0, name => 'require', value => 0 },
    version      => { n => 1 },
    include      => { n => 1 },
    inner        => { n => 0 },
    'only_inner' => { n => 0, value => -1, name => 'inner', tag => 0 },
    exclude      => { n => 1 },
);

sub import {

    # first element of @_ is just us!
    shift;

    return unless @_;

    my $to = caller(0);

    my %opt;

    while (@_) {

        if ( 'ARRAY' eq ref $_[0] ) {

            my %lopt = %opt;
            local @_ = @{ shift @_ };

            unshift @_, \%lopt, \%opt_nargs, qq[global option '-%s': %s];
            &_parse_args;

            unshift @_, $to, \%lopt;
            &_process_pkg;

        }

        elsif ( $_[0] =~ /^-/ ) {

            unshift @_, \%opt, \%opt_nargs, qq[global option '-%s': %s];
            &_parse_args;

        }

        else {
            unshift @_, $to, \%opt;
            &_process_pkg;
            last;
        }

    }

    return;
}

sub _process_pkg {

    my ( $to, $opt ) = ( shift, shift );

    my $package = shift;

    unshift @_, \my %mopt, \%mopt_nargs,
      qq[package "$package": package option '-%s': %s];
    &_parse_args;

    $mopt{require} //= $opt->{require} // 1;

    # flag indicationg everything in @_ is to be passed to pkg->import
    unless ( defined $mopt{import} ) {

        # if first argument is [], duplicate standard behavior:
        # use A ();     => don't call import
        # use A (), 'b' => A->import( 'b' );
        if ( 'ARRAY' eq ref $_[0] && $_[0] && @{ $_[0] } == 0 ) {

            shift;
            $mopt{import} = @_;
        }
        else {

            $mopt{import} = 1;

        }

    }

    # load package; this won't try to use inner packages
    if ( $mopt{require} ) {
        require Class::Load;
        Class::Load::load_class( $package,
            exists $mopt{version} ? { -version => $mopt{version} } : () );
    }

    my @packages = ($package);

    if ( $mopt{inner} ) {

        croak(qq[can't use option "-$_" when looping over inner packages\n])
          for grep { defined $mopt{$_} } qw[ as ];

        pop @packages if $mopt{inner} < 0;

        require Devel::InnerPackage;
        push @packages, Devel::InnerPackage::list_packages($package);
    }

    for my $pkg (@packages) {

        # print STDERR "package $pkg proferred\n";

        next if defined $mopt{include} && !( $pkg ~~ $mopt{include} );
        next if defined $mopt{exclude} && $pkg ~~ $mopt{exclude};

        # print STDERR "package $pkg accepted\n";

        my $alias = $mopt{as} // (
            $opt->{alias}
            ? _dispatch_alias( $opt->{alias}, $pkg )
            : $pkg
        );

        if ( $mopt{import} ) {
            require Import::Into;
            $pkg->import::into( $to, @_ );
        }

        # create alias if requested
        _make_alias( $to, $pkg, $alias )
          if $pkg ne $alias;
    }

    # all done
    return;
}

sub _make_alias {

    my ( $to, $package, $alias ) = @_;

    no strict 'refs';    ## no critic
    *{ join( '::', $to, $alias ) } = sub () { $package };

}

# this gets called as &_parse_args so that it alters
# the called @_ array
sub _parse_args {

    my ( $opts, $attr, $fmt ) = ( shift, shift, shift );

    while ( @_ && $_[0] =~ /^-(.*)/ ) {

        shift;
        my $opt  = $1;
        my $attr = $attr->{$opt};

        _die( $fmt, $opt, 'unknown option' )
          unless defined $attr;

        my $n = $attr->{n};

        _die( $fmt, $opt, 'not enough values' )
          if @_ < $n;

        my $value =
            $n == 0 ? ( exists $attr->{value} ? $attr->{value} : 1 )
          : $n == 1 ? shift(@_)
          :           [ splice( @_, 0, $n ) ];

        if ( $attr->{name} ) {

            $opts->{ $attr->{name} } = $attr->{tag} ? [ $opt, $value ] : $value;
        }

        else {

            $opts->{$opt} = $value;
        }

        last if $attr->{last};
    }

    return;
}

sub _dispatch_alias {

    my ( $name, $arg ) = @{ shift() };
    my $package = shift;

    if ( $name eq 'alias' ) {

        return $arg ? ( $package =~ /([^:]+)$/ )[0] : $package;
    }

    elsif ( $name eq 'strip' ) {

        my %attr = 'HASH' eq ref $arg ? %{$arg} : ( pfx => $arg );

        _die("-strip: no prefix specified\n")
          unless defined $attr{pfx};

        $attr{pfx} = quotemeta( $attr{pfx} );

        my $pfx = $attr{pfx};
        my $sep = defined $attr{sep} ? quotemeta( $attr{sep} ) : '';

        ( my $npkg = $package ) =~ s/^$pfx//;

        # don't return an empty package name
        return $package if $npkg eq '';

        # trim leading separator;
        $npkg =~ s/^:://;
        $npkg =~ s/::/$sep/g;

        return $npkg;
    }

    else {

        _die("internal error");

    }

}

sub _die {

    require Carp;

    my $err = @_ > 1 ? sprintf( shift, @_ ) : $_[0];

    Carp::croak( q[error in use pkg: ], $err );

}

__END__