16 my ($class,@val) = @_;
17 return bless \@val,$class;
24 return $#{$ob} = $sz-1;
37 return scalar(@{$_[0]});
50 my ($ob,$id,$val) = @_;
97 my $off = @_ ? shift : 0;
98 my $len = @_ ? shift : @$ob-1;
99 return splice(@$ob,$off,$len,@_);
102 package NegIndex; # 20020220 MJD
105 # simulate indices -2 .. 2
107 $NegIndex::NEGATIVE_INDICES = 1;
111 # print "# FETCH @_\n";
117 my ($ob,$id,$value) = @_;
118 # print "# STORE @_\n";
125 # print "# DELETE @_\n";
132 # print "# EXISTS @_\n";
144 { my $ob = tie @ary,'Implement',3,2,1;
145 print "not " unless $ob;
146 print "ok ", $test++,"\n";
147 print "not " unless tied(@ary) == $ob;
148 print "ok ", $test++,"\n";
152 print "not " unless @ary == 3;
153 print "ok ", $test++,"\n";
155 print "not " unless $#ary == 2;
156 print "ok ", $test++,"\n";
158 print "not " unless join(':',@ary) eq '3:2:1';
159 print "ok ", $test++,"\n";
161 print "not " unless $seen{'FETCH'} >= 3;
162 print "ok ", $test++,"\n";
166 print "not " unless $seen{'STORE'} >= 3;
167 print "ok ", $test++,"\n";
168 print "not " unless join(':',@ary) eq '1:2:3';
169 print "ok ", $test++,"\n";
172 print "not " unless join(':',@thing) eq '1:2:3';
173 print "ok ", $test++,"\n";
175 tie @thing,'Implement';
177 print "not " unless join(':',@thing) eq '1:2:3';
178 print "ok ", $test++,"\n";
181 print "not " unless pop(@ary) == 3;
182 print "ok ", $test++,"\n";
183 print "not " unless $seen{'POP'} == 1;
184 print "ok ", $test++,"\n";
185 print "not " unless join(':',@ary) eq '1:2';
186 print "ok ", $test++,"\n";
189 print "not " unless $seen{'PUSH'} == 1;
190 print "ok ", $test++,"\n";
191 print "not " unless join(':',@ary) eq '1:2:4';
192 print "ok ", $test++,"\n";
194 my @x = splice(@ary,1,1,7);
197 print "not " unless $seen{'SPLICE'} == 1;
198 print "ok ", $test++,"\n";
200 print "not " unless @x == 1;
201 print "ok ", $test++,"\n";
202 print "not " unless $x[0] == 2;
203 print "ok ", $test++,"\n";
204 print "not " unless join(':',@ary) eq '1:7:4';
205 print "ok ", $test++,"\n";
207 print "not " unless shift(@ary) == 1;
208 print "ok ", $test++,"\n";
209 print "not " unless $seen{'SHIFT'} == 1;
210 print "ok ", $test++,"\n";
211 print "not " unless join(':',@ary) eq '7:4';
212 print "ok ", $test++,"\n";
214 my $n = unshift(@ary,5,6);
215 print "not " unless $seen{'UNSHIFT'} == 1;
216 print "ok ", $test++,"\n";
217 print "not " unless $n == 4;
218 print "ok ", $test++,"\n";
219 print "not " unless join(':',@ary) eq '5:6:7:4';
220 print "ok ", $test++,"\n";
222 @ary = split(/:/,'1:2:3');
223 print "not " unless join(':',@ary) eq '1:2:3';
224 print "ok ", $test++,"\n";
230 print "not " unless $n == ++$t;
231 print "ok ", $test++,"\n";
234 # (30-33) 20020303 mjd-perl-patch+@plover.com
237 pop @ary; # this didn't used to call POP at all
238 print "not " unless $seen{POP} == 1;
239 print "ok ", $test++,"\n";
241 shift @ary; # this didn't used to call SHIFT at all
242 print "not " unless $seen{SHIFT} == 1;
243 print "ok ", $test++,"\n";
245 push @ary; # this didn't used to call PUSH at all
246 print "not " unless $seen{PUSH} == 1;
247 print "ok ", $test++,"\n";
249 unshift @ary; # this didn't used to call UNSHIFT at all
250 print "not " unless $seen{UNSHIFT} == 1;
251 print "ok ", $test++,"\n";
254 print "not " unless join(':',@ary) eq '3:2:1';
255 print "ok ", $test++,"\n";
261 # 20020401 mjd-perl-patch+@plover.com
262 # Thanks to Dave Mitchell for the small test case and the fix
266 sub X::TIEARRAY { bless {}, 'X' }
275 # If we survived this far.
276 print "ok ", $test++, "\n";
280 { # 20020220 mjd-perl-patch+@plover.com
282 tie @n => 'NegIndex', ('A' .. 'E');
285 print "not " unless $n[0] eq 'C';
286 print "ok ", $test++,"\n";
287 print "not " unless $n[1] eq 'D';
288 print "ok ", $test++,"\n";
289 print "not " unless $n[2] eq 'E';
290 print "ok ", $test++,"\n";
291 print "not " unless $n[-1] eq 'B';
292 print "ok ", $test++,"\n";
293 print "not " unless $n[-2] eq 'A';
294 print "ok ", $test++,"\n";
298 print "not " unless $n[-2] eq 'a';
299 print "ok ", $test++,"\n";
301 print "not " unless $n[-1] eq 'b';
302 print "ok ", $test++,"\n";
304 print "not " unless $n[0] eq 'c';
305 print "ok ", $test++,"\n";
307 print "not " unless $n[1] eq 'd';
308 print "ok ", $test++,"\n";
310 print "not " unless $n[2] eq 'e';
311 print "ok ", $test++,"\n";
315 print exists($n[$_]) ? "ok $test\n" : "not ok $test\n";
318 print defined($n[$_]) ? "not ok $test\n" : "ok $test\n";
320 print exists($n[$_]) ? "not ok $test\n" : "ok $test\n";
327 print "not " unless $seen{'DESTROY'} == 3;
328 print "ok ", $test++,"\n";