lib/Package/Variant.pm

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