lib/Package/Variant.pm

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