TIEARRAY updates - almost works ...

p4raw-id: //depot/ansiperl@424

6 files changed, 101 insertions, 19 deletions

diff --git a/t/lib/tie-push.t b/t/lib/tie-push.t
new file mode 100755
index 0000000000..dd718deb14
--- /dev/null
+++ b/t/lib/tie-push.t
@@ -0,0 +1,24 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}    
+
+{
+ package Basic;
+ use Tie::Array;
+ @ISA = qw(Tie::Array);
+
+ sub TIEARRAY  { return bless [], shift }
+ sub FETCH     { $_[0]->[$_[1]] }
+ sub STORE     { $_[0]->[$_[1]] = $_[2] }
+ sub FETCHSIZE { scalar(@{$_[0]}) }
+ sub STORESIZE { $#{$_[0]} = $_[1]-1 }
+}
+
+tie @x,Basic;
+tie @get,Basic;
+tie @got,Basic;
+tie @tests,Basic;
+require "../t/op/push.t"
diff --git a/t/lib/tie-stdarray.t b/t/lib/tie-stdarray.t
new file mode 100755
index 0000000000..7ca4d76f11
--- /dev/null
+++ b/t/lib/tie-stdarray.t
@@ -0,0 +1,12 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use Tie::Array;
+tie @foo,Tie::StdArray;
+tie @ary,Tie::StdArray;
+tie @bar,Tie::StdArray;
+require "../t/op/array.t"
diff --git a/t/lib/tie-stdpush.t b/t/lib/tie-stdpush.t
new file mode 100755
index 0000000000..34a69472f4
--- /dev/null
+++ b/t/lib/tie-stdpush.t
@@ -0,0 +1,10 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use Tie::Array;
+tie @x,Tie::StdArray;
+require "../t/op/push.t"
diff --git a/t/op/avhv.t b/t/op/avhv.t
index 0390429d2b..a7ce58ab87 100755
--- a/t/op/avhv.t
+++ b/t/op/avhv.t
@@ -1,13 +1,23 @@
 #!./perl
+      
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+require Tie::Array;
 
-package Tie::StdArray;
+package Tie::BasicArray;
+@ISA = 'Tie::Array';
 sub TIEARRAY  { bless [], $_[0] }
-sub STORE    { $_[0]->[$_[1]] = $_[2] }
-sub FETCH    { $_[0]->[$_[1]] }
+sub STORE     { $_[0]->[$_[1]] = $_[2] }
+sub FETCH     { $_[0]->[$_[1]] }
+sub FETCHSIZE { scalar(@{$_[0]})} 
+sub STORESIZE { $#{$_[0]} = $_[1]+1 } 
 
 package main;
 
-print "1..4\n";
+print "1..5\n";
 
 $sch = {
     'abc' => 1,
@@ -48,12 +58,19 @@ $a->[0] = $sch;
 $a->{'abc'} = 'ABC';
 if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";}
 
+# quick check with tied array
+tie @fake, 'Tie::BasicArray';
+$a = \@fake;
+$a->[0] = $sch;
+
+$a->{'abc'} = 'ABC';
+if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";}
+
 # quick check with tied array & tied hash
-@INC = ("./lib", "../lib");
 require Tie::Hash;
 tie %fake, Tie::StdHash;
 %fake = %$sch;
 $a->[0] = \%fake;
 
 $a->{'abc'} = 'ABC';
-if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";}
+if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";}
diff --git a/t/op/push.t b/t/op/push.t
index 68fab66af7..f62a4e9d8e 100755
--- a/t/op/push.t
+++ b/t/op/push.t
@@ -22,7 +22,7 @@ die "blech" unless @tests;
 @x = (1,2,3);
 push(@x,@x);
 if (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
-push(x,4);
+push(@x,4);
 if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
 
 $test = 3;
@@ -47,3 +47,4 @@ foreach $line (@tests) {
     }
 }
 
+1;  # this file is require'd by lib/tie-stdpush.t
diff --git a/t/op/tiearray.t b/t/op/tiearray.t
index 045891dd42..da25760809 100755
--- 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
@@ -95,7 +101,7 @@ sub SPLICE
 
 package main;
 
-print "1..23\n";                   
+print "1..29\n";                   
 my $test = 1;
 
 {my @ary;
@@ -154,8 +160,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,21 +167,35 @@ 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";         
+ }
+
+@ary = qw(3 2 1);
+print "not " unless join(':',@ary) eq '3:2:1';
+print "ok ", $test++,"\n";         
 
-# untie @ary;   
+untie @ary;   
 
 }
-
+                           
+print "not " unless $seen{'DESTROY'} == 1;
+print "ok ", $test++,"\n";