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