1 # -*- Mode: cperl; cperl-indent-level: 4 -*-
2 # $Id: Straps.pm,v 1.34 2003/11/23 00:02:11 andy Exp $
4 package Test::Harness::Straps;
11 use Test::Harness::Assert;
12 use Test::Harness::Iterator;
14 # Flags used as return values from our methods. Just for internal
24 Test::Harness::Straps - detailed analysis of test results
28 use Test::Harness::Straps;
30 my $strap = Test::Harness::Straps->new;
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);
38 my %total = $strap->total_results;
40 # Altering the behavior of the strap UNIMPLEMENTED
41 my $verbose_output = $strap->dump_verbose();
42 $strap->dump_verbose_fh($output_filehandle);
47 B<THIS IS ALPHA SOFTWARE> in that the interface is subject to change
48 in incompatible ways. It is otherwise stable.
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
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
65 my $strap = Test::Harness::Straps->new;
67 Initialize a new strap.
73 my($class) = ref $proto || $proto;
75 my $self = bless {}, $class;
85 Initialize the internal state of a strap to make it ready for parsing.
92 $self->{_is_vms} = ( $^O eq 'VMS' );
93 $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ );
94 $self->{_is_macos} = ( $^O eq 'MacOS' );
101 my %results = $strap->analyze($name, \@test_output);
103 Analyzes the output of a single test, assigning it the given C<$name>
104 for use in the total report. Returns the C<%results> of the test.
107 C<@test_output> should be the raw output from the test, including
113 my($self, $name, $test_output) = @_;
115 my $it = Test::Harness::Iterator->new($test_output);
116 return $self->_analyze_iterator($name, $it);
120 sub _analyze_iterator {
121 my($self, $name, $it) = @_;
123 $self->_reset_file_state;
124 $self->{file} = $name;
137 # Set them up here so callbacks can have them.
138 $self->{totals}{$name} = \%totals;
139 while( defined(my $line = $it->next) ) {
140 $self->_analyze_line($line, \%totals);
141 last if $self->{saw_bailout};
144 $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all};
146 my $passed = ($totals{max} == 0 && defined $totals{skip_all}) ||
147 ($totals{max} && $totals{seen} &&
148 $totals{max} == $totals{seen} &&
149 $totals{max} == $totals{ok});
150 $totals{passing} = $passed ? 1 : 0;
157 my($self, $line, $totals) = @_;
164 if( $self->_is_header($line) ) {
167 $self->{saw_header}++;
169 $totals->{max} += $self->{max};
171 elsif( $self->_is_test($line, \%result) ) {
175 $result{number} = $self->{'next'} unless $result{number};
177 # sometimes the 'not ' and the 'ok' are on different lines,
178 # happens often on VMS if you do:
179 # print "not " unless $test;
181 if( $self->{saw_lone_not} &&
182 ($self->{lone_not_line} == $self->{line} - 1) )
187 my $pass = $result{ok};
188 $result{type} = 'todo' if $self->{todo}{$result{number}};
190 if( $result{type} eq 'todo' ) {
193 $totals->{bonus}++ if $result{ok}
195 elsif( $result{type} eq 'skip' ) {
200 $totals->{ok}++ if $pass;
202 if( $result{number} > 100000 && $result{number} > $self->{max} ) {
203 warn "Enormous test number seen [test $result{number}]\n";
204 warn "Can't detailize, too big.\n";
207 $totals->{details}[$result{number} - 1] =
208 {$self->_detailize($pass, \%result)};
211 # XXX handle counter mismatch
213 elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
215 $self->{saw_bailout} = 1;
221 $self->{callback}->($self, $line, $type, $totals) if $self->{callback};
223 $self->{'next'} = $result{number} + 1 if $type eq 'test';
228 my %results = $strap->analyze_fh($name, $test_filehandle);
230 Like C<analyze>, but it reads from the given filehandle.
235 my($self, $name, $fh) = @_;
237 my $it = Test::Harness::Iterator->new($fh);
238 $self->_analyze_iterator($name, $it);
241 =head2 C<analyze_file>
243 my %results = $strap->analyze_file($test_file);
245 Like C<analyze>, but it runs the given C<$test_file> and parses its
246 results. It will also use that name for the total report.
251 my($self, $file) = @_;
254 $self->{error} = "$file does not exist";
259 $self->{error} = "$file is not readable";
263 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
265 # *sigh* this breaks under taint, but open -| is unportable.
266 my $line = $self->_command_line($file);
267 unless( open(FILE, "$line|") ) {
268 print "can't run $file. $!\n";
272 my %results = $self->analyze_fh($file, \*FILE);
273 my $exit = close FILE;
274 $results{'wait'} = $?;
275 if( $? && $self->{_is_vms} ) {
276 eval q{use vmsish "status"; $results{'exit'} = $?};
279 $results{'exit'} = _wait2exit($?);
281 $results{passing} = 0 unless $? == 0;
283 $self->_restore_PERL5LIB();
289 eval { require POSIX; &POSIX::WEXITSTATUS(0) };
291 *_wait2exit = sub { $_[0] >> 8 };
294 *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) }
297 =head2 C<_command_line( $file )>
299 my $command_line = $self->_command_line();
301 Returns the full command line that will be run to test I<$file>.
309 my $command = $self->_command();
310 my $switches = $self->_switches($file);
312 $file = qq["$file"] if ($file =~ /\s/) && ($file !~ /^".*"$/);
313 my $line = "$command $switches $file";
321 my $command = $self->_command();
323 Returns the command that runs the test. Combine this with _switches()
324 to build a command line.
326 Typically this is C<$^X>, but you can set C<$ENV{HARNESS_COMMAND}>
327 to use a different Perl than what you're running the harness under.
328 This might be to run a threaded Perl, for example.
330 You can also overload this method if you've built your own strap subclass,
331 such as a PHP interpreter for a PHP-based strap.
338 return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
339 return "MCR $^X" if $self->{_is_vms};
340 return Win32::GetShortPathName($^X) if $self->{_is_win32};
347 my $switches = $self->_switches($file);
349 Formats and returns the switches necessary to run the test.
354 my($self, $file) = @_;
356 my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} );
357 my @derived_switches;
360 open(TEST, $file) or print "can't open $file. $!\n";
361 my $shebang = <TEST>;
362 close(TEST) or print "can't close $file. $!\n";
364 my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
365 push( @derived_switches, "-$1" ) if $taint;
367 # When taint mode is on, PERL5LIB is ignored. So we need to put
368 # all that on the command line as -Is.
369 # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not.
370 if ( $taint || $self->{_is_macos} ) {
371 my @inc = $self->_filtered_INC;
372 push @derived_switches, map { "-I$_" } @inc;
375 # Quote all switches to prevent shell interference, or VMS downcasing
376 for ( @derived_switches ) {
377 $_ = qq["$_"] if /\s/ && !/^".*"$/;
379 return join( " ", @existing_switches, @derived_switches );
382 =head2 C<_cleaned_switches>
384 my @switches = $self->_cleaned_switches( @switches_from_user );
386 Returns only defined, non-blank, trimmed switches from the parms passed.
390 sub _cleaned_switches {
398 next unless defined $switch;
401 push( @switches, $switch ) if $switch ne "";
407 =head2 C<_INC2PERL5LIB>
409 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
411 Takes the current value of C<@INC> and turns it into something suitable
412 for putting onto C<PERL5LIB>.
419 $self->{_old5lib} = $ENV{PERL5LIB};
421 return join $Config{path_sep}, $self->_filtered_INC;
424 =head2 C<_filtered_INC>
426 my @filtered_inc = $self->_filtered_INC;
428 Shortens C<@INC> by removing redundant and unnecessary entries.
429 Necessary for OSes with limited command line lengths, like VMS.
434 my($self, @inc) = @_;
435 @inc = @INC unless @inc;
437 if( $self->{_is_vms} ) {
438 # VMS has a 255-byte limit on the length of %ENV entries, so
439 # toss the ones that involve perl_root, the install location
440 @inc = grep !/perl_root/i, @inc;
442 } elsif ( $self->{_is_win32} ) {
443 # Lose any trailing backslashes in the Win32 paths
444 s/[\\\/+]$// foreach @inc;
448 @inc = grep !$dupes{$_}++, @inc;
454 =head2 C<_restore_PERL5LIB>
456 $self->_restore_PERL5LIB;
458 This restores the original value of the C<PERL5LIB> environment variable.
459 Necessary on VMS, otherwise a no-op.
463 sub _restore_PERL5LIB {
466 return unless $self->{_is_vms};
468 if (defined $self->{_old5lib}) {
469 $ENV{PERL5LIB} = $self->{_old5lib};
475 Methods for identifying what sort of line you're looking at.
477 =head2 C<_is_comment>
479 my $is_comment = $strap->_is_comment($line, \$comment);
481 Checks if the given line is a comment. If so, it will place it into
482 C<$comment> (sans #).
487 my($self, $line, $comment) = @_;
489 if( $line =~ /^\s*\#(.*)/ ) {
500 my $is_header = $strap->_is_header($line);
502 Checks if the given line is a header (1..M) line. If so, it places how
503 many tests there will be in C<< $strap->{max} >>, a list of which tests
504 are todo in C<< $strap->{todo} >> and if the whole test was skipped
505 C<< $strap->{skip_all} >> contains the reason.
509 # Regex for parsing a header. Will be run with /x
510 my $Extra_Header_Re = <<'REGEX';
512 (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set
513 (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason
517 my($self, $line) = @_;
519 if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
521 assert( $self->{max} >= 0, 'Max # of tests looks right' );
523 if( defined $extra ) {
524 my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
526 $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
528 if( $self->{max} == 0 ) {
529 $reason = '' unless defined $skip and $skip =~ /^Skip/i;
532 $self->{skip_all} = $reason;
544 my $is_test = $strap->_is_test($line, \%test);
546 Checks if the $line is a test report (ie. 'ok/not ok'). Reports the
547 result back in C<%test> which will contain:
549 ok did it succeed? This is the literal 'ok' or 'not ok'.
550 name name of the test (if any)
551 number test number (if any)
553 type 'todo' or 'skip' (if any)
554 reason why is it todo or skip? (if any)
556 If will also catch lone 'not' lines, note it saw them
557 C<< $strap->{saw_lone_not} >> and the line in C<< $strap->{lone_not_line} >>.
561 my $Report_Re = <<'REGEX';
565 (?:\s+(\d+))? # optional test number
570 my $Extra_Re = <<'REGEX';
572 (.*?) (?:(?:[^\\]|^)# (.*))?
577 my($self, $line, $test) = @_;
579 # We pulverize the line down into pieces in three parts.
580 if( my($not, $num, $extra) = $line =~ /$Report_Re/ox ) {
581 my ($name, $control) = $extra ? split(/(?:[^\\]|^)#/, $extra) : ();
582 my ($type, $reason) = $control ? $control =~ /^\s*(\S+)(?:\s+(.*))?$/ : ();
584 $test->{number} = $num;
585 $test->{ok} = $not ? 0 : 1;
586 $test->{name} = $name;
588 if( defined $type ) {
589 $test->{type} = $type =~ /^TODO$/i ? 'todo' :
590 $type =~ /^Skip/i ? 'skip' : 0;
595 $test->{reason} = $reason;
600 # Sometimes the "not " and "ok" will be on separate lines on VMS.
601 # We catch this and remember we saw it.
602 if( $line =~ /^not\s+$/ ) {
603 $self->{saw_lone_not} = 1;
604 $self->{lone_not_line} = $self->{line};
611 =head2 C<_is_bail_out>
613 my $is_bail_out = $strap->_is_bail_out($line, \$reason);
615 Checks if the line is a "Bail out!". Places the reason for bailing
621 my($self, $line, $reason) = @_;
623 if( $line =~ /^Bail out!\s*(.*)/i ) {
632 =head2 C<_reset_file_state>
634 $strap->_reset_file_state;
636 Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
637 etc. so it's ready to parse the next file.
641 sub _reset_file_state {
644 delete @{$self}{qw(max skip_all todo)};
646 $self->{saw_header} = 0;
647 $self->{saw_bailout}= 0;
648 $self->{saw_lone_not} = 0;
649 $self->{lone_not_line} = 0;
650 $self->{bailout_reason} = '';
656 The C<%results> returned from C<analyze()> contain the following
659 passing true if the whole test is considered a pass
660 (or skipped), false if its a failure
662 exit the exit code of the test run, if from a file
663 wait the wait code of the test run, if from a file
665 max total tests which should have been run
666 seen total tests actually seen
667 skip_all if the whole test was skipped, this will
670 ok number of tests which passed
671 (including todo and skips)
673 todo number of todo tests seen
674 bonus number of todo tests which
677 skip number of tests skipped
679 So a successful test should have max == seen == ok.
682 There is one final item, the details.
684 details an array ref reporting the result of
685 each test looks like this:
687 $results{details}[$test_num - 1] =
688 { ok => is the test considered ok?
689 actual_ok => did it literally say 'ok'?
690 name => name of the test (if any)
691 type => 'skip' or 'todo' (if any)
692 reason => reason for the above (if any)
695 Element 0 of the details is test #1. I tried it with element 1 being
696 #1 and 0 being empty, this is less awkward.
700 my %details = $strap->_detailize($pass, \%test);
702 Generates the details based on the last test line seen. C<$pass> is
703 true if it was considered to be a passed test. C<%test> is the results
704 of the test you're summarizing.
709 my($self, $pass, $test) = @_;
711 my %details = ( ok => $pass,
712 actual_ok => $test->{ok}
715 assert( !(grep !defined $details{$_}, keys %details),
716 'test contains the ok and actual_ok info' );
718 # We don't want these to be undef because they are often
719 # checked and don't want the checker to have to deal with
720 # uninitialized vars.
721 foreach my $piece (qw(name type reason)) {
722 $details{$piece} = defined $test->{$piece} ? $test->{$piece} : '';
730 See F<examples/mini_harness.plx> for an example of use.
734 Michael G Schwern C<< <schwern@pobox.com> >>, currently maintained by
735 Andy Lester C<< <andy@petdance.com> >>.