line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Monkey::Patch; |
2
|
|
|
|
|
|
|
BEGIN { |
3
|
3
|
|
|
3
|
|
117405
|
$Monkey::Patch::VERSION = '0.03'; |
4
|
|
|
|
|
|
|
} |
5
|
|
|
|
|
|
|
|
6
|
3
|
|
|
3
|
|
28
|
use warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
229
|
|
7
|
3
|
|
|
3
|
|
16
|
use strict; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
251
|
|
8
|
|
|
|
|
|
|
|
9
|
3
|
|
|
3
|
|
2453
|
use Monkey::Patch::Handle; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
95
|
|
10
|
3
|
|
|
3
|
|
2331
|
use Monkey::Patch::Handle::Class; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
87
|
|
11
|
3
|
|
|
3
|
|
2150
|
use Monkey::Patch::Handle::Object; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
75
|
|
12
|
|
|
|
|
|
|
|
13
|
3
|
|
|
3
|
|
17
|
use Exporter qw(import); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
818
|
|
14
|
|
|
|
|
|
|
our @EXPORT_OK = qw(patch_package patch_class patch_object); |
15
|
|
|
|
|
|
|
our %EXPORT_TAGS = (all => \@EXPORT_OK); |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
sub patch_package { |
18
|
2
|
|
|
2
|
1
|
62
|
Monkey::Patch::Handle->new( |
19
|
|
|
|
|
|
|
package => shift, |
20
|
|
|
|
|
|
|
subname => shift, |
21
|
|
|
|
|
|
|
code => shift, |
22
|
|
|
|
|
|
|
)->install; |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
sub patch_class { |
26
|
2
|
|
|
2
|
1
|
1985
|
Monkey::Patch::Handle::Class->new( |
27
|
|
|
|
|
|
|
package => shift, |
28
|
|
|
|
|
|
|
subname => shift, |
29
|
|
|
|
|
|
|
code => shift, |
30
|
|
|
|
|
|
|
)->install; |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
sub patch_object { |
34
|
3
|
|
|
3
|
1
|
938
|
my $obj = shift; |
35
|
3
|
|
|
|
|
48
|
Monkey::Patch::Handle::Object->new( |
36
|
|
|
|
|
|
|
object => $obj, |
37
|
|
|
|
|
|
|
package => ref $obj, |
38
|
|
|
|
|
|
|
subname => shift, |
39
|
|
|
|
|
|
|
code => shift, |
40
|
|
|
|
|
|
|
)->install; |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
=head1 NAME |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
Monkey::Patch - Scoped monkeypatching (you can at least play nice) |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
=head1 VERSION |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
version 0.03 |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
=head1 SYNOPSIS |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
use Monkey::Patch qw(:all); |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
sub some_subroutine { |
56
|
|
|
|
|
|
|
my $pkg = patch_class 'Some::Class' => 'something' => sub { |
57
|
|
|
|
|
|
|
my $original = shift; |
58
|
|
|
|
|
|
|
say "Whee!"; |
59
|
|
|
|
|
|
|
$original->(@_); |
60
|
|
|
|
|
|
|
}; |
61
|
|
|
|
|
|
|
Some::Class->something(); # says Whee! and does whatever |
62
|
|
|
|
|
|
|
undef $pkg; |
63
|
|
|
|
|
|
|
Some::Class->something(); # no longer says Whee! |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
my $obj = Some::Class->new; |
66
|
|
|
|
|
|
|
my $obj2 = Some::Class->new; |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
my $whoah = patch_object $obj, 'twiddle' => sub { |
69
|
|
|
|
|
|
|
my $original = shift; |
70
|
|
|
|
|
|
|
my $self = shift; |
71
|
|
|
|
|
|
|
say "Whoah!"; |
72
|
|
|
|
|
|
|
$self->$original(@_); |
73
|
|
|
|
|
|
|
}; |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
$obj->twiddle(); # says Whoah! |
76
|
|
|
|
|
|
|
$obj2->twiddle(); # doesn't |
77
|
|
|
|
|
|
|
$obj->twiddle() # still does |
78
|
|
|
|
|
|
|
undef $whoah; |
79
|
|
|
|
|
|
|
$obj->twiddle(); # but not any more |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=head1 SUBROUTINES |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
The following subroutines are available (either individually or via :all) |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
=head2 patch_package (package, subname, code) |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
Wraps C's subroutine named with your . Your code |
88
|
|
|
|
|
|
|
recieves the original subroutine as its first argument, followed by any |
89
|
|
|
|
|
|
|
arguments the subroutine would have normally gotten. You can always call the |
90
|
|
|
|
|
|
|
subroutine ref your received; if there was no subroutine by that name, the |
91
|
|
|
|
|
|
|
coderef will simply do nothing. |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
=head2 patch_class (class, methodname, code) |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
Just like C, except that the @ISA chain is walked when you try |
96
|
|
|
|
|
|
|
to call the original subroutine if there wasn't any subroutine by that name in |
97
|
|
|
|
|
|
|
the package. |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
=head2 patch_object (object, methodname, code) |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
Just like C, except that your code will only get called on the |
102
|
|
|
|
|
|
|
object you pass, not the entire class. |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
=head1 HANDLES |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
All the C functions return a handle object. As soon as you lose the |
107
|
|
|
|
|
|
|
value of the handle (by calling in void context, assigning over the variable, |
108
|
|
|
|
|
|
|
undeffing the variable, letting it go out of scope, etc), the monkey patch is |
109
|
|
|
|
|
|
|
unwrapped. You can stack monkeypatches and let go of the handles in any |
110
|
|
|
|
|
|
|
order; they obey a stack discipline, and the most recent valid monkeypatch |
111
|
|
|
|
|
|
|
will always be called. Calling the "original" argument to your wrapper |
112
|
|
|
|
|
|
|
routine will always call the next-most-recent monkeypatched version (or, the |
113
|
|
|
|
|
|
|
original subroutine, of course). |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
=head1 BUGS |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
This magic is only faintly black, but mucking around with the symbol table is |
118
|
|
|
|
|
|
|
not for the faint of heart. Help make this module better by reporting any |
119
|
|
|
|
|
|
|
strange behavior that you see! |