xref: /openbsd/gnu/usr.bin/perl/t/op/tiearray.t (revision cecf84d4) 
1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    @INC = '../lib';
6    require './test.pl';
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) = @_;
24 return $#{$ob} = $sz-1;
25}
26
27sub EXTEND
28{
29 $seen{'EXTEND'}++;
30 my ($ob,$sz) = @_;
31 return @$ob = $sz;
32}
33
34sub FETCHSIZE
35{
36 $seen{'FETCHSIZE'}++;
37 return scalar(@{$_[0]});
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'}++;
57 my $ob = shift;
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'}++;
71 @{$_[0]} = ();
72}
73
74sub DESTROY
75{
76 $seen{'DESTROY'}++;
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
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}
136
137#
138# Returning -1 from FETCHSIZE used to get casted to U32 causing a
139# segfault
140#
141
142package NegFetchsize;
143
144sub TIEARRAY  { bless [] }
145sub FETCH     { }
146sub FETCHSIZE { -1 }
147
148package main;
149
150plan(tests => 69);
151
152{my @ary;
153
154{ my $ob = tie @ary,'Implement',3,2,1;
155  ok($ob);
156  is(tied(@ary), $ob);
157}
158
159is(@ary, 3);
160is($#ary, 2);
161is(join(':',@ary), '3:2:1');
162cmp_ok($seen{'FETCH'}, '>=', 3);
163
164@ary = (1,2,3);
165
166cmp_ok($seen{'STORE'}, '>=', 3);
167is(join(':',@ary), '1:2:3');
168
169{my @thing = @ary;
170is(join(':',@thing), '1:2:3');
171
172tie @thing,'Implement';
173@thing = @ary;
174is(join(':',@thing), '1:2:3');
175}
176
177is(pop(@ary), 3);
178is($seen{'POP'}, 1);
179is(join(':',@ary), '1:2');
180
181is(push(@ary,4), 3);
182is($seen{'PUSH'}, 1);
183is(join(':',@ary), '1:2:4');
184
185my @x = splice(@ary,1,1,7);
186
187is($seen{'SPLICE'}, 1);
188is(@x, 1);
189is($x[0], 2);
190is(join(':',@ary), '1:7:4');
191
192is(shift(@ary), 1);
193is($seen{'SHIFT'}, 1);
194is(join(':',@ary), '7:4');
195
196my $n = unshift(@ary,5,6);
197is($seen{'UNSHIFT'}, 1);
198is($n, 4);
199is(join(':',@ary), '5:6:7:4');
200
201@ary = split(/:/,'1:2:3');
202is(join(':',@ary), '1:2:3');
203
204my $t = 0;
205foreach $n (@ary)
206 {
207     is($n, ++$t);
208 }
209
210# (30-33) 20020303 mjd-perl-patch+@plover.com
211@ary = ();
212$seen{POP} = 0;
213pop @ary;                       # this didn't used to call POP at all
214is($seen{POP}, 1);
215$seen{SHIFT} = 0;
216shift @ary;                     # this didn't used to call SHIFT at  all
217is($seen{SHIFT}, 1);
218$seen{PUSH} = 0;
219my $got = push @ary;            # this didn't used to call PUSH at all
220is($got, 0);
221is($seen{PUSH}, 1);
222$seen{UNSHIFT} = 0;
223$got = unshift @ary;            # this didn't used to call UNSHIFT at all
224is($got, 0);
225is($seen{UNSHIFT}, 1);
226
227@ary = qw(3 2 1);
228is(join(':',@ary), '3:2:1');
229
230$#ary = 1;
231is($seen{'STORESIZE'}, 1, 'seen STORESIZE');
232is(join(':',@ary), '3:2');
233
234sub arysize :lvalue { $#ary }
235arysize()--;
236is($seen{'STORESIZE'}, 2, 'seen STORESIZE');
237is(join(':',@ary), '3');
238
239untie @ary;
240
241}
242
243# 20020401 mjd-perl-patch+@plover.com
244# Thanks to Dave Mitchell for the small test case and the fix
245{
246  my @a;
247
248  sub X::TIEARRAY { bless {}, 'X' }
249
250  sub X::SPLICE {
251    do '/dev/null';
252    die;
253  }
254
255  tie @a, 'X';
256  eval { splice(@a) };
257  # If we survived this far.
258  pass();
259}
260
261{ # 20020220 mjd-perl-patch+@plover.com
262  my @n;
263  tie @n => 'NegIndex', ('A' .. 'E');
264
265  # FETCH
266  is($n[0], 'C');
267  is($n[1], 'D');
268  is($n[2], 'E');
269  is($n[-1], 'B');
270  is($n[-2], 'A');
271
272  # STORE
273  $n[-2] = 'a';
274  is($n[-2], 'a');
275  $n[-1] = 'b';
276  is($n[-1], 'b');
277  $n[0] = 'c';
278  is($n[0], 'c');
279  $n[1] = 'd';
280  is($n[1], 'd');
281  $n[2] = 'e';
282  is($n[2], 'e');
283
284  # DELETE and EXISTS
285  for (-2 .. 2) {
286    ok($n[$_]);
287    delete $n[$_];
288    is(defined($n[$_]), '');
289    is(exists($n[$_]), '');
290  }
291}
292
293{
294    tie my @dummy, "NegFetchsize";
295    eval { "@dummy"; };
296    like($@, qr/^FETCHSIZE returned a negative value/,
297	 " - croak on negative FETCHSIZE");
298}
299
300is($seen{'DESTROY'}, 3);
301