File Coverage

blib/lib/CXC/Exporter/Util.pm
Criterion Covered Total %
statement 121 125 96.8
branch 26 32 81.2
condition 22 26 84.6
subroutine 20 21 95.2
pod 4 4 100.0
total 193 208 92.7


line stmt bran cond sub pod time code
1             package CXC::Exporter::Util;
2              
3             # ABSTRACT: Tagged Based Exporting
4              
5 4     4   974036 use v5.20;
  4         41  
6              
7 4     4   21 use strict;
  4         8  
  4         77  
8 4     4   17 use warnings;
  4         9  
  4         188  
9              
10             our $VERSION = '0.04'; # TRIAL
11              
12 4     4   23 use Scalar::Util 'reftype';
  4         8  
  4         264  
13 4     4   27 use List::Util 1.45 'uniqstr';
  4         68  
  4         253  
14 4     4   25 use Import::Into;
  4         15  
  4         103  
15 4     4   19 use experimental 'signatures', 'postderef';
  4         8  
  4         25  
16              
17 4     4   748 use Exporter 'import';
  4         18  
  4         615  
18              
19             our %EXPORT_TAGS = (
20             default => [qw( install_EXPORTS )],
21             constants => [qw( install_CONSTANTS )],
22             utils => [qw( install_constant_tag install_constant_func )],
23             );
24              
25             our %HOOK;
26              
27             install_EXPORTS();
28              
29             sub _croak {
30 0     0   0 require Carp;
31 0         0 goto \&Carp::croak;
32             }
33              
34 23     23   35 sub _EXPORT_TAGS ( $caller = scalar caller ) {
  23         41  
  23         29  
35 4     4   28 no strict 'refs'; ## no critic
  4         7  
  4         638  
36 23         171 *${ \"${caller}::EXPORT_TAGS" }{HASH}
37 23   100     31 // \%{ *${ \"${caller}::EXPORT_TAGS" } = {} };
  5         10  
  5         35  
38             }
39              
40 13     13   22 sub _EXPORT_OK ( $caller = scalar caller ) {
  13         22  
  13         18  
41 4     4   27 no strict 'refs'; ## no critic
  4         7  
  4         667  
42 13         92 *${ \"${caller}::EXPORT_OK" }{ARRAY}
43 13   100     20 // \@{ *${ \"${caller}::EXPORT_OK" } = [] };
  12         22  
  12         113  
44             }
45              
46 13     13   21 sub _EXPORT ( $caller = scalar caller ) {
  13         21  
  13         20  
47 4     4   26 no strict 'refs'; ## no critic
  4         7  
  4         4408  
48 13   50     40 *${ \"${caller}::EXPORT" }{ARRAY} // \@{ *${ \"${caller}::EXPORT" } = [] };
  13         88  
  13         40  
  13         89  
49             }
50              
51              
52              
53              
54              
55              
56              
57              
58              
59              
60              
61              
62              
63              
64              
65              
66              
67              
68              
69              
70              
71              
72              
73              
74              
75              
76              
77              
78              
79              
80              
81              
82              
83              
84              
85              
86              
87              
88              
89              
90              
91              
92              
93              
94              
95              
96              
97              
98              
99              
100              
101              
102              
103              
104              
105              
106              
107              
108              
109              
110              
111             sub install_EXPORTS {
112              
113 13 100 100 13 1 474 my $export_tags = ( reftype( $_[0] ) // '' ) eq 'HASH' ? shift : undef;
114 13 100 100     104 my $u_opts = ( reftype( $_[-1] ) // '' ) eq 'HASH' ? shift : {};
115              
116 13   50     111 my %options = (
117             overwrite => 0,
118             all => 'auto',
119             package => shift // scalar caller,
120             %$u_opts
121             );
122              
123 13 50       40 _croak( "too many arguments to INSTALL_EXPORTS" ) if @_;
124              
125 13         70 my $package = delete $options{package};
126 13         28 my $install_all = delete $options{all};
127              
128             # run hooks.
129 13 100       50 if ( defined( my $hooks = delete $HOOK{$package}{pre} ) ) {
130 1         5 $_->() for values $hooks->%*;
131             }
132              
133 13         33 my $EXPORT_TAGS = _EXPORT_TAGS( $package );
134              
135 13 100       38 if ( defined $export_tags ) {
136              
137 7 100       20 if ( delete $options{overwrite} ) {
138 1         7 $EXPORT_TAGS->%* = $export_tags->%*;
139             }
140              
141             else {
142             # cheap one layer deep hash merge
143 6         21 for my $tag ( keys $export_tags->%* ) {
144             push(
145             ( $EXPORT_TAGS->{$tag} //= [] )->@*,
146 10   50     53 $export_tags->{$tag}->@*
147             );
148             }
149             }
150             }
151              
152             # Exporter::Tiny handles the 'all' tag, as does Sub::Exporter, but
153             # I don't know how to detect when the latter is being used.
154 13 100       140 $install_all = !$package->isa( 'Exporter::Tiny' )
155             if $install_all eq 'auto';
156              
157 13 100       36 if ( $install_all ) {
158             # Assign the all tag in two steps to avoid the situation
159             # where $EXPORT_TAGS->{all} is created with an undefined value
160             # before running values on $EXPORT_TAGS->%*;
161              
162 10         31 my @all = map { $_->@* } values $EXPORT_TAGS->%*;
  25         63  
163 10   50     52 $EXPORT_TAGS->{all} //= \@all;
164             }
165              
166 13   100     54 _EXPORT( $package )->@* = ( $EXPORT_TAGS->{default} // [] )->@*;
167 13         37 _EXPORT_OK( $package )->@* = uniqstr map { $_->@* } values $EXPORT_TAGS->%*;
  45         324  
168             }
169              
170              
171              
172              
173              
174              
175              
176              
177              
178              
179              
180              
181              
182              
183              
184              
185              
186              
187              
188              
189              
190              
191              
192              
193              
194              
195              
196              
197              
198              
199              
200              
201              
202              
203              
204              
205              
206              
207              
208              
209              
210              
211              
212              
213              
214              
215              
216              
217              
218              
219              
220              
221              
222              
223              
224              
225              
226              
227              
228              
229              
230             sub install_CONSTANTS {
231 3 50   3 1 271 my $package = !defined reftype( $_[-1] ) ? pop : scalar caller;
232              
233 3         10 for my $spec ( @_ ) {
234 4         10 my $type = reftype( $spec );
235              
236 4 100       13 if ( 'HASH' eq $type ) {
    50          
237             install_constant_tag( $_, $spec->{$_}, $package )
238 2         18 for keys $spec->%*;
239             }
240              
241             elsif ( 'ARRAY' eq $type ) {
242 2         4 my $idx = $spec->@*;
243 2 50       9 _croak(
244             "constant spec passed as array has an odd number of elements" )
245             unless 0 == $idx % 2;
246              
247 2         5 while ( $idx ) {
248 2         3 my $hash = $spec->[ --$idx ];
249 2         4 my $id = $spec->[ --$idx ];
250 2         4 install_constant_tag( $id, $hash, $package );
251             }
252             }
253              
254             else {
255 0         0 _croak( "expect a HashRef or an ArrayRef" );
256             }
257             }
258             }
259              
260              
261              
262              
263              
264              
265              
266              
267              
268              
269              
270              
271              
272              
273              
274              
275              
276              
277              
278              
279              
280              
281              
282              
283              
284              
285              
286              
287              
288              
289              
290              
291              
292              
293              
294              
295              
296              
297              
298              
299              
300              
301              
302              
303              
304              
305              
306              
307              
308              
309              
310              
311              
312              
313              
314              
315              
316              
317              
318              
319              
320              
321              
322              
323              
324              
325              
326              
327              
328              
329              
330              
331              
332              
333              
334              
335              
336              
337              
338              
339              
340              
341              
342              
343              
344              
345              
346              
347              
348              
349              
350              
351              
352              
353              
354              
355              
356              
357              
358              
359              
360              
361              
362              
363              
364              
365              
366              
367              
368              
369              
370              
371              
372              
373              
374              
375              
376              
377              
378              
379              
380              
381              
382              
383              
384              
385              
386              
387 4     4 1 13 sub install_constant_tag ( $id, $constants, $package = scalar caller ) {
  4         8  
  4         5  
  4         7  
  4         5  
388              
389 4         4 my ( @names, @values );
390 4 100       16 if ( reftype( $constants ) eq 'HASH' ) {
    50          
391 2         6 @names = keys $constants->%*;
392 2         5 @values = values $constants->%*;
393             }
394             elsif ( reftype( $constants ) eq 'ARRAY' ) {
395 2         8 my @copy = $constants->@*;
396 2         10 while ( my ( $name, $value ) = splice( @copy, 0, 2 ) ) {
397 13         15 push @names, $name;
398 13         29 push @values, $value;
399             }
400 2         11 $constants = { $constants->@* };
401             }
402             else {
403 0         0 _croak(
404             '$constants argument should be either a hashref or an arrayref' );
405             }
406              
407 4         29 constant->import::into( $package, $constants );
408              
409             # caller may specify distinct tag and enumeration function names.
410 4 100 100     1120 my ( $tag, $fname )
411             = 'ARRAY' eq ( reftype( $id ) // '' )
412             ? ( $id->[0], $id->[1] )
413             : ( lc( $id ), $id );
414              
415              
416 4   100     10 push( ( _EXPORT_TAGS( $package )->{$tag} //= [] )->@*, @names );
417              
418 4         13 my $fqdn = join '::', $package, $fname;
419             $HOOK{$package}{pre}{$fname} //= sub {
420 4     4   34 no strict 'refs'; ## no critic
  4         8  
  4         1115  
421             _croak( "Error: attempt to redefine enumerating function $fqdn" )
422 3 50   3   4 if exists &{$fqdn};
  3         10  
423             my @values
424 3         8 = map { &{"${package}::${_}"} } _EXPORT_TAGS( $package )->{$tag}->@*;
  21         27  
  21         75  
425 3         8 install_constant_func( $fname, \@values, $package );
426 4   100     189 };
427             }
428              
429              
430              
431              
432              
433              
434              
435              
436              
437              
438              
439              
440              
441              
442              
443              
444              
445              
446              
447              
448              
449              
450              
451              
452              
453              
454              
455              
456              
457              
458              
459              
460              
461              
462              
463              
464              
465              
466              
467              
468              
469              
470              
471              
472 3     3 1 5 sub install_constant_func ( $tag, $values, $caller = scalar caller ) {
  3         5  
  3         4  
  3         3  
  3         4  
473 3         10 constant->import::into( $caller, $tag => $values->@* );
474 3   100     493 push( ( _EXPORT_TAGS( $caller )->{constants_funcs} //= [] )->@*, $tag );
475             }
476              
477              
478             1;
479              
480             #
481             # This file is part of CXC-Exporter-Util
482             #
483             # This software is Copyright (c) 2022 by Smithsonian Astrophysical Observatory.
484             #
485             # This is free software, licensed under:
486             #
487             # The GNU General Public License, Version 3, June 2007
488             #
489              
490             __END__