File Coverage

blib/lib/Exporter/Proxy.pm
Criterion Covered Total %
statement 63 75 84.0
branch 18 40 45.0
condition 5 8 62.5
subroutine 12 15 80.0
pod n/a
total 98 138 71.0


line stmt bran cond sub pod time code
1             ########################################################################
2             # housekeeping
3             ########################################################################
4              
5             package Exporter::Proxy;
6              
7 6     6   2726 use v5.20;
  6         13  
8              
9 6     6   18 use Carp;
  6         5  
  6         339  
10              
11 6     6   27 use List::Util qw( first );
  6         5  
  6         457  
12 6     6   2450 use Symbol qw( qualify_to_ref );
  6         3787  
  6         3978  
13              
14             ########################################################################
15             # package variables
16             ########################################################################
17              
18             our $VERSION = '1.8';
19             $VERSION = eval $VERSION;
20              
21             my $disp_list = 'DISPATCH_OK';
22              
23             ########################################################################
24             # utility functions
25             ########################################################################
26              
27             ########################################################################
28             # methods (public interface)
29             ########################################################################
30              
31             sub import
32             {
33 5     8   37 state $stub = sub{};
        5      
34              
35             # discard this package.
36             # left on the stack are assignment operators and
37             # exported names.
38              
39 5         5 shift;
40              
41             # use "$source" avoid colliding with '$caller' in the
42             # exported subs.
43              
44 5         8 my $source = caller;
45 5         8 my @exportz = grep { ! /=/ } @_;
  8         20  
46             my %argz
47             = map
48             {
49 5         11 split /=/, $_, 2
  2         9  
50             }
51             grep /=/, @_;
52              
53             # maybe carp about extraneous arguments here?
54              
55 5   100     20 my $disp = delete $argz{ dispatch } || '';
56 5   50     21 my $preproc = delete $argz{ prefilter } || '';
57 5   50     19 my $postproc = delete $argz{ postfilter } || '';
58 5   50     26 my $inst_import = delete $argz{ import } // 1;
59              
60             # if a dispatcher is being used then it must
61             # be exported. in most cases this will be the
62             # only thing exported.
63              
64 5 100       23 if( $disp )
65             {
66 2         4 my $list = qualify_to_ref $disp_list, $source;
67              
68 2     2   4 first { $disp eq $_ } @exportz
69 2 50       55 or push @exportz, $disp;
70              
71 2 50       23 unless( $source->can( $disp ) )
72             {
73 2         4 my $sub = qualify_to_ref $disp, $source;
74 2         26 my $can = qualify_to_ref $disp_list, $source;
75              
76 2 50       18 if( my $sanity = *{ $can }{ ARRAY } )
  2         7  
77             {
78             *$sub
79             = sub
80             {
81 0     0   0 my $op = splice @_, 1, 1;
82              
83 0         0 first { $op eq $_ } @$sanity
84             or do
85 0 0       0 {
86 0         0 local $" = ' ';
87              
88 0         0 confess "Bogus $disp: '$op' not in @$sanity"
89             };
90              
91             # this could happen if someone plays with
92             # the symbol table after installing the sub.
93              
94 0 0       0 my $handler = $source->can( $op )
95             or croak "Bogus $disp: $source cannot '$op'";
96              
97 0         0 goto &$handler
98 0         0 };
99             }
100             else
101             {
102             *$sub
103             = sub
104             {
105 4     4   14474 my $op = splice @_, 1, 1;
106              
107 4 50       26 my $handler = $source->can( $op )
108             or croak "Bogus $disp: $source cannot '$op'";
109              
110 4         13 goto &$handler
111 2         7 };
112             }
113             }
114             }
115              
116             @exportz
117 5 50       12 or carp "Oddity: nothing requested for export!";
118              
119 5         10 my $exports = qualify_to_ref 'exports', $source;
120              
121 5         81 undef &$exports;
122              
123             *$exports
124             = sub
125             {
126             # avoid giving away ref's to the closed-over
127             # variable.
128              
129             wantarray
130             ? @exportz
131 4 50   4   1361 : [ @exportz ]
132 5         14 };
133              
134             $inst_import
135             and
136             do
137 5 50       11 {
138 5         10 my $import = qualify_to_ref 'import', $source;
139              
140 5         57 undef &$import;
141              
142             my $find_pre
143             = $preproc
144             ? sub
145             {
146 0 0   0   0 $source->can( $preproc )
147             or die "Unusable $source: cannot '$preproc'";
148             }
149 5 50       11 : $stub
150             ;
151              
152             my $find_post
153             = $postproc
154             ? sub
155             {
156 0 0   0   0 $source->can( $postproc )
157             or die "Unusable $source: cannot '$postproc'";
158             }
159 5 50       8 : $stub
160             ;
161              
162             *$import
163             = sub
164             {
165             # these are delayed since the "use E::P" is
166             # usually dealt with before the subs are defined
167             # in the caller.
168              
169 4     4   76 state $pre_handler = $find_pre->();
170 4         8 state $post_handler = $find_post->();
171              
172             # discard the package as first argument:
173             # $pkg->import
174              
175 4         5 shift;
176              
177 4         8 my $caller = caller;
178            
179             # allow the caller to pre-process the arguments.
180             # notice this happens *before* ":noexport" is
181             # processed.
182              
183 4 50       11 &$pre_handler
184             if $pre_handler;
185              
186             # empty list => use @exportz.
187             # :noexport => use empty list.
188              
189 4 50   3   70 if( first { ':noexport' eq $_ } @_ )
  3 100       11  
190             {
191 0         0 @_ = ();
192             }
193             elsif( @_ )
194             {
195             # nothing more for the moment.
196             }
197             else
198             {
199 2         6 @_ = @exportz;
200             }
201              
202             # resolve these at runtime to account for
203             # possible autoloading, etc.
204              
205 4         18 for my $arg ( @_ )
206             {
207 5 50       29 index $arg, ':'
208             or next;
209              
210 5 50   7   35 if( first { $arg eq $_ } @exportz )
  7         15  
211             {
212 5         17 my $source = qualify_to_ref $arg, $source;
213 5         96 my $install = qualify_to_ref $arg, $caller;
214              
215 5         68 *$install = *$source;
216             }
217             else
218             {
219 0         0 die "Bogus $source: '$arg' not exported";
220             }
221             }
222              
223 4 50       16 goto &$post_handler
224             if $post_handler;
225 5         17 };
226             };
227              
228             return
229 5         354 }
230              
231             # keep require happy
232              
233             1
234              
235             __END__