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;
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 =head2 $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 =head2 $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 =head2 $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 =head2 $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 =head2 $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 =head2 $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 =head2 $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;
478 local $ENV{PERL5LIB};
479 my $perl = $self->_command;
480 my @inc =`$perl -le "print join qq[\\n], \@INC"`;
486 =head2 $strap->_restore_PERL5LIB()
488 $self->_restore_PERL5LIB;
490 This restores the original value of the C<PERL5LIB> environment variable.
491 Necessary on VMS, otherwise a no-op.
495 sub _restore_PERL5LIB {
498 return unless $self->{_is_vms};
500 if (defined $self->{_old5lib}) {
501 $ENV{PERL5LIB} = $self->{_old5lib};
507 Methods for identifying what sort of line you're looking at.
509 =head2 C<_is_diagnostic>
511 my $is_diagnostic = $strap->_is_diagnostic($line, \$comment);
513 Checks if the given line is a comment. If so, it will place it into
514 C<$comment> (sans #).
519 my($self, $line, $comment) = @_;
521 if( $line =~ /^\s*\#(.*)/ ) {
532 my $is_header = $strap->_is_header($line);
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.
541 # Regex for parsing a header. Will be run with /x
542 my $Extra_Header_Re = <<'REGEX';
544 (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set
545 (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason
549 my($self, $line) = @_;
551 if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
553 assert
( $self->{max
} >= 0, 'Max # of tests looks right' );
555 if( defined $extra ) {
556 my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
558 $self->{todo
} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
560 if( $self->{max
} == 0 ) {
561 $reason = '' unless defined $skip and $skip =~ /^Skip/i;
564 $self->{skip_all
} = $reason;
574 =head2 C<_is_bail_out>
576 my $is_bail_out = $strap->_is_bail_out($line, \$reason);
578 Checks if the line is a "Bail out!". Places the reason for bailing
584 my($self, $line, $reason) = @_;
586 if( $line =~ /^Bail out!\s*(.*)/i ) {
595 =head2 C<_reset_file_state>
597 $strap->_reset_file_state;
599 Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
600 etc. so it's ready to parse the next file.
604 sub _reset_file_state
{
607 delete @
{$self}{qw(max skip_all todo too_many_tests)};
609 $self->{saw_header
} = 0;
610 $self->{saw_bailout
}= 0;
611 $self->{lone_not_line
} = 0;
612 $self->{bailout_reason
} = '';
618 The C<%results> returned from C<analyze()> contain the following
621 passing true if the whole test is considered a pass
622 (or skipped), false if its a failure
624 exit the exit code of the test run, if from a file
625 wait the wait code of the test run, if from a file
627 max total tests which should have been run
628 seen total tests actually seen
629 skip_all if the whole test was skipped, this will
632 ok number of tests which passed
633 (including todo and skips)
635 todo number of todo tests seen
636 bonus number of todo tests which
639 skip number of tests skipped
641 So a successful test should have max == seen == ok.
644 There is one final item, the details.
646 details an array ref reporting the result of
647 each test looks like this:
649 $results{details}[$test_num - 1] =
650 { ok => is the test considered ok?
651 actual_ok => did it literally say 'ok'?
652 name => name of the test (if any)
653 diagnostics => test diagnostics (if any)
654 type => 'skip' or 'todo' (if any)
655 reason => reason for the above (if any)
658 Element 0 of the details is test #1. I tried it with element 1 being
659 #1 and 0 being empty, this is less awkward.
663 See F<examples/mini_harness.plx> for an example of use.
667 Michael G Schwern C<< <schwern@pobox.com> >>, currently maintained by
668 Andy Lester C<< <andy@petdance.com> >>.
677 return $_[0] if defined $_[0];