X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Ftiearray.t;h=e7b547bcd9030caeadcd9111f6b2516e9fce8ef2;hb=3511154c18a0900e8873e8e72a4b74931525e718;hp=028fe40c60c75c595b028b7d7a2bf0abcafc7fc7;hpb=93965878572d85daec78ce5ce1926f613d93803b;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/t/op/tiearray.t b/t/op/tiearray.t
old mode 100644
new mode 100755
index 028fe40..e7b547b
--- a/t/op/tiearray.t
+++ b/t/op/tiearray.t
@@ -1,5 +1,6 @@
 #!./perl
 
+
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
@@ -20,7 +21,7 @@ sub STORESIZE
 {        
  $seen{'STORESIZE'}++;
  my ($ob,$sz) = @_; 
- return @$ob = $sz;
+ return $#{$ob} = $sz-1;
 }
 
 sub EXTEND
@@ -33,8 +34,7 @@ sub EXTEND
 sub FETCHSIZE
 {        
  $seen{'FETCHSIZE'}++;
- my ($ob) = @_; 
- return @$ob-1;
+ return scalar(@{$_[0]});
 }
 
 sub FETCH
@@ -54,7 +54,7 @@ sub STORE
 sub UNSHIFT
 {
  $seen{'UNSHIFT'}++;
- $ob = shift;
+ my $ob = shift;
  unshift(@$ob,@_);
 }                 
 
@@ -68,6 +68,12 @@ sub PUSH
 sub CLEAR
 {
  $seen{'CLEAR'}++;
+ @{$_[0]} = ();
+}
+
+sub DESTROY
+{
+ $seen{'DESTROY'}++;
 }
 
 sub POP
@@ -93,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];
+}
 
-print "1..23\n";                   
+sub EXISTS {
+  my ($ob,$id) = @_;
+#  print "# EXISTS @_\n";
+  $id += $offset;
+  exists $ob->[$id];
+}
+
+package main;
+  
+print "1..61\n";                   
 my $test = 1;
 
 {my @ary;
@@ -124,10 +165,19 @@ print "ok ", $test++,"\n";
 
 print "not " unless $seen{'STORE'} >= 3;
 print "ok ", $test++,"\n";
-
 print "not " unless join(':',@ary) eq '1:2:3';
 print "ok ", $test++,"\n";         
 
+{my @thing = @ary;
+print "not " unless join(':',@thing) eq '1:2:3';
+print "ok ", $test++,"\n";         
+
+tie @thing,'Implement';
+@thing = @ary;
+print "not " unless join(':',@thing) eq '1:2:3';
+print "ok ", $test++,"\n";
+} 
+
 print "not " unless pop(@ary) == 3;
 print "ok ", $test++,"\n";
 print "not " unless $seen{'POP'} == 1;
@@ -154,8 +204,6 @@ print "ok ", $test++,"\n";
 print "not " unless join(':',@ary) eq '1:7:4';
 print "ok ", $test++,"\n";             
 
-
-
 print "not " unless shift(@ary) == 1;
 print "ok ", $test++,"\n";
 print "not " unless $seen{'SHIFT'} == 1;
@@ -163,23 +211,119 @@ print "ok ", $test++,"\n";
 print "not " unless join(':',@ary) eq '7:4';
 print "ok ", $test++,"\n";             
 
-
-unshift(@ary,5);
+my $n = unshift(@ary,5,6);
 print "not " unless $seen{'UNSHIFT'} == 1;
 print "ok ", $test++,"\n";
-print "not " unless join(':',@ary) eq '5:7:4';
+print "not " unless $n == 4;
+print "ok ", $test++,"\n";
+print "not " unless join(':',@ary) eq '5:6:7:4';
 print "ok ", $test++,"\n";
 
 @ary = split(/:/,'1:2:3');
 print "not " unless join(':',@ary) eq '1:2:3';
 print "ok ", $test++,"\n";         
 
+  
+my $t = 0;
+foreach $n (@ary)
+ {
+  print "not " unless $n == ++$t;
+  print "ok ", $test++,"\n";         
+ }
+
+# (30-33) 20020303 mjd-perl-patch+@plover.com
+@ary = ();
+$seen{POP} = 0;
+pop @ary;                       # this didn't used to call POP at all
+print "not " unless $seen{POP} == 1;
+print "ok ", $test++,"\n";         
+$seen{SHIFT} = 0;
+shift @ary;                     # this didn't used to call SHIFT at  all
+print "not " unless $seen{SHIFT} == 1;
+print "ok ", $test++,"\n";         
+$seen{PUSH} = 0;
+push @ary;                       # this didn't used to call PUSH at all
+print "not " unless $seen{PUSH} == 1;
+print "ok ", $test++,"\n";         
+$seen{UNSHIFT} = 0;
+unshift @ary;                   # this didn't used to call UNSHIFT at all
+print "not " unless $seen{UNSHIFT} == 1;
+print "ok ", $test++,"\n";         
+
+@ary = qw(3 2 1);
+print "not " unless join(':',@ary) eq '3:2:1';
+print "ok ", $test++,"\n";         
+
 untie @ary;   
 
-exit;
+}
 
+# 20020401 mjd-perl-patch+@plover.com
+# Thanks to Dave Mitchell for the small test case and the fix
+{
+  my @a;
+  
+  sub X::TIEARRAY { bless {}, 'X' }
+
+  sub X::SPLICE {
+    do '/dev/null';
+    die;
+  }
+
+  tie @a, 'X';
+  eval { splice(@a) };
+  # If we survived this far.
+  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";