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
23             classes.
24              
25             Instead of putting 'use Foo;' in your code, simply type 'use
26             Class::Hook;'. The class Foo is unknown in your code. It will be
27             magically catched by Class::Hook which will call Foo itself. You can
28             see Class::Hook as a kind of relay.
29              
30             You can setup a subroutine to be called before any call to
31             Foo->amethod and a subroutine to be called after the call. Your subs
32             will receive all the information that Foo->amethod will receive, so
33             you can trace everything between your code and Foo.
34              
35             =cut
36              
37             package Class::Hook;
38             $Class::Hook::VERSION = '0.04';
39 1     1   11399 use 5.006;
  1         2  
40 1     1   4 use strict;
  1         1  
  1         24  
41 1     1   6 use warnings;
  1         4  
  1         27  
42 1     1   519 use Time::HiRes;
  1         1076  
  1         4  
43 1     1   67 use warnings::register;
  1         1  
  1         102  
44 1     1   3 use Carp;
  1         2  
  1         425  
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 13 my ($class, $before, $after, $param) = @_;
69 1         3 $param_before = undef;
70 1         1 $param_after = undef;
71 1         3 $class->before($before, $param);
72 1         3 $class->after($after, $param);
73 1         3 $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       4 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 3 our ($after, $param_after) = @_[1,2];
130 1 50       2 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   55  
  1     1   3  
  1     1   2  
  1         116  
  1         4  
  1         1  
  1         176  
  1         3  
  1         1  
  1         121  
  1         75  
145             package UNIVERSAL;
146             use Carp;
147             use Data::Dumper;
148             our $AUTOLOAD;
149             my %fields_storage = ();
150             my %methods = ();
151             my %counter;
152              
153             sub UNIVERSAL::AUTOLOAD {
154             return undef if (caller(0) eq 'UNIVERSAL'); # To prevent recursive calls
155             my ($class, $method) = ($AUTOLOAD =~ /(.*)::([^:]+)/);
156             return undef if ($method eq 'DESTROY' or $method eq 'unimport');
157             {
158             no strict;
159             unless ($fields_storage{$class}) { # First time
160             eval "require $class;" or return Class::Hook->_error("$class: $! $@");
161             delete $INC{"$class.pm"};
162             $class->import();
163             %{$fields_storage{$class}} = %{"${class}::"}; # Stores namespace
164             }
165             %{"${class}::"} = %{$fields_storage{$class}};
166             }
167             my @param = @_;
168             my $obj = $_[0] if (ref($_[0]) eq $class);
169             shift @param if ($_[0] eq $class or ref($_[0]) eq $class); # method call
170             $counter{$AUTOLOAD} ||= 0;
171             my @before_params = { class => $class,
172             method => $method,
173             counter => $counter{$AUTOLOAD}++,
174             param => \@param,
175             };
176             unshift @before_params, $Class::Hook::param_before if (defined $Class::Hook::param_before);
177             &$Class::Hook::before( @before_params );
178             my $t0 = [Time::HiRes::gettimeofday()];
179             no strict;
180             my @rtn;
181             if ($obj) {
182             @rtn = $obj->$method(@param) || ();
183             }
184             else {
185             @rtn = $class->$method(@param) || ();
186             }
187             my @after_params = { class => $class,
188             method => $method,
189             counter => $counter{$AUTOLOAD},
190             param => \@param,
191             'return' => wantarray ? \@rtn : $rtn[0],
192             duration => Time::HiRes::tv_interval($t0, [Time::HiRes::gettimeofday()]) };
193             unshift @after_params, $Class::Hook::param_after if (defined $Class::Hook::param_after);
194             &$Class::Hook::after( @after_params );
195             %{"${class}::"} = (); # Clean namespace to force calls to %UNIVERSAL::
196             return wantarray ? @rtn : $rtn[0];
197             }
198             1;
199             } or die "Could not activate $@ $!";
200             }
201              
202              
203              
204              
205             =pod
206              
207             =head2 deactivate()
208              
209             Stops hooks.
210              
211             =cut
212             sub deactivate {
213 1     1 1 30 *UNIVERSAL::AUTOLOAD = *autoload;
214             }
215              
216             sub _error {
217 1 50   1   3 $warnings::enabled and carp $_[1];
218 1         3 return undef;
219             }
220              
221             sub _default_before {
222 0 0   0     $warnings::enabled and carp "before not defined";
223             }
224              
225             sub _default_after {
226 0 0   0     $warnings::enabled and carp "after not defined";
227             }
228              
229             1;
230              
231             =pod
232              
233             =head1 EXAMPLES
234              
235             You want to study calls to a class 'Foo'
236             ========================================
237             main.pl
238             =======
239             # Don't write 'use Foo;'!
240             use Data::Dumper;
241             use Class::Hook;
242             Class::Hook->new(\&mybefore, \&myafter);
243              
244             Foo->new('bla', 'blu');
245             Foo->bar( { key1 => 'value1',
246             key2 => 'value2'} );
247             Foo->xxxx(); # Non existing method
248              
249             sub mybefore {
250             print "Before called: ".Dumper(\@_);
251             }
252              
253             sub myafter {
254             print "After called: ".Dumper(\@_);
255             }
256              
257              
258             Foo.pm
259             ======
260             package Foo;
261             sub new {
262             my ($class, @param) = @_;
263             warn "Foo->new called";
264             return bless { 'something' => 'whatever',
265             'init' => \@param }
266             => $class;
267             }
268              
269             sub bar {
270             warn "Foo->bar called";
271             return "Hello from bar";
272             }
273              
274             1;
275              
276             =head1 CAVEATS
277              
278             It works only with method calls, not with subroutines
279             calls. Foo->method will work Foo::method will NOT work
280             UNIVSERAL::AUTOLOAD is overriden after Class::Hook->activate() has
281             been called. Expect some strange behaviors if the module you use plays
282             with it.
283              
284             =head1 BUGS
285              
286             Don't rely on it for production purpose. Has been tested on perl
287             5.6.0 only and probably will need some update with later perl versions.
288              
289             =head1 AUTHOR
290              
291             "Pierre Denis"
292              
293             =head1 COPYRIGHT
294              
295             Copyright (C) 2005, IT Release Ltd. All rights reserved.
296              
297             This is free software. This software
298             may be modified and/or distributed under the same terms as Perl
299             itself.
300              
301             =cut
302