[perl #24674]

[p5sagit/p5-mst-13.2.git] / t / op / tiearray.t

diff --git a/t/op/tiearray.t b/t/op/tiearray.t
index 0c91303..e7b547b 100755 (executable)
--- a/t/op/tiearray.t
+++ b/t/op/tiearray.t
@@ -99,9 +99,44 @@ sub SPLICE
  return splice(@$ob,$off,$len,@_);
 }
 
-package main;
+package NegIndex;               # 20020220 MJD
+@ISA = 'Implement';
+
+# simulate indices -2 .. 2
+my $offset = 2;
+$NegIndex::NEGATIVE_INDICES = 1;
+
+sub FETCH {
+  my ($ob,$id) = @_;
+#  print "# FETCH @_\n";
+  $id += $offset;
+  $ob->[$id];
+}
+
+sub STORE {
+  my ($ob,$id,$value) = @_;
+#  print "# STORE @_\n";
+  $id += $offset;
+  $ob->[$id] = $value;
+}
+
+sub DELETE {
+  my ($ob,$id) = @_;
+#  print "# DELETE @_\n";
+  $id += $offset;
+  delete $ob->[$id];
+}
+
+sub EXISTS {
+  my ($ob,$id) = @_;
+#  print "# EXISTS @_\n";
+  $id += $offset;
+  exists $ob->[$id];
+}
 
-print "1..36\n";                   
+package main;
+  
+print "1..61\n";                   
 my $test = 1;
 
 {my @ary;
@@ -224,12 +259,8 @@ 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
+# Thanks to Dave Mitchell for the small test case and the fix
+{
   my @a;
   
   sub X::TIEARRAY { bless {}, 'X' }
@@ -241,13 +272,58 @@ untie @ary;
 
   tie @a, 'X';
   eval { splice(@a) };
-  print "ok\n"
-End_of_Test
+  # If we survived this far.
+  print "ok ", $test++, "\n";
 }
-$test++;
-                           
-print "not " unless $seen{'DESTROY'} == 2;
-print "ok ", $test++,"\n";         
 
 
+{ # 20020220 mjd-perl-patch+@plover.com
+  my @n;
+  tie @n => 'NegIndex', ('A' .. 'E');
+
+  # FETCH
+  print "not " unless $n[0] eq 'C';
+  print "ok ", $test++,"\n";
+  print "not " unless $n[1] eq 'D';
+  print "ok ", $test++,"\n";
+  print "not " unless $n[2] eq 'E';
+  print "ok ", $test++,"\n";
+  print "not " unless $n[-1] eq 'B';
+  print "ok ", $test++,"\n";
+  print "not " unless $n[-2] eq 'A';
+  print "ok ", $test++,"\n";
+
+  # STORE
+  $n[-2] = 'a';
+  print "not " unless $n[-2] eq 'a';
+  print "ok ", $test++,"\n";
+  $n[-1] = 'b';
+  print "not " unless $n[-1] eq 'b';
+  print "ok ", $test++,"\n";
+  $n[0] = 'c';
+  print "not " unless $n[0] eq 'c';
+  print "ok ", $test++,"\n";
+  $n[1] = 'd';
+  print "not " unless $n[1] eq 'd';
+  print "ok ", $test++,"\n";
+  $n[2] = 'e';
+  print "not " unless $n[2] eq 'e';
+  print "ok ", $test++,"\n";
+
+  # DELETE and EXISTS
+  for (-2 .. 2) {
+    print exists($n[$_]) ? "ok $test\n" : "not ok $test\n";
+    $test++;
+    delete $n[$_];
+    print defined($n[$_]) ? "not ok $test\n" : "ok $test\n";
+    $test++;
+    print exists($n[$_]) ? "not ok $test\n" : "ok $test\n";
+    $test++;
+  }
+}
+                           
+
+                           
+print "not " unless $seen{'DESTROY'} == 3;
+print "ok ", $test++,"\n";