1 # -*- Mode: cperl; cperl-indent-level: 4 -*-
2 package Test::Harness::Straps;
9 use Test::Harness::Assert;
10 use Test::Harness::Iterator;
11 use Test::Harness::Point;
13 # Flags used as return values from our methods. Just for internal
20 Test::Harness::Straps - detailed analysis of test results
24 use Test::Harness::Straps;
26 my $strap = Test::Harness::Straps->new;
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);
34 my %total = $strap->total_results;
36 # Altering the behavior of the strap UNIMPLEMENTED
37 my $verbose_output = $strap->dump_verbose();
38 $strap->dump_verbose_fh($output_filehandle);
43 B<THIS IS ALPHA SOFTWARE> in that the interface is subject to change
44 in incompatible ways. It is otherwise stable.
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
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
61 my $strap = Test::Harness::Straps->new;
63 Initialize a new strap.
69 my $self = bless {}, $class;
76 =for private $strap->_init
80 Initialize the internal state of a strap to make it ready for parsing.
87 $self->{_is_vms} = ( $^O eq 'VMS' );
88 $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ );
89 $self->{_is_macos} = ( $^O eq 'MacOS' );
94 =head2 $strap->analyze( $name, \@output_lines )
96 my %results = $strap->analyze($name, \@test_output);
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.
102 C<@test_output> should be the raw output from the test, including
108 my($self, $name, $test_output) = @_;
110 my $it = Test::Harness::Iterator->new($test_output);
111 return $self->_analyze_iterator($name, $it);
115 sub _analyze_iterator {
116 my($self, $name, $it) = @_;
118 $self->_reset_file_state;
119 $self->{file} = $name;
132 # Set them up here so callbacks can have them.
133 $self->{totals}{$name} = \%totals;
134 while( defined(my $line = $it->next) ) {
135 $self->_analyze_line($line, \%totals);
136 last if $self->{saw_bailout};
139 $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all};
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});
145 $totals{passing} = $passed ? 1 : 0;
159 my $point = Test::Harness::Point->from_test_line( $line );
164 $point->set_number( $self->{'next'} ) unless $point->number;
166 # sometimes the 'not ' and the 'ok' are on different lines,
167 # happens often on VMS if you do:
168 # print "not " unless $test;
170 if ( $self->{lone_not_line} && ($self->{lone_not_line} == $self->{line} - 1) ) {
174 if ( $self->{todo}{$point->number} ) {
175 $point->set_directive_type( 'todo' );
178 if ( $point->is_todo ) {
180 $totals->{bonus}++ if $point->ok;
182 elsif ( $point->is_skip ) {
186 $totals->{ok}++ if $point->pass;
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";
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 ),
203 assert( defined( $details->{ok} ) && defined( $details->{actual_ok} ) );
204 $totals->{details}[$point->number - 1] = $details;
207 elsif ( $line =~ /^not\s+$/ ) {
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};
213 elsif ( $self->_is_header($line) ) {
214 $linetype = 'header';
216 $self->{saw_header}++;
218 $totals->{max} += $self->{max};
220 elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
221 $linetype = 'bailout';
222 $self->{saw_bailout} = 1;
224 elsif (my $diagnostics = $self->_is_diagnostic_line( $line )) {
226 my $test = $totals->{details}[-1];
227 $test->{diagnostics} ||= '';
228 $test->{diagnostics} .= $diagnostics;
234 $self->{callback}->($self, $line, $linetype, $totals) if $self->{callback};
236 $self->{'next'} = $point->number + 1 if $point;
240 sub _is_diagnostic_line {
241 my ($self, $line) = @_;
242 return if index( $line, '# Looks like you failed' ) == 0;
247 =for private $strap->analyze_fh( $name, $test_filehandle )
249 my %results = $strap->analyze_fh($name, $test_filehandle);
251 Like C<analyze>, but it reads from the given filehandle.
256 my($self, $name, $fh) = @_;
258 my $it = Test::Harness::Iterator->new($fh);
259 return $self->_analyze_iterator($name, $it);
262 =head2 $strap->analyze_file( $test_file )
264 my %results = $strap->analyze_file($test_file);
266 Like C<analyze>, but it runs the given C<$test_file> and parses its
267 results. It will also use that name for the total report.
272 my($self, $file) = @_;
275 $self->{error} = "$file does not exist";
280 $self->{error} = "$file is not readable";
284 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
285 if ( $Test::Harness::Debug ) {
286 local $^W=0; # ignore undef warnings
287 print "# PERL5LIB=$ENV{PERL5LIB}\n";
290 # *sigh* this breaks under taint, but open -| is unportable.
291 my $line = $self->_command_line($file);
293 unless ( open(FILE, "$line|" )) {
294 print "can't run $file. $!\n";
298 my %results = $self->analyze_fh($file, \*FILE);
299 my $exit = close FILE;
300 $results{'wait'} = $?;
301 if( $? && $self->{_is_vms} ) {
302 eval q{use vmsish "status"; $results{'exit'} = $?};
305 $results{'exit'} = _wait2exit($?);
307 $results{passing} = 0 unless $? == 0;
309 $self->_restore_PERL5LIB();
315 eval { require POSIX; &POSIX::WEXITSTATUS(0) };
317 *_wait2exit = sub { $_[0] >> 8 };
320 *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) }
323 =for private $strap->_command_line( $file )
325 Returns the full command line that will be run to test I<$file>.
333 my $command = $self->_command();
334 my $switches = $self->_switches($file);
336 $file = qq["$file"] if ($file =~ /\s/) && ($file !~ /^".*"$/);
337 my $line = "$command $switches $file";
343 =for private $strap->_command()
345 Returns the command that runs the test. Combine this with C<_switches()>
346 to build a command line.
348 Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}>
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.
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.
360 return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
361 return qq["$^X"] if $self->{_is_win32} && ($^X =~ /[^\w\.\/\\]/);
366 =for private $strap->_switches( $file )
368 Formats and returns the switches necessary to run the test.
373 my($self, $file) = @_;
375 my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} );
376 my @derived_switches;
379 open(TEST, $file) or print "can't open $file. $!\n";
380 my $shebang = <TEST>;
381 close(TEST) or print "can't close $file. $!\n";
383 my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
384 push( @derived_switches, "-$1" ) if $taint;
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;
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.
397 for ( @derived_switches ) {
398 $_ = qq["$_"] if ((/\s/ || $self->{_is_vms}) && !/^".*"$/ );
400 return join( " ", @existing_switches, @derived_switches );
403 =for private $strap->_cleaned_switches( @switches_from_user )
405 Returns only defined, non-blank, trimmed switches from the parms passed.
409 sub _cleaned_switches {
417 next unless defined $switch;
420 push( @switches, $switch ) if $switch ne "";
426 =for private $strap->_INC2PERL5LIB
428 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
430 Takes the current value of C<@INC> and turns it into something suitable
431 for putting onto C<PERL5LIB>.
438 $self->{_old5lib} = $ENV{PERL5LIB};
440 return join $Config{path_sep}, $self->_filtered_INC;
443 =for private $strap->_filtered_INC()
445 my @filtered_inc = $self->_filtered_INC;
447 Shortens C<@INC> by removing redundant and unnecessary entries.
448 Necessary for OSes with limited command line lengths, like VMS.
453 my($self, @inc) = @_;
454 @inc = @INC unless @inc;
456 if( $self->{_is_vms} ) {
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
459 @inc = grep !/perl_root/i, @inc;
462 elsif ( $self->{_is_win32} ) {
463 # Lose any trailing backslashes in the Win32 paths
464 s/[\\\/+]$// foreach @inc;
468 $seen{$_}++ foreach $self->_default_inc();
469 @inc = grep !$seen{$_}++, @inc;
475 { # Without caching, _default_inc() takes a huge amount of time
479 my $perl = $self->_command;
480 $cache{$perl} ||= [do {
481 local $ENV{PERL5LIB};
482 my @inc =`$perl -le "print join qq[\\n], \@INC"`;
485 return @{$cache{$perl}};
490 =for private $strap->_restore_PERL5LIB()
492 $self->_restore_PERL5LIB;
494 This restores the original value of the C<PERL5LIB> environment variable.
495 Necessary on VMS, otherwise a no-op.
499 sub _restore_PERL5LIB {
502 return unless $self->{_is_vms};
504 if (defined $self->{_old5lib}) {
505 $ENV{PERL5LIB} = $self->{_old5lib};
511 Methods for identifying what sort of line you're looking at.
513 =for private _is_diagnostic
515 my $is_diagnostic = $strap->_is_diagnostic($line, \$comment);
517 Checks if the given line is a comment. If so, it will place it into
518 C<$comment> (sans #).
523 my($self, $line, $comment) = @_;
525 if( $line =~ /^\s*\#(.*)/ ) {
534 =for private _is_header
536 my $is_header = $strap->_is_header($line);
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.
545 # Regex for parsing a header. Will be run with /x
546 my $Extra_Header_Re = <<'REGEX';
548 (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set
549 (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason
553 my($self, $line) = @_;
555 if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
557 assert( $self->{max} >= 0, 'Max # of tests looks right' );
559 if( defined $extra ) {
560 my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
562 $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
564 if( $self->{max} == 0 ) {
565 $reason = '' unless defined $skip and $skip =~ /^Skip/i;
568 $self->{skip_all} = $reason;
578 =for private _is_bail_out
580 my $is_bail_out = $strap->_is_bail_out($line, \$reason);
582 Checks if the line is a "Bail out!". Places the reason for bailing
588 my($self, $line, $reason) = @_;
590 if( $line =~ /^Bail out!\s*(.*)/i ) {
599 =for private _reset_file_state
601 $strap->_reset_file_state;
603 Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
604 etc. so it's ready to parse the next file.
608 sub _reset_file_state {
611 delete @{$self}{qw(max skip_all todo too_many_tests)};
613 $self->{saw_header} = 0;
614 $self->{saw_bailout}= 0;
615 $self->{lone_not_line} = 0;
616 $self->{bailout_reason} = '';
622 The C<%results> returned from C<analyze()> contain the following
625 passing true if the whole test is considered a pass
626 (or skipped), false if its a failure
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
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
636 ok number of tests which passed
637 (including todo and skips)
639 todo number of todo tests seen
640 bonus number of todo tests which
643 skip number of tests skipped
645 So a successful test should have max == seen == ok.
648 There is one final item, the details.
650 details an array ref reporting the result of
651 each test looks like this:
653 $results{details}[$test_num - 1] =
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)
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.
667 See F<examples/mini_harness.plx> for an example of use.
671 Michael G Schwern C<< <schwern at pobox.com> >>, currently maintained by
672 Andy Lester C<< <andy at petdance.com> >>.
681 return $_[0] if defined $_[0];