File Coverage

blib/lib/Test/Weaken.pm
Criterion Covered Total %
statement 294 330 89.0
branch 139 176 78.9
condition 16 21 76.1
subroutine 22 22 100.0
pod 8 10 80.0
total 479 559 85.6


line stmt bran cond sub pod time code
1             package Test::Weaken;
2              
3              
4             # maybe:
5             # contents_funcs => arrayref of funcs
6             # multiple contents, or sub{} returning list enough ?
7             # track_filehandles => 1 GLOB and IO
8             #
9             # locations=>1
10             # top->{'foo'}->[10]->REF->*{IO}
11             # top.H{'foo'}.A[10].REF.*{IO}
12             # unfreed_locations() arrayref of strings
13             # first location encountered
14             # locations_maxdepth
15              
16              
17 18     18   721040 use 5.006;
  18         77  
  18         899  
18 18     18   104 use strict;
  18         34  
  18         738  
19 18     18   101 use warnings;
  18         51  
  18         1931  
20              
21             require Exporter;
22              
23 18     18   100 use base qw(Exporter);
  18         33  
  18         3512  
24             our @EXPORT_OK = qw(leaks poof);
25             our $VERSION = '3.022000';
26              
27             #use Smart::Comments;
28              
29             ### Using Smart Comments ...
30              
31             =begin Implementation:
32              
33             The basic strategy: get a list of all the objects which allocate memory,
34             create probe references to them, weaken those probe references, attempt
35             to free the memory, and check the references. If the memory is free,
36             the probe references will be undefined.
37              
38             Probe references also serve a second purpose -- to avoid copying any
39             weak reference in the original object. When you copy a weak reference,
40             the result is a strong reference.
41              
42             There may be good reasons for Perl strengthen-on-copy policy, but that
43             behavior is a big problem for this module. A lot of what might seem
44             like needless indirection in the code below is done to avoid working
45             with references directly in situations which could involve making a copy
46             of them, even implicitly.
47              
48             =end Implementation:
49              
50             =cut
51              
52             package Test::Weaken::Internal;
53              
54 18     18   31465 use English qw( -no_match_vars );
  18         104815  
  18         125  
55 18     18   10684 use Carp;
  18         36  
  18         1582  
56 18     18   101 use Scalar::Util 1.18 qw();
  18         818  
  18         84771  
57              
58             my @default_tracked_types = qw(REF SCALAR VSTRING HASH ARRAY CODE);
59              
60             sub follow {
61 90     90   181 my ( $self, @base_probe_list ) = @_;
62              
63 90         146 my $ignore_preds = $self->{ignore_preds};
64 90         189 my $contents = $self->{contents};
65 90         124 my $trace_maxdepth = $self->{trace_maxdepth};
66 90         129 my $trace_following = $self->{trace_following};
67 90         180 my $trace_tracking = $self->{trace_tracking};
68 90         321 my $user_tracked_types = $self->{tracked_types};
69              
70 90         302 my @tracked_types = @default_tracked_types;
71 90 100       276 if ( defined $user_tracked_types ) {
72 5         6 push @tracked_types, @{$user_tracked_types};
  5         12  
73             }
74 90         188 my %tracked_type = map { ( $_, 1 ) } @tracked_types;
  547         5919  
75              
76 90 50       293 defined $trace_maxdepth or $trace_maxdepth = 0;
77              
78             # Initialize the results with a reference to the dereferenced
79             # base reference.
80              
81             # The initialization assumes each $base_probe is a reference,
82             # not part of the test object, whose referent is also a reference
83             # which IS part of the test object.
84 90         154 my @follow_probes = @base_probe_list;
85 90         174 my @tracking_probes = @base_probe_list;
86 90         130 my %already_followed = ();
87 90         126 my %already_tracked = ();
88              
89             FOLLOW_OBJECT:
90 90         266 while ( defined( my $follow_probe = pop @follow_probes ) ) {
91              
92             # The follow probes are to objects which either will not be
93             # tracked or which have already been added to @tracking_probes
94              
95             next FOLLOW_OBJECT
96 684 100       2533 if $already_followed{ Scalar::Util::refaddr $follow_probe }++;
97              
98 636         5818 my $object_type = Scalar::Util::reftype $follow_probe;
99              
100 636         824 my @child_probes = ();
101              
102 636 50       1111 if ($trace_following) {
103 0         0 require Data::Dumper;
104             ## no critic (ValuesAndExpressions::ProhibitLongChainsOfMethodCalls)
105 0 0       0 print {*STDERR} 'Following: ',
  0         0  
106             Data::Dumper->new( [$follow_probe], [qw(tracking)] )->Terse(1)
107             ->Maxdepth($trace_maxdepth)->Dump
108             or Carp::croak("Cannot print to STDOUT: $ERRNO");
109             ## use critic
110             } ## end if ($trace_following)
111              
112 636 100       1258 if ( defined $contents ) {
113 50         57 my $safe_copy = $follow_probe;
114 50         109 push @child_probes, map { \$_ } ( $contents->($safe_copy) );
  8         96  
115             }
116              
117             FIND_CHILDREN: {
118              
119 636         800 foreach my $ignore (@$ignore_preds) {
  636         1266  
120 232         270 my $safe_copy = $follow_probe;
121 232 100       386 last FIND_CHILDREN if $ignore->($safe_copy);
122             }
123              
124 612 100       1567 if ( $object_type eq 'ARRAY' ) {
125 83 100       107 if ( my $tied_var = tied @{$follow_probe} ) {
  83         251  
126 1         3 push @child_probes, \($tied_var);
127             }
128 83         111 foreach my $i ( 0 .. $#{$follow_probe} ) {
  83         225  
129 149 100       334 if ( exists $follow_probe->[$i] ) {
130 144         313 push @child_probes, \( $follow_probe->[$i] );
131             }
132             }
133 83         161 last FIND_CHILDREN;
134             } ## end if ( $object_type eq 'ARRAY' )
135              
136 529 100       1083 if ( $object_type eq 'HASH' ) {
137 79 100       90 if ( my $tied_var = tied %{$follow_probe} ) {
  79         232  
138 1         2 push @child_probes, \($tied_var);
139             }
140 79         112 push @child_probes, map { \$_ } values %{$follow_probe};
  122         347  
  79         184  
141 79         142 last FIND_CHILDREN;
142             } ## end if ( $object_type eq 'HASH' )
143              
144             # GLOB is not tracked by default,
145             # but we follow ties
146 450 100       927 if ( $object_type eq 'GLOB' ) {
147 7 100       11 if ( my $tied_var = tied *${$follow_probe} ) {
  7         33  
148 1         2 push @child_probes, \($tied_var);
149             }
150 7         14 last FIND_CHILDREN;
151             } ## end if ( $object_type eq 'GLOB' )
152              
153             # LVALUE is not tracked by default,
154             # but we follow ties
155 443 50 66     3170 if ( $object_type eq 'SCALAR'
      66        
156             or $object_type eq 'VSTRING'
157             or $object_type eq 'LVALUE' )
158             {
159 144 100       168 if ( my $tied_var = tied ${$follow_probe} ) {
  144         426  
160 1         2 push @child_probes, \($tied_var);
161             }
162 144         219 last FIND_CHILDREN;
163             } ## end if ( $object_type eq 'SCALAR' or $object_type eq ...)
164              
165 299 100       630 if ( $object_type eq 'REF' ) {
166 297 50       308 if ( my $tied_var = tied ${$follow_probe} ) {
  297         770  
167 0         0 push @child_probes, \($tied_var);
168             }
169 297         363 push @child_probes, ${$follow_probe};
  297         445  
170 297         531 last FIND_CHILDREN;
171             } ## end if ( $object_type eq 'REF' )
172              
173             } ## end FIND_CHILDREN:
174              
175 634         810 push @follow_probes, @child_probes;
176              
177 634         1524 CHILD_PROBE: for my $child_probe (@child_probes) {
178              
179 575         1170 my $child_type = Scalar::Util::reftype $child_probe;
180              
181 575 100       2301 next CHILD_PROBE unless $tracked_type{$child_type};
182              
183 573         628 my $new_tracking_probe = $child_probe;
184              
185             next CHILD_PROBE
186 573 100       2242 if $already_tracked{ Scalar::Util::refaddr $new_tracking_probe
187             }++;
188              
189 525         842 foreach my $ignore (@$ignore_preds) {
190 178         186 my $safe_copy = $new_tracking_probe;
191 178 100       305 next CHILD_PROBE if $ignore->($safe_copy);
192             }
193              
194 501 50       1428 if ($trace_tracking) {
195             ## no critic (ValuesAndExpressions::ProhibitLongChainsOfMethodCalls)
196 0 0       0 print {*STDERR} 'Tracking: ',
  0         0  
197             Data::Dumper->new( [$new_tracking_probe], [qw(tracking)] )
198             ->Terse(1)->Maxdepth($trace_maxdepth)->Dump
199             or Carp::croak("Cannot print to STDOUT: $ERRNO");
200             ## use critic
201              
202             # print {*STDERR} 'Tracking: ',
203             # "$new_tracking_probe\n";
204              
205             } ## end if ($trace_tracking)
206 501         1966 push @tracking_probes, $new_tracking_probe;
207              
208             } ## end for my $child_probe (@child_probes)
209              
210             } # FOLLOW_OBJECT
211              
212 86         681 return \@tracking_probes;
213              
214             } # sub follow
215              
216             # See POD, below
217             sub Test::Weaken::new {
218 90     90 1 2569 my ( $class, $arg1, $arg2 ) = @_;
219 90         169 my $self = {};
220 90         224 bless $self, $class;
221 90         317 $self->{test} = 1;
222              
223 90         117 my @ignore_preds;
224             my @ignore_classes;
225 0         0 my @ignore_objects;
226 90         244 $self->{ignore_preds} = \@ignore_preds;
227              
228             UNPACK_ARGS: {
229 90 100       138 if ( ref $arg1 eq 'CODE' ) {
  90         311  
230 36         94 $self->{constructor} = $arg1;
231 36 100       115 if ( defined $arg2 ) {
232 7         14 $self->{destructor} = $arg2;
233             }
234 36         115 return $self;
235             }
236              
237 54 50       161 if ( ref $arg1 ne 'HASH' ) {
238 0         0 Carp::croak('arg to Test::Weaken::new is not HASH ref');
239             }
240              
241 54 50       272 if (defined (my $constructor = delete $arg1->{constructor})) {
242 54         116 $self->{constructor} = $constructor;
243             }
244              
245 54 100       197 if (defined (my $destructor = delete $arg1->{destructor})) {
246 6         22 $self->{destructor} = $destructor;
247             }
248 54 100       157 if (defined (my $destructor_method = delete $arg1->{destructor_method})) {
249 2         4 $self->{destructor_method} = $destructor_method;
250             }
251              
252 54 100       163 if (defined (my $coderef = delete $arg1->{ignore})) {
253 25 50       65 if (ref $coderef ne 'CODE') {
254 0         0 Carp::croak('Test::Weaken: ignore must be CODE ref');
255             }
256 25         47 push @ignore_preds, $coderef;
257             }
258 54 100       151 if (defined (my $ignore_preds = delete $arg1->{ignore_preds})) {
259 3         6 push @ignore_preds, @$ignore_preds;
260             }
261 54 100       149 if ( defined (my $ignore_class = delete $arg1->{ignore_class} )) {
262 3         4 push @ignore_classes, $ignore_class;
263             }
264 54 100       275 if ( defined (my $ignore_classes = delete $arg1->{ignore_classes} )) {
265 2         4 push @ignore_classes, @$ignore_classes;
266             }
267 54         275 push @ignore_objects, delete $arg1->{ignore_object};
268 54 100       348 if ( defined (my $ignore_objects = delete $arg1->{ignore_objects} )) {
269 3         6 push @ignore_objects, @$ignore_objects;
270             }
271              
272 54 50       137 if ( defined $arg1->{trace_maxdepth} ) {
273 0         0 $self->{trace_maxdepth} = $arg1->{trace_maxdepth};
274 0         0 delete $arg1->{trace_maxdepth};
275             }
276              
277 54 50       159 if ( defined $arg1->{trace_following} ) {
278 0         0 $self->{trace_following} = $arg1->{trace_following};
279 0         0 delete $arg1->{trace_following};
280             }
281              
282 54 50       167 if ( defined $arg1->{trace_tracking} ) {
283 0         0 $self->{trace_tracking} = $arg1->{trace_tracking};
284 0         0 delete $arg1->{trace_tracking};
285             }
286              
287 54 100       210 if ( defined $arg1->{contents} ) {
288 6         22 $self->{contents} = $arg1->{contents};
289 6         11 delete $arg1->{contents};
290             }
291              
292 54 50       219 if ( defined $arg1->{test} ) {
293 0         0 $self->{test} = $arg1->{test};
294 0         0 delete $arg1->{test};
295             }
296              
297 54 100       128 if ( defined $arg1->{tracked_types} ) {
298 5         12 $self->{tracked_types} = $arg1->{tracked_types};
299 5         9 delete $arg1->{tracked_types};
300             }
301              
302 54         63 my @unknown_named_args = keys %{$arg1};
  54         161  
303              
304 54 50       188 if (@unknown_named_args) {
305 0         0 my $message = q{};
306 0         0 for my $unknown_named_arg (@unknown_named_args) {
307 0         0 $message .= "Unknown named arg: '$unknown_named_arg'\n";
308             }
309 0         0 Carp::croak( $message
310             . 'Test::Weaken failed due to unknown named arg(s)' );
311             }
312              
313             } # UNPACK_ARGS
314              
315 54 50       291 if ( my $ref_type = ref $self->{constructor} ) {
316 54 50       225 Carp::croak('Test::Weaken: constructor must be CODE ref')
317             unless ref $self->{constructor} eq 'CODE';
318             }
319              
320 54 100       159 if ( my $ref_type = ref $self->{destructor} ) {
321 6 50       33 Carp::croak('Test::Weaken: destructor must be CODE ref')
322             unless ref $self->{destructor} eq 'CODE';
323             }
324              
325 54 100       158 if ( my $ref_type = ref $self->{contents} ) {
326 6 50       23 Carp::croak('Test::Weaken: contents must be CODE ref')
327             unless ref $self->{contents} eq 'CODE';
328             }
329              
330 54 100       140 if ( my $ref_type = ref $self->{tracked_types} ) {
331 5 50       17 Carp::croak('Test::Weaken: tracked_types must be ARRAY ref')
332             unless ref $self->{tracked_types} eq 'ARRAY';
333             }
334              
335 54 100       127 if (@ignore_classes) {
336             push @ignore_preds, sub {
337 30     30   33 my ($ref) = @_;
338 30 100       75 if (Scalar::Util::blessed($ref)) {
339 20         24 foreach my $class (@ignore_classes) {
340 28 100       147 if ($ref->isa($class)) {
341 12         52 return 1;
342             }
343             }
344             }
345 18         60 return 0;
346 4         16 };
347             }
348              
349             # undefs in ignore objects are skipped
350 54         105 @ignore_objects = grep {defined} @ignore_objects;
  59         182  
351 54 100       116 if (@ignore_objects) {
352             push @ignore_preds, sub {
353 30     30   34 my ($ref) = @_;
354 30         46 $ref = Scalar::Util::refaddr($ref);
355 30         31 foreach my $object (@ignore_objects) {
356 44 100       112 if (Scalar::Util::refaddr($object) == $ref) {
357 12         52 return 1;
358             }
359             }
360 18         54 return 0;
361 4         13 };
362             }
363              
364 54         155 return $self;
365              
366             } # sub new
367              
368             sub Test::Weaken::test {
369              
370 90     90 1 206 my $self = shift;
371              
372 90 50       290 if ( defined $self->{unfreed_probes} ) {
373 0         0 Carp::croak('Test::Weaken tester was already evaluated');
374             }
375              
376 90         141 my $constructor = $self->{constructor};
377 90         147 my $destructor = $self->{destructor};
378             # my $ignore = $self->{ignore};
379 90         136 my $contents = $self->{contents};
380 90         247 my $test = $self->{test};
381              
382 90         258 my @test_object_probe_list = map {\$_} $constructor->();
  112         4512  
383 90         191 foreach my $test_object_probe (@test_object_probe_list) {
384 112 50       133 if ( not ref ${$test_object_probe} ) {
  112         602  
385 0         0 Carp::carp(
386             'Test::Weaken test object constructor returned a non-reference'
387             );
388             }
389             }
390 90         265 my $probes = Test::Weaken::Internal::follow( $self, @test_object_probe_list );
391              
392 86         141 $self->{probe_count} = @{$probes};
  86         228  
393 293         1124 $self->{weak_probe_count} =
394 86 100       126 grep { ref $_ eq 'REF' and Scalar::Util::isweak ${$_} } @{$probes};
  605         1853  
  86         148  
395 86         238 $self->{strong_probe_count} =
396             $self->{probe_count} - $self->{weak_probe_count};
397              
398 86 50       219 if ( not $test ) {
399 0         0 $self->{unfreed_probes} = $probes;
400 0         0 return scalar @{$probes};
  0         0  
401             }
402              
403 86         113 for my $probe ( @{$probes} ) {
  86         174  
404 605         1351 Scalar::Util::weaken($probe);
405             }
406              
407             # Now free everything.
408 86 100       296 if (defined (my $destructor_method = $self->{destructor_method})) {
409 2         3 foreach my $test_object_probe (@test_object_probe_list) {
410 4         1022 my $obj = $$test_object_probe;
411 4         11 $obj->$destructor_method;
412             }
413             }
414 86 100       1186 if (defined $destructor) {
415 13         27 $destructor->( map {$$_} @test_object_probe_list ) ;
  14         71  
416             }
417              
418 86         14165 @test_object_probe_list = ();
419              
420 86         162 my $unfreed_probes = [ grep { defined $_ } @{$probes} ];
  605         1773  
  86         169  
421 86         213 $self->{unfreed_probes} = $unfreed_probes;
422              
423 86         120 return scalar @{$unfreed_probes};
  86         325  
424              
425             } # sub test
426              
427             # Undocumented and deprecated
428             sub poof_array_return {
429              
430 2     2   5 my $tester = shift;
431 2         12 my $results = $tester->{unfreed_probes};
432              
433 2         5 my @unfreed_strong = ();
434 2         3 my @unfreed_weak = ();
435 2         4 for my $probe ( @{$results} ) {
  2         5  
436 12 100 100     40 if ( ref $probe eq 'REF' and Scalar::Util::isweak ${$probe} ) {
  8         30  
437 2         6 push @unfreed_weak, $probe;
438             }
439             else {
440 10         22 push @unfreed_strong, $probe;
441             }
442             }
443              
444             return (
445 2         21 $tester->weak_probe_count(),
446             $tester->strong_probe_count(),
447             \@unfreed_weak, \@unfreed_strong
448             );
449              
450             } ## end sub poof_array_return;
451              
452             sub Test::Weaken::poof {
453 2     2 1 518 my @args = @_;
454 2         17 my $tester = Test::Weaken->new(@args);
455 2         8 my $result = $tester->test();
456 2 50       13 return Test::Weaken::Internal::poof_array_return($tester) if wantarray;
457 0         0 return $result;
458             }
459              
460             sub Test::Weaken::leaks {
461 78     78 1 37025 my @args = @_;
462 78         416 my $tester = Test::Weaken->new(@args);
463 78         225 my $result = $tester->test();
464 74 100       278 return $tester if $result;
465 31         239 return;
466             }
467              
468             sub Test::Weaken::unfreed_proberefs {
469 25     25 1 1454 my $tester = shift;
470 25         49 my $result = $tester->{unfreed_probes};
471 25 50       82 if ( not defined $result ) {
472 0         0 Carp::croak('Results not available for this Test::Weaken object');
473             }
474 25         74 return $result;
475             }
476              
477             sub Test::Weaken::unfreed_count {
478 25     25 1 4764 my $tester = shift;
479 25         42 my $result = $tester->{unfreed_probes};
480 25 50       65 if ( not defined $result ) {
481 0         0 Carp::croak('Results not available for this Test::Weaken object');
482             }
483 25         30 return scalar @{$result};
  25         112  
484             }
485              
486             sub Test::Weaken::probe_count {
487 5     5 1 37 my $tester = shift;
488 5         11 my $count = $tester->{probe_count};
489 5 50       18 if ( not defined $count ) {
490 0         0 Carp::croak('Results not available for this Test::Weaken object');
491             }
492 5         47 return $count;
493             }
494              
495             # Undocumented and deprecated
496             sub Test::Weaken::weak_probe_count {
497 10     10 0 161 my $tester = shift;
498 10         18 my $count = $tester->{weak_probe_count};
499 10 50       26 if ( not defined $count ) {
500 0         0 Carp::croak('Results not available for this Test::Weaken object');
501             }
502 10         58 return $count;
503             }
504              
505             # Undocumented and deprecated
506             sub Test::Weaken::strong_probe_count {
507 10     10 0 54 my $tester = shift;
508 10         18 my $count = $tester->{strong_probe_count};
509 10 50       34 if ( not defined $count ) {
510 0         0 Carp::croak('Results not available for this Test::Weaken object');
511             }
512 10         84 return $count;
513             }
514              
515             sub Test::Weaken::check_ignore {
516 18     18 1 29648 my ( $ignore, $max_errors, $compare_depth, $reporting_depth ) = @_;
517              
518 18         32 my $error_count = 0;
519              
520 18 100       56 $max_errors = 1 if not defined $max_errors;
521 18 50       98 if ( not Scalar::Util::looks_like_number($max_errors) ) {
522 0         0 Carp::croak('Test::Weaken::check_ignore max_errors must be a number');
523             }
524 18 100       49 $max_errors = 0 if $max_errors <= 0;
525              
526 18 100       43 $reporting_depth = -1 if not defined $reporting_depth;
527 18 50       130 if ( not Scalar::Util::looks_like_number($reporting_depth) ) {
528 0         0 Carp::croak(
529             'Test::Weaken::check_ignore reporting_depth must be a number');
530             }
531 18 100       44 $reporting_depth = -1 if $reporting_depth < 0;
532              
533 18 100       134 $compare_depth = 0 if not defined $compare_depth;
534 18 50 33     172 if ( not Scalar::Util::looks_like_number($compare_depth)
535             or $compare_depth < 0 )
536             {
537 0         0 Carp::croak(
538             'Test::Weaken::check_ignore compare_depth must be a non-negative number'
539             );
540             }
541              
542             return sub {
543 239     239   284 my ($probe_ref) = @_;
544              
545 239         296 my $array_context = wantarray;
546              
547             my $before_weak =
548             ( ref $probe_ref eq 'REF'
549 239   100     595 and Scalar::Util::isweak( ${$probe_ref} ) );
550 239         5472 my $before_dump =
551             Data::Dumper->new( [$probe_ref], [qw(proberef)] )
552             ->Maxdepth($compare_depth)->Dump();
553 239         14805 my $before_reporting_dump;
554 239 100       571 if ( $reporting_depth >= 0 ) {
555             #<<< perltidy doesn't do this well
556 150         614 $before_reporting_dump =
557             Data::Dumper->new(
558             [$probe_ref],
559             [qw(proberef_before_callback)]
560             )
561             ->Maxdepth($reporting_depth)
562             ->Dump();
563             #>>>
564             }
565              
566 239         8667 my $scalar_return_value;
567             my @array_return_value;
568 239 50       453 if ($array_context) {
569 0         0 @array_return_value = $ignore->($probe_ref);
570             }
571             else {
572 239         524 $scalar_return_value = $ignore->($probe_ref);
573             }
574              
575             my $after_weak =
576             ( ref $probe_ref eq 'REF'
577 239   66     2607 and Scalar::Util::isweak( ${$probe_ref} ) );
578 239         971 my $after_dump =
579             Data::Dumper->new( [$probe_ref], [qw(proberef)] )
580             ->Maxdepth($compare_depth)->Dump();
581 239         13650 my $after_reporting_dump;
582 239 100       538 if ( $reporting_depth >= 0 ) {
583             #<<< perltidy doesn't do this well
584 150         596 $after_reporting_dump =
585             Data::Dumper->new(
586             [$probe_ref],
587             [qw(proberef_after_callback)]
588             )
589             ->Maxdepth($reporting_depth)
590             ->Dump();
591             #<<<
592             }
593              
594 239         8408 my $problems = q{};
595 239         274 my $include_before = 0;
596 239         252 my $include_after = 0;
597              
598 239 100       483 if ( $before_weak != $after_weak ) {
599 1 50       4 my $changed = $before_weak ? 'strengthened' : 'weakened';
600 1         4 $problems .= "Probe referent $changed by ignore call\n";
601 1         3 $include_before = defined $before_reporting_dump;
602             }
603 239 100       453 if ( $before_dump ne $after_dump ) {
604 27         46 $problems .= "Probe referent changed by ignore call\n";
605 27         36 $include_before = defined $before_reporting_dump;
606 27         36 $include_after = defined $after_reporting_dump;
607             }
608              
609 239 100       376 if ($problems) {
610              
611 28         31 $error_count++;
612              
613 28         33 my $message = q{};
614 28 100       50 $message .= $before_reporting_dump
615             if $include_before;
616 28 100       51 $message .= $after_reporting_dump
617             if $include_after;
618 28         38 $message .= $problems;
619              
620 28 100 100     101 if ( $max_errors > 0 and $error_count >= $max_errors ) {
621 4         10 $message
622             .= "Terminating ignore callbacks after finding $error_count error(s)";
623 4         572 Carp::croak($message);
624             }
625              
626 24         4318 Carp::carp( $message . 'Above errors reported' );
627              
628             }
629              
630 235 50       1923 return $array_context ? @array_return_value : $scalar_return_value;
631              
632 18         216 };
633             }
634              
635             1;
636              
637             __END__