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";
241 print "not " unless $n == ++$t;
242 print "ok ", $test++,"\n";
245 # (30-33) 20020303 mjd-perl-patch+@plover.com
248 pop @ary; # this didn't used to call POP at all
249 print "not " unless $seen{POP} == 1;
250 print "ok ", $test++,"\n";
252 shift @ary; # this didn't used to call SHIFT at all
253 print "not " unless $seen{SHIFT} == 1;
254 print "ok ", $test++,"\n";
256 push @ary; # this didn't used to call PUSH at all
257 print "not " unless $seen{PUSH} == 1;
258 print "ok ", $test++,"\n";
260 unshift @ary; # this didn't used to call UNSHIFT at all
261 print "not " unless $seen{UNSHIFT} == 1;
262 print "ok ", $test++,"\n";
265 print "not " unless join(':',@ary) eq '3:2:1';
266 print "ok ", $test++,"\n";
272 # 20020401 mjd-perl-patch+@plover.com
273 # Thanks to Dave Mitchell for the small test case and the fix
277 sub X::TIEARRAY { bless {}, 'X' }
286 # If we survived this far.
287 print "ok ", $test++, "\n";
291 { # 20020220 mjd-perl-patch+@plover.com
293 tie @n => 'NegIndex', ('A' .. 'E');
296 print "not " unless $n[0] eq 'C';
297 print "ok ", $test++,"\n";
298 print "not " unless $n[1] eq 'D';
299 print "ok ", $test++,"\n";
300 print "not " unless $n[2] eq 'E';
301 print "ok ", $test++,"\n";
302 print "not " unless $n[-1] eq 'B';
303 print "ok ", $test++,"\n";
304 print "not " unless $n[-2] eq 'A';
305 print "ok ", $test++,"\n";
309 print "not " unless $n[-2] eq 'a';
310 print "ok ", $test++,"\n";
312 print "not " unless $n[-1] eq 'b';
313 print "ok ", $test++,"\n";
315 print "not " unless $n[0] eq 'c';
316 print "ok ", $test++,"\n";
318 print "not " unless $n[1] eq 'd';
319 print "ok ", $test++,"\n";
321 print "not " unless $n[2] eq 'e';
322 print "ok ", $test++,"\n";
326 print exists($n[$_]) ? "ok $test\n" : "not ok $test\n";
329 print defined($n[$_]) ? "not ok $test\n" : "ok $test\n";
331 print exists($n[$_]) ? "not ok $test\n" : "ok $test\n";
339 tie my @dummy, "NegFetchsize";
342 print "not " unless $@ =~ /^FETCHSIZE returned a negative value/;
343 print "ok ", $test++, " - croak on negative FETCHSIZE\n";
346 print "not " unless $seen{'DESTROY'} == 3;
347 print "ok ", $test++,"\n";