File Coverage

blib/lib/Test/Resub.pm
Criterion Covered Total %
statement 168 229 73.3
branch 37 68 54.4
condition 15 18 83.3
subroutine 42 46 91.3
pod 8 15 53.3
total 270 376 71.8


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__