develooper Front page | perl.cvs.parrot | Postings from December 2008

[svn:parrot] r33761 - in branches/testparrottest: lib/Parrot t/perl

From:
jkeenan
Date:
December 10, 2008 05:17
Subject:
[svn:parrot] r33761 - in branches/testparrottest: lib/Parrot t/perl
Message ID:
20081210131657.1912BCBA89@x12.develooper.com
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} ) {



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About