added API for creating named variants

diff --git a/Changes b/Changes
index ce9d1db..e5636f3 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,7 @@
 Revision history for Package-Variant
 
+  - added API for creating named variants
+
 1.002002 - 2014-08-21
   - fix license in metadata
 

diff --git a/lib/Package/Variant.pm b/lib/Package/Variant.pm
index a242d93..33d0dc3 100644 (file)
--- a/lib/Package/Variant.pm
+++ b/lib/Package/Variant.pm
@@ -78,6 +78,9 @@ sub import {
     *{"${target}::${as}"} = sub {
       $me->build_variant_of($variable, @_);
     };
+    *{"${target}::${as}_named"} = sub {
+      $me->build_named_variant_of($variable, @_);
+    };
   };
   my $subs = $Variable{$variable}{subs};
   foreach my $name (keys %$subs) {
@@ -92,11 +95,26 @@ sub import {
     shift;
     $me->build_variant_of($variable, @_);
   };
-}
+  *{"${variable}::build_named_variant"} = sub {
+    shift;
+    $me->build_named_variant_of($variable, @_);
+  };
+  }
 
 sub build_variant_of {
   my ($me, $variable, @args) = @_;
+  my $variant_name = $me->_name_for($variable);
+  return $me->build_named_variant_of($variable, $variant_name, @args)
+}
+
+sub _name_for {
+  my (undef, $variable) = @_;
   my $variant_name = "${variable}::_Variant_".++$Variable{$variable}{anon};
+  return $variant_name;
+}
+
+sub build_named_variant_of {
+  my ($me, $variable, $variant_name, @args) = @_;
   foreach my $to_import (@{$Variable{$variable}{args}{importing}}) {
     my ($pkg, $args) = @$to_import;
     require_module $pkg;
@@ -156,9 +174,12 @@ Package::Variant - Parameterizable packages
 
   with ObjectAttr(name => 'some_obj', class => 'Some::Class');
 
+  with ObjectAttr_named("NamedVariant", name => 'named_obj', class => 'Named');
+
   # using our class
   my $obj = My::Class::WithObjectAttr->new;
   $obj->some_obj; # returns a Some::Class instance
+  die if !$obj->does("NamedVariant"); # works fine
 
 =head1 DESCRIPTION
 
@@ -166,8 +187,9 @@ This module allows you to build a variable package that contains a package
 template and can use it to build variant packages at runtime.
 
 Your variable package will export a subroutine which will build a variant
-package, combining its arguments with the template, and return the name of the
-new variant package.
+package, combining its arguments with the template, and return the generated
+name of the new variant package. Additionally it will export a subroutine that
+can build variant packages with user-defined package names.
 
 The implementation does not care about what kind of packages it builds, be they
 simple function exporters, classes, singletons or something entirely different.
@@ -320,10 +342,12 @@ C<@arguments> defining the requested variant.
 
   use Some::Variant::Package;
   my $variant_package = Package( @arguments );
+  my $named_variant_package = Package_named("VariantName", @arguments );
 
 This method is provided for you. It will allow a user to C<use> your
 package and receive a subroutine taking C<@arguments> defining the variant
-and returning the name of the newly created variant package.
+and returning the name of the newly created variant package, as well as a
+subroutine which takes a package name for the newly created variant package.
 
 The following options can be specified when importing:
 
@@ -348,6 +372,14 @@ and return its name, just like the generator sub provided by
 L</import>.  This allows you to avoid importing anything into the
 consuming package.
 
+=head2 build_named_variant
+
+  use Some::Variant::Package ();
+  my $named = Some::Variant::Package->build_named_variant( "Named", @args );
+
+Does the same thing as C<build_variant>, but takes additionally a name for the
+newly created variant package.
+
 =head1 C<Package::Variant> METHODS
 
 These methods are available on C<Package::Variant> itself.
@@ -362,6 +394,14 @@ C<$variable_package>, which is a pre-declared variable package, and a set
 of C<@arguments> passed to the package to generate a new
 C<$variant_package>, which will be returned.
 
+=head2 build_named_variant_of
+
+  my $named_variant_package = Package::Variant
+    ->build_variant_of($variable_package, "VariantName", @arguments);
+
+Does the same thing as C<build_variant_of>, but takes additionally a name for
+the newly created variant package.
+
 =head2 import
 
   use Package::Variant @options;
@@ -396,6 +436,8 @@ phaylon - Robert Sedlacek (cpan:PHAYLON) <r.sedlacek@shadowcat.co.uk>
 
 haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
 
+Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@gmail.com>
+
 =head1 COPYRIGHT
 
 Copyright (c) 2010-2012 the C<Package::Variant> L</AUTHOR> and

diff --git a/t/01simple.t b/t/01simple.t
index 3d3813d..4bb4548 100644 (file)
--- a/t/01simple.t
+++ b/t/01simple.t
@@ -36,25 +36,30 @@ BEGIN {
   $INC{'TestVariable.pm'} = __FILE__;
 }
 
-my $variant = do {
+my ($variant, $named_variant) = do {
     package TestScopeA;
     use TestVariable;
-    TestVariable(3..7);
+    (TestVariable(3..7), TestVariable_named("Name", 3..7));
 };
 
-ok defined($variant), 'new variant is a defined value';
-ok length($variant), 'new variant has length';
-is $variant->target, $variant, 'target was new variant';
-is_deeply $variant->args, [3..7], 'correct arguments received';
-
-is_deeply shift(@DECLARED), [target => $variant],
-  'target passed via proxy';
-is_deeply shift(@DECLARED), [args => [3..7]],
-  'arguments passed via proxy';
-is_deeply shift(@DECLARED), [class => 'TestVariable'],
-  'class method resolution';
+for ($variant, $named_variant) {
+  ok defined($_), 'new variant is a defined value';
+  ok length($_), 'new variant has length';
+  is $_->target, $_, 'target was new variant';
+  is_deeply $_->args, [3..7], 'correct arguments received';
+
+  is_deeply shift(@DECLARED), [target => $_],
+    'target passed via proxy';
+  is_deeply shift(@DECLARED), [args => [3..7]],
+    'arguments passed via proxy';
+  is_deeply shift(@DECLARED), [class => 'TestVariable'],
+    'class method resolution';
+}
+
 is scalar(@DECLARED), 0, 'proxy sub called right amount of times';
 
+ok $named_variant->isa("Name"), 'created class can be named';
+
 use TestVariable as => 'RenamedVar';
 is exception {
   my $renamed = RenamedVar(9..12);
@@ -107,6 +112,14 @@ TestSingleImport::->build_variant;
 is_deeply [@imported], [qw( TestImportableA )],
   'build_variant works';
 
+@imported = ();
+
+is( TestSingleImport::->build_named_variant("Named"), "Named",
+  "build_named_variant applies name" );
+
+is_deeply [@imported], [qw( TestImportableA )],
+  'build_variant works';
+
 like exception {
   Package::Variant->import(
     importing => \'foo', subs => [qw( foo )],