Message-ID: <20020401203218.25230.qmail@plover.com>

p4raw-id: //depot/perl@15667

diff --git a/lib/Tie/File/t/04_splice.t b/lib/Tie/File/t/04_splice.t
index 156adc3..601f1f2 100644 (file)
--- a/lib/Tie/File/t/04_splice.t
+++ b/lib/Tie/File/t/04_splice.t
@@ -154,14 +154,15 @@ splice(@a, 89, 0, "pie pie pie");
 check_contents("I$:like$:pie$:pie pie pie$:");
 
 # (97) Splicing with too large a negative number should be fatal
-# This test ignored because it causes 5.6.1 and 5.7.2 to dump core
+# This test ignored because it causes 5.6.1 and 5.7.3 to dump core
+# It also garbles the stack under 5.005_03 (20020401)
 # NOT MY FAULT
-if ($] < 5.006 || $] > 5.007003) {
+if ($] > 5.008) {
   eval { splice(@a, -7, 0) };
   print $@ =~ /^Modification of non-creatable array value attempted, subscript -7/
       ? "ok $N\n" : "not ok $N \# \$\@ was '$@'\n";
 } else { 
-  print "ok $N \# skipped (5.6.0 through 5.7.3 dump core here.)\n";
+  print "ok $N \# skipped (5.6.0 through 5.8 dump core here.)\n";
 }
 $N++;
        

diff --git a/lib/Tie/File/t/10_splice_rs.t b/lib/Tie/File/t/10_splice_rs.t
index 4db1443..e4d472a 100644 (file)
--- a/lib/Tie/File/t/10_splice_rs.t
+++ b/lib/Tie/File/t/10_splice_rs.t
@@ -154,13 +154,14 @@ check_contents("Iblahlikeblahpieblahpie pie pieblah");
 
 # (97) Splicing with too large a negative number should be fatal
 # This test ignored because it causes 5.6.1 and 5.7.3 to dump core
+# It also garbles the stack under 5.005_03 (20020401)
 # NOT MY FAULT
-if ($] < 5.006 || $] > 5.007003) {
+if ($] > 5.008) {
   eval { splice(@a, -7, 0) };
   print $@ =~ /^Modification of non-creatable array value attempted, subscript -7/
       ? "ok $N\n" : "not ok $N \# \$\@ was '$@'\n";
 } else { 
-  print "ok $N \# skipped (5.6.0 through 5.7.3 dump core here.)\n";
+  print "ok $N \# skipped (5.6.0 through 5.8 dump core here.)\n";
 }
 $N++;
        

diff --git a/t/op/tiearray.t b/t/op/tiearray.t
index 3d0004b..0c91303 100755 (executable)
--- a/t/op/tiearray.t
+++ b/t/op/tiearray.t
@@ -101,7 +101,7 @@ sub SPLICE
 
 package main;
 
-print "1..35\n";                   
+print "1..36\n";                   
 my $test = 1;
 
 {my @ary;
@@ -196,7 +196,7 @@ foreach $n (@ary)
   print "ok ", $test++,"\n";         
  }
 
-# (30-33) 20020303 MJD
+# (30-33) 20020303 mjd-perl-patch+@plover.com
 @ary = ();
 $seen{POP} = 0;
 pop @ary;                       # this didn't used to call POP at all
@@ -222,6 +222,29 @@ print "ok ", $test++,"\n";
 untie @ary;   
 
 }
+
+# 20020401 mjd-perl-patch+@plover.com
+# Thanks to Dave Mitchell for the small test case
+{ require './test.pl';
+  curr_test(35);
+  local $::TODO = 'Not fixed yet';
+  fresh_perl_is(<<'End_of_Test', "ok", {}, "Core dump in 'leavetry'");
+######## [ID 20020301.011] Core dump in 'leavetry' in 5.7.2
+  my @a;
+  
+  sub X::TIEARRAY { bless {}, 'X' }
+
+  sub X::SPLICE {
+    do '/dev/null';
+    die;
+  }
+
+  tie @a, 'X';
+  eval { splice(@a) };
+  print "ok\n"
+End_of_Test
+}
+$test++;
                            
 print "not " unless $seen{'DESTROY'} == 2;
 print "ok ", $test++,"\n";         

diff --git a/t/test.pl b/t/test.pl
index 91daf1a..debce6e 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -30,8 +30,12 @@ END {
 # Use this instead of "print STDERR" when outputing failure diagnostic 
 # messages
 sub _diag {
+    return unless @_;
+    my @mess = map { /^#/ ? "$_\n" : "# $_\n" } 
+               map { split /\n/ } @_;
     my $fh = $TODO ? *STDOUT : *STDERR;
-    print $fh @_;
+    print $fh @mess;
+
 }
 
 sub skip_all {
@@ -64,8 +68,7 @@ sub _ok {
     }
 
     # Ensure that the message is properly escaped.
-    _diag map { /^#/ ? "$_\n" : "# $_\n" } 
-          map { split /\n/ } @mess if @mess;
+    _diag @mess;
 
     $test++;
 
@@ -241,11 +244,12 @@ sub fail {
 }
 
 sub curr_test {
+    $test = shift if @_;
     return $test;
 }
 
 sub next_test {
-    $test++
+  $test++;
 }
 
 # Note: can't pass multipart messages since we try to
@@ -512,10 +516,10 @@ sub _fresh_perl {
 
     my $pass = $resolve->($results);
     unless ($pass) {
-        print STDERR "# PROG: $switch\n$prog\n";
-        print STDERR "# EXPECTED:\n", $resolve->(), "\n";
-        print STDERR "# GOT:\n$results\n";
-        print STDERR "# STATUS: $status\n";
+        _diag "# PROG: \n$prog\n";
+        _diag "# EXPECTED:\n", $resolve->(), "\n";
+        _diag "# GOT:\n$results\n";
+        _diag "# STATUS: $status\n";
     }
 
     # Use the first line of the program as a name if none was given