1 # -*- Mode: cperl; cperl-indent-level: 4 -*-
2 # $Id: Straps.pm,v 1.17 2003/04/03 17:47:25 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
67 my $strap = Test::Harness::Straps->new;
69 Initialize a new strap.
75 my($class) = ref $proto || $proto;
77 my $self = bless {}, $class;
89 Initialize the internal state of a strap to make it ready for parsing.
96 $self->{_is_vms} = $^O eq 'VMS';
97 $self->{_is_win32} = $^O eq 'Win32';
110 my %results = $strap->analyze($name, \@test_output);
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
116 @test_output should be the raw output from the test, including newlines.
121 my($self, $name, $test_output) = @_;
123 my $it = Test::Harness::Iterator->new($test_output);
124 return $self->_analyze_iterator($name, $it);
128 sub _analyze_iterator {
129 my($self, $name, $it) = @_;
131 $self->_reset_file_state;
132 $self->{file} = $name;
145 # Set them up here so callbacks can have them.
146 $self->{totals}{$name} = \%totals;
147 while( defined(my $line = $it->next) ) {
148 $self->_analyze_line($line, \%totals);
149 last if $self->{saw_bailout};
152 $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all};
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});
158 $totals{passing} = $passed ? 1 : 0;
165 my($self, $line, $totals) = @_;
172 if( $self->_is_header($line) ) {
175 $self->{saw_header}++;
177 $totals->{max} += $self->{max};
179 elsif( $self->_is_test($line, \%result) ) {
183 $result{number} = $self->{'next'} unless $result{number};
185 # sometimes the 'not ' and the 'ok' are on different lines,
186 # happens often on VMS if you do:
187 # print "not " unless $test;
189 if( $self->{saw_lone_not} &&
190 ($self->{lone_not_line} == $self->{line} - 1) )
195 my $pass = $result{ok};
196 $result{type} = 'todo' if $self->{todo}{$result{number}};
198 if( $result{type} eq 'todo' ) {
201 $totals->{bonus}++ if $result{ok}
203 elsif( $result{type} eq 'skip' ) {
208 $totals->{ok}++ if $pass;
210 if( $result{number} > 100000 && $result{number} > $self->{max} ) {
211 warn "Enormous test number seen [test $result{number}]\n";
212 warn "Can't detailize, too big.\n";
215 $totals->{details}[$result{number} - 1] =
216 {$self->_detailize($pass, \%result)};
219 # XXX handle counter mismatch
221 elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
223 $self->{saw_bailout} = 1;
229 $self->{callback}->($self, $line, $type, $totals) if $self->{callback};
231 $self->{'next'} = $result{number} + 1 if $type eq 'test';
236 my %results = $strap->analyze_fh($name, $test_filehandle);
238 Like C<analyze>, but it reads from the given filehandle.
243 my($self, $name, $fh) = @_;
245 my $it = Test::Harness::Iterator->new($fh);
246 $self->_analyze_iterator($name, $it);
249 =item B<analyze_file>
251 my %results = $strap->analyze_file($test_file);
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.
259 my($self, $file) = @_;
262 $self->{error} = "$file does not exist";
267 $self->{error} = "$file is not readable";
271 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
273 my $cmd = $self->{_is_vms} ? "MCR $^X" :
274 $self->{_is_win32} ? Win32::GetShortPathName($^X)
277 my $switches = $self->_switches($file);
279 # *sigh* this breaks under taint, but open -| is unportable.
280 unless( open(FILE, "$cmd $switches $file|") ) {
281 print "can't run $file. $!\n";
285 my %results = $self->analyze_fh($file, \*FILE);
286 my $exit = close FILE;
287 $results{'wait'} = $?;
288 if( $? && $self->{_is_vms} ) {
289 eval q{use vmsish "status"; $results{'exit'} = $?};
292 $results{'exit'} = _wait2exit($?);
294 $results{passing} = 0 unless $? == 0;
296 $self->_restore_PERL5LIB();
302 eval { require POSIX; &POSIX::WEXITSTATUS(0) };
304 *_wait2exit = sub { $_[0] >> 8 };
307 *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) }
315 my $switches = $self->_switches($file);
317 Formats and returns the switches necessary to run the test.
322 my($self, $file) = @_;
325 open(TEST, $file) or print "can't open $file. $!\n";
327 my $s = $Test::Harness::Switches || '';
328 $s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
329 if exists $ENV{'HARNESS_PERL_SWITCHES'};
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;
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;
341 close(TEST) or print "can't close $file. $!\n";
347 =item B<_INC2PERL5LIB>
349 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
351 Takes the current value of @INC and turns it into something suitable
352 for putting onto PERL5LIB.
359 $self->{_old5lib} = $ENV{PERL5LIB};
361 return join $Config{path_sep}, $self->_filtered_INC;
364 =item B<_filtered_INC>
366 my @filtered_inc = $self->_filtered_INC;
368 Shortens @INC by removing redundant and unnecessary entries.
369 Necessary for OS's with limited command line lengths, like VMS.
374 my($self, @inc) = @_;
375 @inc = @INC unless @inc;
377 # VMS has a 255-byte limit on the length of %ENV entries, so
378 # toss the ones that involve perl_root, the install location
380 if( $self->{_is_vms} ) {
381 @inc = grep !/perl_root/i, @inc;
388 =item B<_restore_PERL5LIB>
390 $self->_restore_PERL5LIB;
392 This restores the original value of the PERL5LIB environment variable.
393 Necessary on VMS, otherwise a no-op.
397 sub _restore_PERL5LIB {
400 return unless $self->{_is_vms};
402 if (defined $self->{_old5lib}) {
403 $ENV{PERL5LIB} = $self->{_old5lib};
417 Methods for identifying what sort of line you're looking at.
423 my $is_comment = $strap->_is_comment($line, \$comment);
425 Checks if the given line is a comment. If so, it will place it into
431 my($self, $line, $comment) = @_;
433 if( $line =~ /^\s*\#(.*)/ ) {
444 my $is_header = $strap->_is_header($line);
446 Checks if the given line is a header (1..M) line. If so, it places
447 how many tests there will be in $strap->{max}, a list of which tests
448 are todo in $strap->{todo} and if the whole test was skipped
449 $strap->{skip_all} contains the reason.
453 # Regex for parsing a header. Will be run with /x
454 my $Extra_Header_Re = <<'REGEX';
456 (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set
457 (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason
461 my($self, $line) = @_;
463 if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
465 assert( $self->{max} >= 0, 'Max # of tests looks right' );
467 if( defined $extra ) {
468 my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
470 $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
472 if( $self->{max} == 0 ) {
473 $reason = '' unless defined $skip and $skip =~ /^Skip/i;
476 $self->{skip_all} = $reason;
488 my $is_test = $strap->_is_test($line, \%test);
490 Checks if the $line is a test report (ie. 'ok/not ok'). Reports the
491 result back in %test which will contain:
493 ok did it succeed? This is the literal 'ok' or 'not ok'.
494 name name of the test (if any)
495 number test number (if any)
497 type 'todo' or 'skip' (if any)
498 reason why is it todo or skip? (if any)
500 If will also catch lone 'not' lines, note it saw them
501 $strap->{saw_lone_not} and the line in $strap->{lone_not_line}.
505 my $Report_Re = <<'REGEX';
509 (?:\s+(\d+))? # optional test number
514 my $Extra_Re = <<'REGEX';
516 (.*?) (?:(?:[^\\]|^)# (.*))?
521 my($self, $line, $test) = @_;
523 # We pulverize the line down into pieces in three parts.
524 if( my($not, $num, $extra) = $line =~ /$Report_Re/ox ) {
525 my($name, $control) = split /(?:[^\\]|^)#/, $extra if $extra;
526 my($type, $reason) = $control =~ /^\s*(\S+)(?:\s+(.*))?$/ if $control;
528 $test->{number} = $num;
529 $test->{ok} = $not ? 0 : 1;
530 $test->{name} = $name;
532 if( defined $type ) {
533 $test->{type} = $type =~ /^TODO$/i ? 'todo' :
534 $type =~ /^Skip/i ? 'skip' : 0;
539 $test->{reason} = $reason;
544 # Sometimes the "not " and "ok" will be on seperate lines on VMS.
545 # We catch this and remember we saw it.
546 if( $line =~ /^not\s+$/ ) {
547 $self->{saw_lone_not} = 1;
548 $self->{lone_not_line} = $self->{line};
555 =item B<_is_bail_out>
557 my $is_bail_out = $strap->_is_bail_out($line, \$reason);
559 Checks if the line is a "Bail out!". Places the reason for bailing
565 my($self, $line, $reason) = @_;
567 if( $line =~ /^Bail out!\s*(.*)/i ) {
576 =item B<_reset_file_state>
578 $strap->_reset_file_state;
580 Resets things like $strap->{max}, $strap->{skip_all}, etc... so its
581 ready to parse the next file.
585 sub _reset_file_state {
588 delete @{$self}{qw(max skip_all todo)};
590 $self->{saw_header} = 0;
591 $self->{saw_bailout}= 0;
592 $self->{saw_lone_not} = 0;
593 $self->{lone_not_line} = 0;
594 $self->{bailout_reason} = '';
605 The %results returned from analyze() contain the following information:
607 passing true if the whole test is considered a pass
608 (or skipped), false if its a failure
610 exit the exit code of the test run, if from a file
611 wait the wait code of the test run, if from a file
613 max total tests which should have been run
614 seen total tests actually seen
615 skip_all if the whole test was skipped, this will
618 ok number of tests which passed
619 (including todo and skips)
621 todo number of todo tests seen
622 bonus number of todo tests which
625 skip number of tests skipped
627 So a successful test should have max == seen == ok.
630 There is one final item, the details.
632 details an array ref reporting the result of
633 each test looks like this:
635 $results{details}[$test_num - 1] =
636 { ok => is the test considered ok?
637 actual_ok => did it literally say 'ok'?
638 name => name of the test (if any)
639 type => 'skip' or 'todo' (if any)
640 reason => reason for the above (if any)
643 Element 0 of the details is test #1. I tried it with element 1 being
644 #1 and 0 being empty, this is less awkward.
652 my %details = $strap->_detailize($pass, \%test);
654 Generates the details based on the last test line seen. $pass is true
655 if it was considered to be a passed test. %test is the results of the
656 test you're summarizing.
661 my($self, $pass, $test) = @_;
663 my %details = ( ok => $pass,
664 actual_ok => $test->{ok}
667 assert( !(grep !defined $details{$_}, keys %details),
668 'test contains the ok and actual_ok info' );
670 # We don't want these to be undef because they are often
671 # checked and don't want the checker to have to deal with
672 # uninitialized vars.
673 foreach my $piece (qw(name type reason)) {
674 $details{$piece} = defined $test->{$piece} ? $test->{$piece} : '';
686 See F<examples/mini_harness.plx> for an example of use.
690 Michael G Schwern E<lt>schwern@pobox.comE<gt>