1#!./perl 2 3 4BEGIN { 5 chdir 't' if -d 't'; 6 unshift @INC, '../lib'; 7} 8 9my %seen; 10 11package Implement; 12 13sub TIEARRAY 14{ 15 $seen{'TIEARRAY'}++; 16 my ($class,@val) = @_; 17 return bless \@val,$class; 18} 19 20sub STORESIZE 21{ 22 $seen{'STORESIZE'}++; 23 my ($ob,$sz) = @_; 24 return $#{$ob} = $sz-1; 25} 26 27sub EXTEND 28{ 29 $seen{'EXTEND'}++; 30 my ($ob,$sz) = @_; 31 return @$ob = $sz; 32} 33 34sub FETCHSIZE 35{ 36 $seen{'FETCHSIZE'}++; 37 return scalar(@{$_[0]}); 38} 39 40sub FETCH 41{ 42 $seen{'FETCH'}++; 43 my ($ob,$id) = @_; 44 return $ob->[$id]; 45} 46 47sub STORE 48{ 49 $seen{'STORE'}++; 50 my ($ob,$id,$val) = @_; 51 $ob->[$id] = $val; 52} 53 54sub UNSHIFT 55{ 56 $seen{'UNSHIFT'}++; 57 my $ob = shift; 58 unshift(@$ob,@_); 59} 60 61sub PUSH 62{ 63 $seen{'PUSH'}++; 64 my $ob = shift;; 65 push(@$ob,@_); 66} 67 68sub CLEAR 69{ 70 $seen{'CLEAR'}++; 71 @{$_[0]} = (); 72} 73 74sub DESTROY 75{ 76 $seen{'DESTROY'}++; 77} 78 79sub POP 80{ 81 $seen{'POP'}++; 82 my ($ob) = @_; 83 return pop(@$ob); 84} 85 86sub SHIFT 87{ 88 $seen{'SHIFT'}++; 89 my ($ob) = @_; 90 return shift(@$ob); 91} 92 93sub SPLICE 94{ 95 $seen{'SPLICE'}++; 96 my $ob = shift; 97 my $off = @_ ? shift : 0; 98 my $len = @_ ? shift : @$ob-1; 99 return splice(@$ob,$off,$len,@_); 100} 101 102package main; 103 104print "1..31\n"; 105my $test = 1; 106 107{my @ary; 108 109{ my $ob = tie @ary,'Implement',3,2,1; 110 print "not " unless $ob; 111 print "ok ", $test++,"\n"; 112 print "not " unless tied(@ary) == $ob; 113 print "ok ", $test++,"\n"; 114} 115 116 117print "not " unless @ary == 3; 118print "ok ", $test++,"\n"; 119 120print "not " unless $#ary == 2; 121print "ok ", $test++,"\n"; 122 123print "not " unless join(':',@ary) eq '3:2:1'; 124print "ok ", $test++,"\n"; 125 126print "not " unless $seen{'FETCH'} >= 3; 127print "ok ", $test++,"\n"; 128 129@ary = (1,2,3); 130 131print "not " unless $seen{'STORE'} >= 3; 132print "ok ", $test++,"\n"; 133print "not " unless join(':',@ary) eq '1:2:3'; 134print "ok ", $test++,"\n"; 135 136{my @thing = @ary; 137print "not " unless join(':',@thing) eq '1:2:3'; 138print "ok ", $test++,"\n"; 139 140tie @thing,'Implement'; 141@thing = @ary; 142print "not " unless join(':',@thing) eq '1:2:3'; 143print "ok ", $test++,"\n"; 144} 145 146print "not " unless pop(@ary) == 3; 147print "ok ", $test++,"\n"; 148print "not " unless $seen{'POP'} == 1; 149print "ok ", $test++,"\n"; 150print "not " unless join(':',@ary) eq '1:2'; 151print "ok ", $test++,"\n"; 152 153push(@ary,4); 154print "not " unless $seen{'PUSH'} == 1; 155print "ok ", $test++,"\n"; 156print "not " unless join(':',@ary) eq '1:2:4'; 157print "ok ", $test++,"\n"; 158 159my @x = splice(@ary,1,1,7); 160 161 162print "not " unless $seen{'SPLICE'} == 1; 163print "ok ", $test++,"\n"; 164 165print "not " unless @x == 1; 166print "ok ", $test++,"\n"; 167print "not " unless $x[0] == 2; 168print "ok ", $test++,"\n"; 169print "not " unless join(':',@ary) eq '1:7:4'; 170print "ok ", $test++,"\n"; 171 172print "not " unless shift(@ary) == 1; 173print "ok ", $test++,"\n"; 174print "not " unless $seen{'SHIFT'} == 1; 175print "ok ", $test++,"\n"; 176print "not " unless join(':',@ary) eq '7:4'; 177print "ok ", $test++,"\n"; 178 179my $n = unshift(@ary,5,6); 180print "not " unless $seen{'UNSHIFT'} == 1; 181print "ok ", $test++,"\n"; 182print "not " unless $n == 4; 183print "ok ", $test++,"\n"; 184print "not " unless join(':',@ary) eq '5:6:7:4'; 185print "ok ", $test++,"\n"; 186 187@ary = split(/:/,'1:2:3'); 188print "not " unless join(':',@ary) eq '1:2:3'; 189print "ok ", $test++,"\n"; 190 191my $t = 0; 192foreach $n (@ary) 193 { 194 print "not " unless $n == ++$t; 195 print "ok ", $test++,"\n"; 196 } 197 198@ary = qw(3 2 1); 199print "not " unless join(':',@ary) eq '3:2:1'; 200print "ok ", $test++,"\n"; 201 202untie @ary; 203 204} 205 206print "not " unless $seen{'DESTROY'} == 2; 207print "ok ", $test++,"\n"; 208 209 210 211