line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
5
|
|
|
5
|
|
128148
|
use strict; |
|
5
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
169
|
|
2
|
5
|
|
|
5
|
|
25
|
use warnings; |
|
5
|
|
|
|
|
11
|
|
|
5
|
|
|
|
|
195
|
|
3
|
|
|
|
|
|
|
package Test::Resub; |
4
|
5
|
|
|
5
|
|
28
|
use base qw(Exporter); |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
787
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
our @EXPORT = qw(resub bulk_resub); |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our $VERSION = 2.03; |
9
|
|
|
|
|
|
|
|
10
|
5
|
|
|
5
|
|
27
|
use Carp qw(croak); |
|
5
|
|
|
|
|
15
|
|
|
5
|
|
|
|
|
518
|
|
11
|
5
|
|
|
5
|
|
4431
|
use Storable qw(dclone); |
|
5
|
|
|
|
|
16191
|
|
|
5
|
|
|
|
|
479
|
|
12
|
5
|
|
|
5
|
|
44
|
use Scalar::Util qw(weaken); |
|
5
|
|
|
|
|
23
|
|
|
5
|
|
|
|
|
7931
|
|
13
|
|
|
|
|
|
|
|
14
|
4
|
|
|
4
|
0
|
10
|
sub default_replacement_sub { sub {} } |
|
10
|
|
|
10
|
|
75
|
|
15
|
|
|
|
|
|
|
sub set_prototype(&$) { |
16
|
32
|
50
|
|
32
|
0
|
162
|
if (_implements('Scalar::Util','set_prototype')) { |
17
|
32
|
|
|
|
|
221
|
goto \&Scalar::Util::set_prototype; |
18
|
|
|
|
|
|
|
} else { |
19
|
0
|
|
|
|
|
0
|
my $code = shift; |
20
|
0
|
|
|
|
|
0
|
my $proto = shift; |
21
|
0
|
0
|
|
|
|
0
|
$proto = defined $proto ? "($proto)" : ''; |
22
|
0
|
|
|
|
|
0
|
local $@; |
23
|
0
|
|
|
|
|
0
|
return eval "sub $proto { goto \$code }"; |
24
|
|
|
|
|
|
|
} |
25
|
|
|
|
|
|
|
} |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
sub resub { |
28
|
8
|
|
|
8
|
0
|
14795
|
my ($name, $code, %args) = @_; |
29
|
8
|
50
|
|
|
|
69
|
die "give me a fully qualified function name: $name ain't good enough\n" |
30
|
|
|
|
|
|
|
unless $name =~ /::/; |
31
|
8
|
|
|
|
|
71
|
return __PACKAGE__->new( |
32
|
|
|
|
|
|
|
%args, |
33
|
|
|
|
|
|
|
name => $name, |
34
|
|
|
|
|
|
|
code => $code, |
35
|
|
|
|
|
|
|
); |
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
sub bulk_resub { |
39
|
1
|
|
|
1
|
0
|
23
|
my ($target, $data, %args) = @_; |
40
|
1
|
|
|
|
|
2
|
my %rs; |
41
|
1
|
|
|
|
|
4
|
foreach (keys %$data) { |
42
|
2
|
|
|
|
|
10
|
$rs{$_} = resub "$target\::$_", $data->{$_}, %args; |
43
|
|
|
|
|
|
|
} |
44
|
1
|
|
|
|
|
5
|
return %rs; |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
sub _validate_params_lameley { |
48
|
35
|
|
|
35
|
|
127
|
my ($class, %args) = @_; |
49
|
|
|
|
|
|
|
|
50
|
210
|
|
|
|
|
455
|
my %known = |
51
|
35
|
|
|
|
|
78
|
map { $_ => 1 } |
52
|
|
|
|
|
|
|
qw(name code create call capture deep_copy); |
53
|
|
|
|
|
|
|
|
54
|
0
|
|
|
|
|
0
|
my %bad = |
55
|
86
|
|
|
|
|
240
|
map { $_ => $args{$_} } |
56
|
35
|
|
|
|
|
102
|
grep { ! $known{$_} } |
57
|
|
|
|
|
|
|
keys %args; |
58
|
|
|
|
|
|
|
|
59
|
35
|
50
|
|
|
|
117
|
if (scalar keys %bad) { |
60
|
0
|
|
|
|
|
0
|
my $bad = join ', ', map { "$_ => $bad{$_}" } keys %bad; |
|
0
|
|
|
|
|
0
|
|
61
|
0
|
|
|
|
|
0
|
croak "$class->new - not sure how to handle unknown arg '$bad'\n"; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
|
64
|
35
|
100
|
100
|
|
|
172
|
croak "don't know how to handle 'call => $args{call}'" |
65
|
|
|
|
|
|
|
if exists $args{call} && ! in($args{call}, qw(optional required forbidden)); |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
return ( |
68
|
34
|
|
|
|
|
274
|
deep_copy => 0, |
69
|
|
|
|
|
|
|
call => 'required', |
70
|
|
|
|
|
|
|
%args, |
71
|
|
|
|
|
|
|
); |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
sub new { |
75
|
35
|
|
|
35
|
0
|
16024
|
my $class = shift; |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
# lame adaptor for old-style users of Test::Resub (are there any?) |
78
|
35
|
100
|
|
|
|
137
|
my %args = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_; |
|
27
|
|
|
|
|
120
|
|
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
# I'm not gonna lie, this really is stupidly ugly |
81
|
35
|
|
|
|
|
152
|
%args = $class->_validate_params_lameley(%args); |
82
|
|
|
|
|
|
|
|
83
|
34
|
50
|
|
|
|
129
|
croak "I return a highly useful object, gotta call me in non-void context!\n" |
84
|
|
|
|
|
|
|
unless defined wantarray; |
85
|
|
|
|
|
|
|
|
86
|
34
|
|
|
|
|
84
|
my $name = $args{name}; |
87
|
34
|
|
|
|
|
189
|
(my $sane = $name) =~ s{->}{::}g; |
88
|
34
|
|
|
|
|
84
|
$sane =~ s{[^\w:]}{}g; |
89
|
34
|
100
|
|
|
|
384
|
croak "bad method name: $args{name} (expected: $sane)" if $args{name} ne $sane; |
90
|
|
|
|
|
|
|
|
91
|
33
|
|
66
|
|
|
130
|
my $code = $args{code} || $class->default_replacement_sub; |
92
|
|
|
|
|
|
|
|
93
|
33
|
|
|
|
|
158
|
my ($orig_code, $autovivified) = $class->_get_orig_code(%args); |
94
|
|
|
|
|
|
|
|
95
|
32
|
|
|
|
|
260
|
my ($package, $sub) = $args{name} =~ m{^(.*)::(.*?)$}; |
96
|
|
|
|
|
|
|
|
97
|
32
|
|
|
|
|
155
|
my $self = bless { |
98
|
|
|
|
|
|
|
%args, |
99
|
|
|
|
|
|
|
target_package => $package, |
100
|
|
|
|
|
|
|
target_sub => $sub, |
101
|
|
|
|
|
|
|
orig_code => $orig_code, |
102
|
|
|
|
|
|
|
called => 0, |
103
|
|
|
|
|
|
|
args => [], |
104
|
|
|
|
|
|
|
autovivified => $autovivified, |
105
|
|
|
|
|
|
|
stashed_variables => _save_variables($args{name}), |
106
|
|
|
|
|
|
|
deep_copy => $args{deep_copy}, |
107
|
|
|
|
|
|
|
}, $class; |
108
|
|
|
|
|
|
|
|
109
|
32
|
|
|
|
|
140
|
weaken(my $weak_self = $self); |
110
|
|
|
|
|
|
|
my $wrapper_for_code = set_prototype(sub { |
111
|
30
|
|
|
30
|
|
2911
|
$weak_self->{called}++; |
112
|
30
|
|
|
|
|
55
|
$weak_self->{was_called} = 1; |
113
|
30
|
|
|
|
|
134
|
push @{$weak_self->{args}}, ($weak_self->{deep_copy} |
114
|
30
|
100
|
|
|
|
37
|
? do { |
115
|
1
|
|
|
|
|
3
|
local $Storable::Deparse = 1; |
116
|
1
|
|
|
|
|
2
|
local $Storable::Eval = 1; |
117
|
1
|
|
|
1
|
|
24
|
dclone(\@_); |
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
17
|
|
|
1
|
|
|
|
|
525
|
|
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
: [@_]); |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
# Are you debugging? Here's where we call the original code in its original context. |
122
|
30
|
|
|
|
|
92
|
return $code->(@_); |
123
|
32
|
|
|
|
|
136
|
}, prototype(\&{$self->{name}})); |
|
32
|
|
|
|
|
204
|
|
124
|
|
|
|
|
|
|
|
125
|
32
|
|
|
|
|
161
|
$self->swap_out($wrapper_for_code); |
126
|
32
|
|
|
|
|
132
|
_restore_variables($self->{name}, $self->{stashed_variables}); |
127
|
|
|
|
|
|
|
|
128
|
32
|
|
|
|
|
150
|
return $self; |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
sub _context { |
132
|
0
|
|
|
0
|
|
0
|
my ($class) = @_; |
133
|
0
|
|
|
|
|
0
|
my $wantarray = (caller(1))[5]; |
134
|
0
|
0
|
|
|
|
0
|
my $context = $wantarray |
|
|
0
|
|
|
|
|
|
135
|
|
|
|
|
|
|
? 'list' |
136
|
|
|
|
|
|
|
: defined $wantarray |
137
|
|
|
|
|
|
|
? 'scalar' |
138
|
|
|
|
|
|
|
: 'void'; |
139
|
0
|
|
|
|
|
0
|
return $context; |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sub _save_variables { |
143
|
32
|
|
|
32
|
|
46
|
my ($varname) = @_; |
144
|
5
|
|
|
5
|
|
40
|
no strict 'refs'; |
|
5
|
|
|
|
|
12
|
|
|
5
|
|
|
|
|
413
|
|
145
|
|
|
|
|
|
|
return { |
146
|
32
|
|
|
|
|
474
|
scalar => $$varname, |
147
|
|
|
|
|
|
|
array => \@$varname, |
148
|
|
|
|
|
|
|
hash => \%$varname, |
149
|
|
|
|
|
|
|
}; |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
sub _restore_variables { |
153
|
63
|
|
|
63
|
|
280
|
my ($varname, $data) = @_; |
154
|
5
|
|
|
5
|
|
165
|
no strict 'refs'; |
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
157
|
|
155
|
5
|
|
|
5
|
|
29
|
no warnings 'uninitialized'; |
|
5
|
|
|
|
|
6
|
|
|
5
|
|
|
|
|
3195
|
|
156
|
63
|
|
|
|
|
177
|
$$varname = $data->{scalar}; |
157
|
63
|
|
|
|
|
71
|
@$varname = @{$data->{array}}; |
|
63
|
|
|
|
|
188
|
|
158
|
63
|
|
|
|
|
87
|
%$varname = %{$data->{hash}}; |
|
63
|
|
|
|
|
439
|
|
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
sub _implements { |
162
|
65
|
|
|
65
|
|
96
|
my ($package, $sub) = @_; |
163
|
|
|
|
|
|
|
|
164
|
65
|
|
|
|
|
74
|
local $@; |
165
|
65
|
|
|
|
|
3645
|
my %stash = eval "\%$package\::"; |
166
|
65
|
50
|
|
|
|
770
|
croak "finding $package\'s stash: $@\n" if $@; |
167
|
|
|
|
|
|
|
|
168
|
65
|
|
66
|
|
|
210
|
return exists $stash{$sub} && *{$stash{$sub}}{CODE} && *{$stash{$sub}}{NAME} eq $sub; |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
sub _get_orig_code { |
172
|
33
|
|
|
33
|
|
210
|
my ($class, %args) = @_; |
173
|
|
|
|
|
|
|
|
174
|
33
|
|
|
|
|
330
|
my ($package, $sub) = $args{name} =~ m{^(.*)::(.+)$}; |
175
|
|
|
|
|
|
|
|
176
|
33
|
100
|
|
|
|
85
|
return (\&{$args{name}}, 0) if _implements($package, $sub); |
|
13
|
|
|
|
|
66
|
|
177
|
20
|
100
|
|
|
|
272
|
return ($package->can($sub), 1) if $package->can($sub); |
178
|
|
|
|
|
|
|
|
179
|
9
|
100
|
|
|
|
33
|
if (!$args{create}) { |
180
|
1
|
|
|
|
|
330
|
croak "Package $package doesn't implement nor inherit a sub named '$sub'. " . |
181
|
|
|
|
|
|
|
"Generally autovivifying subs into existance leads to bugs, but if you know " . |
182
|
|
|
|
|
|
|
"what you're doing you can pass the 'create' flag to $class->new"; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
8
|
|
|
|
|
14
|
return (\&{$args{name}}, 1); |
|
8
|
|
|
|
|
50
|
|
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
sub in { |
189
|
11
|
|
|
11
|
0
|
20
|
my $needle = shift; |
190
|
11
|
|
|
|
|
28
|
foreach (@_) { |
191
|
18
|
100
|
|
|
|
83
|
return 1 if $_ eq $needle; |
192
|
|
|
|
|
|
|
} |
193
|
1
|
|
|
|
|
184
|
return 0; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub _looks_moosey { |
197
|
0
|
|
|
0
|
|
0
|
my ($self, $code) = @_; |
198
|
0
|
|
|
|
|
0
|
my ($target_package, $target_sub) = @{$self}{qw(target_package target_sub)}; |
|
0
|
|
|
|
|
0
|
|
199
|
0
|
|
|
|
|
0
|
my $meta = do { local $@; eval { Class::MOP::get_metaclass_by_name($target_package) } }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
200
|
0
|
|
|
|
|
0
|
return $meta; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
sub swap_out { |
204
|
63
|
|
|
63
|
0
|
97
|
my ($self, $code, $is_destroy) = @_; |
205
|
|
|
|
|
|
|
|
206
|
63
|
|
|
|
|
90
|
my ($name, $target_package, $target_sub) = @{$self}{qw(name target_package target_sub)}; |
|
63
|
|
|
|
|
159
|
|
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
my $do_simple_swap = sub { |
209
|
5
|
|
|
5
|
|
153
|
no strict 'refs'; |
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
232
|
|
210
|
5
|
|
|
5
|
|
25
|
no warnings 'redefine'; |
|
5
|
|
|
|
|
8
|
|
|
5
|
|
|
|
|
1870
|
|
211
|
63
|
|
|
63
|
|
247
|
*{$name} = $code; |
|
63
|
|
|
|
|
943
|
|
212
|
63
|
|
|
|
|
240
|
}; |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# find the Class::MOP metaclass associated with our victim's encapsulating class |
215
|
63
|
100
|
|
|
|
138
|
my $meta = $is_destroy ? 0 : do { |
216
|
32
|
|
|
|
|
35
|
local $@; |
217
|
32
|
|
|
|
|
54
|
eval { Class::MOP::get_metaclass_by_name($target_package) }; |
|
32
|
|
|
|
|
340
|
|
218
|
|
|
|
|
|
|
}; |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
# If we're DESTROYing then we can simply swap stuff in: either we're not moosey (so there are no modifiers to |
221
|
|
|
|
|
|
|
# apply around our replacement code) -or- we are moosey but are destroying (in which case the original code we |
222
|
|
|
|
|
|
|
# saved off is already wrapped up). |
223
|
|
|
|
|
|
|
# |
224
|
|
|
|
|
|
|
# If we don't have a $meta then we don't have a metaclass so can simply swap things in and out, regardless of |
225
|
|
|
|
|
|
|
# whether we're DESTROYing or not: there's no Moose/Class::MOP wrappers to copy from the original code to our |
226
|
|
|
|
|
|
|
# replacement. |
227
|
63
|
50
|
66
|
|
|
4980
|
if ($is_destroy || ! defined $meta) { |
228
|
63
|
|
|
|
|
109
|
$do_simple_swap->(); |
229
|
63
|
|
|
|
|
228
|
return; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# If we got this far then we're not DESTROYing, and do have a $meta - so we need to find any wrappers for the |
233
|
|
|
|
|
|
|
# original code. Here's how we'd find it for some versions of Moose: |
234
|
0
|
0
|
|
|
|
0
|
my ($wrapped) = grep { $_->{name} eq $target_sub && $_->can('before_modifiers') } $meta->get_all_methods; |
|
0
|
|
|
|
|
0
|
|
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
# ugly code to go dig around for wrappers |
237
|
0
|
|
|
|
|
0
|
my ($before, $around, $after) = ([], [], []); |
238
|
0
|
0
|
|
|
|
0
|
if (defined $wrapped) { |
239
|
0
|
|
|
|
|
0
|
($before, $around, $after) = |
240
|
0
|
|
|
|
|
0
|
map { [$wrapped->$_] } |
241
|
|
|
|
|
|
|
qw(before_modifiers around_modifiers after_modifiers); |
242
|
|
|
|
|
|
|
} else { |
243
|
0
|
0
|
|
|
|
0
|
if (_deep_exists($meta, methods => $target_sub => modifier_table =>)) { |
244
|
0
|
|
|
|
|
0
|
my $modifier_table = $meta->{methods}{$target_sub}{modifier_table}; |
245
|
0
|
0
|
|
|
|
0
|
$before = [ @{$modifier_table->{before} || []} ]; |
|
0
|
|
|
|
|
0
|
|
246
|
0
|
0
|
|
|
|
0
|
$around = [ @{$modifier_table->{around}{cache} || []} ]; |
|
0
|
|
|
|
|
0
|
|
247
|
0
|
0
|
|
|
|
0
|
$after = [ @{$modifier_table->{after} || []} ]; |
|
0
|
|
|
|
|
0
|
|
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
|
251
|
0
|
0
|
|
|
|
0
|
if (scalar grep { scalar @$_ } $before, $around, $after) { |
|
0
|
|
|
|
|
0
|
|
252
|
5
|
|
|
5
|
|
34
|
no strict 'refs'; |
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
164
|
|
253
|
5
|
|
|
5
|
|
28
|
no warnings 'redefine'; |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
6832
|
|
254
|
0
|
|
|
|
|
0
|
*{$name} = sub { |
255
|
0
|
|
|
0
|
|
0
|
my $context = _context(); |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
# call before hooks in correct context |
258
|
|
|
|
|
|
|
+{ |
259
|
0
|
|
|
|
|
0
|
list => sub { ($_->(@_)) foreach @$before }, |
260
|
0
|
|
|
|
|
0
|
scalar => sub { scalar $_->(@_) foreach @$before }, |
261
|
0
|
|
|
|
|
0
|
void => sub { $_->(@_) foreach @$before }, |
262
|
0
|
|
|
|
|
0
|
}->{$context}->(@_); |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
# $_->($code, @$_) foreach @$around; |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
# call swapped-in code in correct context |
267
|
0
|
|
|
|
|
0
|
my @out; |
268
|
|
|
|
|
|
|
+{ |
269
|
0
|
|
|
|
|
0
|
list => sub { @out = $code->(@_) }, |
270
|
0
|
|
|
|
|
0
|
scalar => sub { $out[0] = $code->(@_) }, |
271
|
0
|
|
|
|
|
0
|
void => sub { $code->(@_); 1 }, |
|
0
|
|
|
|
|
0
|
|
272
|
0
|
|
|
|
|
0
|
}->{$context}->(@_); |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
# call after hooks in correct context |
275
|
|
|
|
|
|
|
+{ |
276
|
0
|
|
|
|
|
0
|
list => sub { ($_->(@_)) foreach @$after }, |
277
|
0
|
|
|
|
|
0
|
scalar => sub { scalar $_->(@_) foreach @$after }, |
278
|
0
|
|
|
|
|
0
|
void => sub { $_->(@_) foreach @$after }, |
279
|
0
|
|
|
|
|
0
|
}->{$context}->(@_); |
280
|
|
|
|
|
|
|
|
281
|
0
|
0
|
|
|
|
0
|
return $context eq 'list' ? @out : $out[0]; |
282
|
0
|
|
|
|
|
0
|
}; |
283
|
|
|
|
|
|
|
} else { |
284
|
|
|
|
|
|
|
# we're moose-like but don't have any wrappers: swap ourselves in! |
285
|
0
|
|
|
|
|
0
|
$do_simple_swap->(); |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
sub _deep_exists { |
290
|
0
|
|
|
0
|
|
0
|
my ($hashref, @keys) = @_; |
291
|
0
|
|
|
|
|
0
|
foreach (@keys) { |
292
|
0
|
0
|
|
|
|
0
|
return 0 unless exists $hashref->{$_}; |
293
|
0
|
|
|
|
|
0
|
$hashref = $hashref->{$_}; |
294
|
|
|
|
|
|
|
} |
295
|
0
|
|
|
|
|
0
|
return 1; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
7
|
|
|
7
|
1
|
562
|
sub called { return shift->{called} } |
299
|
63
|
|
|
63
|
1
|
1015
|
sub was_called { return shift->{was_called} } |
300
|
|
|
|
|
|
|
|
301
|
2
|
|
|
2
|
1
|
13
|
sub not_called { return ! shift->called } |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
sub _args { |
304
|
19
|
|
|
19
|
|
29
|
my ($self, $mutator) = @_; |
305
|
19
|
|
|
|
|
27
|
return [map { $mutator->() } @{$self->{args}}]; |
|
16
|
|
|
|
|
30
|
|
|
19
|
|
|
|
|
66
|
|
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
|
308
|
4
|
|
|
4
|
1
|
28
|
sub args { shift->_args(sub { [@$_] }) } |
|
5
|
|
|
5
|
|
41
|
|
309
|
2
|
|
|
2
|
1
|
6
|
sub method_args { shift->_args(sub { my @copy = @$_; shift @copy; \@copy; }) } |
|
2
|
|
|
3
|
|
2
|
|
|
2
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
21
|
|
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
sub named_args { |
312
|
11
|
|
|
11
|
1
|
33
|
my ($self, %args) = @_; |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
return $self->_args(sub { |
315
|
10
|
|
|
10
|
|
26
|
my @copy = @$_; |
316
|
10
|
100
|
|
|
|
41
|
splice @copy, 0, $args{arg_start_index} if $args{arg_start_index}; |
317
|
10
|
100
|
|
|
|
31
|
my @scalars = $args{scalars} |
318
|
|
|
|
|
|
|
? splice @copy, 0, $args{scalars} |
319
|
|
|
|
|
|
|
: (); |
320
|
10
|
100
|
|
|
|
133
|
return $args{scalars} |
321
|
|
|
|
|
|
|
? (@scalars, +{@copy}) |
322
|
|
|
|
|
|
|
: +{@copy}; |
323
|
11
|
|
|
|
|
71
|
}); |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
sub named_method_args { |
327
|
5
|
|
|
5
|
1
|
27
|
my ($self, %args) = @_; |
328
|
5
|
|
|
|
|
9
|
$args{arg_start_index} += 1; |
329
|
5
|
|
|
|
|
19
|
return $self->named_args(%args); |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
sub reset { |
333
|
4
|
|
|
4
|
1
|
10
|
my ($self) = @_; |
334
|
4
|
|
|
|
|
8
|
$self->{called} = 0; |
335
|
4
|
|
|
|
|
14
|
$self->{args} = []; |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
sub DESTROY { |
339
|
31
|
|
|
31
|
|
10925
|
my($self,) = @_; |
340
|
|
|
|
|
|
|
|
341
|
31
|
|
|
|
|
104
|
$self->swap_out($self->{orig_code}, 1); |
342
|
|
|
|
|
|
|
|
343
|
31
|
100
|
|
|
|
89
|
if ($self->{autovivified}) { |
344
|
19
|
|
|
|
|
28
|
my ($package, $sub) = @{$self}{qw(target_package target_sub)}; |
|
19
|
|
|
|
|
41
|
|
345
|
19
|
|
|
|
|
27
|
local $@; |
346
|
19
|
|
|
|
|
1038
|
eval "delete \$${package}::{$sub}"; |
347
|
19
|
50
|
|
|
|
80
|
croak "ack: $@\n" if $@; |
348
|
|
|
|
|
|
|
} |
349
|
31
|
|
|
|
|
91
|
_restore_variables($self->{name}, $self->{stashed_variables}); |
350
|
|
|
|
|
|
|
|
351
|
31
|
100
|
100
|
|
|
93
|
if (!$self->was_called && $self->{call} eq 'required') { |
352
|
3
|
|
|
|
|
6
|
my $text = 'was not called'; |
353
|
3
|
|
|
|
|
402
|
print STDOUT "not ok 1000 - the " . __PACKAGE__ . " object for '$self->{name}' $text\n" . Carp::longmess; |
354
|
|
|
|
|
|
|
} |
355
|
31
|
100
|
100
|
|
|
878
|
if ($self->was_called && $self->{call} eq 'forbidden') { |
356
|
1
|
|
|
|
|
2
|
my $text = 'was called'; |
357
|
1
|
|
|
|
|
89
|
print STDOUT "not ok 1000 - the " . __PACKAGE__ . " object for '$self->{name}' $text\n" . Carp::longmess; |
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
1; |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
__END__ |