lib/Package/Variant.pm

   1 package Package::Variant;
   2
   3 use strictures 1;
   4 use Module::Runtime qw(require_module module_notional_filename);
   5 use Carp qw(croak);
   6
   7 our $VERSION = '1.002000'; # 1.2.0
   8
   9 $VERSION = eval $VERSION;
  10
  11 our %Variable;
  12
  13 my $sanitize_importing = sub {
  14   my ($me, $spec) = @_;
  15   return []
  16     unless defined $spec;
  17   my @specced =
  18     not(ref $spec)
  19       ? ($spec)
  20     : (ref($spec) eq 'ARRAY')
  21       ? (@$spec)
  22     : (ref($spec) eq 'HASH')
  23       ? (map {
  24           croak qq{The import argument list for '$_' is not an array ref}
  25             unless ref($spec->{$_}) eq 'ARRAY';
  26           ($_ => $spec->{$_});
  27         } sort keys %$spec)
  28     : croak q{The 'importing' option has to be either a hash or array ref};
  29   my @imports;
  30   my $arg_count = 1;
  31   while (@specced) {
  32     my $key = shift @specced;
  33     croak qq{Value $arg_count in 'importing' is not a package string},
  34       $arg_count
  35       unless defined($key) and not(ref $key);
  36     $arg_count++;
  37     my $import_args =
  38       (not(@specced) or (defined($specced[0]) and not ref($specced[0])))
  39         ? []
  40       : (ref($specced[0]) eq 'ARRAY')
  41         ? do { $arg_count++; shift @specced }
  42       : croak(
  43             qq{Value $arg_count for package '$key' in 'importing' is not}
  44           . qq{ a package string or array ref}
  45         );
  46     push @imports, [$key, $import_args];
  47   }
  48   return \@imports;
  49 };
  50
  51 my $sub_namer = eval {
  52   require Sub::Name; sub { shift if @_ > 2; Sub::Name::subname(@_) }
  53 } || sub { $_[-1] };
  54
  55 sub import {
  56   my $variable = caller;
  57   my $me = shift;
  58   my $last = (split '::', $variable)[-1];
  59   my $anon = 'A000';
  60   my %args = @_;
  61   no strict 'refs';
  62   $Variable{$variable} = {
  63     anon => $anon,
  64     args => {
  65       %args,
  66       importing => $me->$sanitize_importing($args{importing}),
  67     },
  68     subs => {
  69       map +($_ => sub {}), @{$args{subs}||[]},
  70     },
  71   };
  72   *{"${variable}::import"} = sub {
  73     my $target = caller;
  74     my (undef, %arg) = @_;
  75     my $as = defined($arg{as}) ? $arg{as} : $last;
  76     no strict 'refs';
  77     *{"${target}::${as}"} = sub {
  78       $me->build_variant_of($variable, @_);
  79     };
  80   };
  81   my $subs = $Variable{$variable}{subs};
  82   foreach my $name (keys %$subs) {
  83     *{"${variable}::${name}"} = sub {
  84       goto &{$subs->{$name}}
  85     };
  86   }
  87   *{"${variable}::install"} = sub {
  88     goto &{$Variable{$variable}{install}};
  89   };
  90   *{"${variable}::build_variant"} = sub {
  91     shift;
  92     $me->build_variant_of($variable, @_);
  93   };
  94 }
  95
  96 sub build_variant_of {
  97   my ($me, $variable, @args) = @_;
  98   my $variant_name = "${variable}::_Variant_".++$Variable{$variable}{anon};
  99   my $build = "package $variant_name;\n";
 100   my $importing = $Variable{$variable}{args}{importing};
 101   foreach my $i (0 .. $#$importing) {
 102     my $pkg = $importing->[$i][0];
 103     $build .= "use $pkg \@{\$importing->[$i][1]};\n";
 104   }
 105   my $subs = $Variable{$variable}{subs};
 106   my $builder = sub {
 107     local @{$subs}{keys %$subs} = map $variant_name->can($_), keys %$subs;
 108     local $Variable{$variable}{install} = sub {
 109       my $full_name = "${variant_name}::".shift;
 110
 111       my $ref = $sub_namer->($full_name, @_);
 112
 113       no strict 'refs';
 114       *$full_name = $ref;
 115     };
 116     $variable->make_variant($variant_name, @args);
 117   };
 118   $build .= "BEGIN { \$builder->() }\n1;\n";
 119   eval $build or die $@;
 120   $INC{module_notional_filename($variant_name)} = '(built by Package::Variant)';
 121   return $variant_name;
 122 }
 123
 124 1;
 125
 126 __END__
 127
 128 =head1 NAME
 129
 130 Package::Variant - Parameterizable packages
 131
 132 =head1 SYNOPSIS
 133
 134   # declaring a variable Moo role
 135   package My::Role::ObjectAttr;
 136   use strictures 1;
 137   use Package::Variant
 138     # what modules to 'use'
 139     importing => ['Moo::Role'],
 140     # proxied subroutines
 141     subs => [ qw(has around before after with) ],
 142
 143   sub make_variant {
 144     my ($class, $target_package, %arguments) = @_;
 145     # access arguments
 146     my $name = $arguments{name};
 147     # use proxied 'has' to add an attribute
 148     has $name => (is => 'lazy');
 149     # install a builder method
 150     install "_build_${name}" => sub {
 151       return $arguments{class}->new;
 152     };
 153   }
 154
 155   # using the role
 156   package My::Class::WithObjectAttr;
 157   use strictures 1;
 158   use Moo;
 159   use My::Role::ObjectAttr;
 160
 161   with ObjectAttr(name => 'some_obj', class => 'Some::Class');
 162
 163   # using our class
 164   my $obj = My::Class::WithObjectAttr->new;
 165   $obj->some_obj; # returns a Some::Class instance
 166
 167 =head1 DESCRIPTION
 168
 169 This module allows you to build packages that return different variations
 170 depending on what parameters are given.
 171
 172 Users of your package will receive a subroutine able to take parameters
 173 and return the name of a suitable variant package. The implementation does
 174 not care about what kind of package it builds.
 175
 176 =head2 Declaring a variable package
 177
 178 There are two important parts to creating a variable package. You first
 179 have to give C<Package::Variant> some basic information about what kind of
 180 package you want to provide, and how. The second part is implementing a
 181 method receiving the user's arguments and generating your variants.
 182
 183 =head3 Setting up the environment for building variations
 184
 185 When you C<use Package::Variant>, you pass along some arguments that
 186 describe how you intend to build your variations.
 187
 188   use Package::Variant
 189     importing => { $package => \@import_arguments, ... },
 190     subs      => [ @proxied_subroutine_names ];
 191
 192 The L</importing> option needs to be a hash or array reference with
 193 package names to be C<use>d as keys, and array references containing the
 194 import arguments as values. These packages will be imported into every new
 195 variant, and need to set up every declarative subroutine you require to
 196 build your variable package. The next option will allow you to use these
 197 functions. See L</importing> for more options. You can omit empty import
 198 argument lists when passing an array reference.
 199
 200 The L</subs> option is an array reference of subroutine names that are
 201 exported by the packages specified with L</importing>. These subroutines
 202 will be proxied from your declaration package to the variant to be
 203 generated.
 204
 205 With L</importing> initializing your package and L</subs> declaring what
 206 subroutines you want to use to build a variant, you can now write a
 207 L</make_variant> method building your variants.
 208
 209 =head3 Declaring a method to produce variants
 210
 211 Every time a user requests a new variant a method named L</make_variant>
 212 will be called with the name of the target package and the arguments from
 213 the user.
 214
 215 It can then use the proxied subroutines declared with L</subs> to
 216 customize the new package. An L</install> subroutine is exported as well
 217 allowing you to dynamically install methods into the new package. If these
 218 options aren't flexible enough, you can use the passed name of the new
 219 package to do any other kind of customizations.
 220
 221   sub make_variant {
 222     my ($class, $target, @arguments) = @_;
 223     # ...
 224     # customization goes here
 225     # ...
 226   }
 227
 228 When the method is finished, the user will receive the name of the new
 229 package variant you just set up.
 230
 231 =head2 Using variable packages
 232
 233 After your variable package is L<created|/Declaring a variable package>
 234 your users can get a variant generating subroutine by simply importing
 235 your package.
 236
 237   use My::Variant;
 238   my $new_variant_package = Variant(@variant_arguments);
 239
 240 The package is now fully initialized and used. You can import the
 241 subroutine under a different name by specifying an C<as> argument.
 242
 243 =head2 Dynamic creation of variant packages
 244
 245 For regular uses, the L<normal import|/Using variable packages> provides
 246 more than enough flexibility. However, if you want to create variations of
 247 dynamically determined packages, you can use the L</build_variant_of>
 248 method.
 249
 250 You can use this to create variations of other packages and pass arguments
 251 on to them to allow more modular and extensible variations.
 252
 253 =head1 OPTIONS
 254
 255 These are the options that can be passed when importing
 256 C<Package::Variant>. They describe the environment in which the variants
 257 are created.
 258
 259   use Package::Variant
 260     importing => { $package => \@import_arguments, ... },
 261     subs      => [ @proxied_subroutines ];
 262
 263 =head2 importing
 264
 265 This option is a hash reference mapping package names to array references
 266 containing import arguments. The packages will be imported with the given
 267 arguments by every variation before the L</make_variant> method is asked
 268 to create the package (this is done using L<Import::Into>).
 269
 270 If import order is important to you, you can also pass the C<importing>
 271 arguments as a flat array reference:
 272
 273   use Package::Variant
 274     importing => [ 'PackageA', 'PackageB' ];
 275
 276   # same as
 277   use Package::Variant
 278     importing => [ 'PackageA' => [], 'PackageB' => [] ];
 279
 280   # or
 281   use Package::Variant
 282     importing => { 'PackageA' => [], 'PackageB' => [] };
 283
 284 The import method will be called even if the list of import arguments is
 285 empty or not specified,
 286
 287 If you just want to import a single package's default exports, you can
 288 also pass a string instead:
 289
 290   use Package::Variant importing => 'Package';
 291
 292 =head2 subs
 293
 294 An array reference of strings listing the names of subroutines that should
 295 be proxied. These subroutines are expected to be installed into the new
 296 variant package by the modules imported with L</importing>. Subroutines
 297 with the same name will be available in your declaration package, and will
 298 proxy through to the newly created package when used within
 299 L</make_variant>.
 300
 301 =head1 VARIABLE PACKAGE METHODS
 302
 303 These are methods on the variable package you declare when you import
 304 C<Package::Variant>.
 305
 306 =head2 make_variant
 307
 308   Some::Variant::Package->make_variant( $target, @arguments );
 309
 310 B<You need to provide this method.> This method will be called for every
 311 new variant of your package. This method should use the subroutines
 312 declared in L</subs> to customize the new variant package.
 313
 314 This is a class method receiving the C<$target> package and the
 315 C<@arguments> defining the requested variant.
 316
 317 =head2 import
 318
 319   use Some::Variant::Package;
 320   my $variant_package = Package( @arguments );
 321
 322 This method is provided for you. It will allow a user to C<use> your
 323 package and receive a subroutine taking C<@arguments> defining the variant
 324 and returning the name of the newly created variant package.
 325
 326 The following options can be specified when importing:
 327
 328 =over
 329
 330 =item * B<as>
 331
 332   use Some::Variant::Package as => 'Foo';
 333   my $variant_package = Foo(@arguments);
 334
 335 Exports the generator subroutine under a different name than the default.
 336
 337 =back
 338
 339 =head2 build_variant
 340
 341   use Some::Variant::Package ();
 342   my $variant_package = Some::Variant::Package->build_variant( @arguments );
 343
 344 This method is provided for you.  It will generate a variant package
 345 and return its name, just like the generator sub provided by
 346 L</import>.  This allows you to avoid importing anything into the
 347 consuming package.
 348
 349 =head1 C<Package::Variant> METHODS
 350
 351 These methods are available on C<Package::Variant> itself.
 352
 353 =head2 build_variant_of
 354
 355   my $variant_package = Package::Variant
 356     ->build_variant_of($variable_package, @arguments);
 357
 358 This is the dynamic method of creating new variants. It takes the
 359 C<$variable_package>, which is a pre-declared variable package, and a set
 360 of C<@arguments> passed to the package to generate a new
 361 C<$variant_package>, which will be returned.
 362
 363 =head2 import
 364
 365   use Package::Variant @options;
 366
 367 Sets up the environment in which you declare the variants of your
 368 packages. See L</OPTIONS> for details on the available options and
 369 L</EXPORTS> for a list of exported subroutines.
 370
 371 =head1 EXPORTS
 372
 373 Additionally to the proxies for subroutines provided in L</subs>, the
 374 following exports will be available in your variable package:
 375
 376 =head2 install
 377
 378   install($method_name, $code_reference);
 379
 380 Installs a method with the given C<$method_name> into the newly created
 381 variant package. The C<$code_reference> will be used as the body for the
 382 method, and if L<Sub::Name> is available the coderef will be named. If you
 383 want to name it something else, then use:
 384
 385   install($method_name, $name_to_use, $code_reference);
 386
 387 =head1 AUTHOR
 388
 389 mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
 390
 391 =head1 CONTRIBUTORS
 392
 393 phaylon - Robert Sedlacek (cpan:PHAYLON) <r.sedlacek@shadowcat.co.uk>
 394
 395 haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
 396
 397 =head1 COPYRIGHT
 398
 399 Copyright (c) 2010-2012 the C<Package::Variant> L</AUTHOR> and
 400 L</CONTRIBUTORS> as listed above.
 401
 402 =head1 LICENSE
 403
 404 This library is free software and may be distributed under the same
 405 terms as perl itself.
 406
 407 =cut