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