File Coverage

blib/lib/Hook/WrapSub.pm
Criterion Covered Total %
statement 82 87 94.2
branch 17 28 60.7
condition 3 6 50.0
subroutine 12 12 100.0
pod 2 2 100.0
total 116 135 85.9


line stmt bran cond sub pod time code
1             package Hook::WrapSub;
2             $Hook::WrapSub::VERSION = '0.05';
3 1     1   56017 use 5.006;
  1         5  
4 1     1   8 use strict;
  1         3  
  1         36  
5 1     1   8 use warnings;
  1         9  
  1         43  
6              
7 1     1   8 use Exporter;
  1         3  
  1         75  
8 1     1   1997 use Symbol;
  1         1442  
  1         800  
9              
10             our @ISA = qw/ Exporter /;
11             our @EXPORT_OK = qw/ wrap_subs unwrap_subs /;
12              
13              
14             =head1 NAME
15              
16             Hook::WrapSub - wrap subs with pre- and post-call hooks
17              
18             =head1 SYNOPSIS
19              
20             use Hook::WrapSub qw( wrap_subs unwrap_subs );
21              
22             wrap_subs \&before, 'some_func', 'another_func', \&after;
23              
24             unwrap_subs 'some_func';
25              
26              
27             =head1 DESCRIPTION
28              
29             There are a number of other modules that provide the same functionality
30             as this module, some of them better. Have a look at the list in SEE ALSO,
31             below, before you decide which to use.
32              
33             =head2 wrap_subs
34              
35             This function enables intercepting a call to any named
36             function; handlers may be added both before and after
37             the call to the intercepted function.
38              
39             For example:
40              
41             wrap_subs \&before, 'some_func', \&after;
42              
43             In this case, whenever the sub named 'some_func' is called,
44             the &before sub is called first, and the &after sub is called
45             afterwards. These are both optional. If you only want
46             to intercept the call beforehand:
47              
48             wrap_subs \&before, 'some_func';
49              
50             You may pass more than one sub name:
51              
52             wrap_subs \&before, 'foo', 'bar', 'baz', \&after;
53              
54             and each one will have the same hooks applied.
55              
56             The sub names may be qualified. Any unqualified names
57             are assumed to reside in the package of the caller.
58              
59             The &before sub and the &after sub are both passed the
60             argument list which is destined for the wrapped sub.
61             This can be inspected, and even altered, in the &before
62             sub:
63              
64             sub before {
65             ref($_[1]) && $_[1] =~ /\bARRAY\b/
66             or croak "2nd arg must be an array-ref!";
67             @_ or @_ = qw( default values );
68             # if no args passed, insert some default values
69             }
70              
71             The &after sub is also passed this list. Modifications
72             to it will (obviously) not be seen by the wrapped sub,
73             but the caller will see the changes, if it happens to
74             be looking.
75              
76             Here's an example that causes a certain method call
77             to be redirected to a specific object. (Note, we
78             use splice to change $_[0], because assigning directly
79             to $_[0] would cause the change to be visible to the caller,
80             due to the magical aliasing nature of @_.)
81              
82             my $handler_object = new MyClass;
83              
84             Hook::WrapSub::wrap_subs
85             sub { splice @_, 0, 1, $handler_object },
86             'MyClass::some_method';
87              
88             my $other_object = new MyClass;
89             $other_object->some_method;
90              
91             # even though the method is invoked on
92             # $other_object, it will actually be executed
93             # with a 0'th argument = $handler_obj,
94             # as arranged by the pre-call hook sub.
95              
96             =head2 Package Variables
97              
98             There are some Hook::WrapSub package variables defined,
99             which the &before and &after subs may inspect.
100              
101             =over 4
102              
103             =item $Hook::WrapSub::name
104              
105             This is the fully qualified name of the wrapped sub.
106              
107             =item @Hook::WrapSub::caller
108              
109             This is a list which strongly resembles the result of a
110             call to the built-in function C; it is provided
111             because calling C will in fact produce confusing
112             results; if your sub is inclined to call C,
113             have it look at this variable instead.
114              
115             =item @Hook::WrapSub::result
116              
117             This contains the result of the call to the wrapped sub.
118             It is empty in the &before sub. In the &after sub, it
119             will be empty if the sub was called in a void context,
120             it will contain one value if the sub was called in a
121             scalar context; otherwise, it may have any number of
122             elements. Note that the &after function is not prevented
123             from modifying the contents of this array; any such
124             modifications will be seen by the caller!
125              
126              
127             =back
128              
129             This simple example shows how Hook::WrapSub can be
130             used to log certain subroutine calls:
131              
132             sub before {
133             print STDERR <<" EOF";
134             About to call $Hook::WrapSub::name( @_ );
135             Wantarray=$Hook::WrapSub::caller[5]
136             EOF
137             }
138              
139             sub after {
140             print STDERR <<" EOF";
141             Called $Hook::WrapSub::name( @_ );
142             Result=( @Hook::WrapSub::result )
143             EOF
144             @Hook::WrapSub::result
145             or @Hook::WrapSub::result = qw( default return );
146             # if the sub failed to return something...
147             }
148              
149             Much more elaborate uses are possible. Here's one
150             one way it could be used with database operations:
151              
152             my $dbh; # initialized elsewhere.
153              
154             wrap_subs
155             sub {
156             $dbh->checkpoint
157             },
158              
159             'MyDb::update',
160             'MyDb::delete',
161              
162             sub {
163             # examine result of sub call:
164             if ( $Hook::WrapSub::result[0] ) {
165             # success
166             $dbh->commit;
167             }
168             else {
169             # failure
170             $dbh->rollback;
171             }
172             };
173              
174             =head2 unwrap_subs
175              
176             This removes the most recent wrapping of the named subs.
177              
178             NOTE: Any given sub may be wrapped an unlimited
179             number of times. A "stack" of the wrappings is
180             maintained internally. wrap_subs "pushes" a wrapping,
181             and unwrap_subs "pops".
182              
183             =cut
184              
185             sub wrap_subs(@) {
186 2     2 1 27 my( $precall_cr, $postcall_cr );
187 2 50       8 ref($_[0]) and $precall_cr = shift;
188 2 50       7 ref($_[-1]) and $postcall_cr = pop;
189 2         4 my @names = @_;
190              
191 2         7 my( $calling_package ) = caller;
192              
193 2         4 for my $name ( @names ) {
194              
195 2         4 my $fullname;
196 2         3 my $sr = *{ qualify_to_ref($name,$calling_package) }{CODE};
  2         7  
197 2 50       46 if ( defined $sr ) {
198 2         6 $fullname = qualify($name,$calling_package);
199             }
200             else {
201 0         0 warn "Can't find subroutine named '$name'\n";
202 0         0 next;
203             }
204              
205              
206             my $cr = sub {
207 6 100   6   35 $Hook::WrapSub::UNWRAP and return $sr;
208              
209             #
210             # this is a bunch of kludg to make a list of values
211             # that look like a "real" caller() result.
212             #
213 4         6 my $up = 0;
214 4         28 my @args = caller($up);
215 4         14 while ( $args[0] =~ /Hook::WrapSub/ ) {
216 1         2 $up++;
217 1         9 @args = caller($up);
218             }
219 4         16 my @vargs = @args; # save temp
220 4   66     24 while ( defined($args[3]) && $args[3] =~ /Hook::WrapSub/ ) {
221 4         5 $up++;
222 4         17 @args = caller($up);
223             }
224 4         5 $vargs[3] = $args[3];
225             # now @vargs looks right.
226              
227 4         8 local $Hook::WrapSub::name = $fullname;
228 4         6 local @Hook::WrapSub::result = ();
229 4         13 local @Hook::WrapSub::caller = @vargs;
230 4         6 my $wantarray = $Hook::WrapSub::caller[5];
231             #
232             # try to supply the same calling context to the nested sub:
233             #
234              
235 4 100       10 unless ( defined $wantarray ) {
236             # void context
237 1 50       5 &$precall_cr if $precall_cr;
238 1         11 &$sr;
239 1 50       6 &$postcall_cr if $postcall_cr;
240 1         9 return();
241             }
242              
243 3 100       9 unless ( $wantarray ) {
244             # scalar context
245 1 50       6 &$precall_cr if $precall_cr;
246 1         16 $Hook::WrapSub::result[0] = &$sr;
247 1 50       8 &$postcall_cr if $postcall_cr;
248 1         13 return $Hook::WrapSub::result[0];
249             }
250              
251             # list context
252 2 50       8 &$precall_cr if $precall_cr;
253 2         22 @Hook::WrapSub::result = &$sr;
254 2 50       15 &$postcall_cr if $postcall_cr;
255 2         24 return( @Hook::WrapSub::result );
256 2         38 };
257              
258 1     1   8 no warnings 'redefine';
  1         2  
  1         72  
259 1     1   7 no strict 'refs';
  1         3  
  1         467  
260 2         3 *{ $fullname } = $cr;
  2         14  
261             }
262             }
263              
264             sub unwrap_subs(@) {
265 2     2 1 26 my @names = @_;
266              
267 2         6 my( $calling_package ) = caller;
268              
269 2         6 for my $name ( @names ) {
270 2         3 my $fullname;
271 2         2 my $sr = *{ qualify_to_ref($name,$calling_package) }{CODE};
  2         6  
272 2 50       35 if ( defined $sr ) {
273 2         5 $fullname = qualify($name,$calling_package);
274             }
275             else {
276 0         0 warn "Can't find subroutine named '$name'\n";
277 0         0 next;
278             }
279 2         25 local $Hook::WrapSub::UNWRAP = 1;
280 2         4 my $cr = $sr->();
281 2 50 33     18 if ( defined $cr and $cr =~ /\bCODE\b/ ) {
282 1     1   6 no strict 'refs';
  1         3  
  1         35  
283 1     1   4 no warnings 'redefine';
  1         1  
  1         113  
284 2         3 *{ $fullname } = $cr;
  2         31  
285             }
286             else {
287 0           warn "Subroutine '$fullname' not wrapped!";
288             }
289             }
290             }
291              
292             1;
293              
294             =head1 SEE ALSO
295              
296             L provides a similar capability to C,
297             but has the benefit that the C function works correctly
298             within the wrapped subroutine.
299              
300             L lets you provide a sub that will be called before
301             a named sub. The C function works correctly in the
302             wrapped sub.
303              
304             L provides a number of related functions.
305             You can provide pre- and post-call hooks,
306             you can temporarily override a function and then restore it later,
307             and more.
308              
309             L lets you add pre- and post-call hooks around any
310             methods called by your code. It doesn't support functions.
311              
312             L lets you register callbacks that will be invoked
313             when execution leaves the scope they were registered in.
314              
315             L provides an OO interface for wrapping
316             a function with pre- and post-call hook functions.
317             Last updated in 1997, and marked as alpha.
318              
319             L provides an OO interface for wrapping pre- and post-call
320             hooks around functions or methods in a package. Not updated sinc 2003,
321             and has a 20% failed rate on CPAN Testers.
322              
323             L provides the C function, which takes a coderef
324             and a package name. The coderef is invoked every time a method in
325             the package is called.
326              
327             L lets you stack pre- and post-call hooks.
328             Last updated in 2001.
329              
330             =head1 REPOSITORY
331              
332             L
333              
334             =head1 AUTHOR
335              
336             jdporter@min.net (John Porter)
337              
338             =head1 COPYRIGHT
339              
340             This is free software. This software may be modified and/or
341             distributed under the same terms as Perl itself.
342              
343             =cut
344