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 main;
 103
 104 print "1..31\n";
 105 my $test = 1;
 106
 107 {my @ary;
 108
 109 { my $ob = tie @ary,'Implement',3,2,1;
 110   print "not " unless $ob;
 111   print "ok ", $test++,"\n";
 112   print "not " unless tied(@ary) == $ob;
 113   print "ok ", $test++,"\n";
 114 }
 115
 116
 117 print "not " unless @ary == 3;
 118 print "ok ", $test++,"\n";
 119
 120 print "not " unless $#ary == 2;
 121 print "ok ", $test++,"\n";
 122
 123 print "not " unless join(':',@ary) eq '3:2:1';
 124 print "ok ", $test++,"\n";
 125
 126 print "not " unless $seen{'FETCH'} >= 3;
 127 print "ok ", $test++,"\n";
 128
 129 @ary = (1,2,3);
 130
 131 print "not " unless $seen{'STORE'} >= 3;
 132 print "ok ", $test++,"\n";
 133 print "not " unless join(':',@ary) eq '1:2:3';
 134 print "ok ", $test++,"\n";
 135
 136 {my @thing = @ary;
 137 print "not " unless join(':',@thing) eq '1:2:3';
 138 print "ok ", $test++,"\n";
 139
 140 tie @thing,'Implement';
 141 @thing = @ary;
 142 print "not " unless join(':',@thing) eq '1:2:3';
 143 print "ok ", $test++,"\n";
 144 }
 145
 146 print "not " unless pop(@ary) == 3;
 147 print "ok ", $test++,"\n";
 148 print "not " unless $seen{'POP'} == 1;
 149 print "ok ", $test++,"\n";
 150 print "not " unless join(':',@ary) eq '1:2';
 151 print "ok ", $test++,"\n";
 152
 153 push(@ary,4);
 154 print "not " unless $seen{'PUSH'} == 1;
 155 print "ok ", $test++,"\n";
 156 print "not " unless join(':',@ary) eq '1:2:4';
 157 print "ok ", $test++,"\n";
 158
 159 my @x = splice(@ary,1,1,7);
 160
 161
 162 print "not " unless $seen{'SPLICE'} == 1;
 163 print "ok ", $test++,"\n";
 164
 165 print "not " unless @x == 1;
 166 print "ok ", $test++,"\n";
 167 print "not " unless $x[0] == 2;
 168 print "ok ", $test++,"\n";
 169 print "not " unless join(':',@ary) eq '1:7:4';
 170 print "ok ", $test++,"\n";
 171
 172 print "not " unless shift(@ary) == 1;
 173 print "ok ", $test++,"\n";
 174 print "not " unless $seen{'SHIFT'} == 1;
 175 print "ok ", $test++,"\n";
 176 print "not " unless join(':',@ary) eq '7:4';
 177 print "ok ", $test++,"\n";
 178
 179 my $n = unshift(@ary,5,6);
 180 print "not " unless $seen{'UNSHIFT'} == 1;
 181 print "ok ", $test++,"\n";
 182 print "not " unless $n == 4;
 183 print "ok ", $test++,"\n";
 184 print "not " unless join(':',@ary) eq '5:6:7:4';
 185 print "ok ", $test++,"\n";
 186
 187 @ary = split(/:/,'1:2:3');
 188 print "not " unless join(':',@ary) eq '1:2:3';
 189 print "ok ", $test++,"\n";
 190
 191 my $t = 0;
 192 foreach $n (@ary)
 193  {
 194   print "not " unless $n == ++$t;
 195   print "ok ", $test++,"\n";
 196  }
 197
 198 @ary = qw(3 2 1);
 199 print "not " unless join(':',@ary) eq '3:2:1';
 200 print "ok ", $test++,"\n";
 201
 202 untie @ary;
 203
 204 }
 205
 206 print "not " unless $seen{'DESTROY'} == 2;
 207 print "ok ", $test++,"\n";
 208
 209
 210