X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FPackage%2FVariant.pm;h=a76d75e7724f1c8050832fa4b3f637655287d05b;hb=192cd3271b84863fa5a649297fb0297ac150095a;hp=e490bfb757113939a86bb91b97383d299bd59597;hpb=236a4386470d4edcbdda8a7d5564dd04401c7027;p=p5sagit%2FPackage-Variant.git

diff --git a/lib/Package/Variant.pm b/lib/Package/Variant.pm
index e490bfb..a76d75e 100644
--- a/lib/Package/Variant.pm
+++ b/lib/Package/Variant.pm
@@ -1,58 +1,476 @@
 package Package::Variant;
 
-use strictures 1;
+use strictures 2;
+use Import::Into;
+use Module::Runtime qw(require_module);
+use Carp qw(croak);
+
+our $VERSION = '1.003001';
+
+$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 $target = caller;
+  my $variable = caller;
   my $me = shift;
-  my $last = (split '::', $target)[-1];
+  my $last = (split '::', $variable)[-1];
   my $anon = 'A000';
-  my $variable = $target;
   my %args = @_;
   no strict 'refs';
   $Variable{$variable} = {
     anon => $anon,
-    args => \%args,
+    args => {
+      %args,
+      importing => $me->$sanitize_importing($args{importing}),
+    },
     subs => {
       map +($_ => sub {}), @{$args{subs}||[]},
     },
   };
-  *{"${target}::import"} = sub {
+  *{"${variable}::import"} = sub {
     my $target = caller;
+    my (undef, %arg) = @_;
+    my $as = defined($arg{as}) ? $arg{as} : $last;
     no strict 'refs';
-    *{"${target}::${last}"} = sub {
+    *{"${target}::${as}"} = sub {
       $me->build_variant_of($variable, @_);
     };
   };
   my $subs = $Variable{$variable}{subs};
   foreach my $name (keys %$subs) {
-    *{"${target}::${name}"} = sub {
+    *{"${variable}::${name}"} = sub {
       goto &{$subs->{$name}}
     };
   }
-  *{"${target}::install"} = sub {
+  *{"${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 = "${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 $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 ($name, $ref) = @_;
+    my $full_name = "${variant_name}::".shift;
+
+    my $ref = $sub_namer->($full_name, @_);
+    
     no strict 'refs';
-    *{"${variant_name}::${name}"} = $ref;
+    *$full_name = $ref;
   };
   $variable->make_variant($variant_name, @args);
   return $variant_name;
 }
 
 1;
+
+__END__
+
+=head1 NAME
+
+Package::Variant - Parameterizable packages
+
+=head1 SYNOPSIS
+
+Creation of anonymous variants:
+
+  # declaring a variable Moo role
+  package My::VariableRole::ObjectAttr;
+  use strictures 2;
+  use Package::Variant
+    # what modules to 'use'
+    importing => ['Moo::Role'],
+    # proxied subroutines
+    subs => [ qw(has around before after with) ];
+
+  sub make_variant {
+    my ($class, $target_package, %arguments) = @_;
+    # access arguments
+    my $name = $arguments{name};
+    # use proxied 'has' to add an attribute
+    has $name => (is => 'lazy');
+    # install a builder method
+    install "_build_${name}" => sub {
+      return $arguments{class}->new;
+    };
+  }
+
+  # using the role
+  package My::Class::WithObjectAttr;
+  use strictures 2;
+  use Moo;
+  use My::VariableRole::ObjectAttr;
+
+  with ObjectAttr(name => 'some_obj', class => 'Some::Class');
+
+  # using our class
+  my $obj = My::Class::WithObjectAttr->new;
+  $obj->some_obj; # returns a Some::Class instance
+
+And the same thing, only with named variants:
+
+  # declaring a variable Moo role that can be named
+  package My::VariableRole::ObjectAttrNamed;
+  use strictures 2;
+  use Package::Variant importing => ['Moo::Role'],
+    subs => [ qw(has around before after with) ];
+  use Module::Runtime 'module_notional_filename'; # only if you need protection
+
+  # this method is run at variant creation time to determine its custom
+  # package name. it can use the arguments or do something entirely else.
+  sub make_variant_package_name {
+    my ($class, $package, %arguments) = @_;
+    $package = "Private::$package"; # you can munge the input here if you like
+    # only if you *need* protection
+    die "Won't clobber $package" if $INC{module_notional_filename $package};
+    return $package;
+  }
+
+  # same as in the example above, except for the argument list. in this example
+  # $package is the user input, and
+  # $target_package is the actual package in which the variant gets installed
+  sub make_variant {
+    my ($class, $target_package, $package, %arguments) = @_;
+    my $name = $arguments{name};
+    has $name => (is => 'lazy');
+    install "_build_${name}" => sub {return $arguments{class}->new};
+  }
+
+  # using the role
+  package My::Class::WithObjectAttr;
+  use strictures 2;
+  use Moo;
+  use My::VariableRole::ObjectAttrNamed;
+
+  # create the role under a specific name
+  ObjectAttrNamed "My::Role" => (name => 'some_obj', class => 'Some::Class');
+  # and use it
+  with "Private::My::Role";
+
+  # using our class
+  my $obj = My::Class::WithObjectAttr->new;
+  $obj->some_obj; # returns a Some::Class instance
+
+=head1 DESCRIPTION
+
+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.
+
+The implementation does not care about what kind of packages it builds, be they
+simple function exporters, classes, singletons or something entirely different.
+
+=head2 Declaring a variable package
+
+There are two important parts to creating a variable package. You first
+have to give C<Package::Variant> some basic information about what kind of
+variant packages you want to provide, and how. The second part is implementing a
+method which builds the components of the variant packages that use the user's
+arguments or cannot be provided with a static import.
+
+=head3 Setting up the environment for building variants
+
+When you C<use Package::Variant>, you pass along some arguments that
+describe how you intend to build your variants.
+
+  use Package::Variant
+    importing => { $package => \@import_arguments, ... },
+    subs      => [ @proxied_subroutine_names ];
+
+The L</importing> option needs to be a hash or array reference with
+package names to be C<use>d as keys, and array references containing the
+import arguments as values. These packages will be imported into every new
+variant package, to provide static functionality of the variant packages and to
+set up every declarative subroutine you require to build variants package
+components. The next option will allow you to use these functions. See
+L</importing> for more options. You can omit empty import argument lists when
+passing an array reference.
+
+The L</subs> option is an array reference of subroutine names that are
+exported by the packages specified with L</importing>. These subroutines
+will be proxied from your variable package to the variant to be
+generated.
+
+With L</importing> initializing your package and L</subs> declaring what
+subroutines you want to use to build a variant, you can now write a
+L</make_variant> method building your variants.
+
+=head3 Declaring a method to produce variants
+
+Every time a user requests a new variant, a method named L</make_variant>
+will be called with the name of the target package and the arguments from
+the user.
+
+It can then use the proxied subroutines declared with L</subs> to
+customize the variant package. An L</install> subroutine is exported as well
+allowing you to dynamically install methods into the variant package. If these
+options aren't flexible enough, you can use the passed name of the variant
+package to do any other kind of customizations.
+
+  sub make_variant {
+    my ($class, $target, @arguments) = @_;
+    # ...
+    # customization goes here
+    # ...
+  }
+
+When the method is finished, the user will receive the name of the new variant
+package you just set up.
+
+=head2 Using variable packages
+
+After your variable package is L<created|/Declaring a variable package>
+your users can get a variant generator subroutine by simply importing
+your package.
+
+  use My::Variant;
+  my $new_variant_package = Variant(@variant_arguments);
+  # the variant package is now fully initialized and used
+
+You can import the subroutine under a different name by specifying an C<as>
+argument.
+
+=head2 Dynamic creation of variant packages
+
+For regular uses, the L<normal import|/Using variable packages> provides
+more than enough flexibility. However, if you want to create variants of
+dynamically determined packages, you can use the L</build_variant_of>
+method.
+
+You can use this to create variants of other packages and pass arguments
+on to them to allow more modular and extensible variants.
+
+=head1 OPTIONS
+
+These are the options that can be passed when importing
+C<Package::Variant>. They describe the environment in which the variants
+are created.
+
+  use Package::Variant
+    importing => { $package => \@import_arguments, ... },
+    subs      => [ @proxied_subroutines ];
+
+=head2 importing
+
+This option is a hash reference mapping package names to array references
+containing import arguments. The packages will be imported with the given
+arguments by every variant before the L</make_variant> method is asked
+to create the package (this is done using L<Import::Into>).
+
+If import order is important to you, you can also pass the C<importing>
+arguments as a flat array reference:
+
+  use Package::Variant
+    importing => [ 'PackageA', 'PackageB' ];
+
+  # same as
+  use Package::Variant
+    importing => [ 'PackageA' => [], 'PackageB' => [] ];
+
+  # or
+  use Package::Variant
+    importing => { 'PackageA' => [], 'PackageB' => [] };
+
+The import method will be called even if the list of import arguments is
+empty or not specified,
+
+If you just want to import a single package's default exports, you can
+also pass a string instead:
+
+  use Package::Variant importing => 'Package';
+
+=head2 subs
+
+An array reference of strings listing the names of subroutines that should
+be proxied. These subroutines are expected to be installed into the new
+variant package by the modules imported with L</importing>. Subroutines
+with the same name will be available in your variable package, and will
+proxy through to the newly created package when used within
+L</make_variant>.
+
+=head1 VARIABLE PACKAGE METHODS
+
+These are methods on the variable package you declare when you import
+C<Package::Variant>.
+
+=head2 make_variant
+
+  Some::Variant::Package->make_variant( $target, @arguments );
+
+B<You need to provide this method.> This method will be called for every
+new variant of your package. This method should use the subroutines
+declared in L</subs> to customize the new variant package.
+
+This is a class method receiving the C<$target> package and the
+C<@arguments> defining the requested variant.
+
+=head2 make_variant_package_name
+
+  Some::Variant::Package->make_variant_package_name( @arguments );
+
+B<You may optionally provide this method.> If present, this method will be
+used to determine the package name for a particular variant being constructed.
+
+If you do not implement it, a unique package name something like
+
+  Some::Variant::Package::_Variant_A003
+
+will be created for you.
+
+=head2 import
+
+  use Some::Variant::Package;
+  my $variant_package = Package( @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.
+
+The following options can be specified when importing:
+
+=over
+
+=item * B<as>
+
+  use Some::Variant::Package as => 'Foo';
+  my $variant_package = Foo(@arguments);
+
+Exports the generator subroutine under a different name than the default.
+
+=back
+
+=head2 build_variant
+
+  use Some::Variant::Package ();
+  my $variant_package = Some::Variant::Package->build_variant( @arguments );
+
+This method is provided for you.  It will generate a variant package
+and return its name, just like the generator sub provided by
+L</import>.  This allows you to avoid importing anything into the
+consuming package.
+
+=head1 C<Package::Variant> METHODS
+
+These methods are available on C<Package::Variant> itself.
+
+=head2 build_variant_of
+
+  my $variant_package = Package::Variant
+    ->build_variant_of($variable_package, @arguments);
+
+This is the dynamic method of creating new variants. It takes the
+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 import
+
+  use Package::Variant @options;
+
+Sets up the environment in which you declare the variants of your
+packages. See L</OPTIONS> for details on the available options and
+L</EXPORTS> for a list of exported subroutines.
+
+=head1 EXPORTS
+
+Additionally to the proxies for subroutines provided in L</subs>, the
+following exports will be available in your variable package:
+
+=head2 install
+
+  install($method_name, $code_reference);
+
+Installs a method with the given C<$method_name> into the newly created
+variant package. The C<$code_reference> will be used as the body for the
+method, and if L<Sub::Name> is available the coderef will be named. If you
+want to name it something else, then use:
+
+  install($method_name, $name_to_use, $code_reference);
+
+=head1 AUTHOR
+
+mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
+
+=head1 CONTRIBUTORS
+
+phaylon - Robert Sedlacek (cpan:PHAYLON) <r.sedlacek@shadowcat.co.uk>
+
+haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2010-2012 the C<Package::Variant> L</AUTHOR> and
+L</CONTRIBUTORS> as listed above.
+
+=head1 LICENSE
+
+This library is free software and may be distributed under the same
+terms as perl itself.
+
+=cut