| Subject: | [PATCH lib/Test/Harness/Straps.pm] Collect and Report Diagnostic Output |
This patch to Test::Harness::Straps allows the optional collection and reporting of diagnostic output as discussed on the perl-qa mailing list (http://www.nntp.perl.org/group/perl.qa/3499 and followups).
diff -ur lib/Test/Harness/Straps.pm~ lib/Test/Harness/Straps.pm
--- lib/Test/Harness/Straps.pm~ 2004-12-31 13:28:32.000000000 -0800
+++ lib/Test/Harness/Straps.pm 2005-01-26 19:39:40.000000000 -0800
@@ -8,6 +8,7 @@
use Config;
$VERSION = '0.20';
+use IPC::Open3;
use Test::Harness::Assert;
use Test::Harness::Iterator;
@@ -69,9 +70,10 @@
=cut
sub new {
- my $class = shift;
+ my ($class, %args) = @_;
- my $self = bless {}, $class;
+ my $self = bless {}, $class;
+ $self->{extra} = 1 if $args{extra};
$self->_init;
return $self;
@@ -228,6 +230,13 @@
$type = 'bailout';
$self->{saw_bailout} = 1;
}
+ elsif ($self->{extra} and my $extra = $self->_is_extra_line( $line ))
+ {
+ my $test = $totals->{details}[-1];
+ $test->{extra} ||= '';
+ $test->{extra} .= $extra;
+ $type = 'other';
+ }
else {
$type = 'other';
}
@@ -237,6 +246,14 @@
$self->{'next'} = $result{number} + 1 if $type eq 'test';
}
+sub _is_extra_line
+{
+ my ($self, $line) = @_;
+ return if index( $line, '# Looks like you failed' ) == 0;
+ $line =~ s/^#\s//;
+ return $line;
+}
+
=head2 C<analyze_fh>
my %results = $strap->analyze_fh($name, $test_filehandle);
@@ -282,13 +299,17 @@
# *sigh* this breaks under taint, but open -| is unportable.
my $line = $self->_command_line($file);
- unless( open(FILE, "$line|") ) {
+ my $reader;
+
+ my $pid;
+ unless ($pid = open3( undef, $reader, $reader, $line ))
+ {
print "can't run $file. $!\n";
return;
- }
+ }
- my %results = $self->analyze_fh($file, \*FILE);
- my $exit = close FILE;
+ my %results = $self->analyze_fh($file, $reader);
+ my $exit = waitpid $pid, 0;
$results{'wait'} = $?;
if( $? && $self->{_is_vms} ) {
eval q{use vmsish "status"; $results{'exit'} = $?};
diff -ur MANIFEST~ MANIFEST
--- MANIFEST~ 2004-12-31 13:28:32.000000000 -0800
+++ MANIFEST 2005-01-26 19:41:49.000000000 -0800
@@ -23,6 +23,7 @@
t/prove-globbing.t
t/prove-switches.t
t/strap-analyze.t
+t/strap-analyze-extra.t
t/strap.t
t/test-harness.t
--- /dev/null 1969-12-31 16:00:00.000000000 -0800
+++ t/strap-analyze-extra.t 2005-01-26 19:41:26.000000000 -0800
@@ -0,0 +1,133 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use strict;
+use Test::More;
+use File::Spec;
+
+my $Curdir = File::Spec->curdir;
+my $SAMPLE_TESTS = $ENV{PERL_CORE}
+ ? File::Spec->catdir($Curdir, 'lib', 'sample-tests')
+ : File::Spec->catdir($Curdir, 't', 'sample-tests');
+
+
+my $IsMacPerl = $^O eq 'MacOS';
+my $IsVMS = $^O eq 'VMS';
+
+# VMS uses native, not POSIX, exit codes.
+my $die_exit = $IsVMS ? 44 : 1;
+
+# We can only predict that the wait status should be zero or not.
+my $wait_non_zero = 1;
+
+my %samples = (
+ 'with_comments' =>{
+ passing => 1,
+ 'exit' => 0,
+ 'wait' => 0,
+
+ max => 5,
+ seen => 5,
+
+ 'ok' => 5,
+ 'todo' => 4,
+ 'skip' => 0,
+ bonus => 2,
+
+ details => [ {
+ 'ok' => 1,
+ actual_ok => 0,
+ extra => "Failed test 1 in t/todo.t at line 9 *TODO*\n",
+ type => 'todo'
+ },
+ {
+ 'ok' => 1,
+ actual_ok => 1,
+ reason => 'at line 10 TODO?!)',
+ type => 'todo'
+ },
+ {
+ 'ok' => 1,
+ actual_ok => 1,
+ },
+ {
+ 'ok' => 1,
+ actual_ok => 0,
+ extra => "Test 4 got: '0' (t/todo.t at line 12 *TODO*)\n"
+ . " Expected: '1' (need more tuits)\n",
+ type => 'todo'
+ },
+ {
+ 'ok' => 1,
+ actual_ok => 1,
+ reason => 'at line 13 TODO?!)',
+ extra => "woo\n",
+ type => 'todo'
+ },
+ ]},
+);
+
+plan tests => (keys(%samples) * 5) + 3;
+
+use Test::Harness::Straps;
+
+$SIG{__WARN__} = sub {
+ warn @_ unless $_[0] =~ /^Enormous test number/ ||
+ $_[0] =~ /^Can't detailize/
+};
+
+for my $test ( sort keys %samples ) {
+ my $expect = $samples{$test};
+
+ for (0..$#{$expect->{details}}) {
+ $expect->{details}[$_]{type} = ''
+ unless exists $expect->{details}[$_]{type};
+ $expect->{details}[$_]{name} = ''
+ unless exists $expect->{details}[$_]{name};
+ $expect->{details}[$_]{reason} = ''
+ unless exists $expect->{details}[$_]{reason};
+ }
+
+ my $test_path = File::Spec->catfile($SAMPLE_TESTS, $test);
+ my $strap = Test::Harness::Straps->new( extra => 1 );
+ isa_ok( $strap, 'Test::Harness::Straps' );
+ my %results = $strap->analyze_file($test_path);
+
+ is_deeply($results{details}, $expect->{details}, "$test details" );
+
+ delete $expect->{details};
+ delete $results{details};
+
+ SKIP: {
+ skip '$? unreliable in MacPerl', 2 if $IsMacPerl;
+
+ # We can only check if it's zero or non-zero.
+ is( !!$results{'wait'}, !!$expect->{'wait'}, 'wait status' );
+ delete $results{'wait'};
+ delete $expect->{'wait'};
+
+ # Have to check the exit status seperately so we can skip it
+ # in MacPerl.
+ is( $results{'exit'}, $expect->{'exit'} );
+ delete $results{'exit'};
+ delete $expect->{'exit'};
+ }
+
+ is_deeply(\%results, $expect, " the rest $test" );
+} # for %samples
+
+NON_EXISTENT_FILE: {
+ my $strap = Test::Harness::Straps->new;
+ isa_ok( $strap, 'Test::Harness::Straps' );
+ ok( !$strap->analyze_file('I_dont_exist') );
+ is( $strap->{error}, "I_dont_exist does not exist" );
+}