File Coverage

blib/lib/Pcore/Core/Exporter.pm
Criterion Covered Total %
statement 107 117 91.4
branch 42 66 63.6
condition 11 22 50.0
subroutine 11 11 100.0
pod 0 1 0.0
total 171 217 78.8


line stmt bran cond sub pod time code
1             package Pcore::Core::Exporter;
2              
3 5     5   26 use common::header;
  5         9  
  5         115  
4              
5             our $EXPORT_PRAGMA = { #
6             export => 1,
7             };
8              
9             our $CACHE;
10              
11             sub import {
12 48     48   92 my $self = shift;
13              
14             # parse tags and pragmas
15 48         105 my $import = parse_import( $self, @_ );
16              
17             # find caller
18 48   50     1090 my $caller = $import->{pragma}->{caller} // caller( $import->{pragma}->{level} // 0 );
      66        
19              
20             # process -export pragma
21 48 50       125 if ( !exists $CACHE->{$caller} ) {
22 48 100       186 $import->{pragma}->{export} = { ALL => $import->{pragma}->{export} } if ref $import->{pragma}->{export} eq 'ARRAY';
23              
24 48         77 my $tags; # 0 - processing, 1 - done
25              
26 133     133   155 my $process_tag = sub ($tag) {
  133         159  
  133         180  
27              
28             # tag is already processed
29 133 100       277 return if $tags->{$tag};
30              
31 128 50 33     290 die qq[Cyclic reference found whils processing export tag "$tag"] if exists $tags->{$tag} && !$tags->{$tag};
32              
33 128         200 $tags->{$tag} = 0;
34              
35 128         254 for ( $import->{pragma}->{export}->{$tag}->@* ) {
36 816         997 my $sym = $_;
37              
38 816 100       1785 my $type = $sym =~ s/\A([:&\$@%*])//sm ? $1 : q[];
39              
40 816 100       1194 if ( $type ne q[:] ) {
41 811 50       1181 $type = q[] if $type eq q[&];
42              
43 811         1698 $CACHE->{$caller}->{$tag}->{ $type . $sym } = 1;
44              
45 811         2213 $CACHE->{$caller}->{ALL}->{ $type . $sym } = [ $sym, $type ];
46             }
47             else {
48 5 50       18 die qq["ALL" export tag can not contain references to the other tags in package "$caller"] if $tag eq 'ALL';
49              
50 5         29 __SUB__->($sym);
51              
52 5         33 $CACHE->{$caller}->{$tag}->@{ keys $CACHE->{$caller}->{$sym}->%* } = values $CACHE->{$caller}->{$sym}->%*;
53             }
54             }
55              
56             # mark tag as processed
57 128         215 $tags->{$tag} = 1;
58              
59 128         574 return;
60 48         233 };
61              
62 48         178 for my $tag ( keys $import->{pragma}->{export}->%* ) {
63 128         219 $process_tag->($tag);
64             }
65             }
66              
67             # export import method
68             {
69 5     5   37 no strict qw[refs];
  5         13  
  5         799  
  48         88  
70              
71 48         95 *{"$caller\::import"} = \&_import;
  48         263  
72             }
73              
74 48         149 return;
75             }
76              
77             sub parse_import {
78 781     781 0 1204 my $caller = shift;
79              
80 781         998 my $res;
81              
82 781         1012 my $export_pragma = do {
83 5     5   28 no strict qw[refs];
  5         16  
  5         134  
84 5     5   24 no warnings qw[once];
  5         9  
  5         4381  
85              
86 781         940 ${"$caller\::EXPORT_PRAGMA"};
  781         2573  
87             };
88              
89 781         1989 while ( my $arg = shift ) {
90 933 50       2516 if ( ref $arg ) {
    100          
91 0         0 die q[Invalid value in the import specification. References are not supported.];
92             }
93             elsif ( substr( $arg, 0, 1 ) eq q[-] ) {
94 708         1163 substr $arg, 0, 1, q[];
95              
96 708 100 66     2695 if ( $arg eq 'level' || $arg eq 'caller' ) {
    50 33        
97 489         1699 $res->{pragma}->{$arg} = shift;
98             }
99             elsif ( $export_pragma && exists $export_pragma->{$arg} ) {
100 219 100       1027 $res->{pragma}->{$arg} = $export_pragma->{$arg} ? shift : 1;
101             }
102             else {
103 0         0 die qq[Unknown exporter pragma found "-$arg" while importing package "$caller"];
104             }
105             }
106             else {
107 225         760 $res->{import}->{$arg} = undef;
108             }
109             }
110              
111 781         1436 return $res;
112             }
113              
114             sub _import {
115 551     551   44922 my $self = shift;
116              
117             # parse tags and pragmas
118 551         1159 my $import = parse_import( $self, @_ );
119              
120             # find caller
121 551   50     1931 my $caller = $import->{pragma}->{caller} // caller( $import->{pragma}->{level} // 0 );
      66        
122              
123             # protection from re-exporting to myself
124 551 100       1122 return if $caller eq $self;
125              
126 546         1619 _export_tags( $self, $caller, $import->{import} );
127              
128 546         45301 return;
129             }
130              
131 546     546   1069 sub _export_tags ( $self, $caller, $import ) {
  546         760  
  546         678  
  546         907  
  546         654  
132 546         999 my $export = $CACHE->{$self};
133              
134 546 100       974 if ( !$import ) {
135 431 50       869 if ( !exists $export->{DEFAULT} ) {
136 0         0 return;
137             }
138             else {
139 431         897 $import->{':DEFAULT'} = undef;
140             }
141             }
142             else {
143 115 50       290 die qq[Package "$self" doesn't export anything] if !$export;
144             }
145              
146             # gather symbols to export
147 546         721 my $symbols;
148              
149 546         1479 for my $sym ( keys $import->%* ) {
150 656         990 my $no_export;
151              
152             my $is_tag;
153              
154 656 100       2458 if ( $sym =~ s/\A([!:])//sm ) {
155 460 50       1153 if ( $1 eq q[!] ) {
156 0         0 $no_export = 1;
157              
158 0 0       0 $is_tag = 1 if $sym =~ s/\A://sm;
159             }
160             else {
161 460         638 $is_tag = 1;
162             }
163             }
164              
165 656 100       1178 if ($is_tag) {
166 460 50       929 die qq[Unknown tag ":$sym" to import from "$self"] if !exists $export->{$sym};
167              
168 460 50       1015 if ($no_export) {
169 0         0 delete $symbols->@{ keys $export->{$sym}->%* };
170             }
171             else {
172 460         2154 $symbols->@{ keys $export->{$sym}->%* } = ();
173             }
174             }
175             else {
176              
177             # remove "&" sigil
178 196         331 $sym =~ s/\A&//sm;
179              
180 196         267 my $alias;
181              
182 196 50       521 ( $sym, $alias ) = $sym =~ /(.+)=(.+)/sm if index( $sym, q[=] ) > 0;
183              
184 196 50       485 die qq[Unknown symbol "$sym" to import from package "$self"] if !exists $export->{ALL}->{$sym};
185              
186 196 50       348 if ($no_export) {
187 0         0 delete $symbols->{$sym};
188             }
189             else {
190 196         431 $symbols->{$sym} = $alias;
191             }
192             }
193             }
194              
195             # export
196 546 50       1294 if ( $symbols->%* ) {
197 546         878 my $export_all = $export->{ALL};
198              
199 546         1248 for my $sym ( keys $symbols->%* ) {
200              
201             # skip symbol if it is not exists in symbol table
202 1900 100       2355 next if !defined *{"$self\::$export_all->{$sym}->[0]"};
  1900         6032  
203              
204 1870         2804 my $type = $export_all->{$sym}->[1];
205              
206 1870   33     4670 my $alias = $symbols->{$sym} // $export_all->{$sym}->[0];
207              
208             {
209 5     5   35 no strict qw[refs];
  5         7  
  5         146  
  1870         2156  
210              
211 5     5   25 no warnings qw[once];
  5         8  
  5         1277  
212              
213 1870         7716 *{"$caller\::$alias"}
214 505         1357 = $type eq q[] ? \&{"$self\::$export_all->{$sym}->[0]"}
215 1365         3156 : $type eq q[$] ? \${"$self\::$export_all->{$sym}->[0]"}
216 0         0 : $type eq q[@] ? \@{"$self\::$export_all->{$sym}->[0]"}
217 0         0 : $type eq q[%] ? \%{"$self\::$export_all->{$sym}->[0]"}
218 1870 0       3222 : $type eq q[*] ? *{"$self\::$export_all->{$sym}->[0]"}
  0 0       0  
    0          
    50          
    100          
219             : die;
220             }
221             }
222             }
223              
224 546         1560 return;
225             }
226              
227             1;
228             ## -----SOURCE FILTER LOG BEGIN-----
229             ##
230             ## PerlCritic profile "common" policy violations:
231             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
232             ## | Sev. | Lines | Policy |
233             ## |======+======================+================================================================================================================|
234             ## | 3 | 31, 48, 91, 103, | ErrorHandling::RequireCarping - "die" used instead of "croak" |
235             ## | | 143, 166, 184, 219 | |
236             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
237             ## | 3 | 131 | Subroutines::ProhibitExcessComplexity - Subroutine "_export_tags" with high complexity score (28) |
238             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
239             ## | 2 | 1 | Modules::RequireVersionVar - No package-scoped "$VERSION" variable found |
240             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
241             ##
242             ## -----SOURCE FILTER LOG END-----
243             __END__
244             =pod
245              
246             =encoding utf8
247              
248             =head1 NAME
249              
250             Pcore::Core::Exporter
251              
252             =head1 SYNOPSIS
253              
254             use Pcore::Core::Exporter;
255              
256             our $EXPORT = [ ...SYMBOLS TO EXPORT... ];
257              
258             or
259              
260             our $EXPORT = {
261             TAG1 => [qw[sub1 $var1 ... ]],
262             TAG2 => [qw[:TAG1 sub2 $var2 ... ]],
263             DEFAULT => [qw[:TAG1 :TAG2 sym3 ...]],
264             };
265              
266             our $EXPORT_PRAGMA = {
267             trigger => 0,
268             option => 1,
269             };
270              
271             ...
272              
273             use Package qw[-trigger -option OPTION_VALUE :TAG1 !:TAG2 sub1 !sub2 $var1 !$var2 @arr1 !@arr2 %hash1 !%hash2 *sym1 !*sym2], {};
274              
275             # export aliases
276             use Package qw[$SYM=alias1 @SYM=alias2 sub=alias3]
277              
278             =head1 DESCRIPTION
279              
280             Tag ":ALL" is reserver and is created automatically.
281              
282             If no symbols / tags are specified for import - ":DEFAULT" tag will be exported, if defined.
283              
284             =head1 SEE ALSO
285              
286             =cut