Author: jkeenan
Date: Wed Dec 10 05:16:56 2008
New Revision: 33761
Modified:
branches/testparrottest/lib/Parrot/Test.pm
branches/testparrottest/t/perl/Parrot_Test.t
Log:
Refactor unlink code into sub so that POSTMORTEM can be tested; test not yet
complete.
Modified: branches/testparrottest/lib/Parrot/Test.pm
==============================================================================
--- branches/testparrottest/lib/Parrot/Test.pm (original)
+++ branches/testparrottest/lib/Parrot/Test.pm Wed Dec 10 05:16:56 2008
@@ -193,6 +193,10 @@
my ( $code, $expected, $desc, %extra ) = @_;
my $args = $ENV{TEST_PROG_ARGS} ||
'';
+ # Due to ongoing changes in PBC format, all tests in
+ # t/native_pbc/*.t are currently being SKIPped. This means we
+ # have no tests on which to model tests of the following block.
+ # Hence, test coverage will be lacking.
if ( $func =~ /^pbc_output_/ && $args =~ /-r / ) {
# native tests with --run-pbc don't make sense
return $builder->skip("no native tests with -r");
@@ -203,7 +207,7 @@
my $meth = $parrot_test_map{$func};
my $real_output = slurp_file($out_f);
- unlink $out_f unless $ENV{POSTMORTEM};
+ _unlink_or_retain( $out_f );
# set a todo-item for Test::Builder to find
my $call_pkg = $builder->exported_to() || '';
@@ -318,7 +322,7 @@
$builder->diag("'$cmd' failed with exit code $exit_code")
if $exit_code and not $pass;
- unlink $out_f unless $ENV{POSTMORTEM};
+ _unlink_or_retain( $out_f );
return $pass;
};
@@ -555,11 +559,11 @@
}
}
- unless ( $ENV{POSTMORTEM} ) {
- unlink $out_f, $build_f, $exe_f, $obj_f;
- unlink per_test( '.ilk', $test_no );
- unlink per_test( '.pdb', $test_no );
- }
+ _unlink_or_retain(
+ $out_f, $build_f, $exe_f, $obj_f,
+ per_test( '.ilk', $test_no ),
+ per_test( '.pdb', $test_no ),
+ );
return $pass;
};
@@ -773,6 +777,15 @@
);
}
+sub _unlink_or_retain {
+ my @deletables = @_;
+ my $deleted = 0;
+ unless ( $ENV{POSTMORTEM} ) {
+ $deleted = unlink @deletables;
+ }
+ return $deleted;
+}
+
sub generate_languages_functions {
my %test_map = (
Modified: branches/testparrottest/t/perl/Parrot_Test.t
==============================================================================
--- branches/testparrottest/t/perl/Parrot_Test.t (original)
+++ branches/testparrottest/t/perl/Parrot_Test.t Wed Dec 10 05:16:56 2008
@@ -33,7 +33,7 @@
plan( skip_all => "Test::Builder::Tester not installed\n" );
exit 0;
}
- plan( tests => 115 );
+ plan( tests => 116 );
}
use lib qw( . lib ../lib ../../lib );
@@ -382,6 +382,7 @@
EXPECTED
example_output_is( $file, $expected );
+# next is dying at _unlink_or_retain
$expected = <<EXPECTED;
The answer is
769
@@ -631,6 +632,22 @@
test_test($desc);
}
+{
+ local $ENV{POSTMORTEM} = 1;
+ $desc = 'pir_output_is: success';
+ test_out("ok 1 - $desc");
+ pir_output_is( <<'CODE', <<'OUTPUT', $desc );
+.sub 'test' :main
+ print "foo\n"
+.end
+CODE
+foo
+OUTPUT
+ test_test($desc);
+
+}
+
+
# Cleanup t/perl/
unless ( $ENV{POSTMORTEM} ) {
