File Coverage

blib/lib/Sub/WrapPackages.pm
Criterion Covered Total %
statement 165 166 99.4
branch 37 44 84.0
condition 21 22 95.4
subroutine 22 22 100.0
pod 1 1 100.0
total 246 255 96.4


line stmt bran cond sub pod time code
1 20     20   1089551 use strict;
  20         215  
  20         585  
2 20     20   104 use warnings;
  20         37  
  20         1618  
3              
4             package Sub::WrapPackages;
5              
6             our $VERSION;
7             our %ORIGINAL_SUBS; # coderefs of what we're wrapping, keyed
8             # by package::sub
9             our @MAGICINCS; # list of magic INC subs, used by lib.pm hack
10             our %INHERITED; # coderefs of inherited methods (before proxies
11             # installed), keys by package::sub
12             our %WRAPPED_BY_WRAPPER; # coderefs of original subs, keyed by
13             # stringified coderef of wrapper
14             our %WRAPPER_BY_WRAPPED; # coderefs of wrapper subs, keyed by
15             # stringified coderef of original sub
16 20     20   5048 use Sub::Prototype ();
  20         205672  
  20         550  
17 20     20   5629 use Devel::Caller::IgnoreNamespaces;
  20         7860  
  20         736  
18             Devel::Caller::IgnoreNamespaces::register(__PACKAGE__);
19              
20 20     20   5175 use Data::Dumper;
  20         74668  
  20         1486  
21             $Data::Dumper::Deparse = 1;
22              
23             $VERSION = '2.01';
24              
25 20     20   844 use lib ();
  20         1624  
  20         364  
26             {
27 20     20   91 no strict 'refs';
  20         40  
  20         547  
28 20     20   117 no warnings 'redefine';
  20         42  
  20         4287  
29            
30             my $originallibimport = \&{'lib::import'};
31             my $newimport = sub {
32 2     2   18 $originallibimport->(@_);
33 2         185 my %magicincs = map { $_, 1 } @Sub::WrapPackages::MAGICINCS;
  1         6  
34             @INC = (
35 21         50 (grep { exists($magicincs{$_}); } @INC),
36 2         5 (grep { !exists($magicincs{$_}); } @INC)
  21         79  
37             );
38             };
39            
40             *{'lib::import'} = $newimport;
41             }
42              
43              
44             =head1 NAME
45              
46             Sub::WrapPackages - add pre- and post-execution wrappers around all the
47             subroutines in packages or around individual subs
48              
49             =head1 SYNOPSIS
50              
51             use Sub::WrapPackages
52             packages => [qw(Foo Bar Baz::*)], # wrap all subs in Foo and Bar
53             # and any Baz::* packages
54             subs => [qw(Barf::a, Barf::b)], # wrap these two subs as well
55             wrap_inherited => 1, # and wrap any methods
56             # inherited by Foo, Bar, or
57             # Baz::*
58             except => qr/::w[oi]bble$/, # but don't wrap any sub called
59             # wibble or wobble
60             pre => sub {
61             print "called $_[0] with params ".
62             join(', ', @_[1..$#_])."\n";
63             },
64             post => sub {
65             print "$_[0] returned $_[1]\n";
66             };
67              
68             =head1 COMPATIBILITY
69              
70             While this module does broadly the same job as the 1.x versions did,
71             the interface may have changed incompatibly. Sorry. Hopefully it'll
72             be more maintainable and slightly less crazily magical. Also, caller()
73             should now work properly, ignoring wrappings.
74              
75             =head1 DESCRIPTION
76              
77             This module installs pre- and post- execution subroutines for the
78             subroutines or packages you specify. The pre-execution subroutine
79             is passed the
80             wrapped subroutine's name and all its arguments. The post-execution
81             subroutine is passed the wrapped sub's name and its results.
82              
83             The return values from the pre- and post- subs are ignored, and they
84             are called in the same context (void, scalar or list) as the calling
85             code asked for.
86              
87             Normal usage is to pass a bunch of parameters when the module is used.
88             However, you can also call Sub::WrapPackages::wrapsubs with the same
89             parameters.
90              
91             =head1 PARAMETERS
92              
93             Either pass parameters on loading the module, as above, or pass them
94             to ...
95              
96             =head2 the wrapsubs subroutine
97              
98             =over 4
99              
100             =item the subs arrayref
101              
102             In the synopsis above, you will see two named parameters, C and
103             C. Any subroutine mentioned in C will be wrapped.
104             Any subroutines mentioned in 'subs' must already exist - ie their modules
105             must be loaded - at the time you try to wrap them.
106              
107             =item the packages arrayref
108              
109             Any package mentioned here will have all its subroutines wrapped,
110             including any that it imports at load-time. Packages can be loaded
111             in any order - they don't have to already be loaded for Sub::WrapPackages
112             to work its magic.
113              
114             You can specify wildcard packages. Anything ending in ::* is assumed
115             to be such. For example, if you specify Orchard::Tree::*, then that
116             matches Orchard::Tree, Orchard::Tree::Pear, Orchard::Apple::KingstonBlack
117             etc, but not - of course - Pine::Tree or My::Orchard::Tree.
118              
119             Note, however, that if a module exports a subroutine at load-time using
120             C then that sub will be wrapped in the exporting module but not in
121             the importing module. This is because import() runs before we get a chance
122             to fiddle with things. Sorry.
123              
124             Deferred wrapping of subs in packages that aren't yet loaded works
125             via a subroutine inserted in @INC. This means that if you mess around
126             with @INC, eg by inserting a directoy at the beginning of the path, the
127             magic might not get a chance to run. If you C to mess with
128             @INC though, it should work, as I've over-ridden lib's import() method.
129             That said, code this funky has no right to work. Use with caution!
130              
131             =item wrap_inherited
132              
133             In conjunction with the C arrayref, this wraps all calls to
134             inherited methods made through those packages. If you call those
135             methods directly in the superclass then they are not affected - unless
136             they're wrapped in the superclass of course.
137              
138             =item pre and post
139              
140             References to the subroutines you want to use as wrappers.
141              
142             =item except
143              
144             A regex, any subroutine whose fully-qualified name (ie including the package
145             name) matches this will not be wrapped.
146              
147             =item debug
148              
149             This exists, but probably isn't of much use unless you want to hack on
150             Sub::WrapPackage's guts.
151              
152             =back
153              
154             =head1 BUGS
155              
156             AUTOLOAD and DESTROY are not treated as being special. I'm not sure
157             whether they should be or not.
158              
159             If you use wrap_inherited but classes change their inheritance tree at
160             run-time, then very bad things will happen. VERY BAD THINGS. So don't
161             do that. You shouldn't be doing that anyway. Mind you, you shouldn't
162             be doing the things that this module does either. BAD PROGRAMMER, NO
163             BIKKIT!
164              
165             Bug reports should be made on Github or by email.
166              
167             =head1 FEEDBACK
168              
169             I like to know who's using my code. All comments, including constructive
170             criticism, are welcome. Please email me.
171              
172             =head1 SOURCE CODE REPOSITORY
173              
174             L
175              
176             =head1 COPYRIGHT and LICENCE
177              
178             Copyright 2003-2009 David Cantrell EFE
179              
180             This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively.
181              
182             =head1 THANKS TO
183              
184             Thanks to Tom Hukins for sending in a test case for the situation when
185             a class and a subclass are both defined in the same file, and for
186             prompting me to support inherited methods;
187              
188             to Dagfinn Ilmari Mannsaker for help with the craziness for
189             fiddling with modules that haven't yet been loaded;
190              
191             to Lee Johnson for reporting a bug caused by perl 5.10's
192             constant.pm being Far Too Clever, and providing a patch and test;
193              
194             to Adam Trickett who thought this was a jolly good idea;
195              
196             to Ed
197             Summers, whose code for figgering out what functions a package contains
198             I borrowed out of L;
199              
200             and to Yanick Champoux for numerous readability improvements.
201              
202             =cut
203              
204             sub import {
205 20     20   297 shift;
206 20         57 wrapsubs(@_);
207             }
208              
209             sub _subs_in_packages {
210 58     58   111 my @targets = map { $_.'::' } @_;
  65         192  
211              
212 58         91 my @subs;
213 58         106 foreach my $package (@targets) {
214 20     20   131 no strict;
  20         71  
  20         24686  
215 65         91 while(my($k, $v) = each(%{$package})) {
  437         1569  
216 372 100 100     721 push @subs, $package.$k if(ref($v) ne 'SCALAR' && defined(&{$v}));
  371         1515  
217             }
218             }
219 58         208 return @subs;
220             }
221              
222             sub _make_magic_inc {
223 32     32   88 my %params = @_;
224 32         87 my $wildcard_packages = [map { (my $p = $_) =~ s/::.$//; $p; } grep { /::\*$/ } @{$params{packages}}];
  3         13  
  3         11  
  39         244  
  32         62  
225 32         58 my $nonwildcard_packages = [grep { $_ !~ /::\*$/ } @{$params{packages}}];
  39         108  
  32         102  
226              
227             push @MAGICINCS, sub {
228 159     159   1116299 my($me, $file) = @_;
229 159         608 (my $module = $file) =~ s{/}{::}g;
230 159         490 $module =~ s/\.pm//;
231             return undef unless(
232 19         186 (grep { $module =~ /^$_(::|$)/ } @{$wildcard_packages}) ||
  159         491  
233 159 100 100     271 (grep { $module eq $_ } @{$nonwildcard_packages})
  183         30420  
  157         279  
234             );
235 11         25 local @INC = grep { $_ ne $me } @INC;
  126         310  
236 11         54 local $/;
237 11         24 my @files = grep { -e $_ } map { join('/', $_, $file) } @INC;
  115         1356  
  115         258  
238 11 50       318 open(my $fh, $files[0]) || die("Can't locate $file in \@INC\n");
239 11         193 my $text = <$fh>;
240 11         67 close($fh);
241              
242 11 100       37 if(!%Sub::WrapPackages::params) {
243             print STDERR "Setting \%Sub::WrapPackages::params\n", Dumper(\%params)
244 7 50       24 if($params{debug});
245 7         36 %Sub::WrapPackages::params = %params;
246             }
247              
248 11         203 $text =~ /(.*?)(__DATA__.*|__END__.*|$)/s;
249 11         57 my($code, $trailer) = ($1, $2);
250 11         44 $text = $code.qq[
251             ;
252             Sub::WrapPackages::wrapsubs(
253             %Sub::WrapPackages::params,
254             packages => [qw($module)]
255             );
256             1;
257             ]."\n$trailer";
258 11     7   196 open($fh, '<', \$text);
  7         71  
  7         12  
  7         54  
259 11         5594 $fh;
260 32         209 };
261 32         105 unshift @INC, $MAGICINCS[-1];
262             }
263              
264             sub _getparents {
265 26     26   40 my $package = shift;
266 26         1133 my @parents = eval '@'.$package.'::ISA';
267 26         105 return @parents, (map { _getparents($_) } @parents);
  13         45  
268             }
269              
270             sub wrapsubs {
271 36     36 1 2898 my %params = @_;
272              
273 36 100 66     364 if(exists($params{packages}) && ref($params{packages}) =~ /^ARRAY/) {
    50          
274 32         62 my $wildcard_packages = [map { (my $foo = $_) =~ s/::.$//; $foo; } grep { /::\*$/ } @{$params{packages}}];
  3         18  
  3         14  
  39         135  
  32         89  
275 32         53 my $nonwildcard_packages = [grep { $_ !~ /::\*$/ } @{$params{packages}}];
  39         104  
  32         64  
276              
277             # defer wrapping stuff that's not yet loaded
278 32         142 _make_magic_inc(%params);
279              
280             # wrap wildcards that are loaded
281 32 100       52 if(@{$wildcard_packages}) {
  32         111  
282 3         159 foreach my $loaded (map { (my $f = $_) =~ s!/!::!g; $f =~ s/\.pm$//; $f } keys %INC) {
  326         902  
  326         983  
  326         775  
283 326         461 my $pattern = '^('.join('|', @{$wildcard_packages}).')(::|$)';
  326         608  
284 326 100       875 if($loaded =~ /$pattern/) {
285 1 50       5 print STDERR "found loaded wildcard $loaded - matches $pattern\n" if($params{debug});
286 1         14 wrapsubs(%params, packages => [$loaded]);
287             }
288             }
289             }
290              
291             # wrap non-wildcards that are loaded
292 32 100       140 if($params{wrap_inherited}) {
293 11         15 foreach my $package (@{$nonwildcard_packages}) {
  11         26  
294 13         34 my @parents = _getparents($package);
295              
296             # get inherited (but not over-ridden!) subs
297             my %subs_in_package = map {
298 13         85 (split '::' )[-1] => 1
  18         77  
299             } _subs_in_packages($package);
300              
301             my @subs_to_define = grep {
302 50         94 !exists($subs_in_package{$_})
303             } map {
304 13         39 (split '::' )[-1]
  50         129  
305             } _subs_in_packages(@parents);
306              
307             # define proxy method that just does a goto to get
308             # to the right place. We then later wrap the proxy
309 13         30 foreach my $sub (@subs_to_define) {
310 43 100       123 next if(exists($INHERITED{$package."::$sub"}));
311 39         268 $INHERITED{$package."::$sub"} = $package->can($sub);
312             # if the inherited method is already wrapped,
313             # point this proxy at the original method
314             # so we don't wrap a wrapper
315 39 100       130 if(exists($WRAPPED_BY_WRAPPER{$INHERITED{$package."::$sub"}})) {
316             $INHERITED{$package."::$sub"} =
317 5         14 $WRAPPED_BY_WRAPPER{$INHERITED{$package."::$sub"}};
318             }
319 39         1616 eval qq{
320             sub ${package}::$sub {
321             goto &{\$Sub::WrapPackages::INHERITED{"${package}::$sub"}};
322             }
323             };
324 39 50       130 die($@) if($@);
325 39 50       123 print STDERR "created stub ${package}::$sub for inherited method\n" if($params{debug});
326             }
327             }
328             }
329 32         55 push @{$params{subs}}, _subs_in_packages(@{$params{packages}});
  32         96  
  32         81  
330             } elsif(exists($params{packages})) {
331 0         0 die("Bad param 'packages'");
332             }
333              
334 36 100 100     150 return undef if(!$params{pre} && !$params{post});
335 35   100 4   101 $params{pre} ||= sub {};
336 35   100 12   100 $params{post} ||= sub {};
337              
338 35         54 foreach my $sub (@{$params{subs}}) {
  35         362  
339             next if(
340             (exists($params{except}) && $sub =~ $params{except}) ||
341 179 100 100     718 exists($ORIGINAL_SUBS{$sub})
      100        
342             );
343              
344 170         207 $ORIGINAL_SUBS{$sub} = \&{$sub};
  170         465  
345             my $imposter = sub {
346 55     55   16580 local *__ANON__ = $sub;
347 55         137 my(@r, $r) = ();
348 55         103 my $wa = wantarray();
349 55 100       190 if(!defined($wa)) {
    100          
350 9         45 $params{pre}->($sub, @_);
351 9         1393 $ORIGINAL_SUBS{$sub}->(@_);
352 9         851 $params{post}->($sub);
353             } elsif($wa) {
354 16         51 my @f = $params{pre}->($sub, @_);
355 16         181 @r = $ORIGINAL_SUBS{$sub}->(@_);
356 16         314 @f = $params{post}->($sub, @r);
357             } else {
358 30         121 my $f = $params{pre}->($sub, @_);
359 30         4529 $r = $ORIGINAL_SUBS{$sub}->(@_);
360 30         179 $f = $params{post}->($sub, $r);
361             }
362 55 100       4630 return wantarray() ? @r : $r;
363 170         731 };
364             Sub::Prototype::set_prototype($imposter, prototype($ORIGINAL_SUBS{$sub}))
365 170 100       449 if(prototype($ORIGINAL_SUBS{$sub}));
366              
367             {
368 20     20   158 no strict 'refs';
  20         37  
  20         616  
  170         216  
369 20     20   97 no warnings 'redefine';
  20         39  
  20         2930  
370 170         360 $WRAPPED_BY_WRAPPER{$imposter} = $ORIGINAL_SUBS{$sub};
371 170         358 $WRAPPER_BY_WRAPPED{$ORIGINAL_SUBS{$sub}} = $imposter;
372              
373 170         207 *{$sub} = $imposter;
  170         411  
374 170 50       15051 print STDERR "wrapped $sub\n" if($params{debug});
375             };
376             }
377             }
378              
379             1;