Commit | Line | Data |
13287dd5 |
1 | # -*- Mode: cperl; cperl-indent-level: 4 -*- |
13287dd5 |
2 | package Test::Harness::Straps; |
3 | |
4 | use strict; |
5 | use vars qw($VERSION); |
0cb1540a |
6 | $VERSION = '0.26_01'; |
13287dd5 |
7 | |
c0c1f8c2 |
8 | use Config; |
13287dd5 |
9 | use Test::Harness::Assert; |
10 | use Test::Harness::Iterator; |
c0c1f8c2 |
11 | use Test::Harness::Point; |
5b1ebecd |
12 | use Test::Harness::Results; |
13287dd5 |
13 | |
14 | # Flags used as return values from our methods. Just for internal |
15 | # clarification. |
c0c1f8c2 |
16 | my $YES = (1==1); |
17 | my $NO = !$YES; |
13287dd5 |
18 | |
19 | =head1 NAME |
20 | |
21 | Test::Harness::Straps - detailed analysis of test results |
22 | |
23 | =head1 SYNOPSIS |
24 | |
25 | use Test::Harness::Straps; |
26 | |
27 | my $strap = Test::Harness::Straps->new; |
28 | |
29 | # Various ways to interpret a test |
5b1ebecd |
30 | my $results = $strap->analyze($name, \@test_output); |
31 | my $results = $strap->analyze_fh($name, $test_filehandle); |
32 | my $results = $strap->analyze_file($test_file); |
13287dd5 |
33 | |
34 | # UNIMPLEMENTED |
35 | my %total = $strap->total_results; |
36 | |
37 | # Altering the behavior of the strap UNIMPLEMENTED |
38 | my $verbose_output = $strap->dump_verbose(); |
39 | $strap->dump_verbose_fh($output_filehandle); |
40 | |
41 | |
42 | =head1 DESCRIPTION |
43 | |
44 | B<THIS IS ALPHA SOFTWARE> in that the interface is subject to change |
45 | in incompatible ways. It is otherwise stable. |
46 | |
47 | Test::Harness is limited to printing out its results. This makes |
48 | analysis of the test results difficult for anything but a human. To |
49 | make it easier for programs to work with test results, we provide |
50 | Test::Harness::Straps. Instead of printing the results, straps |
51 | provide them as raw data. You can also configure how the tests are to |
52 | be run. |
53 | |
54 | The interface is currently incomplete. I<Please> contact the author |
55 | if you'd like a feature added or something change or just have |
56 | comments. |
57 | |
c0c1f8c2 |
58 | =head1 CONSTRUCTION |
13287dd5 |
59 | |
c0c1f8c2 |
60 | =head2 new() |
13287dd5 |
61 | |
62 | my $strap = Test::Harness::Straps->new; |
63 | |
64 | Initialize a new strap. |
65 | |
66 | =cut |
67 | |
68 | sub new { |
3c87ea76 |
69 | my $class = shift; |
c0c1f8c2 |
70 | my $self = bless {}, $class; |
13287dd5 |
71 | |
13287dd5 |
72 | $self->_init; |
73 | |
74 | return $self; |
75 | } |
76 | |
20f9f807 |
77 | =for private $strap->_init |
13287dd5 |
78 | |
79 | $strap->_init; |
80 | |
81 | Initialize the internal state of a strap to make it ready for parsing. |
82 | |
83 | =cut |
84 | |
85 | sub _init { |
86 | my($self) = shift; |
87 | |
e4fc8a1e |
88 | $self->{_is_vms} = ( $^O eq 'VMS' ); |
89 | $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ ); |
90 | $self->{_is_macos} = ( $^O eq 'MacOS' ); |
13287dd5 |
91 | } |
92 | |
c0c1f8c2 |
93 | =head1 ANALYSIS |
13287dd5 |
94 | |
3c87ea76 |
95 | =head2 $strap->analyze( $name, \@output_lines ) |
13287dd5 |
96 | |
5b1ebecd |
97 | my $results = $strap->analyze($name, \@test_output); |
13287dd5 |
98 | |
cf2ab31a |
99 | Analyzes the output of a single test, assigning it the given C<$name> |
5b1ebecd |
100 | for use in the total report. Returns the C<$results> of the test. |
cf2ab31a |
101 | See L<Results>. |
13287dd5 |
102 | |
cf2ab31a |
103 | C<@test_output> should be the raw output from the test, including |
104 | newlines. |
13287dd5 |
105 | |
106 | =cut |
107 | |
108 | sub analyze { |
109 | my($self, $name, $test_output) = @_; |
110 | |
111 | my $it = Test::Harness::Iterator->new($test_output); |
112 | return $self->_analyze_iterator($name, $it); |
113 | } |
114 | |
115 | |
116 | sub _analyze_iterator { |
117 | my($self, $name, $it) = @_; |
118 | |
119 | $self->_reset_file_state; |
120 | $self->{file} = $name; |
13287dd5 |
121 | |
5b1ebecd |
122 | my $results = Test::Harness::Results->new; |
13287dd5 |
123 | |
308957f5 |
124 | # Set them up here so callbacks can have them. |
5b1ebecd |
125 | $self->{totals}{$name} = $results; |
13287dd5 |
126 | while( defined(my $line = $it->next) ) { |
5b1ebecd |
127 | $self->_analyze_line($line, $results); |
13287dd5 |
128 | last if $self->{saw_bailout}; |
129 | } |
130 | |
5b1ebecd |
131 | $results->set_skip_all( $self->{skip_all} ) if defined $self->{skip_all}; |
132 | |
133 | my $passed = |
134 | (($results->max == 0) && defined $results->skip_all) || |
135 | ($results->max && |
136 | $results->seen && |
137 | $results->max == $results->seen && |
138 | $results->max == $results->ok); |
356733da |
139 | |
5b1ebecd |
140 | $results->set_passing( $passed ? 1 : 0 ); |
13287dd5 |
141 | |
5b1ebecd |
142 | return $results; |
13287dd5 |
143 | } |
144 | |
145 | |
146 | sub _analyze_line { |
c0c1f8c2 |
147 | my $self = shift; |
148 | my $line = shift; |
5b1ebecd |
149 | my $results = shift; |
308957f5 |
150 | |
13287dd5 |
151 | $self->{line}++; |
152 | |
c0c1f8c2 |
153 | my $linetype; |
154 | my $point = Test::Harness::Point->from_test_line( $line ); |
155 | if ( $point ) { |
156 | $linetype = 'test'; |
13287dd5 |
157 | |
5b1ebecd |
158 | $results->inc_seen; |
c0c1f8c2 |
159 | $point->set_number( $self->{'next'} ) unless $point->number; |
13287dd5 |
160 | |
161 | # sometimes the 'not ' and the 'ok' are on different lines, |
162 | # happens often on VMS if you do: |
163 | # print "not " unless $test; |
164 | # print "ok $num\n"; |
c0c1f8c2 |
165 | if ( $self->{lone_not_line} && ($self->{lone_not_line} == $self->{line} - 1) ) { |
166 | $point->set_ok( 0 ); |
13287dd5 |
167 | } |
168 | |
c0c1f8c2 |
169 | if ( $self->{todo}{$point->number} ) { |
170 | $point->set_directive_type( 'todo' ); |
171 | } |
13287dd5 |
172 | |
c0c1f8c2 |
173 | if ( $point->is_todo ) { |
5b1ebecd |
174 | $results->inc_todo; |
175 | $results->inc_bonus if $point->ok; |
13287dd5 |
176 | } |
c0c1f8c2 |
177 | elsif ( $point->is_skip ) { |
5b1ebecd |
178 | $results->inc_skip; |
13287dd5 |
179 | } |
180 | |
5b1ebecd |
181 | $results->inc_ok if $point->pass; |
13287dd5 |
182 | |
73ea3450 |
183 | if ( ($point->number > 100_000) && ($point->number > ($self->{max}||100_000)) ) { |
184 | if ( !$self->{too_many_tests}++ ) { |
185 | warn "Enormous test number seen [test ", $point->number, "]\n"; |
186 | warn "Can't detailize, too big.\n"; |
187 | } |
356733da |
188 | } |
189 | else { |
3c87ea76 |
190 | my $details = { |
c0c1f8c2 |
191 | ok => $point->pass, |
192 | actual_ok => $point->ok, |
193 | name => _def_or_blank( $point->description ), |
194 | type => _def_or_blank( $point->directive_type ), |
195 | reason => _def_or_blank( $point->directive_reason ), |
3c87ea76 |
196 | }; |
197 | |
198 | assert( defined( $details->{ok} ) && defined( $details->{actual_ok} ) ); |
5b1ebecd |
199 | $results->set_details( $point->number, $details ); |
356733da |
200 | } |
c0c1f8c2 |
201 | } # test point |
202 | elsif ( $line =~ /^not\s+$/ ) { |
203 | $linetype = 'other'; |
204 | # Sometimes the "not " and "ok" will be on separate lines on VMS. |
205 | # We catch this and remember we saw it. |
206 | $self->{lone_not_line} = $self->{line}; |
13287dd5 |
207 | } |
3c87ea76 |
208 | elsif ( $self->_is_header($line) ) { |
c0c1f8c2 |
209 | $linetype = 'header'; |
3c87ea76 |
210 | |
211 | $self->{saw_header}++; |
212 | |
5b1ebecd |
213 | $results->inc_max( $self->{max} ); |
3c87ea76 |
214 | } |
13287dd5 |
215 | elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) { |
c0c1f8c2 |
216 | $linetype = 'bailout'; |
13287dd5 |
217 | $self->{saw_bailout} = 1; |
218 | } |
c0c1f8c2 |
219 | elsif (my $diagnostics = $self->_is_diagnostic_line( $line )) { |
220 | $linetype = 'other'; |
5b1ebecd |
221 | # XXX We can throw this away, really. |
222 | my $test = $results->details->[-1]; |
c0c1f8c2 |
223 | $test->{diagnostics} ||= ''; |
224 | $test->{diagnostics} .= $diagnostics; |
225 | } |
13287dd5 |
226 | else { |
c0c1f8c2 |
227 | $linetype = 'other'; |
13287dd5 |
228 | } |
229 | |
5b1ebecd |
230 | $self->callback->($self, $line, $linetype, $results) if $self->callback; |
13287dd5 |
231 | |
c0c1f8c2 |
232 | $self->{'next'} = $point->number + 1 if $point; |
233 | } # _analyze_line |
234 | |
235 | |
236 | sub _is_diagnostic_line { |
237 | my ($self, $line) = @_; |
238 | return if index( $line, '# Looks like you failed' ) == 0; |
239 | $line =~ s/^#\s//; |
240 | return $line; |
13287dd5 |
241 | } |
242 | |
20f9f807 |
243 | =for private $strap->analyze_fh( $name, $test_filehandle ) |
13287dd5 |
244 | |
5b1ebecd |
245 | my $results = $strap->analyze_fh($name, $test_filehandle); |
13287dd5 |
246 | |
247 | Like C<analyze>, but it reads from the given filehandle. |
248 | |
249 | =cut |
250 | |
251 | sub analyze_fh { |
252 | my($self, $name, $fh) = @_; |
253 | |
254 | my $it = Test::Harness::Iterator->new($fh); |
3c87ea76 |
255 | return $self->_analyze_iterator($name, $it); |
13287dd5 |
256 | } |
257 | |
c0c1f8c2 |
258 | =head2 $strap->analyze_file( $test_file ) |
13287dd5 |
259 | |
5b1ebecd |
260 | my $results = $strap->analyze_file($test_file); |
13287dd5 |
261 | |
cf2ab31a |
262 | Like C<analyze>, but it runs the given C<$test_file> and parses its |
356733da |
263 | results. It will also use that name for the total report. |
13287dd5 |
264 | |
265 | =cut |
266 | |
267 | sub analyze_file { |
268 | my($self, $file) = @_; |
269 | |
0be28027 |
270 | unless( -e $file ) { |
271 | $self->{error} = "$file does not exist"; |
272 | return; |
273 | } |
274 | |
275 | unless( -r $file ) { |
276 | $self->{error} = "$file is not readable"; |
277 | return; |
278 | } |
279 | |
13287dd5 |
280 | local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; |
3c87ea76 |
281 | if ( $Test::Harness::Debug ) { |
282 | local $^W=0; # ignore undef warnings |
283 | print "# PERL5LIB=$ENV{PERL5LIB}\n"; |
284 | } |
13287dd5 |
285 | |
13287dd5 |
286 | # *sigh* this breaks under taint, but open -| is unportable. |
e4fc8a1e |
287 | my $line = $self->_command_line($file); |
c0c1f8c2 |
288 | |
289 | unless ( open(FILE, "$line|" )) { |
13287dd5 |
290 | print "can't run $file. $!\n"; |
291 | return; |
292 | } |
293 | |
5b1ebecd |
294 | my $results = $self->analyze_fh($file, \*FILE); |
c0c1f8c2 |
295 | my $exit = close FILE; |
5b1ebecd |
296 | |
297 | $results->set_wait($?); |
298 | if ( $? && $self->{_is_vms} ) { |
5078fe9d |
299 | $results->set_exit($?); |
f0008e52 |
300 | } |
301 | else { |
5b1ebecd |
302 | $results->set_exit( _wait2exit($?) ); |
f0008e52 |
303 | } |
5b1ebecd |
304 | $results->set_passing(0) unless $? == 0; |
13287dd5 |
305 | |
306 | $self->_restore_PERL5LIB(); |
307 | |
5b1ebecd |
308 | return $results; |
13287dd5 |
309 | } |
310 | |
6e5a998b |
311 | |
312 | eval { require POSIX; &POSIX::WEXITSTATUS(0) }; |
313 | if( $@ ) { |
314 | *_wait2exit = sub { $_[0] >> 8 }; |
315 | } |
316 | else { |
317 | *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) } |
318 | } |
319 | |
20f9f807 |
320 | =for private $strap->_command_line( $file ) |
e4fc8a1e |
321 | |
322 | Returns the full command line that will be run to test I<$file>. |
323 | |
324 | =cut |
325 | |
326 | sub _command_line { |
327 | my $self = shift; |
328 | my $file = shift; |
329 | |
330 | my $command = $self->_command(); |
331 | my $switches = $self->_switches($file); |
332 | |
333 | $file = qq["$file"] if ($file =~ /\s/) && ($file !~ /^".*"$/); |
334 | my $line = "$command $switches $file"; |
335 | |
336 | return $line; |
337 | } |
338 | |
339 | |
20f9f807 |
340 | =for private $strap->_command() |
e4fc8a1e |
341 | |
c0c1f8c2 |
342 | Returns the command that runs the test. Combine this with C<_switches()> |
e4fc8a1e |
343 | to build a command line. |
344 | |
c0c1f8c2 |
345 | Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}> |
e4fc8a1e |
346 | to use a different Perl than what you're running the harness under. |
347 | This might be to run a threaded Perl, for example. |
348 | |
349 | You can also overload this method if you've built your own strap subclass, |
350 | such as a PHP interpreter for a PHP-based strap. |
351 | |
352 | =cut |
353 | |
354 | sub _command { |
355 | my $self = shift; |
356 | |
20f9f807 |
357 | return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL}; |
0cb1540a |
358 | #return qq["$^X"] if $self->{_is_win32} && ($^X =~ /[^\w\.\/\\]/); |
359 | return qq["$^X"] if $^X =~ /\s/ and $^X !~ /^["']/; |
e4fc8a1e |
360 | return $^X; |
361 | } |
362 | |
6e5a998b |
363 | |
20f9f807 |
364 | =for private $strap->_switches( $file ) |
13287dd5 |
365 | |
366 | Formats and returns the switches necessary to run the test. |
367 | |
368 | =cut |
369 | |
370 | sub _switches { |
371 | my($self, $file) = @_; |
372 | |
e4fc8a1e |
373 | my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} ); |
374 | my @derived_switches; |
375 | |
13287dd5 |
376 | local *TEST; |
377 | open(TEST, $file) or print "can't open $file. $!\n"; |
e4fc8a1e |
378 | my $shebang = <TEST>; |
379 | close(TEST) or print "can't close $file. $!\n"; |
380 | |
381 | my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ ); |
382 | push( @derived_switches, "-$1" ) if $taint; |
383 | |
384 | # When taint mode is on, PERL5LIB is ignored. So we need to put |
385 | # all that on the command line as -Is. |
386 | # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not. |
387 | if ( $taint || $self->{_is_macos} ) { |
388 | my @inc = $self->_filtered_INC; |
389 | push @derived_switches, map { "-I$_" } @inc; |
11c6125c |
390 | } |
e4fc8a1e |
391 | |
60e33a80 |
392 | # Quote the argument if there's any whitespace in it, or if |
393 | # we're VMS, since VMS requires all parms quoted. Also, don't quote |
394 | # it if it's already quoted. |
e4fc8a1e |
395 | for ( @derived_switches ) { |
60e33a80 |
396 | $_ = qq["$_"] if ((/\s/ || $self->{_is_vms}) && !/^".*"$/ ); |
11c6125c |
397 | } |
e4fc8a1e |
398 | return join( " ", @existing_switches, @derived_switches ); |
399 | } |
13287dd5 |
400 | |
20f9f807 |
401 | =for private $strap->_cleaned_switches( @switches_from_user ) |
13287dd5 |
402 | |
e4fc8a1e |
403 | Returns only defined, non-blank, trimmed switches from the parms passed. |
404 | |
405 | =cut |
406 | |
407 | sub _cleaned_switches { |
408 | my $self = shift; |
409 | |
410 | local $_; |
411 | |
412 | my @switches; |
413 | for ( @_ ) { |
414 | my $switch = $_; |
415 | next unless defined $switch; |
416 | $switch =~ s/^\s+//; |
417 | $switch =~ s/\s+$//; |
418 | push( @switches, $switch ) if $switch ne ""; |
419 | } |
420 | |
421 | return @switches; |
422 | } |
13287dd5 |
423 | |
20f9f807 |
424 | =for private $strap->_INC2PERL5LIB |
13287dd5 |
425 | |
426 | local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; |
427 | |
cf2ab31a |
428 | Takes the current value of C<@INC> and turns it into something suitable |
429 | for putting onto C<PERL5LIB>. |
13287dd5 |
430 | |
431 | =cut |
432 | |
433 | sub _INC2PERL5LIB { |
434 | my($self) = shift; |
435 | |
436 | $self->{_old5lib} = $ENV{PERL5LIB}; |
437 | |
27caa5c1 |
438 | return join $Config{path_sep}, $self->_filtered_INC; |
d5d4ec93 |
439 | } |
13287dd5 |
440 | |
20f9f807 |
441 | =for private $strap->_filtered_INC() |
13287dd5 |
442 | |
443 | my @filtered_inc = $self->_filtered_INC; |
444 | |
cf2ab31a |
445 | Shortens C<@INC> by removing redundant and unnecessary entries. |
446 | Necessary for OSes with limited command line lengths, like VMS. |
13287dd5 |
447 | |
448 | =cut |
449 | |
450 | sub _filtered_INC { |
451 | my($self, @inc) = @_; |
452 | @inc = @INC unless @inc; |
453 | |
13287dd5 |
454 | if( $self->{_is_vms} ) { |
e4fc8a1e |
455 | # VMS has a 255-byte limit on the length of %ENV entries, so |
456 | # toss the ones that involve perl_root, the install location |
13287dd5 |
457 | @inc = grep !/perl_root/i, @inc; |
e4fc8a1e |
458 | |
ca09b021 |
459 | } |
460 | elsif ( $self->{_is_win32} ) { |
e4fc8a1e |
461 | # Lose any trailing backslashes in the Win32 paths |
462 | s/[\\\/+]$// foreach @inc; |
13287dd5 |
463 | } |
464 | |
3c87ea76 |
465 | my %seen; |
466 | $seen{$_}++ foreach $self->_default_inc(); |
467 | @inc = grep !$seen{$_}++, @inc; |
468 | |
469 | return @inc; |
470 | } |
471 | |
e4fc8a1e |
472 | |
ea5423ed |
473 | { # Without caching, _default_inc() takes a huge amount of time |
474 | my %cache; |
475 | sub _default_inc { |
476 | my $self = shift; |
477 | my $perl = $self->_command; |
478 | $cache{$perl} ||= [do { |
479 | local $ENV{PERL5LIB}; |
480 | my @inc =`$perl -le "print join qq[\\n], \@INC"`; |
481 | chomp @inc; |
482 | }]; |
483 | return @{$cache{$perl}}; |
484 | } |
13287dd5 |
485 | } |
486 | |
487 | |
20f9f807 |
488 | =for private $strap->_restore_PERL5LIB() |
13287dd5 |
489 | |
490 | $self->_restore_PERL5LIB; |
491 | |
cf2ab31a |
492 | This restores the original value of the C<PERL5LIB> environment variable. |
13287dd5 |
493 | Necessary on VMS, otherwise a no-op. |
494 | |
495 | =cut |
496 | |
497 | sub _restore_PERL5LIB { |
498 | my($self) = shift; |
499 | |
500 | return unless $self->{_is_vms}; |
501 | |
502 | if (defined $self->{_old5lib}) { |
503 | $ENV{PERL5LIB} = $self->{_old5lib}; |
504 | } |
505 | } |
d5d4ec93 |
506 | |
cf2ab31a |
507 | =head1 Parsing |
13287dd5 |
508 | |
509 | Methods for identifying what sort of line you're looking at. |
510 | |
20f9f807 |
511 | =for private _is_diagnostic |
13287dd5 |
512 | |
c0c1f8c2 |
513 | my $is_diagnostic = $strap->_is_diagnostic($line, \$comment); |
13287dd5 |
514 | |
515 | Checks if the given line is a comment. If so, it will place it into |
cf2ab31a |
516 | C<$comment> (sans #). |
13287dd5 |
517 | |
518 | =cut |
519 | |
c0c1f8c2 |
520 | sub _is_diagnostic { |
13287dd5 |
521 | my($self, $line, $comment) = @_; |
522 | |
523 | if( $line =~ /^\s*\#(.*)/ ) { |
524 | $$comment = $1; |
525 | return $YES; |
526 | } |
527 | else { |
528 | return $NO; |
529 | } |
530 | } |
531 | |
20f9f807 |
532 | =for private _is_header |
13287dd5 |
533 | |
534 | my $is_header = $strap->_is_header($line); |
535 | |
cf2ab31a |
536 | Checks if the given line is a header (1..M) line. If so, it places how |
537 | many tests there will be in C<< $strap->{max} >>, a list of which tests |
538 | are todo in C<< $strap->{todo} >> and if the whole test was skipped |
539 | C<< $strap->{skip_all} >> contains the reason. |
13287dd5 |
540 | |
541 | =cut |
542 | |
543 | # Regex for parsing a header. Will be run with /x |
544 | my $Extra_Header_Re = <<'REGEX'; |
545 | ^ |
546 | (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set |
547 | (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason |
548 | REGEX |
549 | |
550 | sub _is_header { |
551 | my($self, $line) = @_; |
552 | |
553 | if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) { |
554 | $self->{max} = $max; |
555 | assert( $self->{max} >= 0, 'Max # of tests looks right' ); |
0be28027 |
556 | |
557 | if( defined $extra ) { |
13287dd5 |
558 | my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo; |
559 | |
560 | $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo; |
561 | |
a72fde19 |
562 | if( $self->{max} == 0 ) { |
563 | $reason = '' unless defined $skip and $skip =~ /^Skip/i; |
564 | } |
565 | |
566 | $self->{skip_all} = $reason; |
13287dd5 |
567 | } |
568 | |
569 | return $YES; |
570 | } |
571 | else { |
572 | return $NO; |
573 | } |
574 | } |
575 | |
20f9f807 |
576 | =for private _is_bail_out |
13287dd5 |
577 | |
578 | my $is_bail_out = $strap->_is_bail_out($line, \$reason); |
579 | |
580 | Checks if the line is a "Bail out!". Places the reason for bailing |
581 | (if any) in $reason. |
582 | |
583 | =cut |
584 | |
585 | sub _is_bail_out { |
586 | my($self, $line, $reason) = @_; |
587 | |
588 | if( $line =~ /^Bail out!\s*(.*)/i ) { |
589 | $$reason = $1 if $1; |
590 | return $YES; |
591 | } |
592 | else { |
593 | return $NO; |
594 | } |
595 | } |
596 | |
20f9f807 |
597 | =for private _reset_file_state |
13287dd5 |
598 | |
599 | $strap->_reset_file_state; |
600 | |
cf2ab31a |
601 | Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>, |
602 | etc. so it's ready to parse the next file. |
13287dd5 |
603 | |
604 | =cut |
605 | |
606 | sub _reset_file_state { |
607 | my($self) = shift; |
608 | |
73ea3450 |
609 | delete @{$self}{qw(max skip_all todo too_many_tests)}; |
13287dd5 |
610 | $self->{line} = 0; |
611 | $self->{saw_header} = 0; |
612 | $self->{saw_bailout}= 0; |
13287dd5 |
613 | $self->{lone_not_line} = 0; |
614 | $self->{bailout_reason} = ''; |
615 | $self->{'next'} = 1; |
616 | } |
617 | |
13287dd5 |
618 | =head1 EXAMPLES |
619 | |
620 | See F<examples/mini_harness.plx> for an example of use. |
621 | |
622 | =head1 AUTHOR |
623 | |
20f9f807 |
624 | Michael G Schwern C<< <schwern at pobox.com> >>, currently maintained by |
625 | Andy Lester C<< <andy at petdance.com> >>. |
13287dd5 |
626 | |
627 | =head1 SEE ALSO |
628 | |
629 | L<Test::Harness> |
630 | |
631 | =cut |
632 | |
c0c1f8c2 |
633 | sub _def_or_blank { |
634 | return $_[0] if defined $_[0]; |
635 | return ""; |
636 | } |
637 | |
5b1ebecd |
638 | sub set_callback { |
639 | my $self = shift; |
640 | $self->{callback} = shift; |
641 | } |
642 | |
643 | sub callback { |
644 | my $self = shift; |
645 | return $self->{callback}; |
646 | } |
647 | |
13287dd5 |
648 | 1; |