Bump Devel::PPPort to 3.44 for CPAN release
[perl.git] / t / op / tiearray.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 plan(tests => 75);
10
11 my %seen;
12
13 package Implement;
14
15 sub TIEARRAY {
16     $seen{'TIEARRAY'}++;
17     my ($class,@val) = @_;
18     return bless \@val,$class;
19 }
20
21 sub STORESIZE {
22     $seen{'STORESIZE'}++;
23     my ($ob,$sz) = @_;
24     return $#{$ob} = $sz-1;
25 }
26
27 sub EXTEND {
28     $seen{'EXTEND'}++;
29     my ($ob,$sz) = @_;
30     return @$ob = $sz;
31 }
32
33 sub FETCHSIZE {
34     $seen{'FETCHSIZE'}++;
35     return scalar(@{$_[0]});
36 }
37
38 sub FETCH {
39     $seen{'FETCH'}++;
40     my ($ob,$id) = @_;
41     return $ob->[$id];
42 }
43
44 sub STORE {
45     $seen{'STORE'}++;
46     my ($ob,$id,$val) = @_;
47     $ob->[$id] = $val;
48 }
49
50 sub UNSHIFT {
51     $seen{'UNSHIFT'}++;
52     my $ob = shift;
53     unshift(@$ob,@_);
54 }
55
56 sub PUSH {
57     $seen{'PUSH'}++;
58     my $ob = shift;;
59     push(@$ob,@_);
60 }
61
62 sub CLEAR {
63     $seen{'CLEAR'}++;
64     @{$_[0]} = ();
65 }
66
67 sub DESTROY {
68     $seen{'DESTROY'}++;
69 }
70
71 sub POP {
72     $seen{'POP'}++;
73     my ($ob) = @_;
74     return pop(@$ob);
75 }
76
77 sub SHIFT {
78     $seen{'SHIFT'}++;
79     my ($ob) = @_;
80     return shift(@$ob);
81 }
82
83 sub SPLICE {
84     $seen{'SPLICE'}++;
85     my $ob  = shift;
86     my $off = @_ ? shift : 0;
87     my $len = @_ ? shift : @$ob-1;
88     return splice(@$ob,$off,$len,@_);
89 }
90
91 package NegIndex;               # 20020220 MJD
92 @ISA = 'Implement';
93
94 # simulate indices -2 .. 2
95 my $offset = 2;
96 $NegIndex::NEGATIVE_INDICES = 1;
97
98 sub FETCH {
99     my ($ob,$id) = @_;
100     #print "# FETCH @_\n";
101     $id += $offset;
102     $ob->[$id];
103 }
104
105 sub STORE {
106     my ($ob,$id,$value) = @_;
107     #print "# STORE @_\n";
108     $id += $offset;
109     $ob->[$id] = $value;
110 }
111
112 sub DELETE {
113     my ($ob,$id) = @_;
114     #print "# DELETE @_\n";
115     $id += $offset;
116     delete $ob->[$id];
117 }
118
119 sub EXISTS {
120     my ($ob,$id) = @_;
121     #print "# EXISTS @_\n";
122     $id += $offset;
123     exists $ob->[$id];
124 }
125
126 #
127 # Returning -1 from FETCHSIZE used to get casted to U32 causing a
128 # segfault
129 #
130
131 package NegFetchsize;
132
133 sub TIEARRAY  { bless [] }
134 sub FETCH     { }
135 sub FETCHSIZE { -1 }
136
137
138 package main;
139
140 {
141     $seen{'DESTROY'} = 0;
142     my @ary;
143
144     {
145         my $ob = tie @ary,'Implement',3,2,1;
146         ok($ob);
147         is(tied(@ary), $ob);
148     }
149
150     is(@ary, 3);
151     is($#ary, 2);
152     is(join(':',@ary), '3:2:1');
153     cmp_ok($seen{'FETCH'}, '>=', 3);
154
155     @ary = (1,2,3);
156
157     cmp_ok($seen{'STORE'}, '>=', 3);
158     is(join(':',@ary), '1:2:3');
159
160     {
161         my @thing = @ary;
162         is(join(':',@thing), '1:2:3');
163
164         tie @thing,'Implement';
165         @thing = @ary;
166         is(join(':',@thing), '1:2:3');
167     }
168     is($seen{'DESTROY'}, 1, "thing freed");
169
170     is(pop(@ary), 3);
171     is($seen{'POP'}, 1);
172     is(join(':',@ary), '1:2');
173
174     is(push(@ary,4), 3);
175     is($seen{'PUSH'}, 1);
176     is(join(':',@ary), '1:2:4');
177
178     my @x = splice(@ary,1,1,7);
179
180     is($seen{'SPLICE'}, 1);
181     is(@x, 1);
182     is($x[0], 2);
183     is(join(':',@ary), '1:7:4');
184
185     is(shift(@ary), 1);
186     is($seen{'SHIFT'}, 1);
187     is(join(':',@ary), '7:4');
188
189     my $n = unshift(@ary,5,6);
190     is($seen{'UNSHIFT'}, 1);
191     is($n, 4);
192     is(join(':',@ary), '5:6:7:4');
193
194     @ary = split(/:/,'1:2:3');
195     is(join(':',@ary), '1:2:3');
196
197     my $t = 0;
198     foreach $n (@ary) {
199          is($n, ++$t);
200     }
201
202     # (30-33) 20020303 mjd-perl-patch+@plover.com
203     @ary = ();
204     $seen{POP} = 0;
205     pop @ary;                       # this didn't used to call POP at all
206     is($seen{POP}, 1);
207     $seen{SHIFT} = 0;
208     shift @ary;                     # this didn't used to call SHIFT at  all
209     is($seen{SHIFT}, 1);
210     $seen{PUSH} = 0;
211     my $got = push @ary;            # this didn't used to call PUSH at all
212     is($got, 0);
213     is($seen{PUSH}, 1);
214     $seen{UNSHIFT} = 0;
215     $got = unshift @ary;            # this didn't used to call UNSHIFT at all
216     is($got, 0);
217     is($seen{UNSHIFT}, 1);
218
219     @ary = qw(3 2 1);
220     is(join(':',@ary), '3:2:1');
221
222     $#ary = 1;
223     is($seen{'STORESIZE'}, 1, 'seen STORESIZE');
224     is(join(':',@ary), '3:2');
225
226     sub arysize :lvalue { $#ary }
227     arysize()--;
228     is($seen{'STORESIZE'}, 2, 'seen STORESIZE');
229     is(join(':',@ary), '3');
230
231     untie @ary;
232 }
233 is($seen{'DESTROY'}, 2, "ary freed");
234
235 # 20020401 mjd-perl-patch+@plover.com
236 # Thanks to Dave Mitchell for the small test case and the fix
237 {
238     my @a;
239
240     sub X::TIEARRAY { bless {}, 'X' }
241
242     sub X::SPLICE {
243         do '/dev/null';
244         die;
245     }
246
247     tie @a, 'X';
248     eval { splice(@a) };
249     # If we survived this far.
250     pass();
251 }
252
253 # 20020220 mjd-perl-patch+@plover.com
254 {
255     $seen{'DESTROY'} = 0;
256
257     my @n;
258     tie @n => 'NegIndex', ('A' .. 'E');
259
260     # FETCH
261     is($n[0], 'C');
262     is($n[1], 'D');
263     is($n[2], 'E');
264     is($n[-1], 'B');
265     is($n[-2], 'A');
266
267     # STORE
268     $n[-2] = 'a';
269     is($n[-2], 'a');
270     $n[-1] = 'b';
271     is($n[-1], 'b');
272     $n[0] = 'c';
273     is($n[0], 'c');
274     $n[1] = 'd';
275     is($n[1], 'd');
276     $n[2] = 'e';
277     is($n[2], 'e');
278
279     # DELETE and EXISTS
280     for (-2 .. 2) {
281         ok($n[$_]);
282         delete $n[$_];
283         is(defined($n[$_]), '');
284         is(exists($n[$_]), '');
285     }
286 }
287 is($seen{'DESTROY'}, 1, "n freed");
288
289 {
290     tie my @dummy, "NegFetchsize";
291     eval { "@dummy"; };
292     like($@, qr/^FETCHSIZE returned a negative value/,
293          " - croak on negative FETCHSIZE");
294 }
295
296 {
297     # check that a tied element assigned to an array doesn't remain tied
298
299     package Magical;
300
301     my $i = 10;
302
303     sub TIEARRAY { bless [1] }
304     sub TIEHASH  { bless [1] }
305     sub FETCHSIZE { 1; }
306     sub FETCH { $i++ }
307     sub STORE { $_[0][0] = $_[1]; }
308     sub FIRSTKEY { 0 }
309     sub NEXTKEY { }
310
311     package main;
312
313     my (@a, @b);
314     tie @a, 'Magical';
315     @b = @a;
316     is ($b[0],  10, "Magical array fetch 1");
317     $b[0] = 100;
318     is ($b[0], 100, "Magical array fetch 2");
319
320     my (%a, %b);
321     tie %a, 'Magical';
322     %b = %a;
323     is ($b{0},  11, "Magical hash fetch 1");
324     $b{0} = 100;
325     is ($b{0}, 100, "Magical hash fetch 2");
326 }