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
CommitLineData
93965878
NIS
1#!./perl
2
a60c0954 3
93965878
NIS
4BEGIN {
5 chdir 't' if -d 't';
20822f61 6 @INC = '../lib';
93965878
NIS
7}
8
9my %seen;
10
11package Implement;
12
13sub TIEARRAY
14{
15 $seen{'TIEARRAY'}++;
16 my ($class,@val) = @_;
17 return bless \@val,$class;
18}
19
20sub STORESIZE
21{
22 $seen{'STORESIZE'}++;
23 my ($ob,$sz) = @_;
a60c0954 24 return $#{$ob} = $sz-1;
93965878
NIS
25}
26
27sub EXTEND
28{
29 $seen{'EXTEND'}++;
30 my ($ob,$sz) = @_;
31 return @$ob = $sz;
32}
33
34sub FETCHSIZE
35{
36 $seen{'FETCHSIZE'}++;
a60c0954 37 return scalar(@{$_[0]});
93965878
NIS
38}
39
40sub FETCH
41{
42 $seen{'FETCH'}++;
43 my ($ob,$id) = @_;
44 return $ob->[$id];
45}
46
47sub STORE
48{
49 $seen{'STORE'}++;
50 my ($ob,$id,$val) = @_;
51 $ob->[$id] = $val;
52}
53
54sub UNSHIFT
55{
56 $seen{'UNSHIFT'}++;
a60c0954 57 my $ob = shift;
93965878
NIS
58 unshift(@$ob,@_);
59}
60
61sub PUSH
62{
63 $seen{'PUSH'}++;
64 my $ob = shift;;
65 push(@$ob,@_);
66}
67
68sub CLEAR
69{
70 $seen{'CLEAR'}++;
a60c0954
NIS
71 @{$_[0]} = ();
72}
73
74sub DESTROY
75{
76 $seen{'DESTROY'}++;
93965878
NIS
77}
78
79sub POP
80{
81 $seen{'POP'}++;
82 my ($ob) = @_;
83 return pop(@$ob);
84}
85
86sub SHIFT
87{
88 $seen{'SHIFT'}++;
89 my ($ob) = @_;
90 return shift(@$ob);
91}
92
93sub 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
6f12eb6d
MJD
102package NegIndex; # 20020220 MJD
103@ISA = 'Implement';
104
105# simulate indices -2 .. 2
106my $offset = 2;
107$NegIndex::NEGATIVE_INDICES = 1;
108
109sub FETCH {
110 my ($ob,$id) = @_;
111# print "# FETCH @_\n";
112 $id += $offset;
113 $ob->[$id];
114}
115
116sub STORE {
117 my ($ob,$id,$value) = @_;
118# print "# STORE @_\n";
119 $id += $offset;
120 $ob->[$id] = $value;
121}
122
123sub DELETE {
124 my ($ob,$id) = @_;
125# print "# DELETE @_\n";
126 $id += $offset;
127 delete $ob->[$id];
128}
129
130sub EXISTS {
131 my ($ob,$id) = @_;
132# print "# EXISTS @_\n";
133 $id += $offset;
134 exists $ob->[$id];
135}
93965878 136
6f12eb6d
MJD
137package main;
138
139print "1..61\n";
93965878
NIS
140my $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
152print "not " unless @ary == 3;
153print "ok ", $test++,"\n";
154
155print "not " unless $#ary == 2;
156print "ok ", $test++,"\n";
157
158print "not " unless join(':',@ary) eq '3:2:1';
159print "ok ", $test++,"\n";
160
161print "not " unless $seen{'FETCH'} >= 3;
162print "ok ", $test++,"\n";
163
164@ary = (1,2,3);
165
166print "not " unless $seen{'STORE'} >= 3;
167print "ok ", $test++,"\n";
93965878
NIS
168print "not " unless join(':',@ary) eq '1:2:3';
169print "ok ", $test++,"\n";
170
1c0b011c
NIS
171{my @thing = @ary;
172print "not " unless join(':',@thing) eq '1:2:3';
173print "ok ", $test++,"\n";
174
175tie @thing,'Implement';
176@thing = @ary;
177print "not " unless join(':',@thing) eq '1:2:3';
178print "ok ", $test++,"\n";
179}
180
93965878
NIS
181print "not " unless pop(@ary) == 3;
182print "ok ", $test++,"\n";
183print "not " unless $seen{'POP'} == 1;
184print "ok ", $test++,"\n";
185print "not " unless join(':',@ary) eq '1:2';
186print "ok ", $test++,"\n";
187
188push(@ary,4);
189print "not " unless $seen{'PUSH'} == 1;
190print "ok ", $test++,"\n";
191print "not " unless join(':',@ary) eq '1:2:4';
192print "ok ", $test++,"\n";
193
194my @x = splice(@ary,1,1,7);
195
196
197print "not " unless $seen{'SPLICE'} == 1;
198print "ok ", $test++,"\n";
199
200print "not " unless @x == 1;
201print "ok ", $test++,"\n";
202print "not " unless $x[0] == 2;
203print "ok ", $test++,"\n";
204print "not " unless join(':',@ary) eq '1:7:4';
205print "ok ", $test++,"\n";
206
93965878
NIS
207print "not " unless shift(@ary) == 1;
208print "ok ", $test++,"\n";
209print "not " unless $seen{'SHIFT'} == 1;
210print "ok ", $test++,"\n";
211print "not " unless join(':',@ary) eq '7:4';
212print "ok ", $test++,"\n";
213
a60c0954 214my $n = unshift(@ary,5,6);
93965878
NIS
215print "not " unless $seen{'UNSHIFT'} == 1;
216print "ok ", $test++,"\n";
a60c0954
NIS
217print "not " unless $n == 4;
218print "ok ", $test++,"\n";
219print "not " unless join(':',@ary) eq '5:6:7:4';
93965878
NIS
220print "ok ", $test++,"\n";
221
222@ary = split(/:/,'1:2:3');
223print "not " unless join(':',@ary) eq '1:2:3';
224print "ok ", $test++,"\n";
8c204006 225
a60c0954
NIS
226
227my $t = 0;
228foreach $n (@ary)
229 {
230 print "not " unless $n == ++$t;
231 print "ok ", $test++,"\n";
232 }
233
cf8feb78 234# (30-33) 20020303 mjd-perl-patch+@plover.com
8c204006
MJD
235@ary = ();
236$seen{POP} = 0;
237pop @ary; # this didn't used to call POP at all
238print "not " unless $seen{POP} == 1;
239print "ok ", $test++,"\n";
240$seen{SHIFT} = 0;
241shift @ary; # this didn't used to call SHIFT at all
242print "not " unless $seen{SHIFT} == 1;
243print "ok ", $test++,"\n";
244$seen{PUSH} = 0;
245push @ary; # this didn't used to call PUSH at all
246print "not " unless $seen{PUSH} == 1;
247print "ok ", $test++,"\n";
248$seen{UNSHIFT} = 0;
249unshift @ary; # this didn't used to call UNSHIFT at all
250print "not " unless $seen{UNSHIFT} == 1;
251print "ok ", $test++,"\n";
252
a60c0954
NIS
253@ary = qw(3 2 1);
254print "not " unless join(':',@ary) eq '3:2:1';
255print "ok ", $test++,"\n";
93965878 256
a60c0954 257untie @ary;
93965878
NIS
258
259}
cf8feb78
MJD
260
261# 20020401 mjd-perl-patch+@plover.com
11ec0460 262# Thanks to Dave Mitchell for the small test case and the fix
74d0c54f 263{
cf8feb78
MJD
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) };
74d0c54f
JH
275 # If we survived this far.
276 print "ok ", $test++, "\n";
cf8feb78 277}
6f12eb6d
MJD
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
a60c0954 326
6f12eb6d 327print "not " unless $seen{'DESTROY'} == 3;
a60c0954 328print "ok ", $test++,"\n";
93965878 329