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 > 100000) && ($point->number > $self->{max}) ) {
189 warn "Enormous test number seen [test ", $point->number, "]\n";
190 warn "Can't detailize, too big.\n";
195 actual_ok => $point->ok,
196 name => _def_or_blank( $point->description ),
197 type => _def_or_blank( $point->directive_type ),
198 reason => _def_or_blank( $point->directive_reason ),
201 assert( defined( $details->{ok} ) && defined( $details->{actual_ok} ) );
202 $totals->{details}[$point->number - 1] = $details;
205 elsif ( $line =~ /^not\s+$/ ) {
207 # Sometimes the "not " and "ok" will be on separate lines on VMS.
208 # We catch this and remember we saw it.
209 $self->{lone_not_line} = $self->{line};
211 elsif ( $self->_is_header($line) ) {
212 $linetype = 'header';
214 $self->{saw_header}++;
216 $totals->{max} += $self->{max};
218 elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
219 $linetype = 'bailout';
220 $self->{saw_bailout} = 1;
222 elsif (my $diagnostics = $self->_is_diagnostic_line( $line )) {
224 my $test = $totals->{details}[-1];
225 $test->{diagnostics} ||= '';
226 $test->{diagnostics} .= $diagnostics;
232 $self->{callback}->($self, $line, $linetype, $totals) if $self->{callback};
234 $self->{'next'} = $point->number + 1 if $point;
238 sub _is_diagnostic_line {
239 my ($self, $line) = @_;
240 return if index( $line, '# Looks like you failed' ) == 0;
245 =head2 $strap->analyze_fh( $name, $test_filehandle )
247 my %results = $strap->analyze_fh($name, $test_filehandle);
249 Like C<analyze>, but it reads from the given filehandle.
254 my($self, $name, $fh) = @_;
256 my $it = Test::Harness::Iterator->new($fh);
257 return $self->_analyze_iterator($name, $it);
260 =head2 $strap->analyze_file( $test_file )
262 my %results = $strap->analyze_file($test_file);
264 Like C<analyze>, but it runs the given C<$test_file> and parses its
265 results. It will also use that name for the total report.
270 my($self, $file) = @_;
273 $self->{error} = "$file does not exist";
278 $self->{error} = "$file is not readable";
282 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
283 if ( $Test::Harness::Debug ) {
284 local $^W=0; # ignore undef warnings
285 print "# PERL5LIB=$ENV{PERL5LIB}\n";
288 # *sigh* this breaks under taint, but open -| is unportable.
289 my $line = $self->_command_line($file);
291 unless ( open(FILE, "$line|" )) {
292 print "can't run $file. $!\n";
296 my %results = $self->analyze_fh($file, \*FILE);
297 my $exit = close FILE;
298 $results{'wait'} = $?;
299 if( $? && $self->{_is_vms} ) {
300 eval q{use vmsish "status"; $results{'exit'} = $?};
303 $results{'exit'} = _wait2exit($?);
305 $results{passing} = 0 unless $? == 0;
307 $self->_restore_PERL5LIB();
313 eval { require POSIX; &POSIX::WEXITSTATUS(0) };
315 *_wait2exit = sub { $_[0] >> 8 };
318 *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) }
321 =head2 $strap->_command_line( $file )
323 Returns the full command line that will be run to test I<$file>.
331 my $command = $self->_command();
332 my $switches = $self->_switches($file);
334 $file = qq["$file"] if ($file =~ /\s/) && ($file !~ /^".*"$/);
335 my $line = "$command $switches $file";
341 =head2 $strap->_command()
343 Returns the command that runs the test. Combine this with C<_switches()>
344 to build a command line.
346 Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}>
347 to use a different Perl than what you're running the harness under.
348 This might be to run a threaded Perl, for example.
350 You can also overload this method if you've built your own strap subclass,
351 such as a PHP interpreter for a PHP-based strap.
358 return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
359 return "MCR $^X" if $self->{_is_vms};
360 return Win32::GetShortPathName($^X) if $self->{_is_win32};
365 =head2 $strap->_switches( $file )
367 Formats and returns the switches necessary to run the test.
372 my($self, $file) = @_;
374 my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} );
375 my @derived_switches;
378 open(TEST, $file) or print "can't open $file. $!\n";
379 my $shebang = <TEST>;
380 close(TEST) or print "can't close $file. $!\n";
382 my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
383 push( @derived_switches, "-$1" ) if $taint;
385 # When taint mode is on, PERL5LIB is ignored. So we need to put
386 # all that on the command line as -Is.
387 # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not.
388 if ( $taint || $self->{_is_macos} ) {
389 my @inc = $self->_filtered_INC;
390 push @derived_switches, map { "-I$_" } @inc;
393 # Quote the argument if there's any whitespace in it, or if
394 # we're VMS, since VMS requires all parms quoted. Also, don't quote
395 # it if it's already quoted.
396 for ( @derived_switches ) {
397 $_ = qq["$_"] if ((/\s/ || $self->{_is_vms}) && !/^".*"$/ );
399 return join( " ", @existing_switches, @derived_switches );
402 =head2 $strap->_cleaned_switches( @switches_from_user )
404 Returns only defined, non-blank, trimmed switches from the parms passed.
408 sub _cleaned_switches {
416 next unless defined $switch;
419 push( @switches, $switch ) if $switch ne "";
425 =head2 $strap->_INC2PERL5LIB
427 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
429 Takes the current value of C<@INC> and turns it into something suitable
430 for putting onto C<PERL5LIB>.
437 $self->{_old5lib} = $ENV{PERL5LIB};
439 return join $Config{path_sep}, $self->_filtered_INC;
442 =head2 $strap->_filtered_INC()
444 my @filtered_inc = $self->_filtered_INC;
446 Shortens C<@INC> by removing redundant and unnecessary entries.
447 Necessary for OSes with limited command line lengths, like VMS.
452 my($self, @inc) = @_;
453 @inc = @INC unless @inc;
455 if( $self->{_is_vms} ) {
456 # VMS has a 255-byte limit on the length of %ENV entries, so
457 # toss the ones that involve perl_root, the install location
458 @inc = grep !/perl_root/i, @inc;
460 } elsif ( $self->{_is_win32} ) {
461 # Lose any trailing backslashes in the Win32 paths
462 s/[\\\/+]$// foreach @inc;
466 $seen{$_}++ foreach $self->_default_inc();
467 @inc = grep !$seen{$_}++, @inc;
476 local $ENV{PERL5LIB};
477 my $perl = $self->_command;
478 my @inc =`$perl -le "print join qq[\\n], \@INC"`;
484 =head2 $strap->_restore_PERL5LIB()
486 $self->_restore_PERL5LIB;
488 This restores the original value of the C<PERL5LIB> environment variable.
489 Necessary on VMS, otherwise a no-op.
493 sub _restore_PERL5LIB {
496 return unless $self->{_is_vms};
498 if (defined $self->{_old5lib}) {
499 $ENV{PERL5LIB} = $self->{_old5lib};
505 Methods for identifying what sort of line you're looking at.
507 =head2 C<_is_diagnostic>
509 my $is_diagnostic = $strap->_is_diagnostic($line, \$comment);
511 Checks if the given line is a comment. If so, it will place it into
512 C<$comment> (sans #).
517 my($self, $line, $comment) = @_;
519 if( $line =~ /^\s*\#(.*)/ ) {
530 my $is_header = $strap->_is_header($line);
532 Checks if the given line is a header (1..M) line. If so, it places how
533 many tests there will be in C<< $strap->{max} >>, a list of which tests
534 are todo in C<< $strap->{todo} >> and if the whole test was skipped
535 C<< $strap->{skip_all} >> contains the reason.
539 # Regex for parsing a header. Will be run with /x
540 my $Extra_Header_Re = <<'REGEX';
542 (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set
543 (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason
547 my($self, $line) = @_;
549 if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
551 assert( $self->{max} >= 0, 'Max # of tests looks right' );
553 if( defined $extra ) {
554 my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
556 $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
558 if( $self->{max} == 0 ) {
559 $reason = '' unless defined $skip and $skip =~ /^Skip/i;
562 $self->{skip_all} = $reason;
572 =head2 C<_is_bail_out>
574 my $is_bail_out = $strap->_is_bail_out($line, \$reason);
576 Checks if the line is a "Bail out!". Places the reason for bailing
582 my($self, $line, $reason) = @_;
584 if( $line =~ /^Bail out!\s*(.*)/i ) {
593 =head2 C<_reset_file_state>
595 $strap->_reset_file_state;
597 Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
598 etc. so it's ready to parse the next file.
602 sub _reset_file_state {
605 delete @{$self}{qw(max skip_all todo)};
607 $self->{saw_header} = 0;
608 $self->{saw_bailout}= 0;
609 $self->{lone_not_line} = 0;
610 $self->{bailout_reason} = '';
616 The C<%results> returned from C<analyze()> contain the following
619 passing true if the whole test is considered a pass
620 (or skipped), false if its a failure
622 exit the exit code of the test run, if from a file
623 wait the wait code of the test run, if from a file
625 max total tests which should have been run
626 seen total tests actually seen
627 skip_all if the whole test was skipped, this will
630 ok number of tests which passed
631 (including todo and skips)
633 todo number of todo tests seen
634 bonus number of todo tests which
637 skip number of tests skipped
639 So a successful test should have max == seen == ok.
642 There is one final item, the details.
644 details an array ref reporting the result of
645 each test looks like this:
647 $results{details}[$test_num - 1] =
648 { ok => is the test considered ok?
649 actual_ok => did it literally say 'ok'?
650 name => name of the test (if any)
651 diagnostics => test diagnostics (if any)
652 type => 'skip' or 'todo' (if any)
653 reason => reason for the above (if any)
656 Element 0 of the details is test #1. I tried it with element 1 being
657 #1 and 0 being empty, this is less awkward.
661 See F<examples/mini_harness.plx> for an example of use.
665 Michael G Schwern C<< <schwern@pobox.com> >>, currently maintained by
666 Andy Lester C<< <andy@petdance.com> >>.
675 return $_[0] if defined $_[0];