File Coverage

blib/lib/Class/Hook.pm
Criterion Covered Total %
statement 43 45 95.5
branch 4 12 33.3
condition n/a
subroutine 16 18 88.8
pod 5 5 100.0
total 68 80 85.0


line stmt bran cond sub pod time code
1             =pod
2              
3             =head1 NAME
4              
5             Class::Hook - Add hooks on methods from other classes
6              
7             =head1 SYNOPSIS
8              
9             use Class::Hook;
10              
11             Class::Hook->before(\&sub1);
12             Class::Hook->after(\&sub2);
13             Class::Hook->activate();
14             # or
15             Class::Hook->new(\&sub1, \&sub2);
16              
17             # and then
18             Anotherclass->aMethod($someParam); # Hooked class
19              
20             =head1 DESCRIPTION
21              
22             Class::Hook enables you to trace methods calls from your code to other classes.
23              
24             Instead of putting 'use Foo;' in your code,
25             simply type 'use Class::Hook;'.
26             The class Foo is unknown in your code.
27             It will be magically caught by Class::Hook which will call Foo itself.
28             You can see Class::Hook as a kind of relay.
29              
30             You can setup a subroutine to be called before any call to
31             C<amethod>> and a subroutine to be called after the call. Your subs
32             will receive all the information that C<amethod>> will receive,
33             so you can trace everything between your code and Foo.
34              
35             =cut
36              
37             package Class::Hook;
38             $Class::Hook::VERSION = '0.05';
39 1     1   11497 use 5.006;
  1         2  
40 1     1   3 use strict;
  1         1  
  1         22  
41 1     1   5 use warnings;
  1         4  
  1         23  
42 1     1   518 use Time::HiRes;
  1         993  
  1         3  
43 1     1   68 use warnings::register;
  1         1  
  1         96  
44 1     1   4 use Carp;
  1         1  
  1         384  
45              
46              
47             local *autoload = *UNIVERSAL::AUTOLOAD;
48             our $before = \&_default_before;
49             our $after = \&_default_after;
50             our $param_before = undef;
51             our $param_after = undef;
52              
53             =pod
54              
55             =head1 METHODS
56              
57             =head2 new($subref_before, $subref_after, $param)
58              
59             Install subroutines to be called whenever a method from an unknown
60             class is called. It is equivalent to the following code:
61              
62             Class::Hook->before($subref_before, $param);
63             Class::Hook->after($subref_after, $param);
64             Class::Hook->activate();
65              
66             =cut
67             sub new {
68 1     1 1 11 my ($class, $before, $after, $param) = @_;
69 1         2 $param_before = undef;
70 1         1 $param_after = undef;
71 1         2 $class->before($before, $param);
72 1         3 $class->after($after, $param);
73 1         2 $class->activate();
74             }
75              
76              
77             =pod
78              
79             =head2 before($subref, $param)
80              
81             Install subroutine to be called whenever a call to an unknown class is
82             made. $param will be sent to your $subref if specified &$subref will
83             receive the following parameters:
84              
85             ( $param, { class => $class_or_object,
86             method => $method_called,
87             param => [@params_sent],
88             counter => $no_calls_for_this_method } )
89             or the following parameters if $param undefined
90              
91             ({ class => $class_or_object,
92             method => $method_called,
93             param => [@params_sent],
94             counter => $no_calls_for_this_method } )
95              
96             =cut
97              
98             sub before {
99 1     1 1 3 our ($before, $param_before) = @_[1,2];
100 1 50       3 ref($before) eq 'CODE' or croak "Not a sub ref";
101             }
102              
103              
104             =pod
105              
106             =head2 after($subref, $param)
107              
108             Install subroutine to be called whenever a call to an unknown class
109             returns. $param will be sent to your $subref if specified. &$subref
110             will receive the following parameters
111              
112             ( $param, { class => $class_or_object,
113             method => $method_called,
114             param => [@params_sent],
115             counter => $no_calls_for_this_method,
116             'return' => [@return_values],
117             duration => $duration in seconds } )
118             or the following parameters if $param undefined
119              
120             ( { class => $class_or_object,
121             method => $method_called,
122             param => [@params_sent],
123             counter => $no_calls_for_this_method,
124             'return' => [@return_values],
125             duration => $duration in seconds } )
126              
127             =cut
128             sub after {
129 1     1 1 2 our ($after, $param_after) = @_[1,2];
130 1 50       3 ref($after) eq 'CODE' or croak "Not a sub ref";
131             }
132              
133              
134             =pod
135              
136             =head2 activate()
137              
138             Activates the hooks on methods calls to unknown classes. Your subs
139             C and C will be called at each call to an unknown
140             package.
141              
142             =cut
143             sub activate {
144 1 50   1 1 6 eval q{
  1     1   1  
  1     1   51  
  1     1   3  
  1     1   1  
  1         106  
  1         4  
  1         0  
  1         167  
  1         3  
  1         1  
  1         119  
  1         60  
145             # hide the package line from PAUSE
146             package
147             UNIVERSAL;
148             use Carp;
149             use Data::Dumper;
150             our $AUTOLOAD;
151             my %fields_storage = ();
152             my %methods = ();
153             my %counter;
154              
155             sub UNIVERSAL::AUTOLOAD {
156             return undef if (caller(0) eq 'UNIVERSAL'); # To prevent recursive calls
157             my ($class, $method) = ($AUTOLOAD =~ /(.*)::([^:]+)/);
158             return undef if ($method eq 'DESTROY' or $method eq 'unimport');
159             {
160             no strict;
161             unless ($fields_storage{$class}) { # First time
162             eval "require $class;" or return Class::Hook->_error("$class: $! $@");
163             delete $INC{"$class.pm"};
164             $class->import();
165             %{$fields_storage{$class}} = %{"${class}::"}; # Stores namespace
166             }
167             %{"${class}::"} = %{$fields_storage{$class}};
168             }
169             my @param = @_;
170             my $obj = $_[0] if (ref($_[0]) eq $class);
171             shift @param if ($_[0] eq $class or ref($_[0]) eq $class); # method call
172             $counter{$AUTOLOAD} ||= 0;
173             my @before_params = { class => $class,
174             method => $method,
175             counter => $counter{$AUTOLOAD}++,
176             param => \@param,
177             };
178             unshift @before_params, $Class::Hook::param_before if (defined $Class::Hook::param_before);
179             &$Class::Hook::before( @before_params );
180             my $t0 = [Time::HiRes::gettimeofday()];
181             no strict;
182             my @rtn;
183             if ($obj) {
184             @rtn = $obj->$method(@param) || ();
185             }
186             else {
187             @rtn = $class->$method(@param) || ();
188             }
189             my @after_params = { class => $class,
190             method => $method,
191             counter => $counter{$AUTOLOAD},
192             param => \@param,
193             'return' => wantarray ? \@rtn : $rtn[0],
194             duration => Time::HiRes::tv_interval($t0, [Time::HiRes::gettimeofday()]) };
195             unshift @after_params, $Class::Hook::param_after if (defined $Class::Hook::param_after);
196             &$Class::Hook::after( @after_params );
197             %{"${class}::"} = (); # Clean namespace to force calls to %UNIVERSAL::
198             return wantarray ? @rtn : $rtn[0];
199             }
200             1;
201             } or die "Could not activate $@ $!";
202             }
203              
204              
205              
206              
207             =pod
208              
209             =head2 deactivate()
210              
211             Stops hooks.
212              
213             =cut
214             sub deactivate {
215 1     1 1 27 *UNIVERSAL::AUTOLOAD = *autoload;
216             }
217              
218             sub _error {
219 1 50   1   3 $warnings::enabled and carp $_[1];
220 1         2 return undef;
221             }
222              
223             sub _default_before {
224 0 0   0     $warnings::enabled and carp "before not defined";
225             }
226              
227             sub _default_after {
228 0 0   0     $warnings::enabled and carp "after not defined";
229             }
230              
231             1;
232              
233             =pod
234              
235             =head1 EXAMPLES
236              
237             You want to study calls to a class 'Foo'
238             ========================================
239             main.pl
240             =======
241             # Don't write 'use Foo;'!
242             use Data::Dumper;
243             use Class::Hook;
244             Class::Hook->new(\&mybefore, \&myafter);
245              
246             Foo->new('bla', 'blu');
247             Foo->bar( { key1 => 'value1',
248             key2 => 'value2'} );
249             Foo->xxxx(); # Non existing method
250              
251             sub mybefore {
252             print "Before called: ".Dumper(\@_);
253             }
254              
255             sub myafter {
256             print "After called: ".Dumper(\@_);
257             }
258              
259              
260             Foo.pm
261             ======
262             package Foo;
263             sub new {
264             my ($class, @param) = @_;
265             warn "Foo->new called";
266             return bless { 'something' => 'whatever',
267             'init' => \@param }
268             => $class;
269             }
270              
271             sub bar {
272             warn "Foo->bar called";
273             return "Hello from bar";
274             }
275              
276             1;
277              
278             =head1 CAVEATS
279              
280             It works only with method calls, not with subroutine calls.
281             Foo->method will work Foo::method will NOT work.
282             UNIVERSAL::AUTOLOAD is overriden after Class::Hook->activate() has
283             been called. Expect some strange behaviors if the module you use plays
284             with it.
285              
286             =head1 BUGS
287              
288             Don't rely on it for production purpose.
289             Has been tested on perl
290             5.6.0 only and probably will need some update with later perl versions.
291              
292             =head1 AUTHOR
293              
294             "Pierre Denis"
295              
296             =head1 COPYRIGHT
297              
298             Copyright (C) 2005, IT Release Ltd. All rights reserved.
299              
300             This is free software. This software
301             may be modified and/or distributed under the same terms as Perl
302             itself.
303              
304             =cut
305