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 [] }
154 { my $ob = tie @ary,'Implement',3,2,1;
161 is(join(':',@ary), '3:2:1');
162 cmp_ok($seen{'FETCH'}, '>=', 3);
166 cmp_ok($seen{'STORE'}, '>=', 3);
167 is(join(':',@ary), '1:2:3');
170 is(join(':',@thing), '1:2:3');
172 tie @thing,'Implement';
174 is(join(':',@thing), '1:2:3');
179 is(join(':',@ary), '1:2');
182 is($seen{'PUSH'}, 1);
183 is(join(':',@ary), '1:2:4');
185 my @x = splice(@ary,1,1,7);
187 is($seen{'SPLICE'}, 1);
190 is(join(':',@ary), '1:7:4');
193 is($seen{'SHIFT'}, 1);
194 is(join(':',@ary), '7:4');
196 my $n = unshift(@ary,5,6);
197 is($seen{'UNSHIFT'}, 1);
199 is(join(':',@ary), '5:6:7:4');
201 @ary = split(/:/,'1:2:3');
202 is(join(':',@ary), '1:2:3');
210 # (30-33) 20020303 mjd-perl-patch+@plover.com
213 pop @ary; # this didn't used to call POP at all
216 shift @ary; # this didn't used to call SHIFT at all
219 my $got = push @ary; # this didn't used to call PUSH at all
223 $got = unshift @ary; # this didn't used to call UNSHIFT at all
225 is($seen{UNSHIFT}, 1);
228 is(join(':',@ary), '3:2:1');
231 is($seen{'STORESIZE'}, 1, 'seen STORESIZE');
232 is(join(':',@ary), '3:2');
234 sub arysize :lvalue { $#ary }
236 is($seen{'STORESIZE'}, 2, 'seen STORESIZE');
237 is(join(':',@ary), '3');
243 # 20020401 mjd-perl-patch+@plover.com
244 # Thanks to Dave Mitchell for the small test case and the fix
248 sub X::TIEARRAY { bless {}, 'X' }
257 # If we survived this far.
261 { # 20020220 mjd-perl-patch+@plover.com
263 tie @n => 'NegIndex', ('A' .. 'E');
288 is(defined($n[$_]), '');
289 is(exists($n[$_]), '');
294 tie my @dummy, "NegFetchsize";
296 like($@, qr/^FETCHSIZE returned a negative value/,
297 " - croak on negative FETCHSIZE");
300 is($seen{'DESTROY'}, 3);