File Coverage

blib/lib/Sub/Exporter.pm
Criterion Covered Total %
statement 177 184 96.2
branch 92 98 93.8
condition 51 55 92.7
subroutine 25 26 96.1
pod 4 5 80.0
total 349 368 94.8


line stmt bran cond sub pod time code
1 16     16   979845 use v5.8;
  16         172  
2 16     16   83 use strict;
  16         30  
  16         375  
3 16     16   87 use warnings;
  16         24  
  16         847  
4             package Sub::Exporter;
5             # ABSTRACT: a sophisticated exporter for custom-built routines
6             $Sub::Exporter::VERSION = '0.988';
7 16     16   91 use Carp ();
  16         44  
  16         432  
8 16     16   5786 use Data::OptList 0.100 ();
  16         118859  
  16         453  
9 16     16   109 use Params::Util 0.14 (); # _CODELIKE
  16         241  
  16         325  
10 16     16   77 use Sub::Install 0.92 ();
  16         166  
  16         21552  
11              
12             #pod =head1 SYNOPSIS
13             #pod
14             #pod Sub::Exporter must be used in two places. First, in an exporting module:
15             #pod
16             #pod # in the exporting module:
17             #pod package Text::Tweaker;
18             #pod use Sub::Exporter -setup => {
19             #pod exports => [
20             #pod qw(squish titlecase), # always works the same way
21             #pod reformat => \&build_reformatter, # generator to build exported function
22             #pod trim => \&build_trimmer,
23             #pod indent => \&build_indenter,
24             #pod ],
25             #pod collectors => [ 'defaults' ],
26             #pod };
27             #pod
28             #pod Then, in an importing module:
29             #pod
30             #pod # in the importing module:
31             #pod use Text::Tweaker
32             #pod 'squish',
33             #pod indent => { margin => 5 },
34             #pod reformat => { width => 79, justify => 'full', -as => 'prettify_text' },
35             #pod defaults => { eol => 'CRLF' };
36             #pod
37             #pod With this setup, the importing module ends up with three routines: C,
38             #pod C, and C. The latter two have been built to the
39             #pod specifications of the importer -- they are not just copies of the code in the
40             #pod exporting package.
41             #pod
42             #pod =head1 DESCRIPTION
43             #pod
44             #pod B If you're not familiar with Exporter or exporting, read
45             #pod L first!
46             #pod
47             #pod =head2 Why Generators?
48             #pod
49             #pod The biggest benefit of Sub::Exporter over existing exporters (including the
50             #pod ubiquitous Exporter.pm) is its ability to build new coderefs for export, rather
51             #pod than to simply export code identical to that found in the exporting package.
52             #pod
53             #pod If your module's consumers get a routine that works like this:
54             #pod
55             #pod use Data::Analyze qw(analyze);
56             #pod my $value = analyze($data, $tolerance, $passes);
57             #pod
58             #pod and they constantly pass only one or two different set of values for the
59             #pod non-C<$data> arguments, your code can benefit from Sub::Exporter. By writing a
60             #pod simple generator, you can let them do this, instead:
61             #pod
62             #pod use Data::Analyze
63             #pod analyze => { tolerance => 0.10, passes => 10, -as => analyze10 },
64             #pod analyze => { tolerance => 0.15, passes => 50, -as => analyze50 };
65             #pod
66             #pod my $value = analyze10($data);
67             #pod
68             #pod The package with the generator for that would look something like this:
69             #pod
70             #pod package Data::Analyze;
71             #pod use Sub::Exporter -setup => {
72             #pod exports => [
73             #pod analyze => \&build_analyzer,
74             #pod ],
75             #pod };
76             #pod
77             #pod sub build_analyzer {
78             #pod my ($class, $name, $arg) = @_;
79             #pod
80             #pod return sub {
81             #pod my $data = shift;
82             #pod my $tolerance = shift || $arg->{tolerance};
83             #pod my $passes = shift || $arg->{passes};
84             #pod
85             #pod analyze($data, $tolerance, $passes);
86             #pod }
87             #pod }
88             #pod
89             #pod Your module's user now has to do less work to benefit from it -- and remember,
90             #pod you're often your own user! Investing in customized subroutines is an
91             #pod investment in future laziness.
92             #pod
93             #pod This also avoids a common form of ugliness seen in many modules: package-level
94             #pod configuration. That is, you might have seen something like the above
95             #pod implemented like so:
96             #pod
97             #pod use Data::Analyze qw(analyze);
98             #pod $Data::Analyze::default_tolerance = 0.10;
99             #pod $Data::Analyze::default_passes = 10;
100             #pod
101             #pod This might save time, until you have multiple modules using Data::Analyze.
102             #pod Because there is only one global configuration, they step on each other's toes
103             #pod and your code begins to have mysterious errors.
104             #pod
105             #pod Generators can also allow you to export class methods to be called as
106             #pod subroutines:
107             #pod
108             #pod package Data::Methodical;
109             #pod use Sub::Exporter -setup => { exports => { some_method => \&_curry_class } };
110             #pod
111             #pod sub _curry_class {
112             #pod my ($class, $name) = @_;
113             #pod sub { $class->$name(@_); };
114             #pod }
115             #pod
116             #pod Because of the way that exporters and Sub::Exporter work, any package that
117             #pod inherits from Data::Methodical can inherit its exporter and override its
118             #pod C. If a user imports C from that package, he'll
119             #pod receive a subroutine that calls the method on the subclass, rather than on
120             #pod Data::Methodical itself. Keep in mind that if you re-setup Sub::Exporter in a
121             #pod package that inherits from Data::Methodical you will, of course, be entirely
122             #pod replacing the exporter from Data::Methodical. C is a method, and is
123             #pod hidden by the same means as any other method.
124             #pod
125             #pod =head2 Other Customizations
126             #pod
127             #pod Building custom routines with generators isn't the only way that Sub::Exporters
128             #pod allows the importing code to refine its use of the exported routines. They may
129             #pod also be renamed to avoid naming collisions.
130             #pod
131             #pod Consider the following code:
132             #pod
133             #pod # this program determines to which circle of Hell you will be condemned
134             #pod use Morality qw(sin virtue); # for calculating viciousness
135             #pod use Math::Trig qw(:all); # for dealing with circles
136             #pod
137             #pod The programmer has inadvertently imported two C routines. The solution,
138             #pod in Exporter.pm-based modules, would be to import only one and then call the
139             #pod other by its fully-qualified name. Alternately, the importer could write a
140             #pod routine that did so, or could mess about with typeglobs.
141             #pod
142             #pod How much easier to write:
143             #pod
144             #pod # this program determines to which circle of Hell you will be condemned
145             #pod use Morality qw(virtue), sin => { -as => 'offense' };
146             #pod use Math::Trig -all => { -prefix => 'trig_' };
147             #pod
148             #pod and to have at one's disposal C and C -- not to mention
149             #pod C and C.
150             #pod
151             #pod =head1 EXPORTER CONFIGURATION
152             #pod
153             #pod You can configure an exporter for your package by using Sub::Exporter like so:
154             #pod
155             #pod package Tools;
156             #pod use Sub::Exporter
157             #pod -setup => { exports => [ qw(function1 function2 function3) ] };
158             #pod
159             #pod This is the simplest way to use the exporter, and is basically equivalent to
160             #pod this:
161             #pod
162             #pod package Tools;
163             #pod use base qw(Exporter);
164             #pod our @EXPORT_OK = qw(function1 function2 function3);
165             #pod
166             #pod Any basic use of Sub::Exporter will look like this:
167             #pod
168             #pod package Tools;
169             #pod use Sub::Exporter -setup => \%config;
170             #pod
171             #pod The following keys are valid in C<%config>:
172             #pod
173             #pod exports - a list of routines to provide for exporting; each routine may be
174             #pod followed by generator
175             #pod groups - a list of groups to provide for exporting; each must be followed by
176             #pod either (a) a list of exports, possibly with arguments for each
177             #pod export, or (b) a generator
178             #pod
179             #pod collectors - a list of names into which values are collected for use in
180             #pod routine generation; each name may be followed by a validator
181             #pod
182             #pod In addition to the basic options above, a few more advanced options may be
183             #pod passed:
184             #pod
185             #pod into_level - how far up the caller stack to look for a target (default 0)
186             #pod into - an explicit target (package) into which to export routines
187             #pod
188             #pod In other words: Sub::Exporter installs a C routine which, when called,
189             #pod exports routines to the calling namespace. The C and C
190             #pod options change where those exported routines are installed.
191             #pod
192             #pod generator - a callback used to produce the code that will be installed
193             #pod default: Sub::Exporter::default_generator
194             #pod
195             #pod installer - a callback used to install the code produced by the generator
196             #pod default: Sub::Exporter::default_installer
197             #pod
198             #pod For information on how these callbacks are used, see the documentation for
199             #pod C> and C>.
200             #pod
201             #pod =head2 Export Configuration
202             #pod
203             #pod The C list may be provided as an array reference or a hash reference.
204             #pod The list is processed in such a way that the following are equivalent:
205             #pod
206             #pod { exports => [ qw(foo bar baz), quux => \&quux_generator ] }
207             #pod
208             #pod { exports =>
209             #pod { foo => undef, bar => undef, baz => undef, quux => \&quux_generator } }
210             #pod
211             #pod Generators are code that return coderefs. They are called with four
212             #pod parameters:
213             #pod
214             #pod $class - the class whose exporter has been called (the exporting class)
215             #pod $name - the name of the export for which the routine is being build
216             #pod \%arg - the arguments passed for this export
217             #pod \%col - the collections for this import
218             #pod
219             #pod Given the configuration in the L, the following C statement:
220             #pod
221             #pod use Text::Tweaker
222             #pod reformat => { -as => 'make_narrow', width => 33 },
223             #pod defaults => { eol => 'CR' };
224             #pod
225             #pod would result in the following call to C<&build_reformatter>:
226             #pod
227             #pod my $code = build_reformatter(
228             #pod 'Text::Tweaker',
229             #pod 'reformat',
230             #pod { width => 33 }, # note that -as is not passed in
231             #pod { defaults => { eol => 'CR' } },
232             #pod );
233             #pod
234             #pod The returned coderef (C<$code>) would then be installed as C in the
235             #pod calling package.
236             #pod
237             #pod Instead of providing a coderef in the configuration, a reference to a method
238             #pod name may be provided. This method will then be called on the invocant of the
239             #pod C method. (In this case, we do not pass the C<$class> parameter, as it
240             #pod would be redundant.)
241             #pod
242             #pod =head2 Group Configuration
243             #pod
244             #pod The C list can be passed in the same forms as C. Groups must
245             #pod have values to be meaningful, which may either list exports that make up the
246             #pod group (optionally with arguments) or may provide a way to build the group.
247             #pod
248             #pod The simpler case is the first: a group definition is a list of exports. Here's
249             #pod the example that could go in exporter in the L.
250             #pod
251             #pod groups => {
252             #pod default => [ qw(reformat) ],
253             #pod shorteners => [ qw(squish trim) ],
254             #pod email_safe => [
255             #pod 'indent',
256             #pod reformat => { -as => 'email_format', width => 72 }
257             #pod ],
258             #pod },
259             #pod
260             #pod Groups are imported by specifying their name prefixed be either a dash or a
261             #pod colon. This line of code would import the C group:
262             #pod
263             #pod use Text::Tweaker qw(-shorteners);
264             #pod
265             #pod Arguments passed to a group when importing are merged into the groups options
266             #pod and passed to any relevant generators. Groups can contain other groups, but
267             #pod looping group structures are ignored.
268             #pod
269             #pod The other possible value for a group definition, a coderef, allows one
270             #pod generator to build several exportable routines simultaneously. This is useful
271             #pod when many routines must share enclosed lexical variables. The coderef must
272             #pod return a hash reference. The keys will be used as export names and the values
273             #pod are the subs that will be exported.
274             #pod
275             #pod This example shows a simple use of the group generator.
276             #pod
277             #pod package Data::Crypto;
278             #pod use Sub::Exporter -setup => { groups => { cipher => \&build_cipher_group } };
279             #pod
280             #pod sub build_cipher_group {
281             #pod my ($class, $group, $arg) = @_;
282             #pod my ($encode, $decode) = build_codec($arg->{secret});
283             #pod return { cipher => $encode, decipher => $decode };
284             #pod }
285             #pod
286             #pod The C and C routines are built in a group because they are
287             #pod built together by code which encloses their secret in their environment.
288             #pod
289             #pod =head3 Default Groups
290             #pod
291             #pod If a module that uses Sub::Exporter is Cd with no arguments, it will try
292             #pod to export the group named C. If that group has not been specifically
293             #pod configured, it will be empty, and nothing will happen.
294             #pod
295             #pod Another group is also created if not defined: C. The C group
296             #pod contains all the exports from the exports list.
297             #pod
298             #pod =head2 Collector Configuration
299             #pod
300             #pod The C entry in the exporter configuration gives names which, when
301             #pod found in the import call, have their values collected and passed to every
302             #pod generator.
303             #pod
304             #pod For example, the C generator that we saw above could be
305             #pod rewritten as:
306             #pod
307             #pod sub build_analyzer {
308             #pod my ($class, $name, $arg, $col) = @_;
309             #pod
310             #pod return sub {
311             #pod my $data = shift;
312             #pod my $tolerance = shift || $arg->{tolerance} || $col->{defaults}{tolerance};
313             #pod my $passes = shift || $arg->{passes} || $col->{defaults}{passes};
314             #pod
315             #pod analyze($data, $tolerance, $passes);
316             #pod }
317             #pod }
318             #pod
319             #pod That would allow the importer to specify global defaults for his imports:
320             #pod
321             #pod use Data::Analyze
322             #pod 'analyze',
323             #pod analyze => { tolerance => 0.10, -as => analyze10 },
324             #pod analyze => { tolerance => 0.15, passes => 50, -as => analyze50 },
325             #pod defaults => { passes => 10 };
326             #pod
327             #pod my $A = analyze10($data); # equivalent to analyze($data, 0.10, 10);
328             #pod my $C = analyze50($data); # equivalent to analyze($data, 0.15, 50);
329             #pod my $B = analyze($data, 0.20); # equivalent to analyze($data, 0.20, 10);
330             #pod
331             #pod If values are provided in the C list during exporter setup, they
332             #pod must be code references, and are used to validate the importer's values. The
333             #pod validator is called when the collection is found, and if it returns false, an
334             #pod exception is thrown. We could ensure that no one tries to set a global data
335             #pod default easily:
336             #pod
337             #pod collectors => { defaults => sub { return (exists $_[0]->{data}) ? 0 : 1 } }
338             #pod
339             #pod Collector coderefs can also be used as hooks to perform arbitrary actions
340             #pod before anything is exported.
341             #pod
342             #pod When the coderef is called, it is passed the value of the collection and a
343             #pod hashref containing the following entries:
344             #pod
345             #pod name - the name of the collector
346             #pod config - the exporter configuration (hashref)
347             #pod import_args - the arguments passed to the exporter, sans collections (aref)
348             #pod class - the package on which the importer was called
349             #pod into - the package into which exports will be exported
350             #pod
351             #pod Collectors with all-caps names (that is, made up of underscore or capital A
352             #pod through Z) are reserved for special use. The only currently implemented
353             #pod special collector is C, whose hook (if present in the exporter
354             #pod configuration) is always run before any other hook.
355             #pod
356             #pod =head1 CALLING THE EXPORTER
357             #pod
358             #pod Arguments to the exporter (that is, the arguments after the module name in a
359             #pod C statement) are parsed as follows:
360             #pod
361             #pod First, the collectors gather any collections found in the arguments. Any
362             #pod reference type may be given as the value for a collector. For each collection
363             #pod given in the arguments, its validator (if any) is called.
364             #pod
365             #pod Next, groups are expanded. If the group is implemented by a group generator,
366             #pod the generator is called. There are two special arguments which, if given to a
367             #pod group, have special meaning:
368             #pod
369             #pod -prefix - a string to prepend to any export imported from this group
370             #pod -suffix - a string to append to any export imported from this group
371             #pod
372             #pod Finally, individual export generators are called and all subs, generated or
373             #pod otherwise, are installed in the calling package. There is only one special
374             #pod argument for export generators:
375             #pod
376             #pod -as - where to install the exported sub
377             #pod
378             #pod Normally, C<-as> will contain an alternate name for the routine. It may,
379             #pod however, contain a reference to a scalar. If that is the case, a reference the
380             #pod generated routine will be placed in the scalar referenced by C<-as>. It will
381             #pod not be installed into the calling package.
382             #pod
383             #pod =head2 Special Exporter Arguments
384             #pod
385             #pod The generated exporter accept some special options, which may be passed as the
386             #pod first argument, in a hashref.
387             #pod
388             #pod These options are:
389             #pod
390             #pod into_level
391             #pod into
392             #pod generator
393             #pod installer
394             #pod
395             #pod These override the same-named configuration options described in L
396             #pod CONFIGURATION>.
397             #pod
398             #pod =cut
399              
400             # Given a potential import name, this returns the group name -- if it's got a
401             # group prefix.
402             sub _group_name {
403 508     508   778 my ($name) = @_;
404              
405 508 100       1366 return if (index q{-:}, (substr $name, 0, 1)) == -1;
406 286         670 return substr $name, 1;
407             }
408              
409             # \@groups is a canonicalized opt list of exports and groups this returns
410             # another canonicalized opt list with groups replaced with relevant exports.
411             # \%seen is groups we've already expanded and can ignore.
412             # \%merge is merged options from the group we're descending through.
413             sub _expand_groups {
414 284     284   31206 my ($class, $config, $groups, $collection, $seen, $merge) = @_;
415 284   100     824 $seen ||= {};
416 284   100     687 $merge ||= {};
417 284         517 my @groups = @$groups;
418              
419 284         571 for my $i (reverse 0 .. $#groups) {
420 351 100       607 if (my $group_name = _group_name($groups[$i][0])) {
421 129         317 my $seen = { %$seen }; # faux-dynamic scoping
422              
423 129         324 splice @groups, $i, 1,
424             _expand_group($class, $config, $groups[$i], $collection, $seen, $merge);
425             } else {
426             # there's nothing to munge in this export's args
427 222 100       714 next unless my %merge = %$merge;
428              
429             # we have things to merge in; do so
430 72   100     197 my $prefix = (delete $merge{-prefix}) || '';
431 72   100     192 my $suffix = (delete $merge{-suffix}) || '';
432              
433 72 100 66     269 if (
434             Params::Util::_CODELIKE($groups[$i][1]) ## no critic Private
435             or
436             Params::Util::_SCALAR0($groups[$i][1]) ## no critic Private
437             ) {
438             # this entry was build by a group generator
439 14         41 $groups[$i][0] = $prefix . $groups[$i][0] . $suffix;
440             } else {
441             my $as
442             = ref $groups[$i][1]{-as} ? $groups[$i][1]{-as}
443 58 100       263 : $groups[$i][1]{-as} ? $prefix . $groups[$i][1]{-as} . $suffix
    100          
444             : $prefix . $groups[$i][0] . $suffix;
445              
446 58         95 $groups[$i][1] = { %{ $groups[$i][1] }, %merge, -as => $as };
  58         288  
447             }
448             }
449             }
450              
451 282         1077 return \@groups;
452             }
453              
454             # \@group is a name/value pair from an opt list.
455             sub _expand_group {
456 157     157   23300 my ($class, $config, $group, $collection, $seen, $merge) = @_;
457 157   100     403 $merge ||= {};
458              
459 157         289 my ($group_name, $group_arg) = @$group;
460 157         331 $group_name = _group_name($group_name);
461              
462             Carp::croak qq(group "$group_name" is not exported by the $class module)
463 157 100       545 unless exists $config->{groups}{$group_name};
464              
465 156 100       465 return if $seen->{$group_name}++;
466              
467 150 100       339 if (ref $group_arg) {
468 73   100     363 my $prefix = (delete $merge->{-prefix}||'') . ($group_arg->{-prefix}||'');
      100        
469 73   100     307 my $suffix = ($group_arg->{-suffix}||'') . (delete $merge->{-suffix}||'');
      100        
470 73 100       367 $merge = {
    100          
471             %$merge,
472             %$group_arg,
473             ($prefix ? (-prefix => $prefix) : ()),
474             ($suffix ? (-suffix => $suffix) : ()),
475             };
476             }
477              
478 150         273 my $exports = $config->{groups}{$group_name};
479              
480 150 100 100     715 if (
481             Params::Util::_CODELIKE($exports) ## no critic Private
482             or
483             Params::Util::_SCALAR0($exports) ## no critic Private
484             ) {
485             # I'm not very happy with this code for hiding -prefix and -suffix, but
486             # it's needed, and I'm not sure, offhand, how to make it better.
487             # -- rjbs, 2006-12-05
488 14 50       115 my $group_arg = $merge ? { %$merge } : {};
489 14         23 delete $group_arg->{-prefix};
490 14         17 delete $group_arg->{-suffix};
491              
492 14 100       48 my $group = Params::Util::_CODELIKE($exports) ## no critic Private
493             ? $exports->($class, $group_name, $group_arg, $collection)
494             : $class->$$exports($group_name, $group_arg, $collection);
495              
496 14 100       374 Carp::croak qq(group generator "$group_name" did not return a hashref)
497             if ref $group ne 'HASH';
498              
499 13         43 my $stuff = [ map { [ $_ => $group->{$_} ] } keys %$group ];
  24         59  
500             return @{
501 13         19 _expand_groups($class, $config, $stuff, $collection, $seen, $merge)
  13         29  
502             };
503             } else {
504 136         442 $exports
505             = Data::OptList::mkopt($exports, "$group_name exports");
506              
507             return @{
508 136         4765 _expand_groups($class, $config, $exports, $collection, $seen, $merge)
  136         379  
509             };
510             }
511             }
512              
513             sub _mk_collection_builder {
514 113     113   189 my ($col, $etc) = @_;
515 113         237 my ($config, $import_args, $class, $into) = @$etc;
516              
517 113         147 my %seen;
518             sub {
519 37     37   71 my ($collection) = @_;
520 37         63 my ($name, $value) = @$collection;
521              
522             Carp::croak "collection $name provided multiple times in import"
523 37 100       268 if $seen{ $name }++;
524              
525 36 100       119 if (ref(my $hook = $config->{collectors}{$name})) {
526 30         130 my $arg = {
527             name => $name,
528             config => $config,
529             import_args => $import_args,
530             class => $class,
531             into => $into,
532             };
533              
534 30         85 my $error_msg = "collection $name failed validation";
535 30 100       94 if (Params::Util::_SCALAR0($hook)) { ## no critic Private
536 2 100       12 Carp::croak $error_msg unless $class->$$hook($value, $arg);
537             } else {
538 28 100       71 Carp::croak $error_msg unless $hook->($value, $arg);
539             }
540             }
541              
542 30         106 $col->{ $name } = $value;
543             }
544 113         581 }
545              
546             # Given a config and pre-canonicalized importer args, remove collections from
547             # the args and return them.
548             sub _collect_collections {
549 113     113   6152 my ($config, $import_args, $class, $into) = @_;
550              
551             my @collections
552 35         105 = map { splice @$import_args, $_, 1 }
553 113         326 grep { exists $config->{collectors}{ $import_args->[$_][0] } }
  131         418  
554             reverse 0 .. $#$import_args;
555              
556 113 100       279 unshift @collections, [ INIT => {} ] if $config->{collectors}{INIT};
557              
558 113         159 my $col = {};
559 113         247 my $builder = _mk_collection_builder($col, \@_);
560 113         265 for my $collection (@collections) {
561 37         69 $builder->($collection)
562             }
563              
564 106         697 return $col;
565             }
566              
567             #pod =head1 SUBROUTINES
568             #pod
569             #pod =head2 setup_exporter
570             #pod
571             #pod This routine builds and installs an C routine. It is called with one
572             #pod argument, a hashref containing the exporter configuration. Using this, it
573             #pod builds an exporter and installs it into the calling package with the name
574             #pod "import." In addition to the normal exporter configuration, a few named
575             #pod arguments may be passed in the hashref:
576             #pod
577             #pod into - into what package should the exporter be installed
578             #pod into_level - into what level up the stack should the exporter be installed
579             #pod as - what name should the installed exporter be given
580             #pod
581             #pod By default the exporter is installed with the name C into the immediate
582             #pod caller of C. In other words, if your package calls
583             #pod C without providing any of the three above arguments, it will
584             #pod have an C routine installed.
585             #pod
586             #pod Providing both C and C will cause an exception to be thrown.
587             #pod
588             #pod The exporter is built by C>.
589             #pod
590             #pod =cut
591              
592             sub setup_exporter {
593 23     23 1 2071 my ($config) = @_;
594              
595             Carp::croak 'into and into_level may not both be supplied to exporter'
596 23 100 100     166 if exists $config->{into} and exists $config->{into_level};
597              
598 22   100     148 my $as = delete $config->{as} || 'import';
599             my $into
600             = exists $config->{into} ? delete $config->{into}
601             : exists $config->{into_level} ? caller(delete $config->{into_level})
602 22 100       101 : caller(0);
    100          
603              
604 22         57 my $import = build_exporter($config);
605              
606 22         109 Sub::Install::reinstall_sub({
607             code => $import,
608             into => $into,
609             as => $as,
610             });
611             }
612              
613             #pod =head2 build_exporter
614             #pod
615             #pod Given a standard exporter configuration, this routine builds and returns an
616             #pod exporter -- that is, a subroutine that can be installed as a class method to
617             #pod perform exporting on request.
618             #pod
619             #pod Usually, this method is called by C>, which then installs
620             #pod the exporter as a package's import routine.
621             #pod
622             #pod =cut
623              
624             sub _key_intersection {
625 51     51   101 my ($x, $y) = @_;
626 51         115 my %seen = map { $_ => 1 } keys %$x;
  152         438  
627 51         142 my @names = grep { $seen{$_} } keys %$y;
  37         152  
628             }
629              
630             # Given the config passed to setup_exporter, which contains sugary opt list
631             # data, rewrite the opt lists into hashes, catch a few kinds of invalid
632             # configurations, and set up defaults. Since the config is a reference, it's
633             # rewritten in place.
634             my %valid_config_key;
635             BEGIN {
636             %valid_config_key =
637 16     16   74 map { $_ => 1 }
  144         22263  
638             qw(as collectors installer generator exports groups into into_level),
639             qw(exporter), # deprecated
640             }
641              
642             sub _assert_collector_names_ok {
643 51     51   92 my ($collectors) = @_;
644              
645 51         129 for my $reserved_name (grep { /\A[_A-Z]+\z/ } keys %$collectors) {
  37         175  
646 0 0       0 Carp::croak "unknown reserved collector name: $reserved_name"
647             if $reserved_name ne 'INIT';
648             }
649             }
650              
651             sub _rewrite_build_config {
652 53     53   89 my ($config) = @_;
653              
654 53 100       167 if (my @keys = grep { not exists $valid_config_key{$_} } keys %$config) {
  128         369  
655 1         78 Carp::croak "unknown options (@keys) passed to Sub::Exporter";
656             }
657              
658             Carp::croak q(into and into_level may not both be supplied to exporter)
659 52 100 100     213 if exists $config->{into} and exists $config->{into_level};
660              
661             # XXX: Remove after deprecation period.
662 51 50       125 if ($config->{exporter}) {
663 0         0 Carp::cluck "'exporter' argument to build_exporter is deprecated. Use 'installer' instead; the semantics are identical.";
664 0         0 $config->{installer} = delete $config->{exporter};
665             }
666              
667             Carp::croak q(into and into_level may not both be supplied to exporter)
668 51 50 66     99 if exists $config->{into} and exists $config->{into_level};
669              
670 51         100 for (qw(exports collectors)) {
671             $config->{$_} = Data::OptList::mkopt_hash(
672 102         5142 $config->{$_},
673             $_,
674             [ 'CODE', 'SCALAR' ],
675             );
676             }
677              
678 51         2247 _assert_collector_names_ok($config->{collectors});
679              
680 51 100       142 if (my @names = _key_intersection(@$config{qw(exports collectors)})) {
681 1         138 Carp::croak "names (@names) used in both collections and exports";
682             }
683              
684             $config->{groups} = Data::OptList::mkopt_hash(
685             $config->{groups},
686 50         173 'groups',
687             [
688             'HASH', # standard opt list
689             'ARRAY', # standard opt list
690             'CODE', # group generator
691             'SCALAR', # name of group generation method
692             ]
693             );
694              
695             # by default, export nothing
696 50   100     2880 $config->{groups}{default} ||= [];
697              
698             # by default, build an all-inclusive 'all' group
699 50   100     144 $config->{groups}{all} ||= [ keys %{ $config->{exports} } ];
  28         125  
700              
701 50   100     278 $config->{generator} ||= \&default_generator;
702 50   100     177 $config->{installer} ||= \&default_installer;
703             }
704              
705             sub build_exporter {
706 53     53 1 11526 my ($config) = @_;
707              
708 53         124 _rewrite_build_config($config);
709              
710             my $import = sub {
711 105     105   63816 my ($class) = shift;
712              
713             # XXX: clean this up -- rjbs, 2006-03-16
714 105 100       287 my $special = (ref $_[0]) ? shift(@_) : {};
715             Carp::croak q(into and into_level may not both be supplied to exporter)
716 105 100 100     358 if exists $special->{into} and exists $special->{into_level};
717              
718 104 50       329 if ($special->{exporter}) {
719 0         0 Carp::cluck "'exporter' special import argument is deprecated. Use 'installer' instead; the semantics are identical.";
720 0         0 $special->{installer} = delete $special->{exporter};
721             }
722              
723             my $into
724             = defined $special->{into} ? delete $special->{into}
725             : defined $special->{into_level} ? caller(delete $special->{into_level})
726             : defined $config->{into} ? $config->{into}
727             : defined $config->{into_level} ? caller($config->{into_level})
728 104 100       426 : caller(0);
    100          
    100          
    100          
729              
730 104   66     404 my $generator = delete $special->{generator} || $config->{generator};
731 104   66     272 my $installer = delete $special->{installer} || $config->{installer};
732              
733             # this builds a AOA, where the inner arrays are [ name => value_ref ]
734 104         311 my $import_args = Data::OptList::mkopt([ @_ ]);
735              
736             # is this right? defaults first or collectors first? -- rjbs, 2006-06-24
737 104 100       2845 $import_args = [ [ -default => undef ] ] unless @$import_args;
738              
739 104         225 my $collection = _collect_collections($config, $import_args, $class, $into);
740              
741 101         197 my $to_import = _expand_groups($class, $config, $import_args, $collection);
742              
743             # now, finally $import_arg is really the "to do" list
744 100         419 _do_import(
745             {
746             class => $class,
747             col => $collection,
748             config => $config,
749             into => $into,
750             generator => $generator,
751             installer => $installer,
752             },
753             $to_import,
754             );
755 50         198 };
756              
757 50         111 return $import;
758             }
759              
760             sub _do_import {
761 100     100   172 my ($arg, $to_import) = @_;
762              
763 100         172 my @todo;
764              
765 100         176 for my $pair (@$to_import) {
766 136         213 my ($name, $import_arg) = @$pair;
767              
768 136         174 my ($generator, $as);
769              
770 136 100 100     399 if ($import_arg and Params::Util::_CODELIKE($import_arg)) { ## no critic
771             # This is the case when a group generator has inserted name/code pairs.
772 10     10   24 $generator = sub { $import_arg };
  10         17  
773 10         16 $as = $name;
774             } else {
775 126 100       305 $import_arg = { $import_arg ? %$import_arg : () };
776              
777             Carp::croak qq("$name" is not exported by the $arg->{class} module)
778 126 100       473 unless exists $arg->{config}{exports}{$name};
779              
780 125         192 $generator = $arg->{config}{exports}{$name};
781              
782 125 100       236 $as = exists $import_arg->{-as} ? (delete $import_arg->{-as}) : $name;
783             }
784              
785             my $code = $arg->{generator}->(
786             {
787             class => $arg->{class},
788             name => $name,
789             arg => $import_arg,
790             col => $arg->{col},
791 135         475 generator => $generator,
792             }
793             );
794              
795 133         755 push @todo, $as, $code;
796             }
797              
798             $arg->{installer}->(
799             {
800             class => $arg->{class},
801             into => $arg->{into},
802             col => $arg->{col},
803             },
804 97         360 \@todo,
805             );
806             }
807              
808             ## Cute idea, possibly for future use: also supply an "unimport" for:
809             ## no Module::Whatever qw(arg arg arg);
810             # sub _unexport {
811             # my (undef, undef, undef, undef, undef, $as, $into) = @_;
812             #
813             # if (ref $as eq 'SCALAR') {
814             # undef $$as;
815             # } elsif (ref $as) {
816             # Carp::croak "invalid reference type for $as: " . ref $as;
817             # } else {
818             # no strict 'refs';
819             # delete &{$into . '::' . $as};
820             # }
821             # }
822              
823             #pod =head2 default_generator
824             #pod
825             #pod This is Sub::Exporter's default generator. It takes bits of configuration that
826             #pod have been gathered during the import and turns them into a coderef that can be
827             #pod installed.
828             #pod
829             #pod my $code = default_generator(\%arg);
830             #pod
831             #pod Passed arguments are:
832             #pod
833             #pod class - the class on which the import method was called
834             #pod name - the name of the export being generated
835             #pod arg - the arguments to the generator
836             #pod col - the collections
837             #pod
838             #pod generator - the generator to be used to build the export (code or scalar ref)
839             #pod
840             #pod =cut
841              
842             sub default_generator {
843 107     107 1 163 my ($arg) = @_;
844 107         262 my ($class, $name, $generator) = @$arg{qw(class name generator)};
845              
846 107 100       193 if (not defined $generator) {
847 39 100       551 my $code = $class->can($name)
848             or Carp::croak "can't locate exported subroutine $name via $class";
849 37         80 return $code;
850             }
851              
852             # I considered making this "$class->$generator(" but it seems that
853             # overloading precedence would turn an overloaded-as-code generator object
854             # into a string before code. -- rjbs, 2006-06-11
855             return $generator->($class, $name, $arg->{arg}, $arg->{col})
856 68 100       257 if Params::Util::_CODELIKE($generator); ## no critic Private
857              
858             # This "must" be a scalar reference, to a generator method name.
859             # -- rjbs, 2006-12-05
860 2         9 return $class->$$generator($name, $arg->{arg}, $arg->{col});
861             }
862              
863             #pod =head2 default_installer
864             #pod
865             #pod This is Sub::Exporter's default installer. It does what Sub::Exporter
866             #pod promises: it installs code into the target package.
867             #pod
868             #pod default_installer(\%arg, \@to_export);
869             #pod
870             #pod Passed arguments are:
871             #pod
872             #pod into - the package into which exports should be delivered
873             #pod
874             #pod C<@to_export> is a list of name/value pairs. The default exporter assigns code
875             #pod (the values) to named slots (the names) in the given package. If the name is a
876             #pod scalar reference, the scalar reference is made to point to the code reference
877             #pod instead.
878             #pod
879             #pod =cut
880              
881             sub default_installer {
882 85     85 1 134 my ($arg, $to_export) = @_;
883              
884 85         906 for (my $i = 0; $i < @$to_export; $i += 2) {
885 105         1846 my ($as, $code) = @$to_export[ $i, $i+1 ];
886              
887             # Allow as isa ARRAY to push onto an array?
888             # Allow into isa HASH to install name=>code into hash?
889              
890 105 100       249 if (ref $as eq 'SCALAR') {
    100          
891 2         26 $$as = $code;
892             } elsif (ref $as) {
893 2         330 Carp::croak "invalid reference type for $as: " . ref $as;
894             } else {
895             Sub::Install::reinstall_sub({
896             code => $code,
897             into => $arg->{into},
898 101         330 as => $as
899             });
900             }
901             }
902             }
903              
904             sub default_exporter {
905 0     0 0 0 Carp::cluck "default_exporter is deprecated; call default_installer instead; the semantics are identical";
906 0         0 goto &default_installer;
907             }
908              
909             #pod =head1 EXPORTS
910             #pod
911             #pod Sub::Exporter also offers its own exports: the C and
912             #pod C routines described above. It also provides a special "setup"
913             #pod collector, which will set up an exporter using the parameters passed to it.
914             #pod
915             #pod Note that the "setup" collector (seen in examples like the L above)
916             #pod uses C, not C. This means that the special
917             #pod arguments like "into" and "as" for C are not accepted here.
918             #pod Instead, you may write something like:
919             #pod
920             #pod use Sub::Exporter
921             #pod { into => 'Target::Package' },
922             #pod -setup => {
923             #pod -as => 'do_import',
924             #pod exports => [ ... ],
925             #pod }
926             #pod ;
927             #pod
928             #pod Finding a good reason for wanting to do this is left as an exercise for the
929             #pod reader.
930             #pod
931             #pod =cut
932              
933             setup_exporter({
934             exports => [
935             qw(setup_exporter build_exporter),
936             _import => sub { build_exporter($_[2]) },
937             ],
938             groups => {
939             all => [ qw(setup_exporter build_export) ],
940             },
941             collectors => { -setup => \&_setup },
942             });
943              
944             sub _setup {
945 18     18   31 my ($value, $arg) = @_;
946              
947 18 100       50 if (ref $value eq 'HASH') {
    100          
948 14         18 push @{ $arg->{import_args} }, [ _import => { -as => 'import', %$value } ];
  14         89  
949 14         60 return 1;
950             } elsif (ref $value eq 'ARRAY') {
951 2         2 push @{ $arg->{import_args} },
  2         6  
952             [ _import => { -as => 'import', exports => $value } ];
953 2         7 return 1;
954             }
955 2         216 return;
956             }
957              
958             #pod =head1 COMPARISONS
959             #pod
960             #pod There are a whole mess of exporters on the CPAN. The features included in
961             #pod Sub::Exporter set it apart from any existing Exporter. Here's a summary of
962             #pod some other exporters and how they compare.
963             #pod
964             #pod =over
965             #pod
966             #pod =item * L and co.
967             #pod
968             #pod This is the standard Perl exporter. Its interface is a little clunky, but it's
969             #pod fast and ubiquitous. It can do some things that Sub::Exporter can't: it can
970             #pod export things other than routines, it can import "everything in this group
971             #pod except this symbol," and some other more esoteric things. These features seem
972             #pod to go nearly entirely unused.
973             #pod
974             #pod It always exports things exactly as they appear in the exporting module; it
975             #pod can't rename or customize routines. Its groups ("tags") can't be nested.
976             #pod
977             #pod L is a whole lot like Exporter, but it does significantly less:
978             #pod it supports exporting symbols, but not groups, pattern matching, or negation.
979             #pod
980             #pod The fact that Sub::Exporter can't export symbols other than subroutines is
981             #pod a good idea, not a missing feature.
982             #pod
983             #pod For simple uses, setting up Sub::Exporter is about as easy as Exporter. For
984             #pod complex uses, Sub::Exporter makes hard things possible, which would not be
985             #pod possible with Exporter.
986             #pod
987             #pod When using a module that uses Sub::Exporter, users familiar with Exporter will
988             #pod probably see no difference in the basics. These two lines do about the same
989             #pod thing in whether the exporting module uses Exporter or Sub::Exporter.
990             #pod
991             #pod use Some::Module qw(foo bar baz);
992             #pod use Some::Module qw(foo :bar baz);
993             #pod
994             #pod The definition for exporting in Exporter.pm might look like this:
995             #pod
996             #pod package Some::Module;
997             #pod use base qw(Exporter);
998             #pod our @EXPORT_OK = qw(foo bar baz quux);
999             #pod our %EXPORT_TAGS = (bar => [ qw(bar baz) ]);
1000             #pod
1001             #pod Using Sub::Exporter, it would look like this:
1002             #pod
1003             #pod package Some::Module;
1004             #pod use Sub::Exporter -setup => {
1005             #pod exports => [ qw(foo bar baz quux) ],
1006             #pod groups => { bar => [ qw(bar baz) ]}
1007             #pod };
1008             #pod
1009             #pod Sub::Exporter respects inheritance, so that a package may export inherited
1010             #pod routines, and will export the most inherited version. Exporting methods
1011             #pod without currying away the invocant is a bad idea, but Sub::Exporter allows you
1012             #pod to do just that -- and anyway, there are other uses for this feature, like
1013             #pod packages of exported subroutines which use inheritance specifically to allow
1014             #pod more specialized, but similar, packages.
1015             #pod
1016             #pod L provides a wrapper around the standard Exporter. It makes it
1017             #pod simpler to build groups, but doesn't provide any more functionality. Because
1018             #pod it is a front-end to Exporter, it will store your exporter's configuration in
1019             #pod global package variables.
1020             #pod
1021             #pod =item * Attribute-Based Exporters
1022             #pod
1023             #pod Some exporters use attributes to mark variables to export. L
1024             #pod supports exporting any kind of symbol, and supports groups. Using a module
1025             #pod like Exporter or Sub::Exporter, it's easy to look at one place and see what is
1026             #pod exported, but it's impossible to look at a variable definition and see whether
1027             #pod it is exported by that alone. Exporter::Simple makes this trade in reverse:
1028             #pod each variable's declaration includes its export definition, but there is no one
1029             #pod place to look to find a manifest of exports.
1030             #pod
1031             #pod More importantly, Exporter::Simple does not add any new features to those of
1032             #pod Exporter. In fact, like Exporter::Easy, it is just a front-end to Exporter, so
1033             #pod it ends up storing its configuration in global package variables. (This means
1034             #pod that there is one place to look for your exporter's manifest, actually. You
1035             #pod can inspect the C<@EXPORT> package variables, and other related package
1036             #pod variables, at runtime.)
1037             #pod
1038             #pod L isn't actually attribute based, but looks similar. Its syntax
1039             #pod is borrowed from Perl 6, and implemented by a source filter. It is a prototype
1040             #pod of an interface that is still being designed. It should probably be avoided
1041             #pod for production work. On the other hand, L implements
1042             #pod Perl 6-like exporting, but translates it into Perl 5 by providing attributes.
1043             #pod
1044             #pod =item * Other Exporters
1045             #pod
1046             #pod L wraps the standard Exporter to allow it to export symbols
1047             #pod with changed names.
1048             #pod
1049             #pod L performs a special kind of routine generation, giving each
1050             #pod importing package an instance of your class, and then exporting the instance's
1051             #pod methods as normal routines. (Sub::Exporter, of course, can easily emulate this
1052             #pod behavior, as shown above.)
1053             #pod
1054             #pod L implements a form of renaming (using its C<_map> argument)
1055             #pod and of prefixing, and implements groups. It also avoids using package
1056             #pod variables for its configuration.
1057             #pod
1058             #pod =back
1059             #pod
1060             #pod =head1 TODO
1061             #pod
1062             #pod =cut
1063              
1064             #pod =over
1065             #pod
1066             #pod =item * write a set of longer, more demonstrative examples
1067             #pod
1068             #pod =item * solidify the "custom exporter" interface (see C<&default_exporter>)
1069             #pod
1070             #pod =item * add an "always" group
1071             #pod
1072             #pod =back
1073             #pod
1074             #pod =head1 THANKS
1075             #pod
1076             #pod Hans Dieter Pearcey provided helpful advice while I was writing Sub::Exporter.
1077             #pod Ian Langworth and Shawn Sorichetti asked some good questions and helped me
1078             #pod improve my documentation quite a bit. Yuval Kogman helped me find a bunch of
1079             #pod little problems.
1080             #pod
1081             #pod Thanks, friends!
1082             #pod
1083             #pod =head1 BUGS
1084             #pod
1085             #pod Please report any bugs or feature requests through the web interface at
1086             #pod L. I will be notified, and then you'll automatically be
1087             #pod notified of progress on your bug as I make changes.
1088             #pod
1089             #pod =cut
1090              
1091             "jn8:32"; # <-- magic true value
1092              
1093             __END__