This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Negative subscripts optionally passed to tied array methods
[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 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