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