lib/Package/Variant.pm

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