t/op/tiearray.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 my %seen;
   9
  10 package Implement;
  11
  12 sub TIEARRAY
  13 {
  14  $seen{'TIEARRAY'}++;
  15  my ($class,@val) = @_;
  16  return bless \@val,$class;
  17 }
  18
  19 sub STORESIZE
  20 {
  21  $seen{'STORESIZE'}++;
  22  my ($ob,$sz) = @_;
  23  return @$ob = $sz;
  24 }
  25
  26 sub EXTEND
  27 {
  28  $seen{'EXTEND'}++;
  29  my ($ob,$sz) = @_;
  30  return @$ob = $sz;
  31 }
  32
  33 sub FETCHSIZE
  34 {
  35  $seen{'FETCHSIZE'}++;
  36  my ($ob) = @_;
  37  return @$ob-1;
  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  $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 }
  72
  73 sub POP
  74 {
  75  $seen{'POP'}++;
  76  my ($ob) = @_;
  77  return pop(@$ob);
  78 }
  79
  80 sub SHIFT
  81 {
  82  $seen{'SHIFT'}++;
  83  my ($ob) = @_;
  84  return shift(@$ob);
  85 }
  86
  87 sub SPLICE
  88 {
  89  $seen{'SPLICE'}++;
  90  my $ob  = shift;
  91  my $off = @_ ? shift : 0;
  92  my $len = @_ ? shift : @$ob-1;
  93  return splice(@$ob,$off,$len,@_);
  94 }
  95
  96 package main;
  97
  98 print "1..23\n";
  99 my $test = 1;
 100
 101 {my @ary;
 102
 103 { my $ob = tie @ary,'Implement',3,2,1;
 104   print "not " unless $ob;
 105   print "ok ", $test++,"\n";
 106   print "not " unless tied(@ary) == $ob;
 107   print "ok ", $test++,"\n";
 108 }
 109
 110
 111 print "not " unless @ary == 3;
 112 print "ok ", $test++,"\n";
 113
 114 print "not " unless $#ary == 2;
 115 print "ok ", $test++,"\n";
 116
 117 print "not " unless join(':',@ary) eq '3:2:1';
 118 print "ok ", $test++,"\n";
 119
 120 print "not " unless $seen{'FETCH'} >= 3;
 121 print "ok ", $test++,"\n";
 122
 123 @ary = (1,2,3);
 124
 125 print "not " unless $seen{'STORE'} >= 3;
 126 print "ok ", $test++,"\n";
 127
 128 print "not " unless join(':',@ary) eq '1:2:3';
 129 print "ok ", $test++,"\n";
 130
 131 print "not " unless pop(@ary) == 3;
 132 print "ok ", $test++,"\n";
 133 print "not " unless $seen{'POP'} == 1;
 134 print "ok ", $test++,"\n";
 135 print "not " unless join(':',@ary) eq '1:2';
 136 print "ok ", $test++,"\n";
 137
 138 push(@ary,4);
 139 print "not " unless $seen{'PUSH'} == 1;
 140 print "ok ", $test++,"\n";
 141 print "not " unless join(':',@ary) eq '1:2:4';
 142 print "ok ", $test++,"\n";
 143
 144 my @x = splice(@ary,1,1,7);
 145
 146
 147 print "not " unless $seen{'SPLICE'} == 1;
 148 print "ok ", $test++,"\n";
 149
 150 print "not " unless @x == 1;
 151 print "ok ", $test++,"\n";
 152 print "not " unless $x[0] == 2;
 153 print "ok ", $test++,"\n";
 154 print "not " unless join(':',@ary) eq '1:7:4';
 155 print "ok ", $test++,"\n";
 156
 157
 158
 159 print "not " unless shift(@ary) == 1;
 160 print "ok ", $test++,"\n";
 161 print "not " unless $seen{'SHIFT'} == 1;
 162 print "ok ", $test++,"\n";
 163 print "not " unless join(':',@ary) eq '7:4';
 164 print "ok ", $test++,"\n";
 165
 166
 167 unshift(@ary,5);
 168 print "not " unless $seen{'UNSHIFT'} == 1;
 169 print "ok ", $test++,"\n";
 170 print "not " unless join(':',@ary) eq '5:7:4';
 171 print "ok ", $test++,"\n";
 172
 173 @ary = split(/:/,'1:2:3');
 174 print "not " unless join(':',@ary) eq '1:2:3';
 175 print "ok ", $test++,"\n";
 176
 177 # untie @ary;
 178
 179 }
 180
 181
 182
 183