lib/Package/Variant.pm

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