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";
138 # Returning -1 from FETCHSIZE used to get casted to U32 causing a
142 package NegFetchsize;
144 sub TIEARRAY { bless [] }
155 { my $ob = tie @ary,'Implement',3,2,1;
156 print "not " unless $ob;
157 print "ok ", $test++,"\n";
158 print "not " unless tied(@ary) == $ob;
159 print "ok ", $test++,"\n";
163 print "not " unless @ary == 3;
164 print "ok ", $test++,"\n";
166 print "not " unless $#ary == 2;
167 print "ok ", $test++,"\n";
169 print "not " unless join(':',@ary) eq '3:2:1';
170 print "ok ", $test++,"\n";
172 print "not " unless $seen{'FETCH'} >= 3;
173 print "ok ", $test++,"\n";
177 print "not " unless $seen{'STORE'} >= 3;
178 print "ok ", $test++,"\n";
179 print "not " unless join(':',@ary) eq '1:2:3';
180 print "ok ", $test++,"\n";
183 print "not " unless join(':',@thing) eq '1:2:3';
184 print "ok ", $test++,"\n";
186 tie @thing,'Implement';
188 print "not " unless join(':',@thing) eq '1:2:3';
189 print "ok ", $test++,"\n";
192 print "not " unless pop(@ary) == 3;
193 print "ok ", $test++,"\n";
194 print "not " unless $seen{'POP'} == 1;
195 print "ok ", $test++,"\n";
196 print "not " unless join(':',@ary) eq '1:2';
197 print "ok ", $test++,"\n";
200 print "not " unless $seen{'PUSH'} == 1;
201 print "ok ", $test++,"\n";
202 print "not " unless join(':',@ary) eq '1:2:4';
203 print "ok ", $test++,"\n";
205 my @x = splice(@ary,1,1,7);
208 print "not " unless $seen{'SPLICE'} == 1;
209 print "ok ", $test++,"\n";
211 print "not " unless @x == 1;
212 print "ok ", $test++,"\n";
213 print "not " unless $x[0] == 2;
214 print "ok ", $test++,"\n";
215 print "not " unless join(':',@ary) eq '1:7:4';
216 print "ok ", $test++,"\n";
218 print "not " unless shift(@ary) == 1;
219 print "ok ", $test++,"\n";
220 print "not " unless $seen{'SHIFT'} == 1;
221 print "ok ", $test++,"\n";
222 print "not " unless join(':',@ary) eq '7:4';
223 print "ok ", $test++,"\n";
225 my $n = unshift(@ary,5,6);
226 print "not " unless $seen{'UNSHIFT'} == 1;
227 print "ok ", $test++,"\n";
228 print "not " unless $n == 4;
229 print "ok ", $test++,"\n";
230 print "not " unless join(':',@ary) eq '5:6:7:4';
231 print "ok ", $test++,"\n";
233 @ary = split(/:/,'1:2:3');
234 print "not " unless join(':',@ary) eq '1:2:3';
235 print "ok ", $test++,"\n";
240 print "not " unless $n == ++$t;
241 print "ok ", $test++,"\n";
244 # (30-33) 20020303 mjd-perl-patch+@plover.com
247 pop @ary; # this didn't used to call POP at all
248 print "not " unless $seen{POP} == 1;
249 print "ok ", $test++,"\n";
251 shift @ary; # this didn't used to call SHIFT at all
252 print "not " unless $seen{SHIFT} == 1;
253 print "ok ", $test++,"\n";
255 push @ary; # this didn't used to call PUSH at all
256 print "not " unless $seen{PUSH} == 1;
257 print "ok ", $test++,"\n";
259 unshift @ary; # this didn't used to call UNSHIFT at all
260 print "not " unless $seen{UNSHIFT} == 1;
261 print "ok ", $test++,"\n";
264 print "not " unless join(':',@ary) eq '3:2:1';
265 print "ok ", $test++,"\n";
268 print "not " unless $seen{'STORESIZE'} == 1;
269 print "ok ", $test++," -- seen STORESIZE\n";
270 print "not " unless join(':',@ary) eq '3:2';
271 print "ok ", $test++,"\n";
273 sub arysize :lvalue { $#ary }
275 print "not " unless $seen{'STORESIZE'} == 2;
276 print "ok ", $test++," -- seen STORESIZE\n";
277 print "not " unless join(':',@ary) eq '3';
278 print "ok ", $test++,"\n";
284 # 20020401 mjd-perl-patch+@plover.com
285 # Thanks to Dave Mitchell for the small test case and the fix
289 sub X::TIEARRAY { bless {}, 'X' }
298 # If we survived this far.
299 print "ok ", $test++, "\n";
303 { # 20020220 mjd-perl-patch+@plover.com
305 tie @n => 'NegIndex', ('A' .. 'E');
308 print "not " unless $n[0] eq 'C';
309 print "ok ", $test++,"\n";
310 print "not " unless $n[1] eq 'D';
311 print "ok ", $test++,"\n";
312 print "not " unless $n[2] eq 'E';
313 print "ok ", $test++,"\n";
314 print "not " unless $n[-1] eq 'B';
315 print "ok ", $test++,"\n";
316 print "not " unless $n[-2] eq 'A';
317 print "ok ", $test++,"\n";
321 print "not " unless $n[-2] eq 'a';
322 print "ok ", $test++,"\n";
324 print "not " unless $n[-1] eq 'b';
325 print "ok ", $test++,"\n";
327 print "not " unless $n[0] eq 'c';
328 print "ok ", $test++,"\n";
330 print "not " unless $n[1] eq 'd';
331 print "ok ", $test++,"\n";
333 print "not " unless $n[2] eq 'e';
334 print "ok ", $test++,"\n";
338 print exists($n[$_]) ? "ok $test\n" : "not ok $test\n";
341 print defined($n[$_]) ? "not ok $test\n" : "ok $test\n";
343 print exists($n[$_]) ? "not ok $test\n" : "ok $test\n";
351 tie my @dummy, "NegFetchsize";
354 print "not " unless $@ =~ /^FETCHSIZE returned a negative value/;
355 print "ok ", $test++, " - croak on negative FETCHSIZE\n";
358 print "not " unless $seen{'DESTROY'} == 3;
359 print "ok ", $test++,"\n";