File Coverage

blib/lib/Package/Variant.pm

Criterion	Covered	Total	%
statement	69	72	95.8
branch	5	8	62.5
condition			n/a
subroutine	16	18	88.8
pod	1	2	50.0
total	91	100	91.0

package Package::Variant;

use strictures 2;
use Import::Into;
use Module::Runtime qw(require_module);
use Carp qw(croak);

our $VERSION = '1.003002';

$VERSION = eval $VERSION;

our %Variable;

my $sanitize_importing = sub {
  my ($me, $spec) = @_;
  return []
    unless defined $spec;
  my @specced =
    not(ref $spec)
      ? ($spec)
    : (ref($spec) eq 'ARRAY')
      ? (@$spec)
    : (ref($spec) eq 'HASH')
      ? (map {
          croak qq{The import argument list for '$_' is not an array ref}
            unless ref($spec->{$_}) eq 'ARRAY';
          ($_ => $spec->{$_});
        } sort keys %$spec)
    : croak q{The 'importing' option has to be either a hash or array ref};
  my @imports;
  my $arg_count = 1;
  while (@specced) {
    my $key = shift @specced;
    croak qq{Value $arg_count in 'importing' is not a package string},
      $arg_count
      unless defined($key) and not(ref $key);
    $arg_count++;
    my $import_args =
      (not(@specced) or (defined($specced[0]) and not ref($specced[0])))
        ? []
      : (ref($specced[0]) eq 'ARRAY')
        ? do { $arg_count++; shift @specced }
      : croak(
            qq{Value $arg_count for package '$key' in 'importing' is not}
          . qq{ a package string or array ref}
        );
    push @imports, [$key, $import_args];
  }
  return \@imports;
};

my $sub_namer = eval {
  require Sub::Name; sub { shift if @_ > 2; Sub::Name::subname(@_) }
} || sub { $_[-1] };

sub import {
  my $variable = caller;
  my $me = shift;
  my $last = (split '::', $variable)[-1];
  my $anon = 'A000';
  my %args = @_;
  no strict 'refs';
  $Variable{$variable} = {
    anon => $anon,
    args => {
      %args,
      importing => $me->$sanitize_importing($args{importing}),
    },
    subs => {
      map +($_ => sub {}), @{$args{subs}||[]},
    },
  };
  *{"${variable}::import"} = sub {
    my $target = caller;
    my (undef, %arg) = @_;
    my $as = defined($arg{as}) ? $arg{as} : $last;
    no strict 'refs';
    *{"${target}::${as}"} = sub {
      $me->build_variant_of($variable, @_);
    };
  };
  my $subs = $Variable{$variable}{subs};
  foreach my $name (keys %$subs) {
    *{"${variable}::${name}"} = sub {
      goto &{$subs->{$name}}
    };
  }
  *{"${variable}::install"} = sub {
    goto &{$Variable{$variable}{install}};
  };
  *{"${variable}::build_variant"} = sub {
    shift;
    $me->build_variant_of($variable, @_);
  };
}

sub build_variant_package_name {
  my ($me, $variable, @args) = @_;
  if ($variable->can('make_variant_package_name')) {
    return $variable->make_variant_package_name(@args);
  }
  return "${variable}::_Variant_".++$Variable{$variable}{anon};
}

sub build_variant_of {
  my ($me, $variable, @args) = @_;
  my $variant_name = $me->build_variant_package_name($variable, @args);
  foreach my $to_import (@{$Variable{$variable}{args}{importing}}) {
    my ($pkg, $args) = @$to_import;
    require_module $pkg;
    eval q{ BEGIN { $pkg->import::into($variant_name, @{$args}) }; 1; }
      or die $@;
  }
  my $subs = $Variable{$variable}{subs};
  local @{$subs}{keys %$subs} = map $variant_name->can($_), keys %$subs;
  local $Variable{$variable}{install} = sub {
    my $full_name = "${variant_name}::".shift;

    my $ref = $sub_namer->($full_name, @_);

    no strict 'refs';
    *$full_name = $ref;
  };
  $variable->make_variant($variant_name, @args);
  return $variant_name;
}

1;

__END__