This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
TIEARRAY updates - almost works ...
[perl5.git] / 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..29\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
134 print "not " unless join(':',@ary) eq '1:2:3';
135 print "ok ", $test++,"\n";         
136
137 print "not " unless pop(@ary) == 3;
138 print "ok ", $test++,"\n";
139 print "not " unless $seen{'POP'} == 1;
140 print "ok ", $test++,"\n";
141 print "not " unless join(':',@ary) eq '1:2';
142 print "ok ", $test++,"\n";
143
144 push(@ary,4);
145 print "not " unless $seen{'PUSH'} == 1;
146 print "ok ", $test++,"\n";
147 print "not " unless join(':',@ary) eq '1:2:4';
148 print "ok ", $test++,"\n";
149
150 my @x = splice(@ary,1,1,7);
151
152
153 print "not " unless $seen{'SPLICE'} == 1;
154 print "ok ", $test++,"\n";
155
156 print "not " unless @x == 1;
157 print "ok ", $test++,"\n";
158 print "not " unless $x[0] == 2;
159 print "ok ", $test++,"\n";
160 print "not " unless join(':',@ary) eq '1:7:4';
161 print "ok ", $test++,"\n";             
162
163 print "not " unless shift(@ary) == 1;
164 print "ok ", $test++,"\n";
165 print "not " unless $seen{'SHIFT'} == 1;
166 print "ok ", $test++,"\n";
167 print "not " unless join(':',@ary) eq '7:4';
168 print "ok ", $test++,"\n";             
169
170 my $n = unshift(@ary,5,6);
171 print "not " unless $seen{'UNSHIFT'} == 1;
172 print "ok ", $test++,"\n";
173 print "not " unless $n == 4;
174 print "ok ", $test++,"\n";
175 print "not " unless join(':',@ary) eq '5:6:7:4';
176 print "ok ", $test++,"\n";
177
178 @ary = split(/:/,'1:2:3');
179 print "not " unless join(':',@ary) eq '1:2:3';
180 print "ok ", $test++,"\n";         
181   
182 my $t = 0;
183 foreach $n (@ary)
184  {
185   print "not " unless $n == ++$t;
186   print "ok ", $test++,"\n";         
187  }
188
189 @ary = qw(3 2 1);
190 print "not " unless join(':',@ary) eq '3:2:1';
191 print "ok ", $test++,"\n";         
192
193 untie @ary;   
194
195 }
196                            
197 print "not " unless $seen{'DESTROY'} == 1;
198 print "ok ", $test++,"\n";         
199
200
201