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..62\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
 238 my $t = 0;
 239 foreach $n (@ary)
 240  {
 241   print "not " unless $n == ++$t;
 242   print "ok ", $test++,"\n";
 243  }
 244
 245 # (30-33) 20020303 mjd-perl-patch+@plover.com
 246 @ary = ();
 247 $seen{POP} = 0;
 248 pop @ary;                       # this didn't used to call POP at all
 249 print "not " unless $seen{POP} == 1;
 250 print "ok ", $test++,"\n";
 251 $seen{SHIFT} = 0;
 252 shift @ary;                     # this didn't used to call SHIFT at  all
 253 print "not " unless $seen{SHIFT} == 1;
 254 print "ok ", $test++,"\n";
 255 $seen{PUSH} = 0;
 256 push @ary;                       # this didn't used to call PUSH at all
 257 print "not " unless $seen{PUSH} == 1;
 258 print "ok ", $test++,"\n";
 259 $seen{UNSHIFT} = 0;
 260 unshift @ary;                   # this didn't used to call UNSHIFT at all
 261 print "not " unless $seen{UNSHIFT} == 1;
 262 print "ok ", $test++,"\n";
 263
 264 @ary = qw(3 2 1);
 265 print "not " unless join(':',@ary) eq '3:2:1';
 266 print "ok ", $test++,"\n";
 267
 268 untie @ary;
 269
 270 }
 271
 272 # 20020401 mjd-perl-patch+@plover.com
 273 # Thanks to Dave Mitchell for the small test case and the fix
 274 {
 275   my @a;
 276
 277   sub X::TIEARRAY { bless {}, 'X' }
 278
 279   sub X::SPLICE {
 280     do '/dev/null';
 281     die;
 282   }
 283
 284   tie @a, 'X';
 285   eval { splice(@a) };
 286   # If we survived this far.
 287   print "ok ", $test++, "\n";
 288 }
 289
 290
 291 { # 20020220 mjd-perl-patch+@plover.com
 292   my @n;
 293   tie @n => 'NegIndex', ('A' .. 'E');
 294
 295   # FETCH
 296   print "not " unless $n[0] eq 'C';
 297   print "ok ", $test++,"\n";
 298   print "not " unless $n[1] eq 'D';
 299   print "ok ", $test++,"\n";
 300   print "not " unless $n[2] eq 'E';
 301   print "ok ", $test++,"\n";
 302   print "not " unless $n[-1] eq 'B';
 303   print "ok ", $test++,"\n";
 304   print "not " unless $n[-2] eq 'A';
 305   print "ok ", $test++,"\n";
 306
 307   # STORE
 308   $n[-2] = 'a';
 309   print "not " unless $n[-2] eq 'a';
 310   print "ok ", $test++,"\n";
 311   $n[-1] = 'b';
 312   print "not " unless $n[-1] eq 'b';
 313   print "ok ", $test++,"\n";
 314   $n[0] = 'c';
 315   print "not " unless $n[0] eq 'c';
 316   print "ok ", $test++,"\n";
 317   $n[1] = 'd';
 318   print "not " unless $n[1] eq 'd';
 319   print "ok ", $test++,"\n";
 320   $n[2] = 'e';
 321   print "not " unless $n[2] eq 'e';
 322   print "ok ", $test++,"\n";
 323
 324   # DELETE and EXISTS
 325   for (-2 .. 2) {
 326     print exists($n[$_]) ? "ok $test\n" : "not ok $test\n";
 327     $test++;
 328     delete $n[$_];
 329     print defined($n[$_]) ? "not ok $test\n" : "ok $test\n";
 330     $test++;
 331     print exists($n[$_]) ? "not ok $test\n" : "ok $test\n";
 332     $test++;
 333   }
 334 }
 335
 336
 337
 338 {
 339     tie my @dummy, "NegFetchsize";
 340     eval { "@dummy"; };
 341     print "# $@" if $@;
 342     print "not " unless $@ =~ /^FETCHSIZE returned a negative value/;
 343     print "ok ", $test++, " - croak on negative FETCHSIZE\n";
 344 }
 345
 346 print "not " unless $seen{'DESTROY'} == 3;
 347 print "ok ", $test++,"\n";
 348