t/op/tiearray.t

   1 #!./perl
   2
   3
   4 BEGIN {
   5     chdir 't' if -d 't';
   6     @INC = '../lib';
   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 print "1..66\n";
 151 my $test = 1;
 152
 153 {my @ary;
 154
 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";
 160 }
 161
 162
 163 print "not " unless @ary == 3;
 164 print "ok ", $test++,"\n";
 165
 166 print "not " unless $#ary == 2;
 167 print "ok ", $test++,"\n";
 168
 169 print "not " unless join(':',@ary) eq '3:2:1';
 170 print "ok ", $test++,"\n";
 171
 172 print "not " unless $seen{'FETCH'} >= 3;
 173 print "ok ", $test++,"\n";
 174
 175 @ary = (1,2,3);
 176
 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";
 181
 182 {my @thing = @ary;
 183 print "not " unless join(':',@thing) eq '1:2:3';
 184 print "ok ", $test++,"\n";
 185
 186 tie @thing,'Implement';
 187 @thing = @ary;
 188 print "not " unless join(':',@thing) eq '1:2:3';
 189 print "ok ", $test++,"\n";
 190 }
 191
 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";
 198
 199 push(@ary,4);
 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";
 204
 205 my @x = splice(@ary,1,1,7);
 206
 207
 208 print "not " unless $seen{'SPLICE'} == 1;
 209 print "ok ", $test++,"\n";
 210
 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";
 217
 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";
 224
 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";
 232
 233 @ary = split(/:/,'1:2:3');
 234 print "not " unless join(':',@ary) eq '1:2:3';
 235 print "ok ", $test++,"\n";
 236
 237 my $t = 0;
 238 foreach $n (@ary)
 239  {
 240   print "not " unless $n == ++$t;
 241   print "ok ", $test++,"\n";
 242  }
 243
 244 # (30-33) 20020303 mjd-perl-patch+@plover.com
 245 @ary = ();
 246 $seen{POP} = 0;
 247 pop @ary;                       # this didn't used to call POP at all
 248 print "not " unless $seen{POP} == 1;
 249 print "ok ", $test++,"\n";
 250 $seen{SHIFT} = 0;
 251 shift @ary;                     # this didn't used to call SHIFT at  all
 252 print "not " unless $seen{SHIFT} == 1;
 253 print "ok ", $test++,"\n";
 254 $seen{PUSH} = 0;
 255 push @ary;                       # this didn't used to call PUSH at all
 256 print "not " unless $seen{PUSH} == 1;
 257 print "ok ", $test++,"\n";
 258 $seen{UNSHIFT} = 0;
 259 unshift @ary;                   # this didn't used to call UNSHIFT at all
 260 print "not " unless $seen{UNSHIFT} == 1;
 261 print "ok ", $test++,"\n";
 262
 263 @ary = qw(3 2 1);
 264 print "not " unless join(':',@ary) eq '3:2:1';
 265 print "ok ", $test++,"\n";
 266
 267 $#ary = 1;
 268 print "not " unless $seen{'STORESIZE'} == 1;
 269 print "ok ", $test++," -- seen STORESIZE\n";
 270 print "not " unless join(':',@ary) eq '3:2';
 271 print "ok ", $test++,"\n";
 272
 273 sub arysize :lvalue { $#ary }
 274 arysize()--;
 275 print "not " unless $seen{'STORESIZE'} == 2;
 276 print "ok ", $test++," -- seen STORESIZE\n";
 277 print "not " unless join(':',@ary) eq '3';
 278 print "ok ", $test++,"\n";
 279
 280 untie @ary;
 281
 282 }
 283
 284 # 20020401 mjd-perl-patch+@plover.com
 285 # Thanks to Dave Mitchell for the small test case and the fix
 286 {
 287   my @a;
 288
 289   sub X::TIEARRAY { bless {}, 'X' }
 290
 291   sub X::SPLICE {
 292     do '/dev/null';
 293     die;
 294   }
 295
 296   tie @a, 'X';
 297   eval { splice(@a) };
 298   # If we survived this far.
 299   print "ok ", $test++, "\n";
 300 }
 301
 302
 303 { # 20020220 mjd-perl-patch+@plover.com
 304   my @n;
 305   tie @n => 'NegIndex', ('A' .. 'E');
 306
 307   # FETCH
 308   print "not " unless $n[0] eq 'C';
 309   print "ok ", $test++,"\n";
 310   print "not " unless $n[1] eq 'D';
 311   print "ok ", $test++,"\n";
 312   print "not " unless $n[2] eq 'E';
 313   print "ok ", $test++,"\n";
 314   print "not " unless $n[-1] eq 'B';
 315   print "ok ", $test++,"\n";
 316   print "not " unless $n[-2] eq 'A';
 317   print "ok ", $test++,"\n";
 318
 319   # STORE
 320   $n[-2] = 'a';
 321   print "not " unless $n[-2] eq 'a';
 322   print "ok ", $test++,"\n";
 323   $n[-1] = 'b';
 324   print "not " unless $n[-1] eq 'b';
 325   print "ok ", $test++,"\n";
 326   $n[0] = 'c';
 327   print "not " unless $n[0] eq 'c';
 328   print "ok ", $test++,"\n";
 329   $n[1] = 'd';
 330   print "not " unless $n[1] eq 'd';
 331   print "ok ", $test++,"\n";
 332   $n[2] = 'e';
 333   print "not " unless $n[2] eq 'e';
 334   print "ok ", $test++,"\n";
 335
 336   # DELETE and EXISTS
 337   for (-2 .. 2) {
 338     print exists($n[$_]) ? "ok $test\n" : "not ok $test\n";
 339     $test++;
 340     delete $n[$_];
 341     print defined($n[$_]) ? "not ok $test\n" : "ok $test\n";
 342     $test++;
 343     print exists($n[$_]) ? "not ok $test\n" : "ok $test\n";
 344     $test++;
 345   }
 346 }
 347
 348
 349
 350 {
 351     tie my @dummy, "NegFetchsize";
 352     eval { "@dummy"; };
 353     print "# $@" if $@;
 354     print "not " unless $@ =~ /^FETCHSIZE returned a negative value/;
 355     print "ok ", $test++, " - croak on negative FETCHSIZE\n";
 356 }
 357
 358 print "not " unless $seen{'DESTROY'} == 3;
 359 print "ok ", $test++,"\n";
 360