#!./perl
+
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
{
$seen{'STORESIZE'}++;
my ($ob,$sz) = @_;
- return @$ob = $sz;
+ return $#{$ob} = $sz-1;
}
sub EXTEND
sub FETCHSIZE
{
$seen{'FETCHSIZE'}++;
- my ($ob) = @_;
- return @$ob-1;
+ return scalar(@{$_[0]});
}
sub FETCH
sub UNSHIFT
{
$seen{'UNSHIFT'}++;
- $ob = shift;
+ my $ob = shift;
unshift(@$ob,@_);
}
sub CLEAR
{
$seen{'CLEAR'}++;
+ @{$_[0]} = ();
+}
+
+sub DESTROY
+{
+ $seen{'DESTROY'}++;
}
sub POP
return splice(@$ob,$off,$len,@_);
}
-package main;
+package NegIndex; # 20020220 MJD
+@ISA = 'Implement';
+
+# simulate indices -2 .. 2
+my $offset = 2;
+$NegIndex::NEGATIVE_INDICES = 1;
+
+sub FETCH {
+ my ($ob,$id) = @_;
+# print "# FETCH @_\n";
+ $id += $offset;
+ $ob->[$id];
+}
+
+sub STORE {
+ my ($ob,$id,$value) = @_;
+# print "# STORE @_\n";
+ $id += $offset;
+ $ob->[$id] = $value;
+}
+
+sub DELETE {
+ my ($ob,$id) = @_;
+# print "# DELETE @_\n";
+ $id += $offset;
+ delete $ob->[$id];
+}
+
+sub EXISTS {
+ my ($ob,$id) = @_;
+# print "# EXISTS @_\n";
+ $id += $offset;
+ exists $ob->[$id];
+}
+
+#
+# Returning -1 from FETCHSIZE used to get casted to U32 causing a
+# segfault
+#
+
+package NegFetchsize;
+
+sub TIEARRAY { bless [] }
+sub FETCH { }
+sub FETCHSIZE { -1 }
-print "1..23\n";
+package main;
+
+print "1..62\n";
my $test = 1;
{my @ary;
print "not " unless $seen{'STORE'} >= 3;
print "ok ", $test++,"\n";
-
print "not " unless join(':',@ary) eq '1:2:3';
print "ok ", $test++,"\n";
+{my @thing = @ary;
+print "not " unless join(':',@thing) eq '1:2:3';
+print "ok ", $test++,"\n";
+
+tie @thing,'Implement';
+@thing = @ary;
+print "not " unless join(':',@thing) eq '1:2:3';
+print "ok ", $test++,"\n";
+}
+
print "not " unless pop(@ary) == 3;
print "ok ", $test++,"\n";
print "not " unless $seen{'POP'} == 1;
print "not " unless join(':',@ary) eq '1:7:4';
print "ok ", $test++,"\n";
-
-
print "not " unless shift(@ary) == 1;
print "ok ", $test++,"\n";
print "not " unless $seen{'SHIFT'} == 1;
print "not " unless join(':',@ary) eq '7:4';
print "ok ", $test++,"\n";
-
-unshift(@ary,5);
+my $n = unshift(@ary,5,6);
print "not " unless $seen{'UNSHIFT'} == 1;
print "ok ", $test++,"\n";
-print "not " unless join(':',@ary) eq '5:7:4';
+print "not " unless $n == 4;
+print "ok ", $test++,"\n";
+print "not " unless join(':',@ary) eq '5:6:7:4';
print "ok ", $test++,"\n";
@ary = split(/:/,'1:2:3');
print "not " unless join(':',@ary) eq '1:2:3';
print "ok ", $test++,"\n";
+
+my $t = 0;
+foreach $n (@ary)
+ {
+ print "not " unless $n == ++$t;
+ print "ok ", $test++,"\n";
+ }
+
+# (30-33) 20020303 mjd-perl-patch+@plover.com
+@ary = ();
+$seen{POP} = 0;
+pop @ary; # this didn't used to call POP at all
+print "not " unless $seen{POP} == 1;
+print "ok ", $test++,"\n";
+$seen{SHIFT} = 0;
+shift @ary; # this didn't used to call SHIFT at all
+print "not " unless $seen{SHIFT} == 1;
+print "ok ", $test++,"\n";
+$seen{PUSH} = 0;
+push @ary; # this didn't used to call PUSH at all
+print "not " unless $seen{PUSH} == 1;
+print "ok ", $test++,"\n";
+$seen{UNSHIFT} = 0;
+unshift @ary; # this didn't used to call UNSHIFT at all
+print "not " unless $seen{UNSHIFT} == 1;
+print "ok ", $test++,"\n";
+
+@ary = qw(3 2 1);
+print "not " unless join(':',@ary) eq '3:2:1';
+print "ok ", $test++,"\n";
+
untie @ary;
-exit;
+}
+# 20020401 mjd-perl-patch+@plover.com
+# Thanks to Dave Mitchell for the small test case and the fix
+{
+ my @a;
+
+ sub X::TIEARRAY { bless {}, 'X' }
+
+ sub X::SPLICE {
+ do '/dev/null';
+ die;
+ }
+
+ tie @a, 'X';
+ eval { splice(@a) };
+ # If we survived this far.
+ print "ok ", $test++, "\n";
}
+{ # 20020220 mjd-perl-patch+@plover.com
+ my @n;
+ tie @n => 'NegIndex', ('A' .. 'E');
+
+ # FETCH
+ print "not " unless $n[0] eq 'C';
+ print "ok ", $test++,"\n";
+ print "not " unless $n[1] eq 'D';
+ print "ok ", $test++,"\n";
+ print "not " unless $n[2] eq 'E';
+ print "ok ", $test++,"\n";
+ print "not " unless $n[-1] eq 'B';
+ print "ok ", $test++,"\n";
+ print "not " unless $n[-2] eq 'A';
+ print "ok ", $test++,"\n";
+
+ # STORE
+ $n[-2] = 'a';
+ print "not " unless $n[-2] eq 'a';
+ print "ok ", $test++,"\n";
+ $n[-1] = 'b';
+ print "not " unless $n[-1] eq 'b';
+ print "ok ", $test++,"\n";
+ $n[0] = 'c';
+ print "not " unless $n[0] eq 'c';
+ print "ok ", $test++,"\n";
+ $n[1] = 'd';
+ print "not " unless $n[1] eq 'd';
+ print "ok ", $test++,"\n";
+ $n[2] = 'e';
+ print "not " unless $n[2] eq 'e';
+ print "ok ", $test++,"\n";
+
+ # DELETE and EXISTS
+ for (-2 .. 2) {
+ print exists($n[$_]) ? "ok $test\n" : "not ok $test\n";
+ $test++;
+ delete $n[$_];
+ print defined($n[$_]) ? "not ok $test\n" : "ok $test\n";
+ $test++;
+ print exists($n[$_]) ? "not ok $test\n" : "ok $test\n";
+ $test++;
+ }
+}
+
+
+
+{
+ tie my @dummy, "NegFetchsize";
+ eval { "@dummy"; };
+ print "# $@" if $@;
+ print "not " unless $@ =~ /^FETCHSIZE returned a negative value/;
+ print "ok ", $test++, " - croak on negative FETCHSIZE\n";
+}
+print "not " unless $seen{'DESTROY'} == 3;
+print "ok ", $test++,"\n";