diff options
Diffstat (limited to 'lib/Test/Harness/Straps.pm')
| -rw-r--r-- | lib/Test/Harness/Straps.pm | 240 |
1 files changed, 91 insertions, 149 deletions
diff --git a/lib/Test/Harness/Straps.pm b/lib/Test/Harness/Straps.pm index c74e47191e..a2b388b6d1 100644 --- a/lib/Test/Harness/Straps.pm +++ b/lib/Test/Harness/Straps.pm @@ -1,23 +1,19 @@ # -*- Mode: cperl; cperl-indent-level: 4 -*- -# $Id: Straps.pm 450 2004-12-20 04:51:42Z andy $ - package Test::Harness::Straps; use strict; use vars qw($VERSION); -use Config; -$VERSION = '0.20_01'; +$VERSION = '0.23'; +use Config; use Test::Harness::Assert; use Test::Harness::Iterator; +use Test::Harness::Point; # Flags used as return values from our methods. Just for internal # clarification. -my $TRUE = (1==1); -my $FALSE = !$TRUE; -my $YES = $TRUE; -my $NO = $FALSE; - +my $YES = (1==1); +my $NO = !$YES; =head1 NAME @@ -58,9 +54,9 @@ The interface is currently incomplete. I<Please> contact the author if you'd like a feature added or something change or just have comments. -=head1 Construction +=head1 CONSTRUCTION -=head2 C<new> +=head2 new() my $strap = Test::Harness::Straps->new; @@ -70,14 +66,14 @@ Initialize a new strap. sub new { my $class = shift; + my $self = bless {}, $class; - my $self = bless {}, $class; $self->_init; return $self; } -=head2 C<_init> +=head2 $strap->_init $strap->_init; @@ -93,11 +89,11 @@ sub _init { $self->{_is_macos} = ( $^O eq 'MacOS' ); } -=head1 Analysis +=head1 ANALYSIS =head2 $strap->analyze( $name, \@output_lines ) - my %results = $strap->analyze($name, \@test_output); + my %results = $strap->analyze($name, \@test_output); Analyzes the output of a single test, assigning it the given C<$name> for use in the total report. Returns the C<%results> of the test. @@ -153,93 +149,102 @@ sub _analyze_iterator { sub _analyze_line { - my($self, $line, $totals) = @_; - - my %result = (); + my $self = shift; + my $line = shift; + my $totals = shift; $self->{line}++; - my $type; - if ( $self->_is_test($line, \%result) ) { - $type = 'test'; + my $linetype; + my $point = Test::Harness::Point->from_test_line( $line ); + if ( $point ) { + $linetype = 'test'; $totals->{seen}++; - $result{number} = $self->{'next'} unless $result{number}; + $point->set_number( $self->{'next'} ) unless $point->number; # sometimes the 'not ' and the 'ok' are on different lines, # happens often on VMS if you do: # print "not " unless $test; # print "ok $num\n"; - if( $self->{saw_lone_not} && - ($self->{lone_not_line} == $self->{line} - 1) ) - { - $result{ok} = 0; + if ( $self->{lone_not_line} && ($self->{lone_not_line} == $self->{line} - 1) ) { + $point->set_ok( 0 ); } - my $pass = $result{ok}; - $result{type} = 'todo' if $self->{todo}{$result{number}}; + if ( $self->{todo}{$point->number} ) { + $point->set_directive_type( 'todo' ); + } - if( $result{type} eq 'todo' ) { + if ( $point->is_todo ) { $totals->{todo}++; - $pass = 1; - $totals->{bonus}++ if $result{ok} + $totals->{bonus}++ if $point->ok; } - elsif( $result{type} eq 'skip' ) { + elsif ( $point->is_skip ) { $totals->{skip}++; - $pass = 1; } - $totals->{ok}++ if $pass; + $totals->{ok}++ if $point->pass; - if( $result{number} > 100000 && $result{number} > $self->{max} ) { - warn "Enormous test number seen [test $result{number}]\n"; + if ( ($point->number > 100000) && ($point->number > $self->{max}) ) { + warn "Enormous test number seen [test ", $point->number, "]\n"; warn "Can't detailize, too big.\n"; } else { - #Generates the details based on the last test line seen. C<$pass> is - #true if it was considered to be a passed test. C<%test> is the results - #of the test you're summarizing. my $details = { - ok => $pass, - actual_ok => $result{ok} + ok => $point->pass, + actual_ok => $point->ok, + name => _def_or_blank( $point->description ), + type => _def_or_blank( $point->directive_type ), + reason => _def_or_blank( $point->directive_reason ), }; assert( defined( $details->{ok} ) && defined( $details->{actual_ok} ) ); - - # We don't want these to be undef because they are often - # checked and don't want the checker to have to deal with - # uninitialized vars. - foreach my $piece (qw(name type reason)) { - $details->{$piece} = defined $result{$piece} ? $result{$piece} : ''; - } - $totals->{details}[$result{number} - 1] = $details; + $totals->{details}[$point->number - 1] = $details; } - - # XXX handle counter mismatch + } # test point + elsif ( $line =~ /^not\s+$/ ) { + $linetype = 'other'; + # Sometimes the "not " and "ok" will be on separate lines on VMS. + # We catch this and remember we saw it. + $self->{lone_not_line} = $self->{line}; } elsif ( $self->_is_header($line) ) { - $type = 'header'; + $linetype = 'header'; $self->{saw_header}++; $totals->{max} += $self->{max}; } elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) { - $type = 'bailout'; + $linetype = 'bailout'; $self->{saw_bailout} = 1; } + elsif (my $diagnostics = $self->_is_diagnostic_line( $line )) { + $linetype = 'other'; + my $test = $totals->{details}[-1]; + $test->{diagnostics} ||= ''; + $test->{diagnostics} .= $diagnostics; + } else { - $type = 'other'; + $linetype = 'other'; } - $self->{callback}->($self, $line, $type, $totals) if $self->{callback}; + $self->{callback}->($self, $line, $linetype, $totals) if $self->{callback}; - $self->{'next'} = $result{number} + 1 if $type eq 'test'; + $self->{'next'} = $point->number + 1 if $point; +} # _analyze_line + + +sub _is_diagnostic_line { + my ($self, $line) = @_; + return if index( $line, '# Looks like you failed' ) == 0; + $line =~ s/^#\s//; + return $line; } -=head2 C<analyze_fh> +=head2 $strap->analyze_fh( $name, $test_filehandle ) - my %results = $strap->analyze_fh($name, $test_filehandle); + my %results = $strap->analyze_fh($name, $test_filehandle); Like C<analyze>, but it reads from the given filehandle. @@ -252,9 +257,9 @@ sub analyze_fh { return $self->_analyze_iterator($name, $it); } -=head2 C<analyze_file> +=head2 $strap->analyze_file( $test_file ) - my %results = $strap->analyze_file($test_file); + my %results = $strap->analyze_file($test_file); Like C<analyze>, but it runs the given C<$test_file> and parses its results. It will also use that name for the total report. @@ -282,13 +287,14 @@ sub analyze_file { # *sigh* this breaks under taint, but open -| is unportable. my $line = $self->_command_line($file); - unless( open(FILE, "$line|") ) { + + unless ( open(FILE, "$line|" )) { print "can't run $file. $!\n"; return; } my %results = $self->analyze_fh($file, \*FILE); - my $exit = close FILE; + my $exit = close FILE; $results{'wait'} = $?; if( $? && $self->{_is_vms} ) { eval q{use vmsish "status"; $results{'exit'} = $?}; @@ -312,9 +318,7 @@ else { *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) } } -=head2 C<_command_line( $file )> - - my $command_line = $self->_command_line(); +=head2 $strap->_command_line( $file ) Returns the full command line that will be run to test I<$file>. @@ -334,14 +338,12 @@ sub _command_line { } -=head2 C<_command> +=head2 $strap->_command() - my $command = $self->_command(); - -Returns the command that runs the test. Combine this with _switches() +Returns the command that runs the test. Combine this with C<_switches()> to build a command line. -Typically this is C<$^X>, but you can set C<$ENV{HARNESS_COMMAND}> +Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}> to use a different Perl than what you're running the harness under. This might be to run a threaded Perl, for example. @@ -360,9 +362,7 @@ sub _command { } -=head2 C<_switches> - - my $switches = $self->_switches($file); +=head2 $strap->_switches( $file ) Formats and returns the switches necessary to run the test. @@ -399,9 +399,7 @@ sub _switches { return join( " ", @existing_switches, @derived_switches ); } -=head2 C<_cleaned_switches> - - my @switches = $self->_cleaned_switches( @switches_from_user ); +=head2 $strap->_cleaned_switches( @switches_from_user ) Returns only defined, non-blank, trimmed switches from the parms passed. @@ -424,7 +422,7 @@ sub _cleaned_switches { return @switches; } -=head2 C<_INC2PERL5LIB> +=head2 $strap->_INC2PERL5LIB local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; @@ -441,7 +439,7 @@ sub _INC2PERL5LIB { return join $Config{path_sep}, $self->_filtered_INC; } -=head2 C<_filtered_INC> +=head2 $strap->_filtered_INC() my @filtered_inc = $self->_filtered_INC; @@ -483,7 +481,7 @@ sub _default_inc { } -=head2 C<_restore_PERL5LIB> +=head2 $strap->_restore_PERL5LIB() $self->_restore_PERL5LIB; @@ -506,16 +504,16 @@ sub _restore_PERL5LIB { Methods for identifying what sort of line you're looking at. -=head2 C<_is_comment> +=head2 C<_is_diagnostic> - my $is_comment = $strap->_is_comment($line, \$comment); + my $is_diagnostic = $strap->_is_diagnostic($line, \$comment); Checks if the given line is a comment. If so, it will place it into C<$comment> (sans #). =cut -sub _is_comment { +sub _is_diagnostic { my($self, $line, $comment) = @_; if( $line =~ /^\s*\#(.*)/ ) { @@ -571,67 +569,6 @@ sub _is_header { } } -=head2 C<_is_test> - - my $is_test = $strap->_is_test($line, \%test); - -Checks if the $line is a test report (ie. 'ok/not ok'). Reports the -result back in C<%test> which will contain: - - ok did it succeed? This is the literal 'ok' or 'not ok'. - name name of the test (if any) - number test number (if any) - - type 'todo' or 'skip' (if any) - reason why is it todo or skip? (if any) - -It will also catch lone 'not' lines, note it saw them in -C<< $strap->{saw_lone_not} >> and the line in C<< $strap->{lone_not_line} >>. - -=cut - -my $Report_Re = <<'REGEX'; - ^ - (not\ )? # failure? - ok\b - (?:\s+(\d+))? # optional test number - \s* - (.*) # and the rest -REGEX - -sub _is_test { - my($self, $line, $test) = @_; - - # We pulverize the line down into pieces in three parts. - if( my($not, $num, $extra) = $line =~ /$Report_Re/ox ) { - ($test->{name}, my $control) = $extra ? split(/(?:[^\\]|^)#/, $extra) : (); - (my $type, $test->{reason}) = $control ? $control =~ /^\s*(\S+)(?:\s+(.*))?$/ : (); - - $test->{number} = $num; - $test->{ok} = $not ? 0 : 1; - - if( defined $type ) { - $test->{type} = $type =~ /^TODO$/i ? 'todo' : - $type =~ /^Skip/i ? 'skip' : 0; - } - else { - $test->{type} = ''; - } - - return $YES; - } - else{ - # Sometimes the "not " and "ok" will be on separate lines on VMS. - # We catch this and remember we saw it. - if( $line =~ /^not\s+$/ ) { - $self->{saw_lone_not} = 1; - $self->{lone_not_line} = $self->{line}; - } - - return $NO; - } -} - =head2 C<_is_bail_out> my $is_bail_out = $strap->_is_bail_out($line, \$reason); @@ -669,7 +606,6 @@ sub _reset_file_state { $self->{line} = 0; $self->{saw_header} = 0; $self->{saw_bailout}= 0; - $self->{saw_lone_not} = 0; $self->{lone_not_line} = 0; $self->{bailout_reason} = ''; $self->{'next'} = 1; @@ -709,11 +645,12 @@ There is one final item, the details. each test looks like this: $results{details}[$test_num - 1] = - { ok => is the test considered ok? - actual_ok => did it literally say 'ok'? - name => name of the test (if any) - type => 'skip' or 'todo' (if any) - reason => reason for the above (if any) + { ok => is the test considered ok? + actual_ok => did it literally say 'ok'? + name => name of the test (if any) + diagnostics => test diagnostics (if any) + type => 'skip' or 'todo' (if any) + reason => reason for the above (if any) }; Element 0 of the details is test #1. I tried it with element 1 being @@ -734,4 +671,9 @@ L<Test::Harness> =cut +sub _def_or_blank { + return $_[0] if defined $_[0]; + return ""; +} + 1; |