t/op/tiearray.t

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