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