From: Christian Walde Date: Sun, 6 Jul 2014 17:28:30 +0000 (+0200) Subject: added API for creating named variants X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FPackage-Variant.git;a=commitdiff_plain;h=185a0b334446d0d1642be7e89c34da88f3b0bff6;hp=f11ad9c91fdc553f1b814e4636861e75eb1ebd7d added API for creating named variants --- diff --git a/Changes b/Changes index ce9d1db..e5636f3 100644 --- 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 --- 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 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. 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, but takes additionally a name for the +newly created variant package. + =head1 C METHODS These methods are available on C 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, 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) haarg - Graham Knop (cpan:HAARG) +Mithaldu - Christian Walde (cpan:MITHALDU) + =head1 COPYRIGHT Copyright (c) 2010-2012 the C L and diff --git a/t/01simple.t b/t/01simple.t index 3d3813d..4bb4548 100644 --- 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 )],