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 package main;
 138
 139 print "1..61\n";
 140 my $test = 1;
 141
 142 {my @ary;
 143
 144 { my $ob = tie @ary,'Implement',3,2,1;
 145   print "not " unless $ob;
 146   print "ok ", $test++,"\n";
 147   print "not " unless tied(@ary) == $ob;
 148   print "ok ", $test++,"\n";
 149 }
 150
 151
 152 print "not " unless @ary == 3;
 153 print "ok ", $test++,"\n";
 154
 155 print "not " unless $#ary == 2;
 156 print "ok ", $test++,"\n";
 157
 158 print "not " unless join(':',@ary) eq '3:2:1';
 159 print "ok ", $test++,"\n";
 160
 161 print "not " unless $seen{'FETCH'} >= 3;
 162 print "ok ", $test++,"\n";
 163
 164 @ary = (1,2,3);
 165
 166 print "not " unless $seen{'STORE'} >= 3;
 167 print "ok ", $test++,"\n";
 168 print "not " unless join(':',@ary) eq '1:2:3';
 169 print "ok ", $test++,"\n";
 170
 171 {my @thing = @ary;
 172 print "not " unless join(':',@thing) eq '1:2:3';
 173 print "ok ", $test++,"\n";
 174
 175 tie @thing,'Implement';
 176 @thing = @ary;
 177 print "not " unless join(':',@thing) eq '1:2:3';
 178 print "ok ", $test++,"\n";
 179 }
 180
 181 print "not " unless pop(@ary) == 3;
 182 print "ok ", $test++,"\n";
 183 print "not " unless $seen{'POP'} == 1;
 184 print "ok ", $test++,"\n";
 185 print "not " unless join(':',@ary) eq '1:2';
 186 print "ok ", $test++,"\n";
 187
 188 push(@ary,4);
 189 print "not " unless $seen{'PUSH'} == 1;
 190 print "ok ", $test++,"\n";
 191 print "not " unless join(':',@ary) eq '1:2:4';
 192 print "ok ", $test++,"\n";
 193
 194 my @x = splice(@ary,1,1,7);
 195
 196
 197 print "not " unless $seen{'SPLICE'} == 1;
 198 print "ok ", $test++,"\n";
 199
 200 print "not " unless @x == 1;
 201 print "ok ", $test++,"\n";
 202 print "not " unless $x[0] == 2;
 203 print "ok ", $test++,"\n";
 204 print "not " unless join(':',@ary) eq '1:7:4';
 205 print "ok ", $test++,"\n";
 206
 207 print "not " unless shift(@ary) == 1;
 208 print "ok ", $test++,"\n";
 209 print "not " unless $seen{'SHIFT'} == 1;
 210 print "ok ", $test++,"\n";
 211 print "not " unless join(':',@ary) eq '7:4';
 212 print "ok ", $test++,"\n";
 213
 214 my $n = unshift(@ary,5,6);
 215 print "not " unless $seen{'UNSHIFT'} == 1;
 216 print "ok ", $test++,"\n";
 217 print "not " unless $n == 4;
 218 print "ok ", $test++,"\n";
 219 print "not " unless join(':',@ary) eq '5:6:7:4';
 220 print "ok ", $test++,"\n";
 221
 222 @ary = split(/:/,'1:2:3');
 223 print "not " unless join(':',@ary) eq '1:2:3';
 224 print "ok ", $test++,"\n";
 225
 226
 227 my $t = 0;
 228 foreach $n (@ary)
 229  {
 230   print "not " unless $n == ++$t;
 231   print "ok ", $test++,"\n";
 232  }
 233
 234 # (30-33) 20020303 mjd-perl-patch+@plover.com
 235 @ary = ();
 236 $seen{POP} = 0;
 237 pop @ary;                       # this didn't used to call POP at all
 238 print "not " unless $seen{POP} == 1;
 239 print "ok ", $test++,"\n";
 240 $seen{SHIFT} = 0;
 241 shift @ary;                     # this didn't used to call SHIFT at  all
 242 print "not " unless $seen{SHIFT} == 1;
 243 print "ok ", $test++,"\n";
 244 $seen{PUSH} = 0;
 245 push @ary;                       # this didn't used to call PUSH at all
 246 print "not " unless $seen{PUSH} == 1;
 247 print "ok ", $test++,"\n";
 248 $seen{UNSHIFT} = 0;
 249 unshift @ary;                   # this didn't used to call UNSHIFT at all
 250 print "not " unless $seen{UNSHIFT} == 1;
 251 print "ok ", $test++,"\n";
 252
 253 @ary = qw(3 2 1);
 254 print "not " unless join(':',@ary) eq '3:2:1';
 255 print "ok ", $test++,"\n";
 256
 257 untie @ary;
 258
 259 }
 260
 261 # 20020401 mjd-perl-patch+@plover.com
 262 # Thanks to Dave Mitchell for the small test case and the fix
 263 {
 264   my @a;
 265
 266   sub X::TIEARRAY { bless {}, 'X' }
 267
 268   sub X::SPLICE {
 269     do '/dev/null';
 270     die;
 271   }
 272
 273   tie @a, 'X';
 274   eval { splice(@a) };
 275   # If we survived this far.
 276   print "ok ", $test++, "\n";
 277 }
 278
 279
 280 { # 20020220 mjd-perl-patch+@plover.com
 281   my @n;
 282   tie @n => 'NegIndex', ('A' .. 'E');
 283
 284   # FETCH
 285   print "not " unless $n[0] eq 'C';
 286   print "ok ", $test++,"\n";
 287   print "not " unless $n[1] eq 'D';
 288   print "ok ", $test++,"\n";
 289   print "not " unless $n[2] eq 'E';
 290   print "ok ", $test++,"\n";
 291   print "not " unless $n[-1] eq 'B';
 292   print "ok ", $test++,"\n";
 293   print "not " unless $n[-2] eq 'A';
 294   print "ok ", $test++,"\n";
 295
 296   # STORE
 297   $n[-2] = 'a';
 298   print "not " unless $n[-2] eq 'a';
 299   print "ok ", $test++,"\n";
 300   $n[-1] = 'b';
 301   print "not " unless $n[-1] eq 'b';
 302   print "ok ", $test++,"\n";
 303   $n[0] = 'c';
 304   print "not " unless $n[0] eq 'c';
 305   print "ok ", $test++,"\n";
 306   $n[1] = 'd';
 307   print "not " unless $n[1] eq 'd';
 308   print "ok ", $test++,"\n";
 309   $n[2] = 'e';
 310   print "not " unless $n[2] eq 'e';
 311   print "ok ", $test++,"\n";
 312
 313   # DELETE and EXISTS
 314   for (-2 .. 2) {
 315     print exists($n[$_]) ? "ok $test\n" : "not ok $test\n";
 316     $test++;
 317     delete $n[$_];
 318     print defined($n[$_]) ? "not ok $test\n" : "ok $test\n";
 319     $test++;
 320     print exists($n[$_]) ? "not ok $test\n" : "ok $test\n";
 321     $test++;
 322   }
 323 }
 324
 325
 326
 327 print "not " unless $seen{'DESTROY'} == 3;
 328 print "ok ", $test++,"\n";
 329