lib/Package/Variant.pm

   1 package Package::Variant;
   2
   3 use strictures 1;
   4
   5 our %Variable;
   6
   7 sub import {
   8   my $target = caller;
   9   my $me = shift;
  10   my $last = (split '::', $target)[-1];
  11   my $anon = 'A000';
  12   my $variable = $target;
  13   my %args = @_;
  14   no strict 'refs';
  15   $Variable{$variable} = {
  16     anon => $anon,
  17     args => \%args,
  18     subs => {
  19       map +($_ => sub {}), @{$args{subs}||[]},
  20     },
  21   };
  22   *{"${target}::import"} = sub {
  23     my $target = caller;
  24     no strict 'refs';
  25     *{"${target}::${last}"} = sub {
  26       $me->build_variant_of($variable, @_);
  27     };
  28   };
  29   my $subs = $Variable{$variable}{subs};
  30   foreach my $name (keys %$subs) {
  31     *{"${target}::${name}"} = sub {
  32       goto &{$subs->{$name}}
  33     };
  34   }
  35   *{"${target}::install"} = sub {
  36     goto &{$Variable{$variable}{install}};
  37   }
  38 }
  39
  40 sub build_variant_of {
  41   my ($me, $variable, @args) = @_;
  42   my $variant_name = "${variable}::_Variant_".++$Variable{$variable}{anon};
  43   my @to_import = keys %{$Variable{$variable}{args}{importing}||{}};
  44   my $setup = join("\n", "package ${variant_name};", (map "use $_;", @to_import), "1;");
  45   eval $setup
  46     or die "evaling ${setup} failed: $@";
  47   my $subs = $Variable{$variable}{subs};
  48   local @{$subs}{keys %$subs} = map $variant_name->can($_), keys %$subs;
  49   local $Variable{$variable}{install} = sub {
  50     my ($name, $ref) = @_;
  51     no strict 'refs';
  52     *{"${variant_name}::${name}"} = $ref;
  53   };
  54   $variable->make_variant($variant_name, @args);
  55   return $variant_name;
  56 }
  57
  58 1;