Commit | Line | Data |
236a4386 |
1 | package Package::Variant; |
2 | |
fb6c1581 |
3 | use strictures 2; |
1bacb018 |
4 | use Import::Into; |
3c1ca277 |
5 | use Module::Runtime qw(require_module); |
1bacb018 |
6 | use Carp qw(croak); |
236a4386 |
7 | |
2f1d078b |
8 | our $VERSION = '1.003002'; |
eacc208a |
9 | |
10 | $VERSION = eval $VERSION; |
11 | |
236a4386 |
12 | our %Variable; |
13 | |
115c342b |
14 | my $sanitize_importing = sub { |
15 | my ($me, $spec) = @_; |
16 | return [] |
17 | unless defined $spec; |
203d81fc |
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}; |
115c342b |
30 | my @imports; |
203d81fc |
31 | my $arg_count = 1; |
115c342b |
32 | while (@specced) { |
33 | my $key = shift @specced; |
203d81fc |
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]; |
115c342b |
48 | } |
49 | return \@imports; |
50 | }; |
51 | |
ed98a1a0 |
52 | my $sub_namer = eval { |
53 | require Sub::Name; sub { shift if @_ > 2; Sub::Name::subname(@_) } |
54 | } || sub { $_[-1] }; |
55 | |
236a4386 |
56 | sub import { |
d61014ce |
57 | my $variable = caller; |
236a4386 |
58 | my $me = shift; |
d61014ce |
59 | my $last = (split '::', $variable)[-1]; |
236a4386 |
60 | my $anon = 'A000'; |
236a4386 |
61 | my %args = @_; |
62 | no strict 'refs'; |
63 | $Variable{$variable} = { |
64 | anon => $anon, |
115c342b |
65 | args => { |
66 | %args, |
67 | importing => $me->$sanitize_importing($args{importing}), |
68 | }, |
236a4386 |
69 | subs => { |
70 | map +($_ => sub {}), @{$args{subs}||[]}, |
71 | }, |
72 | }; |
d61014ce |
73 | *{"${variable}::import"} = sub { |
236a4386 |
74 | my $target = caller; |
0a7db8d2 |
75 | my (undef, %arg) = @_; |
76 | my $as = defined($arg{as}) ? $arg{as} : $last; |
236a4386 |
77 | no strict 'refs'; |
0a7db8d2 |
78 | *{"${target}::${as}"} = sub { |
236a4386 |
79 | $me->build_variant_of($variable, @_); |
80 | }; |
81 | }; |
82 | my $subs = $Variable{$variable}{subs}; |
83 | foreach my $name (keys %$subs) { |
d61014ce |
84 | *{"${variable}::${name}"} = sub { |
236a4386 |
85 | goto &{$subs->{$name}} |
86 | }; |
87 | } |
d61014ce |
88 | *{"${variable}::install"} = sub { |
236a4386 |
89 | goto &{$Variable{$variable}{install}}; |
5a0662d9 |
90 | }; |
91 | *{"${variable}::build_variant"} = sub { |
92 | shift; |
93 | $me->build_variant_of($variable, @_); |
94 | }; |
236a4386 |
95 | } |
96 | |
6779ecfd |
97 | sub build_variant_package_name { |
98 | my ($me, $variable, @args) = @_; |
99 | if ($variable->can('make_variant_package_name')) { |
100 | return $variable->make_variant_package_name(@args); |
101 | } |
102 | return "${variable}::_Variant_".++$Variable{$variable}{anon}; |
103 | } |
104 | |
236a4386 |
105 | sub build_variant_of { |
106 | my ($me, $variable, @args) = @_; |
6779ecfd |
107 | my $variant_name = $me->build_variant_package_name($variable, @args); |
1bacb018 |
108 | foreach my $to_import (@{$Variable{$variable}{args}{importing}}) { |
109 | my ($pkg, $args) = @$to_import; |
3c1ca277 |
110 | require_module $pkg; |
111 | eval q{ BEGIN { $pkg->import::into($variant_name, @{$args}) }; 1; } |
112 | or die $@; |
1bacb018 |
113 | } |
236a4386 |
114 | my $subs = $Variable{$variable}{subs}; |
115 | local @{$subs}{keys %$subs} = map $variant_name->can($_), keys %$subs; |
116 | local $Variable{$variable}{install} = sub { |
ed98a1a0 |
117 | my $full_name = "${variant_name}::".shift; |
118 | |
119 | my $ref = $sub_namer->($full_name, @_); |
120 | |
236a4386 |
121 | no strict 'refs'; |
ed98a1a0 |
122 | *$full_name = $ref; |
236a4386 |
123 | }; |
124 | $variable->make_variant($variant_name, @args); |
125 | return $variant_name; |
126 | } |
127 | |
128 | 1; |
0c378352 |
129 | |
130 | __END__ |
131 | |
132 | =head1 NAME |
133 | |
134 | Package::Variant - Parameterizable packages |
135 | |
136 | =head1 SYNOPSIS |
137 | |
ca6d96a2 |
138 | Creation of anonymous variants: |
139 | |
0c378352 |
140 | # declaring a variable Moo role |
abc0e4ce |
141 | package My::VariableRole::ObjectAttr; |
7104761c |
142 | use strictures 2; |
0c378352 |
143 | use Package::Variant |
144 | # what modules to 'use' |
efaab257 |
145 | importing => ['Moo::Role'], |
0c378352 |
146 | # proxied subroutines |
4e3b8177 |
147 | subs => [ qw(has around before after with) ]; |
0c378352 |
148 | |
149 | sub make_variant { |
150 | my ($class, $target_package, %arguments) = @_; |
151 | # access arguments |
152 | my $name = $arguments{name}; |
153 | # use proxied 'has' to add an attribute |
154 | has $name => (is => 'lazy'); |
155 | # install a builder method |
156 | install "_build_${name}" => sub { |
157 | return $arguments{class}->new; |
158 | }; |
159 | } |
160 | |
161 | # using the role |
162 | package My::Class::WithObjectAttr; |
7104761c |
163 | use strictures 2; |
0c378352 |
164 | use Moo; |
abc0e4ce |
165 | use My::VariableRole::ObjectAttr; |
0c378352 |
166 | |
167 | with ObjectAttr(name => 'some_obj', class => 'Some::Class'); |
168 | |
169 | # using our class |
170 | my $obj = My::Class::WithObjectAttr->new; |
171 | $obj->some_obj; # returns a Some::Class instance |
172 | |
ca6d96a2 |
173 | And the same thing, only with named variants: |
174 | |
175 | # declaring a variable Moo role that can be named |
176 | package My::VariableRole::ObjectAttrNamed; |
7104761c |
177 | use strictures 2; |
ca6d96a2 |
178 | use Package::Variant importing => ['Moo::Role'], |
179 | subs => [ qw(has around before after with) ]; |
180 | use Module::Runtime 'module_notional_filename'; # only if you need protection |
181 | |
182 | # this method is run at variant creation time to determine its custom |
183 | # package name. it can use the arguments or do something entirely else. |
184 | sub make_variant_package_name { |
185 | my ($class, $package, %arguments) = @_; |
186 | $package = "Private::$package"; # you can munge the input here if you like |
187 | # only if you *need* protection |
188 | die "Won't clobber $package" if $INC{module_notional_filename $package}; |
189 | return $package; |
190 | } |
191 | |
192 | # same as in the example above, except for the argument list. in this example |
193 | # $package is the user input, and |
194 | # $target_package is the actual package in which the variant gets installed |
195 | sub make_variant { |
196 | my ($class, $target_package, $package, %arguments) = @_; |
197 | my $name = $arguments{name}; |
198 | has $name => (is => 'lazy'); |
199 | install "_build_${name}" => sub {return $arguments{class}->new}; |
200 | } |
201 | |
202 | # using the role |
203 | package My::Class::WithObjectAttr; |
7104761c |
204 | use strictures 2; |
ca6d96a2 |
205 | use Moo; |
206 | use My::VariableRole::ObjectAttrNamed; |
207 | |
208 | # create the role under a specific name |
209 | ObjectAttrNamed "My::Role" => (name => 'some_obj', class => 'Some::Class'); |
210 | # and use it |
211 | with "Private::My::Role"; |
212 | |
213 | # using our class |
214 | my $obj = My::Class::WithObjectAttr->new; |
215 | $obj->some_obj; # returns a Some::Class instance |
216 | |
0c378352 |
217 | =head1 DESCRIPTION |
218 | |
c59b7a19 |
219 | This module allows you to build a variable package that contains a package |
220 | template and can use it to build variant packages at runtime. |
0c378352 |
221 | |
c59b7a19 |
222 | Your variable package will export a subroutine which will build a variant |
223 | package, combining its arguments with the template, and return the name of the |
224 | new variant package. |
225 | |
226 | The implementation does not care about what kind of packages it builds, be they |
227 | simple function exporters, classes, singletons or something entirely different. |
0c378352 |
228 | |
229 | =head2 Declaring a variable package |
230 | |
231 | There are two important parts to creating a variable package. You first |
232 | have to give C<Package::Variant> some basic information about what kind of |
abc0e4ce |
233 | variant packages you want to provide, and how. The second part is implementing a |
c59b7a19 |
234 | method which builds the components of the variant packages that use the user's |
235 | arguments or cannot be provided with a static import. |
0c378352 |
236 | |
abc0e4ce |
237 | =head3 Setting up the environment for building variants |
0c378352 |
238 | |
239 | When you C<use Package::Variant>, you pass along some arguments that |
abc0e4ce |
240 | describe how you intend to build your variants. |
0c378352 |
241 | |
242 | use Package::Variant |
243 | importing => { $package => \@import_arguments, ... }, |
244 | subs => [ @proxied_subroutine_names ]; |
245 | |
efaab257 |
246 | The L</importing> option needs to be a hash or array reference with |
247 | package names to be C<use>d as keys, and array references containing the |
248 | import arguments as values. These packages will be imported into every new |
c59b7a19 |
249 | variant package, to provide static functionality of the variant packages and to |
250 | set up every declarative subroutine you require to build variants package |
251 | components. The next option will allow you to use these functions. See |
252 | L</importing> for more options. You can omit empty import argument lists when |
253 | passing an array reference. |
0c378352 |
254 | |
255 | The L</subs> option is an array reference of subroutine names that are |
256 | exported by the packages specified with L</importing>. These subroutines |
abc0e4ce |
257 | will be proxied from your variable package to the variant to be |
0c378352 |
258 | generated. |
259 | |
260 | With L</importing> initializing your package and L</subs> declaring what |
261 | subroutines you want to use to build a variant, you can now write a |
262 | L</make_variant> method building your variants. |
263 | |
264 | =head3 Declaring a method to produce variants |
265 | |
c59b7a19 |
266 | Every time a user requests a new variant, a method named L</make_variant> |
0c378352 |
267 | will be called with the name of the target package and the arguments from |
268 | the user. |
269 | |
270 | It can then use the proxied subroutines declared with L</subs> to |
abc0e4ce |
271 | customize the variant package. An L</install> subroutine is exported as well |
272 | allowing you to dynamically install methods into the variant package. If these |
273 | options aren't flexible enough, you can use the passed name of the variant |
0c378352 |
274 | package to do any other kind of customizations. |
275 | |
276 | sub make_variant { |
277 | my ($class, $target, @arguments) = @_; |
278 | # ... |
279 | # customization goes here |
280 | # ... |
281 | } |
282 | |
abc0e4ce |
283 | When the method is finished, the user will receive the name of the new variant |
284 | package you just set up. |
0c378352 |
285 | |
286 | =head2 Using variable packages |
287 | |
288 | After your variable package is L<created|/Declaring a variable package> |
c59b7a19 |
289 | your users can get a variant generator subroutine by simply importing |
0c378352 |
290 | your package. |
291 | |
292 | use My::Variant; |
2b728d4c |
293 | my $new_variant_package = Variant(@variant_arguments); |
abc0e4ce |
294 | # the variant package is now fully initialized and used |
0c378352 |
295 | |
abc0e4ce |
296 | You can import the subroutine under a different name by specifying an C<as> |
297 | argument. |
0c378352 |
298 | |
299 | =head2 Dynamic creation of variant packages |
300 | |
301 | For regular uses, the L<normal import|/Using variable packages> provides |
abc0e4ce |
302 | more than enough flexibility. However, if you want to create variants of |
cfcf68cb |
303 | dynamically determined packages, you can use the L</build_variant_of> |
0c378352 |
304 | method. |
305 | |
abc0e4ce |
306 | You can use this to create variants of other packages and pass arguments |
307 | on to them to allow more modular and extensible variants. |
0c378352 |
308 | |
309 | =head1 OPTIONS |
310 | |
311 | These are the options that can be passed when importing |
312 | C<Package::Variant>. They describe the environment in which the variants |
313 | are created. |
314 | |
315 | use Package::Variant |
316 | importing => { $package => \@import_arguments, ... }, |
317 | subs => [ @proxied_subroutines ]; |
318 | |
319 | =head2 importing |
320 | |
321 | This option is a hash reference mapping package names to array references |
2b728d4c |
322 | containing import arguments. The packages will be imported with the given |
abc0e4ce |
323 | arguments by every variant before the L</make_variant> method is asked |
2b728d4c |
324 | to create the package (this is done using L<Import::Into>). |
0c378352 |
325 | |
067e51ad |
326 | If import order is important to you, you can also pass the C<importing> |
efaab257 |
327 | arguments as a flat array reference: |
067e51ad |
328 | |
329 | use Package::Variant |
efaab257 |
330 | importing => [ 'PackageA', 'PackageB' ]; |
067e51ad |
331 | |
efaab257 |
332 | # same as |
333 | use Package::Variant |
334 | importing => [ 'PackageA' => [], 'PackageB' => [] ]; |
335 | |
336 | # or |
337 | use Package::Variant |
338 | importing => { 'PackageA' => [], 'PackageB' => [] }; |
339 | |
340 | The import method will be called even if the list of import arguments is |
341 | empty or not specified, |
067e51ad |
342 | |
bdc3f3ad |
343 | If you just want to import a single package's default exports, you can |
344 | also pass a string instead: |
345 | |
2b728d4c |
346 | use Package::Variant importing => 'Package'; |
bdc3f3ad |
347 | |
0c378352 |
348 | =head2 subs |
349 | |
350 | An array reference of strings listing the names of subroutines that should |
351 | be proxied. These subroutines are expected to be installed into the new |
352 | variant package by the modules imported with L</importing>. Subroutines |
abc0e4ce |
353 | with the same name will be available in your variable package, and will |
0c378352 |
354 | proxy through to the newly created package when used within |
355 | L</make_variant>. |
356 | |
357 | =head1 VARIABLE PACKAGE METHODS |
358 | |
359 | These are methods on the variable package you declare when you import |
360 | C<Package::Variant>. |
361 | |
362 | =head2 make_variant |
363 | |
364 | Some::Variant::Package->make_variant( $target, @arguments ); |
365 | |
366 | B<You need to provide this method.> This method will be called for every |
367 | new variant of your package. This method should use the subroutines |
368 | declared in L</subs> to customize the new variant package. |
369 | |
370 | This is a class method receiving the C<$target> package and the |
371 | C<@arguments> defining the requested variant. |
372 | |
6779ecfd |
373 | =head2 make_variant_package_name |
374 | |
375 | Some::Variant::Package->make_variant_package_name( @arguments ); |
376 | |
377 | B<You may optionally provide this method.> If present, this method will be |
378 | used to determine the package name for a particular variant being constructed. |
379 | |
380 | If you do not implement it, a unique package name something like |
381 | |
382 | Some::Variant::Package::_Variant_A003 |
383 | |
384 | will be created for you. |
385 | |
0c378352 |
386 | =head2 import |
387 | |
388 | use Some::Variant::Package; |
389 | my $variant_package = Package( @arguments ); |
390 | |
391 | This method is provided for you. It will allow a user to C<use> your |
392 | package and receive a subroutine taking C<@arguments> defining the variant |
393 | and returning the name of the newly created variant package. |
394 | |
0a7db8d2 |
395 | The following options can be specified when importing: |
396 | |
397 | =over |
398 | |
399 | =item * B<as> |
400 | |
401 | use Some::Variant::Package as => 'Foo'; |
2b728d4c |
402 | my $variant_package = Foo(@arguments); |
0a7db8d2 |
403 | |
404 | Exports the generator subroutine under a different name than the default. |
405 | |
406 | =back |
407 | |
5a0662d9 |
408 | =head2 build_variant |
409 | |
410 | use Some::Variant::Package (); |
411 | my $variant_package = Some::Variant::Package->build_variant( @arguments ); |
412 | |
413 | This method is provided for you. It will generate a variant package |
414 | and return its name, just like the generator sub provided by |
415 | L</import>. This allows you to avoid importing anything into the |
416 | consuming package. |
417 | |
0c378352 |
418 | =head1 C<Package::Variant> METHODS |
419 | |
420 | These methods are available on C<Package::Variant> itself. |
421 | |
cfcf68cb |
422 | =head2 build_variant_of |
0c378352 |
423 | |
424 | my $variant_package = Package::Variant |
cfcf68cb |
425 | ->build_variant_of($variable_package, @arguments); |
0c378352 |
426 | |
427 | This is the dynamic method of creating new variants. It takes the |
428 | C<$variable_package>, which is a pre-declared variable package, and a set |
429 | of C<@arguments> passed to the package to generate a new |
430 | C<$variant_package>, which will be returned. |
431 | |
432 | =head2 import |
433 | |
434 | use Package::Variant @options; |
435 | |
436 | Sets up the environment in which you declare the variants of your |
437 | packages. See L</OPTIONS> for details on the available options and |
438 | L</EXPORTS> for a list of exported subroutines. |
439 | |
440 | =head1 EXPORTS |
441 | |
442 | Additionally to the proxies for subroutines provided in L</subs>, the |
443 | following exports will be available in your variable package: |
444 | |
445 | =head2 install |
446 | |
2b728d4c |
447 | install($method_name, $code_reference); |
0c378352 |
448 | |
449 | Installs a method with the given C<$method_name> into the newly created |
450 | variant package. The C<$code_reference> will be used as the body for the |
2b728d4c |
451 | method, and if L<Sub::Name> is available the coderef will be named. If you |
452 | want to name it something else, then use: |
453 | |
454 | install($method_name, $name_to_use, $code_reference); |
0c378352 |
455 | |
456 | =head1 AUTHOR |
457 | |
5b1d922a |
458 | mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk> |
0c378352 |
459 | |
5b1d922a |
460 | =head1 CONTRIBUTORS |
0c378352 |
461 | |
5b1d922a |
462 | phaylon - Robert Sedlacek (cpan:PHAYLON) <r.sedlacek@shadowcat.co.uk> |
0c378352 |
463 | |
39c3689b |
464 | haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org> |
465 | |
0c378352 |
466 | =head1 COPYRIGHT |
467 | |
2b728d4c |
468 | Copyright (c) 2010-2012 the C<Package::Variant> L</AUTHOR> and |
57114c43 |
469 | L</CONTRIBUTORS> as listed above. |
0c378352 |
470 | |
471 | =head1 LICENSE |
472 | |
473 | This library is free software and may be distributed under the same |
474 | terms as perl itself. |
475 | |
476 | =cut |