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