lib/Package/Variant.pm

   1 package Package::Variant;
   2
   3 use strictures 1;
   4 use Import::Into;
   5 use Module::Runtime qw(require_module);
   6 use Carp qw(croak);
   7
   8 our $VERSION = '1.002002';
   9
  10 $VERSION = eval $VERSION;
  11
  12 our %Variable;
  13
  14 my $sanitize_importing = sub {
  15   my ($me, $spec) = @_;
  16   return []
  17     unless defined $spec;
  18   my @specced =
  19     not(ref $spec)
  20       ? ($spec)
  21     : (ref($spec) eq 'ARRAY')
  22       ? (@$spec)
  23     : (ref($spec) eq 'HASH')
  24       ? (map {
  25           croak qq{The import argument list for '$_' is not an array ref}
  26             unless ref($spec->{$_}) eq 'ARRAY';
  27           ($_ => $spec->{$_});
  28         } sort keys %$spec)
  29     : croak q{The 'importing' option has to be either a hash or array ref};
  30   my @imports;
  31   my $arg_count = 1;
  32   while (@specced) {
  33     my $key = shift @specced;
  34     croak qq{Value $arg_count in 'importing' is not a package string},
  35       $arg_count
  36       unless defined($key) and not(ref $key);
  37     $arg_count++;
  38     my $import_args =
  39       (not(@specced) or (defined($specced[0]) and not ref($specced[0])))
  40         ? []
  41       : (ref($specced[0]) eq 'ARRAY')
  42         ? do { $arg_count++; shift @specced }
  43       : croak(
  44             qq{Value $arg_count for package '$key' in 'importing' is not}
  45           . qq{ a package string or array ref}
  46         );
  47     push @imports, [$key, $import_args];
  48   }
  49   return \@imports;
  50 };
  51
  52 my $sub_namer = eval {
  53   require Sub::Name; sub { shift if @_ > 2; Sub::Name::subname(@_) }
  54 } || sub { $_[-1] };
  55
  56 sub import {
  57   my $variable = caller;
  58   my $me = shift;
  59   my $last = (split '::', $variable)[-1];
  60   my $anon = 'A000';
  61   my %args = @_;
  62   no strict 'refs';
  63   $Variable{$variable} = {
  64     anon => $anon,
  65     args => {
  66       %args,
  67       importing => $me->$sanitize_importing($args{importing}),
  68     },
  69     subs => {
  70       map +($_ => sub {}), @{$args{subs}||[]},
  71     },
  72   };
  73   *{"${variable}::import"} = sub {
  74     my $target = caller;
  75     my (undef, %arg) = @_;
  76     my $as = defined($arg{as}) ? $arg{as} : $last;
  77     no strict 'refs';
  78     *{"${target}::${as}"} = sub {
  79       $me->build_variant_of($variable, @_);
  80     };
  81   };
  82   my $subs = $Variable{$variable}{subs};
  83   foreach my $name (keys %$subs) {
  84     *{"${variable}::${name}"} = sub {
  85       goto &{$subs->{$name}}
  86     };
  87   }
  88   *{"${variable}::install"} = sub {
  89     goto &{$Variable{$variable}{install}};
  90   };
  91   *{"${variable}::build_variant"} = sub {
  92     shift;
  93     $me->build_variant_of($variable, @_);
  94   };
  95 }
  96
  97 sub build_variant_of {
  98   my ($me, $variable, @args) = @_;
  99   my $variant_name = "${variable}::_Variant_".++$Variable{$variable}{anon};
 100   foreach my $to_import (@{$Variable{$variable}{args}{importing}}) {
 101     my ($pkg, $args) = @$to_import;
 102     require_module $pkg;
 103     eval q{ BEGIN { $pkg->import::into($variant_name, @{$args}) }; 1; }
 104       or die $@;
 105   }
 106   my $subs = $Variable{$variable}{subs};
 107   local @{$subs}{keys %$subs} = map $variant_name->can($_), keys %$subs;
 108   local $Variable{$variable}{install} = sub {
 109     my $full_name = "${variant_name}::".shift;
 110
 111     my $ref = $sub_namer->($full_name, @_);
 112
 113     no strict 'refs';
 114     *$full_name = $ref;
 115   };
 116   $variable->make_variant($variant_name, @args);
 117   return $variant_name;
 118 }
 119
 120 1;
 121
 122 __END__
 123
 124 =head1 NAME
 125
 126 Package::Variant - Parameterizable packages
 127
 128 =head1 SYNOPSIS
 129
 130   # declaring a variable Moo role
 131   package My::VariableRole::ObjectAttr;
 132   use strictures 1;
 133   use Package::Variant
 134     # what modules to 'use'
 135     importing => ['Moo::Role'],
 136     # proxied subroutines
 137     subs => [ qw(has around before after with) ];
 138
 139   sub make_variant {
 140     my ($class, $target_package, %arguments) = @_;
 141     # access arguments
 142     my $name = $arguments{name};
 143     # use proxied 'has' to add an attribute
 144     has $name => (is => 'lazy');
 145     # install a builder method
 146     install "_build_${name}" => sub {
 147       return $arguments{class}->new;
 148     };
 149   }
 150
 151   # using the role
 152   package My::Class::WithObjectAttr;
 153   use strictures 1;
 154   use Moo;
 155   use My::VariableRole::ObjectAttr;
 156
 157   with ObjectAttr(name => 'some_obj', class => 'Some::Class');
 158
 159   # using our class
 160   my $obj = My::Class::WithObjectAttr->new;
 161   $obj->some_obj; # returns a Some::Class instance
 162
 163 =head1 DESCRIPTION
 164
 165 This module allows you to build a variable package that contains a package
 166 template and can use it to build variant packages at runtime.
 167
 168 Your variable package will export a subroutine which will build a variant
 169 package, combining its arguments with the template, and return the name of the
 170 new variant package.
 171
 172 The implementation does not care about what kind of packages it builds, be they
 173 simple function exporters, classes, singletons or something entirely different.
 174
 175 =head2 Declaring a variable package
 176
 177 There are two important parts to creating a variable package. You first
 178 have to give C<Package::Variant> some basic information about what kind of
 179 variant packages you want to provide, and how. The second part is implementing a
 180 method which builds the components of the variant packages that use the user's
 181 arguments or cannot be provided with a static import.
 182
 183 =head3 Setting up the environment for building variants
 184
 185 When you C<use Package::Variant>, you pass along some arguments that
 186 describe how you intend to build your variants.
 187
 188   use Package::Variant
 189     importing => { $package => \@import_arguments, ... },
 190     subs      => [ @proxied_subroutine_names ];
 191
 192 The L</importing> option needs to be a hash or array reference with
 193 package names to be C<use>d as keys, and array references containing the
 194 import arguments as values. These packages will be imported into every new
 195 variant package, to provide static functionality of the variant packages and to
 196 set up every declarative subroutine you require to build variants package
 197 components. The next option will allow you to use these functions. See
 198 L</importing> for more options. You can omit empty import argument lists when
 199 passing an array reference.
 200
 201 The L</subs> option is an array reference of subroutine names that are
 202 exported by the packages specified with L</importing>. These subroutines
 203 will be proxied from your variable package to the variant to be
 204 generated.
 205
 206 With L</importing> initializing your package and L</subs> declaring what
 207 subroutines you want to use to build a variant, you can now write a
 208 L</make_variant> method building your variants.
 209
 210 =head3 Declaring a method to produce variants
 211
 212 Every time a user requests a new variant, a method named L</make_variant>
 213 will be called with the name of the target package and the arguments from
 214 the user.
 215
 216 It can then use the proxied subroutines declared with L</subs> to
 217 customize the variant package. An L</install> subroutine is exported as well
 218 allowing you to dynamically install methods into the variant package. If these
 219 options aren't flexible enough, you can use the passed name of the variant
 220 package to do any other kind of customizations.
 221
 222   sub make_variant {
 223     my ($class, $target, @arguments) = @_;
 224     # ...
 225     # customization goes here
 226     # ...
 227   }
 228
 229 When the method is finished, the user will receive the name of the new variant
 230 package you just set up.
 231
 232 =head2 Using variable packages
 233
 234 After your variable package is L<created|/Declaring a variable package>
 235 your users can get a variant generator subroutine by simply importing
 236 your package.
 237
 238   use My::Variant;
 239   my $new_variant_package = Variant(@variant_arguments);
 240   # the variant package is now fully initialized and used
 241
 242 You can import the subroutine under a different name by specifying an C<as>
 243 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 variants of
 249 dynamically determined packages, you can use the L</build_variant_of>
 250 method.
 251
 252 You can use this to create variants of other packages and pass arguments
 253 on to them to allow more modular and extensible variants.
 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 imported with the given
 269 arguments by every variant before the L</make_variant> method is asked
 270 to create the package (this is done using L<Import::Into>).
 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 available in your variable 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 =head2 build_variant
 342
 343   use Some::Variant::Package ();
 344   my $variant_package = Some::Variant::Package->build_variant( @arguments );
 345
 346 This method is provided for you.  It will generate a variant package
 347 and return its name, just like the generator sub provided by
 348 L</import>.  This allows you to avoid importing anything into the
 349 consuming package.
 350
 351 =head1 C<Package::Variant> METHODS
 352
 353 These methods are available on C<Package::Variant> itself.
 354
 355 =head2 build_variant_of
 356
 357   my $variant_package = Package::Variant
 358     ->build_variant_of($variable_package, @arguments);
 359
 360 This is the dynamic method of creating new variants. It takes the
 361 C<$variable_package>, which is a pre-declared variable package, and a set
 362 of C<@arguments> passed to the package to generate a new
 363 C<$variant_package>, which will be returned.
 364
 365 =head2 import
 366
 367   use Package::Variant @options;
 368
 369 Sets up the environment in which you declare the variants of your
 370 packages. See L</OPTIONS> for details on the available options and
 371 L</EXPORTS> for a list of exported subroutines.
 372
 373 =head1 EXPORTS
 374
 375 Additionally to the proxies for subroutines provided in L</subs>, the
 376 following exports will be available in your variable package:
 377
 378 =head2 install
 379
 380   install($method_name, $code_reference);
 381
 382 Installs a method with the given C<$method_name> into the newly created
 383 variant package. The C<$code_reference> will be used as the body for the
 384 method, and if L<Sub::Name> is available the coderef will be named. If you
 385 want to name it something else, then use:
 386
 387   install($method_name, $name_to_use, $code_reference);
 388
 389 =head1 AUTHOR
 390
 391 mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
 392
 393 =head1 CONTRIBUTORS
 394
 395 phaylon - Robert Sedlacek (cpan:PHAYLON) <r.sedlacek@shadowcat.co.uk>
 396
 397 haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
 398
 399 =head1 COPYRIGHT
 400
 401 Copyright (c) 2010-2012 the C<Package::Variant> L</AUTHOR> and
 402 L</CONTRIBUTORS> as listed above.
 403
 404 =head1 LICENSE
 405
 406 This library is free software and may be distributed under the same
 407 terms as perl itself.
 408
 409 =cut