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