t/op/tiearray.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 plan(tests => 75);
  10
  11 my %seen;
  12
  13 package Implement;
  14
  15 sub TIEARRAY {
  16     $seen{'TIEARRAY'}++;
  17     my ($class,@val) = @_;
  18     return bless \@val,$class;
  19 }
  20
  21 sub STORESIZE {
  22     $seen{'STORESIZE'}++;
  23     my ($ob,$sz) = @_;
  24     return $#{$ob} = $sz-1;
  25 }
  26
  27 sub EXTEND {
  28     $seen{'EXTEND'}++;
  29     my ($ob,$sz) = @_;
  30     return @$ob = $sz;
  31 }
  32
  33 sub FETCHSIZE {
  34     $seen{'FETCHSIZE'}++;
  35     return scalar(@{$_[0]});
  36 }
  37
  38 sub FETCH {
  39     $seen{'FETCH'}++;
  40     my ($ob,$id) = @_;
  41     return $ob->[$id];
  42 }
  43
  44 sub STORE {
  45     $seen{'STORE'}++;
  46     my ($ob,$id,$val) = @_;
  47     $ob->[$id] = $val;
  48 }
  49
  50 sub UNSHIFT {
  51     $seen{'UNSHIFT'}++;
  52     my $ob = shift;
  53     unshift(@$ob,@_);
  54 }
  55
  56 sub PUSH {
  57     $seen{'PUSH'}++;
  58     my $ob = shift;;
  59     push(@$ob,@_);
  60 }
  61
  62 sub CLEAR {
  63     $seen{'CLEAR'}++;
  64     @{$_[0]} = ();
  65 }
  66
  67 sub DESTROY {
  68     $seen{'DESTROY'}++;
  69 }
  70
  71 sub POP {
  72     $seen{'POP'}++;
  73     my ($ob) = @_;
  74     return pop(@$ob);
  75 }
  76
  77 sub SHIFT {
  78     $seen{'SHIFT'}++;
  79     my ($ob) = @_;
  80     return shift(@$ob);
  81 }
  82
  83 sub SPLICE {
  84     $seen{'SPLICE'}++;
  85     my $ob  = shift;
  86     my $off = @_ ? shift : 0;
  87     my $len = @_ ? shift : @$ob-1;
  88     return splice(@$ob,$off,$len,@_);
  89 }
  90
  91 package NegIndex;               # 20020220 MJD
  92 @ISA = 'Implement';
  93
  94 # simulate indices -2 .. 2
  95 my $offset = 2;
  96 $NegIndex::NEGATIVE_INDICES = 1;
  97
  98 sub FETCH {
  99     my ($ob,$id) = @_;
 100     #print "# FETCH @_\n";
 101     $id += $offset;
 102     $ob->[$id];
 103 }
 104
 105 sub STORE {
 106     my ($ob,$id,$value) = @_;
 107     #print "# STORE @_\n";
 108     $id += $offset;
 109     $ob->[$id] = $value;
 110 }
 111
 112 sub DELETE {
 113     my ($ob,$id) = @_;
 114     #print "# DELETE @_\n";
 115     $id += $offset;
 116     delete $ob->[$id];
 117 }
 118
 119 sub EXISTS {
 120     my ($ob,$id) = @_;
 121     #print "# EXISTS @_\n";
 122     $id += $offset;
 123     exists $ob->[$id];
 124 }
 125
 126 #
 127 # Returning -1 from FETCHSIZE used to get casted to U32 causing a
 128 # segfault
 129 #
 130
 131 package NegFetchsize;
 132
 133 sub TIEARRAY  { bless [] }
 134 sub FETCH     { }
 135 sub FETCHSIZE { -1 }
 136
 137
 138 package main;
 139
 140 {
 141     $seen{'DESTROY'} = 0;
 142     my @ary;
 143
 144     {
 145         my $ob = tie @ary,'Implement',3,2,1;
 146         ok($ob);
 147         is(tied(@ary), $ob);
 148     }
 149
 150     is(@ary, 3);
 151     is($#ary, 2);
 152     is(join(':',@ary), '3:2:1');
 153     cmp_ok($seen{'FETCH'}, '>=', 3);
 154
 155     @ary = (1,2,3);
 156
 157     cmp_ok($seen{'STORE'}, '>=', 3);
 158     is(join(':',@ary), '1:2:3');
 159
 160     {
 161         my @thing = @ary;
 162         is(join(':',@thing), '1:2:3');
 163
 164         tie @thing,'Implement';
 165         @thing = @ary;
 166         is(join(':',@thing), '1:2:3');
 167     }
 168     is($seen{'DESTROY'}, 1, "thing freed");
 169
 170     is(pop(@ary), 3);
 171     is($seen{'POP'}, 1);
 172     is(join(':',@ary), '1:2');
 173
 174     is(push(@ary,4), 3);
 175     is($seen{'PUSH'}, 1);
 176     is(join(':',@ary), '1:2:4');
 177
 178     my @x = splice(@ary,1,1,7);
 179
 180     is($seen{'SPLICE'}, 1);
 181     is(@x, 1);
 182     is($x[0], 2);
 183     is(join(':',@ary), '1:7:4');
 184
 185     is(shift(@ary), 1);
 186     is($seen{'SHIFT'}, 1);
 187     is(join(':',@ary), '7:4');
 188
 189     my $n = unshift(@ary,5,6);
 190     is($seen{'UNSHIFT'}, 1);
 191     is($n, 4);
 192     is(join(':',@ary), '5:6:7:4');
 193
 194     @ary = split(/:/,'1:2:3');
 195     is(join(':',@ary), '1:2:3');
 196
 197     my $t = 0;
 198     foreach $n (@ary) {
 199          is($n, ++$t);
 200     }
 201
 202     # (30-33) 20020303 mjd-perl-patch+@plover.com
 203     @ary = ();
 204     $seen{POP} = 0;
 205     pop @ary;                       # this didn't used to call POP at all
 206     is($seen{POP}, 1);
 207     $seen{SHIFT} = 0;
 208     shift @ary;                     # this didn't used to call SHIFT at  all
 209     is($seen{SHIFT}, 1);
 210     $seen{PUSH} = 0;
 211     my $got = push @ary;            # this didn't used to call PUSH at all
 212     is($got, 0);
 213     is($seen{PUSH}, 1);
 214     $seen{UNSHIFT} = 0;
 215     $got = unshift @ary;            # this didn't used to call UNSHIFT at all
 216     is($got, 0);
 217     is($seen{UNSHIFT}, 1);
 218
 219     @ary = qw(3 2 1);
 220     is(join(':',@ary), '3:2:1');
 221
 222     $#ary = 1;
 223     is($seen{'STORESIZE'}, 1, 'seen STORESIZE');
 224     is(join(':',@ary), '3:2');
 225
 226     sub arysize :lvalue { $#ary }
 227     arysize()--;
 228     is($seen{'STORESIZE'}, 2, 'seen STORESIZE');
 229     is(join(':',@ary), '3');
 230
 231     untie @ary;
 232 }
 233 is($seen{'DESTROY'}, 2, "ary freed");
 234
 235 # 20020401 mjd-perl-patch+@plover.com
 236 # Thanks to Dave Mitchell for the small test case and the fix
 237 {
 238     my @a;
 239
 240     sub X::TIEARRAY { bless {}, 'X' }
 241
 242     sub X::SPLICE {
 243         do '/dev/null';
 244         die;
 245     }
 246
 247     tie @a, 'X';
 248     eval { splice(@a) };
 249     # If we survived this far.
 250     pass();
 251 }
 252
 253 # 20020220 mjd-perl-patch+@plover.com
 254 {
 255     $seen{'DESTROY'} = 0;
 256
 257     my @n;
 258     tie @n => 'NegIndex', ('A' .. 'E');
 259
 260     # FETCH
 261     is($n[0], 'C');
 262     is($n[1], 'D');
 263     is($n[2], 'E');
 264     is($n[-1], 'B');
 265     is($n[-2], 'A');
 266
 267     # STORE
 268     $n[-2] = 'a';
 269     is($n[-2], 'a');
 270     $n[-1] = 'b';
 271     is($n[-1], 'b');
 272     $n[0] = 'c';
 273     is($n[0], 'c');
 274     $n[1] = 'd';
 275     is($n[1], 'd');
 276     $n[2] = 'e';
 277     is($n[2], 'e');
 278
 279     # DELETE and EXISTS
 280     for (-2 .. 2) {
 281         ok($n[$_]);
 282         delete $n[$_];
 283         is(defined($n[$_]), '');
 284         is(exists($n[$_]), '');
 285     }
 286 }
 287 is($seen{'DESTROY'}, 1, "n freed");
 288
 289 {
 290     tie my @dummy, "NegFetchsize";
 291     eval { "@dummy"; };
 292     like($@, qr/^FETCHSIZE returned a negative value/,
 293          " - croak on negative FETCHSIZE");
 294 }
 295
 296 {
 297     # check that a tied element assigned to an array doesn't remain tied
 298
 299     package Magical;
 300
 301     my $i = 10;
 302
 303     sub TIEARRAY { bless [1] }
 304     sub TIEHASH  { bless [1] }
 305     sub FETCHSIZE { 1; }
 306     sub FETCH { $i++ }
 307     sub STORE { $_[0][0] = $_[1]; }
 308     sub FIRSTKEY { 0 }
 309     sub NEXTKEY { }
 310
 311     package main;
 312
 313     my (@a, @b);
 314     tie @a, 'Magical';
 315     @b = @a;
 316     is ($b[0],  10, "Magical array fetch 1");
 317     $b[0] = 100;
 318     is ($b[0], 100, "Magical array fetch 2");
 319
 320     my (%a, %b);
 321     tie %a, 'Magical';
 322     %b = %a;
 323     is ($b{0},  11, "Magical hash fetch 1");
 324     $b{0} = 100;
 325     is ($b{0}, 100, "Magical hash fetch 2");
 326 }