initial import of Package::Variant

diff --git a/lib/Package/Variant.pm b/lib/Package/Variant.pm
new file mode 100644 (file)
index 0000000..e490bfb
--- /dev/null
+++ b/lib/Package/Variant.pm
@@ -0,0 +1,58 @@
+package Package::Variant;
+
+use strictures 1;
+
+our %Variable;
+
+sub import {
+  my $target = caller;
+  my $me = shift;
+  my $last = (split '::', $target)[-1];
+  my $anon = 'A000';
+  my $variable = $target;
+  my %args = @_;
+  no strict 'refs';
+  $Variable{$variable} = {
+    anon => $anon,
+    args => \%args,
+    subs => {
+      map +($_ => sub {}), @{$args{subs}||[]},
+    },
+  };
+  *{"${target}::import"} = sub {
+    my $target = caller;
+    no strict 'refs';
+    *{"${target}::${last}"} = sub {
+      $me->build_variant_of($variable, @_);
+    };
+  };
+  my $subs = $Variable{$variable}{subs};
+  foreach my $name (keys %$subs) {
+    *{"${target}::${name}"} = sub {
+      goto &{$subs->{$name}}
+    };
+  }
+  *{"${target}::install"} = sub {
+    goto &{$Variable{$variable}{install}};
+  }
+}
+
+sub build_variant_of {
+  my ($me, $variable, @args) = @_;
+  my $variant_name = "${variable}::_Variant_".++$Variable{$variable}{anon};
+  my @to_import = keys %{$Variable{$variable}{args}{importing}||{}};
+  my $setup = join("\n", "package ${variant_name};", (map "use $_;", @to_import), "1;");
+  eval $setup
+    or die "evaling ${setup} failed: $@";
+  my $subs = $Variable{$variable}{subs};
+  local @{$subs}{keys %$subs} = map $variant_name->can($_), keys %$subs;
+  local $Variable{$variable}{install} = sub {
+    my ($name, $ref) = @_;
+    no strict 'refs';
+    *{"${variant_name}::${name}"} = $ref;
+  };
+  $variable->make_variant($variant_name, @args);
+  return $variant_name;
+}
+
+1;

diff --git a/t/01simple.t b/t/01simple.t
new file mode 100644 (file)
index 0000000..2b33250
--- /dev/null
+++ b/t/01simple.t
@@ -0,0 +1,36 @@
+use strictures 1;
+use Test::More qw(no_plan);
+
+BEGIN {
+  package My::Role::OnOff;
+
+  use Package::Variant
+    importing => { 'Moo::Role' => [] },
+    subs => [ qw(has before after around) ];
+
+  sub make_variant {
+    my ($me, $into, %args) = @_;
+    my $name = $args{name};
+    has $name => (is => 'rw');
+    install "${name}_on" => sub { shift->$name(1); };
+    install "${name}_off" => sub { shift->$name(0); };
+  }
+  $INC{"My/Role/OnOff.pm"} = __FILE__;
+}
+
+BEGIN {
+  package LightSwitch;
+
+  use My::Role::OnOff;
+  use Moo;
+
+  with OnOff(name => 'lights');
+}
+
+my $lights = LightSwitch->new;
+
+is($lights->lights, undef, 'Initial state');
+is($lights->lights_on, 1, 'Turn on');
+is($lights->lights, 1, 'On');
+is($lights->lights_off, 0, 'Turn off');
+is($lights->lights, 0, 'Off');