File Coverage

File:local/lib/perl5/Sub/Exporter.pm
Coverage:64.2%

linestmtbrancondsubtimecode
1
6
6
6
54
7
use 5.006;
2
6
6
6
6
12
1
60
use strict;
3
6
6
6
6
10
2
123
use warnings;
4package Sub::Exporter;
5{
6  $Sub::Exporter::VERSION = '0.987';
7}
8# ABSTRACT: a sophisticated exporter for custom-built routines
9
10
6
6
6
6
10
2
47
use Carp ();
11
6
6
6
6
621
63
66
use Data::OptList 0.100 ();
12
6
6
6
6
15
42
42
use Params::Util 0.14 (); # _CODELIKE
13
6
6
6
6
9
25
3182
use Sub::Install 0.92 ();
14
15
16# Given a potential import name, this returns the group name -- if it's got a
17# group prefix.
18sub _group_name {
19
30
30
14
  my ($name) = @_;
20
21
30
100
54
  return if (index q{-:}, (substr $name, 0, 1)) == -1;
22
8
11
  return substr $name, 1;
23}
24
25# \@groups is a canonicalized opt list of exports and groups this returns
26# another canonicalized opt list with groups replaced with relevant exports.
27# \%seen is groups we've already expanded and can ignore.
28# \%merge is merged options from the group we're descending through.
29sub _expand_groups {
30
16
16
12
  my ($class, $config, $groups, $collection, $seen, $merge) = @_;
31
16
100
27
  $seen  ||= {};
32
16
100
28
  $merge ||= {};
33
16
13
  my @groups = @$groups;
34
35
16
17
  for my $i (reverse 0 .. $#groups) {
36
26
100
22
    if (my $group_name = _group_name($groups[$i][0])) {
37
4
5
      my $seen = { %$seen }; # faux-dynamic scoping
38
39
4
7
      splice @groups, $i, 1,
40        _expand_group($class, $config, $groups[$i], $collection, $seen, $merge);
41    } else {
42      # there's nothing to munge in this export's args
43
22
50
38
      next unless my %merge = %$merge;
44
45      # we have things to merge in; do so
46
0
0
0
      my $prefix = (delete $merge{-prefix}) || '';
47
0
0
0
      my $suffix = (delete $merge{-suffix}) || '';
48
49
0
0
0
0
      if (
50        Params::Util::_CODELIKE($groups[$i][1]) ## no critic Private
51        or
52        Params::Util::_SCALAR0($groups[$i][1]) ## no critic Private
53      ) {
54        # this entry was build by a group generator
55
0
0
        $groups[$i][0] = $prefix . $groups[$i][0] . $suffix;
56      } else {
57
0
0
0
0
        my $as
58          = ref $groups[$i][1]{-as} ? $groups[$i][1]{-as}
59          :     $groups[$i][1]{-as} ? $prefix . $groups[$i][1]{-as} . $suffix
60          :                           $prefix . $groups[$i][0]      . $suffix;
61
62
0
0
0
0
        $groups[$i][1] = { %{ $groups[$i][1] }, %merge, -as => $as };
63      }
64    }
65  }
66
67
16
29
  return \@groups;
68}
69
70# \@group is a name/value pair from an opt list.
71sub _expand_group {
72
4
4
3
  my ($class, $config, $group, $collection, $seen, $merge) = @_;
73
4
50
6
  $merge ||= {};
74
75
4
3
  my ($group_name, $group_arg) = @$group;
76
4
6
  $group_name = _group_name($group_name);
77
78
4
50
7
  Carp::croak qq(group "$group_name" is not exported by the $class module)
79    unless exists $config->{groups}{$group_name};
80
81
4
50
15
  return if $seen->{$group_name}++;
82
83
4
50
5
  if (ref $group_arg) {
84
0
0
0
0
    my $prefix = (delete $merge->{-prefix}||'') . ($group_arg->{-prefix}||'');
85
0
0
0
0
    my $suffix = ($group_arg->{-suffix}||'') . (delete $merge->{-suffix}||'');
86
0
0
0
0
    $merge = {
87      %$merge,
88      %$group_arg,
89      ($prefix ? (-prefix => $prefix) : ()),
90      ($suffix ? (-suffix => $suffix) : ()),
91    };
92  }
93
94
4
2
  my $exports = $config->{groups}{$group_name};
95
96
4
50
33
17
  if (
97    Params::Util::_CODELIKE($exports) ## no critic Private
98    or
99    Params::Util::_SCALAR0($exports) ## no critic Private
100  ) {
101    # I'm not very happy with this code for hiding -prefix and -suffix, but
102    # it's needed, and I'm not sure, offhand, how to make it better.
103    # -- rjbs, 2006-12-05
104
0
0
0
    my $group_arg = $merge ? { %$merge } : {};
105
0
0
    delete $group_arg->{-prefix};
106
0
0
    delete $group_arg->{-suffix};
107
108
0
0
0
    my $group = Params::Util::_CODELIKE($exports) ## no critic Private
109              ? $exports->($class, $group_name, $group_arg, $collection)
110              : $class->$$exports($group_name, $group_arg, $collection);
111
112
0
0
0
    Carp::croak qq(group generator "$group_name" did not return a hashref)
113      if ref $group ne 'HASH';
114
115
0
0
0
0
    my $stuff = [ map { [ $_ => $group->{$_} ] } keys %$group ];
116    return @{
117
0
0
0
0
      _expand_groups($class, $config, $stuff, $collection, $seen, $merge)
118    };
119  } else {
120
4
7
    $exports
121      = Data::OptList::mkopt($exports, "$group_name exports");
122
123    return @{
124
4
4
6
11
      _expand_groups($class, $config, $exports, $collection, $seen, $merge)
125    };
126  }
127}
128
129sub _mk_collection_builder {
130
12
12
8
  my ($col, $etc) = @_;
131
12
12
  my ($config, $import_args, $class, $into) = @$etc;
132
133
12
7
  my %seen;
134  sub {
135
6
6
2
    my ($collection) = @_;
136
6
6
    my ($name, $value) = @$collection;
137
138
6
50
10
    Carp::croak "collection $name provided multiple times in import"
139      if $seen{ $name }++;
140
141
6
50
10
    if (ref(my $hook = $config->{collectors}{$name})) {
142
6
16
      my $arg = {
143        name        => $name,
144        config      => $config,
145        import_args => $import_args,
146        class       => $class,
147        into        => $into,
148      };
149
150
6
7
      my $error_msg = "collection $name failed validation";
151
6
50
10
      if (Params::Util::_SCALAR0($hook)) { ## no critic Private
152
0
0
0
        Carp::croak $error_msg unless $class->$$hook($value, $arg);
153      } else {
154
6
50
14
        Carp::croak $error_msg unless $hook->($value, $arg);
155      }
156    }
157
158
6
10
    $col->{ $name } = $value;
159  }
160
12
27
}
161
162# Given a config and pre-canonicalized importer args, remove collections from
163# the args and return them.
164sub _collect_collections {
165
12
12
8
  my ($config, $import_args, $class, $into) = @_;
166
167  my @collections
168
6
12
10
22
    = map  { splice @$import_args, $_, 1 }
169
12
15
      grep { exists $config->{collectors}{ $import_args->[$_][0] } }
170      reverse 0 .. $#$import_args;
171
172
12
50
16
  unshift @collections, [ INIT => {} ] if $config->{collectors}{INIT};
173
174
12
8
  my $col = {};
175
12
14
  my $builder = _mk_collection_builder($col, \@_);
176
12
14
  for my $collection (@collections) {
177
6
7
    $builder->($collection)
178  }
179
180
12
52
  return $col;
181}
182
183
184sub setup_exporter {
185
6
6
3
  my ($config)  = @_;
186
187
6
50
33
16
  Carp::croak 'into and into_level may not both be supplied to exporter'
188    if exists $config->{into} and exists $config->{into_level};
189
190
6
50
23
  my $as   = delete $config->{as}   || 'import';
191
6
50
50
21
  my $into
192    = exists $config->{into}       ? delete $config->{into}
193    : exists $config->{into_level} ? caller(delete $config->{into_level})
194    :                                caller(0);
195
196
6
8
  my $import = build_exporter($config);
197
198
6
18
  Sub::Install::reinstall_sub({
199    code => $import,
200    into => $into,
201    as   => $as,
202  });
203}
204
205
206sub _key_intersection {
207
12
12
9
  my ($x, $y) = @_;
208
12
60
14
39
  my %seen = map { $_ => 1 } keys %$x;
209
12
6
21
17
  my @names = grep { $seen{$_} } keys %$y;
210}
211
212# Given the config passed to setup_exporter, which contains sugary opt list
213# data, rewrite the opt lists into hashes, catch a few kinds of invalid
214# configurations, and set up defaults.  Since the config is a reference, it's
215# rewritten in place.
216my %valid_config_key;
217BEGIN {
218
54
3483
  %valid_config_key =
219
6
6
7
    map { $_ => 1 }
220    qw(as collectors installer generator exports groups into into_level),
221    qw(exporter), # deprecated
222}
223
224sub _assert_collector_names_ok {
225
12
12
6
  my ($collectors) = @_;
226
227
12
6
14
17
  for my $reserved_name (grep { /\A[_A-Z]+\z/ } keys %$collectors) {
228
0
0
0
    Carp::croak "unknown reserved collector name: $reserved_name"
229      if $reserved_name ne 'INIT';
230  }
231}
232
233sub _rewrite_build_config {
234
12
12
5
  my ($config) = @_;
235
236
12
24
50
15
37
  if (my @keys = grep { not exists $valid_config_key{$_} } keys %$config) {
237
0
0
    Carp::croak "unknown options (@keys) passed to Sub::Exporter";
238  }
239
240
12
50
33
19
  Carp::croak q(into and into_level may not both be supplied to exporter)
241    if exists $config->{into} and exists $config->{into_level};
242
243  # XXX: Remove after deprecation period.
244
12
50
15
  if ($config->{exporter}) {
245
0
0
    Carp::cluck "'exporter' argument to build_exporter is deprecated. Use 'installer' instead; the semantics are identical.";
246
0
0
    $config->{installer} = delete $config->{exporter};
247  }
248
249
12
50
33
21
  Carp::croak q(into and into_level may not both be supplied to exporter)
250    if exists $config->{into} and exists $config->{into_level};
251
252
12
11
  for (qw(exports collectors)) {
253
24
35
    $config->{$_} = Data::OptList::mkopt_hash(
254      $config->{$_},
255      $_,
256      [ 'CODE', 'SCALAR' ],
257    );
258  }
259
260
12
16
  _assert_collector_names_ok($config->{collectors});
261
262
12
50
16
  if (my @names = _key_intersection(@$config{qw(exports collectors)})) {
263
0
0
    Carp::croak "names (@names) used in both collections and exports";
264  }
265
266
12
18
  $config->{groups} = Data::OptList::mkopt_hash(
267      $config->{groups},
268      'groups',
269      [
270        'HASH',   # standard opt list
271        'ARRAY',  # standard opt list
272        'CODE',   # group generator
273        'SCALAR', # name of group generation method
274      ]
275    );
276
277  # by default, export nothing
278
12
50
34
  $config->{groups}{default} ||= [];
279
280  # by default, build an all-inclusive 'all' group
281
12
6
100
24
13
  $config->{groups}{all} ||= [ keys %{ $config->{exports} } ];
282
283
12
50
30
  $config->{generator} ||= \&default_generator;
284
12
50
28
  $config->{installer} ||= \&default_installer;
285}
286
287sub build_exporter {
288
12
12
8
  my ($config) = @_;
289
290
12
11
  _rewrite_build_config($config);
291
292  my $import = sub {
293
12
12
9
    my ($class) = shift;
294
295    # XXX: clean this up -- rjbs, 2006-03-16
296
12
50
15
    my $special = (ref $_[0]) ? shift(@_) : {};
297
12
50
33
20
    Carp::croak q(into and into_level may not both be supplied to exporter)
298      if exists $special->{into} and exists $special->{into_level};
299
300
12
50
16
    if ($special->{exporter}) {
301
0
0
      Carp::cluck "'exporter' special import argument is deprecated. Use 'installer' instead; the semantics are identical.";
302
0
0
      $special->{installer} = delete $special->{exporter};
303    }
304
305
12
50
50
50
50
38
    my $into
306      = defined $special->{into}       ? delete $special->{into}
307      : defined $special->{into_level} ? caller(delete $special->{into_level})
308      : defined $config->{into}        ? $config->{into}
309      : defined $config->{into_level}  ? caller($config->{into_level})
310      :                                  caller(0);
311
312
12
33
32
    my $generator = delete $special->{generator} || $config->{generator};
313
12
33
23
    my $installer = delete $special->{installer} || $config->{installer};
314
315    # this builds a AOA, where the inner arrays are [ name => value_ref ]
316
12
16
    my $import_args = Data::OptList::mkopt([ @_ ]);
317
318    # is this right?  defaults first or collectors first? -- rjbs, 2006-06-24
319
12
100
17
    $import_args = [ [ -default => undef ] ] unless @$import_args;
320
321
12
15
    my $collection = _collect_collections($config, $import_args, $class, $into);
322
323
12
15
    my $to_import = _expand_groups($class, $config, $import_args, $collection);
324
325    # now, finally $import_arg is really the "to do" list
326
12
26
    _do_import(
327      {
328        class     => $class,
329        col       => $collection,
330        config    => $config,
331        into      => $into,
332        generator => $generator,
333        installer => $installer,
334      },
335      $to_import,
336    );
337
12
20
  };
338
339
12
19
  return $import;
340}
341
342sub _do_import {
343
12
12
6
  my ($arg, $to_import) = @_;
344
345
12
11
  my @todo;
346
347
12
7
  for my $pair (@$to_import) {
348
22
15
    my ($name, $import_arg) = @$pair;
349
350
22
9
    my ($generator, $as);
351
352
22
50
67
36
    if ($import_arg and Params::Util::_CODELIKE($import_arg)) { ## no critic
353      # This is the case when a group generator has inserted name/code pairs.
354
0
0
0
0
0
      $generator = sub { $import_arg };
355
0
0
      $as = $name;
356    } else {
357
22
100
27
      $import_arg = { $import_arg ? %$import_arg : () };
358
359
22
50
27
      Carp::croak qq("$name" is not exported by the $arg->{class} module)
360        unless exists $arg->{config}{exports}{$name};
361
362
22
18
      $generator = $arg->{config}{exports}{$name};
363
364
22
100
23
      $as = exists $import_arg->{-as} ? (delete $import_arg->{-as}) : $name;
365    }
366
367
22
36
    my $code = $arg->{generator}->(
368      {
369        class     => $arg->{class},
370        name      => $name,
371        arg       => $import_arg,
372        col       => $arg->{col},
373        generator => $generator,
374      }
375    );
376
377
22
30
    push @todo, $as, $code;
378  }
379
380
12
28
  $arg->{installer}->(
381    {
382      class => $arg->{class},
383      into  => $arg->{into},
384      col   => $arg->{col},
385    },
386    \@todo,
387  );
388}
389
390## Cute idea, possibly for future use: also supply an "unimport" for:
391## no Module::Whatever qw(arg arg arg);
392# sub _unexport {
393#   my (undef, undef, undef, undef, undef, $as, $into) = @_;
394#
395#   if (ref $as eq 'SCALAR') {
396#     undef $$as;
397#   } elsif (ref $as) {
398#     Carp::croak "invalid reference type for $as: " . ref $as;
399#   } else {
400#     no strict 'refs';
401#     delete &{$into . '::' . $as};
402#   }
403# }
404
405
406sub default_generator {
407
22
22
10
  my ($arg) = @_;
408
22
24
  my ($class, $name, $generator) = @$arg{qw(class name generator)};
409
410
22
100
19
  if (not defined $generator) {
411
16
50
46
    my $code = $class->can($name)
412      or Carp::croak "can't locate exported subroutine $name via $class";
413
16
8
    return $code;
414  }
415
416  # I considered making this "$class->$generator(" but it seems that
417  # overloading precedence would turn an overloaded-as-code generator object
418  # into a string before code. -- rjbs, 2006-06-11
419
6
50
13
  return $generator->($class, $name, $arg->{arg}, $arg->{col})
420    if Params::Util::_CODELIKE($generator); ## no critic Private
421
422  # This "must" be a scalar reference, to a generator method name.
423  # -- rjbs, 2006-12-05
424
0
0
  return $class->$$generator($name, $arg->{arg}, $arg->{col});
425}
426
427
428sub default_installer {
429
12
12
4
  my ($arg, $to_export) = @_;
430
431
12
1355
  for (my $i = 0; $i < @$to_export; $i += 2) {
432
22
20
    my ($as, $code) = @$to_export[ $i, $i+1 ];
433
434    # Allow as isa ARRAY to push onto an array?
435    # Allow into isa HASH to install name=>code into hash?
436
437
22
50
50
31
    if (ref $as eq 'SCALAR') {
438
0
0
      $$as = $code;
439    } elsif (ref $as) {
440
0
0
      Carp::croak "invalid reference type for $as: " . ref $as;
441    } else {
442
22
35
      Sub::Install::reinstall_sub({
443        code => $code,
444        into => $arg->{into},
445        as   => $as
446      });
447    }
448  }
449}
450
451sub default_exporter {
452
0
0
0
  Carp::cluck "default_exporter is deprecated; call default_installer instead; the semantics are identical";
453
0
0
  goto &default_installer;
454}
455
456
457setup_exporter({
458  exports => [
459    qw(setup_exporter build_exporter),
460    _import => sub { build_exporter($_[2]) },
461  ],
462  groups  => {
463    all   => [ qw(setup_exporter build_export) ],
464  },
465  collectors => { -setup => \&_setup },
466});
467
468sub _setup {
469
6
6
4
  my ($value, $arg) = @_;
470
471
6
50
0
11
  if (ref $value eq 'HASH') {
472
6
6
2
14
    push @{ $arg->{import_args} }, [ _import => { -as => 'import', %$value } ];
473
6
15
    return 1;
474  } elsif (ref $value eq 'ARRAY') {
475
0
0
    push @{ $arg->{import_args} },
476      [ _import => { -as => 'import', exports => $value } ];
477
0
    return 1;
478  }
479
0
  return;
480}
481
482
483
484"jn8:32"; # <-- magic true value
485