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
|
|
|
|
|
|
|
|