Commit | Line | Data |
93965878 |
1 | #!./perl |
2 | |
a60c0954 |
3 | |
93965878 |
4 | BEGIN { |
5 | chdir 't' if -d 't'; |
20822f61 |
6 | @INC = '../lib'; |
93965878 |
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) = @_; |
a60c0954 |
24 | return $#{$ob} = $sz-1; |
93965878 |
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'}++; |
a60c0954 |
37 | return scalar(@{$_[0]}); |
93965878 |
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'}++; |
a60c0954 |
57 | my $ob = shift; |
93965878 |
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'}++; |
a60c0954 |
71 | @{$_[0]} = (); |
72 | } |
73 | |
74 | sub DESTROY |
75 | { |
76 | $seen{'DESTROY'}++; |
93965878 |
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 | |
6f12eb6d |
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 | } |
93965878 |
136 | |
22846ab4 |
137 | # |
138 | # Returning -1 from FETCHSIZE used to get casted to U32 causing a |
139 | # segfault |
140 | # |
141 | |
142 | package NegFetchsize; |
143 | |
144 | sub TIEARRAY { bless [] } |
145 | sub FETCH { } |
146 | sub FETCHSIZE { -1 } |
147 | |
6f12eb6d |
148 | package main; |
149 | |
28c5b5bc |
150 | print "1..66\n"; |
93965878 |
151 | my $test = 1; |
152 | |
153 | {my @ary; |
154 | |
155 | { my $ob = tie @ary,'Implement',3,2,1; |
156 | print "not " unless $ob; |
157 | print "ok ", $test++,"\n"; |
158 | print "not " unless tied(@ary) == $ob; |
159 | print "ok ", $test++,"\n"; |
160 | } |
161 | |
162 | |
163 | print "not " unless @ary == 3; |
164 | print "ok ", $test++,"\n"; |
165 | |
166 | print "not " unless $#ary == 2; |
167 | print "ok ", $test++,"\n"; |
168 | |
169 | print "not " unless join(':',@ary) eq '3:2:1'; |
170 | print "ok ", $test++,"\n"; |
171 | |
172 | print "not " unless $seen{'FETCH'} >= 3; |
173 | print "ok ", $test++,"\n"; |
174 | |
175 | @ary = (1,2,3); |
176 | |
177 | print "not " unless $seen{'STORE'} >= 3; |
178 | print "ok ", $test++,"\n"; |
93965878 |
179 | print "not " unless join(':',@ary) eq '1:2:3'; |
180 | print "ok ", $test++,"\n"; |
181 | |
1c0b011c |
182 | {my @thing = @ary; |
183 | print "not " unless join(':',@thing) eq '1:2:3'; |
184 | print "ok ", $test++,"\n"; |
185 | |
186 | tie @thing,'Implement'; |
187 | @thing = @ary; |
188 | print "not " unless join(':',@thing) eq '1:2:3'; |
189 | print "ok ", $test++,"\n"; |
190 | } |
191 | |
93965878 |
192 | print "not " unless pop(@ary) == 3; |
193 | print "ok ", $test++,"\n"; |
194 | print "not " unless $seen{'POP'} == 1; |
195 | print "ok ", $test++,"\n"; |
196 | print "not " unless join(':',@ary) eq '1:2'; |
197 | print "ok ", $test++,"\n"; |
198 | |
199 | push(@ary,4); |
200 | print "not " unless $seen{'PUSH'} == 1; |
201 | print "ok ", $test++,"\n"; |
202 | print "not " unless join(':',@ary) eq '1:2:4'; |
203 | print "ok ", $test++,"\n"; |
204 | |
205 | my @x = splice(@ary,1,1,7); |
206 | |
207 | |
208 | print "not " unless $seen{'SPLICE'} == 1; |
209 | print "ok ", $test++,"\n"; |
210 | |
211 | print "not " unless @x == 1; |
212 | print "ok ", $test++,"\n"; |
213 | print "not " unless $x[0] == 2; |
214 | print "ok ", $test++,"\n"; |
215 | print "not " unless join(':',@ary) eq '1:7:4'; |
216 | print "ok ", $test++,"\n"; |
217 | |
93965878 |
218 | print "not " unless shift(@ary) == 1; |
219 | print "ok ", $test++,"\n"; |
220 | print "not " unless $seen{'SHIFT'} == 1; |
221 | print "ok ", $test++,"\n"; |
222 | print "not " unless join(':',@ary) eq '7:4'; |
223 | print "ok ", $test++,"\n"; |
224 | |
a60c0954 |
225 | my $n = unshift(@ary,5,6); |
93965878 |
226 | print "not " unless $seen{'UNSHIFT'} == 1; |
227 | print "ok ", $test++,"\n"; |
a60c0954 |
228 | print "not " unless $n == 4; |
229 | print "ok ", $test++,"\n"; |
230 | print "not " unless join(':',@ary) eq '5:6:7:4'; |
93965878 |
231 | print "ok ", $test++,"\n"; |
232 | |
233 | @ary = split(/:/,'1:2:3'); |
234 | print "not " unless join(':',@ary) eq '1:2:3'; |
235 | print "ok ", $test++,"\n"; |
8c204006 |
236 | |
a60c0954 |
237 | my $t = 0; |
238 | foreach $n (@ary) |
239 | { |
240 | print "not " unless $n == ++$t; |
241 | print "ok ", $test++,"\n"; |
242 | } |
243 | |
cf8feb78 |
244 | # (30-33) 20020303 mjd-perl-patch+@plover.com |
8c204006 |
245 | @ary = (); |
246 | $seen{POP} = 0; |
247 | pop @ary; # this didn't used to call POP at all |
248 | print "not " unless $seen{POP} == 1; |
249 | print "ok ", $test++,"\n"; |
250 | $seen{SHIFT} = 0; |
251 | shift @ary; # this didn't used to call SHIFT at all |
252 | print "not " unless $seen{SHIFT} == 1; |
253 | print "ok ", $test++,"\n"; |
254 | $seen{PUSH} = 0; |
255 | push @ary; # this didn't used to call PUSH at all |
256 | print "not " unless $seen{PUSH} == 1; |
257 | print "ok ", $test++,"\n"; |
258 | $seen{UNSHIFT} = 0; |
259 | unshift @ary; # this didn't used to call UNSHIFT at all |
260 | print "not " unless $seen{UNSHIFT} == 1; |
261 | print "ok ", $test++,"\n"; |
262 | |
a60c0954 |
263 | @ary = qw(3 2 1); |
264 | print "not " unless join(':',@ary) eq '3:2:1'; |
265 | print "ok ", $test++,"\n"; |
93965878 |
266 | |
28c5b5bc |
267 | $#ary = 1; |
268 | print "not " unless $seen{'STORESIZE'} == 1; |
269 | print "ok ", $test++," -- seen STORESIZE\n"; |
270 | print "not " unless join(':',@ary) eq '3:2'; |
271 | print "ok ", $test++,"\n"; |
272 | |
273 | sub arysize :lvalue { $#ary } |
274 | arysize()--; |
275 | print "not " unless $seen{'STORESIZE'} == 2; |
276 | print "ok ", $test++," -- seen STORESIZE\n"; |
277 | print "not " unless join(':',@ary) eq '3'; |
278 | print "ok ", $test++,"\n"; |
279 | |
a60c0954 |
280 | untie @ary; |
93965878 |
281 | |
282 | } |
cf8feb78 |
283 | |
284 | # 20020401 mjd-perl-patch+@plover.com |
11ec0460 |
285 | # Thanks to Dave Mitchell for the small test case and the fix |
74d0c54f |
286 | { |
cf8feb78 |
287 | my @a; |
288 | |
289 | sub X::TIEARRAY { bless {}, 'X' } |
290 | |
291 | sub X::SPLICE { |
292 | do '/dev/null'; |
293 | die; |
294 | } |
295 | |
296 | tie @a, 'X'; |
297 | eval { splice(@a) }; |
74d0c54f |
298 | # If we survived this far. |
299 | print "ok ", $test++, "\n"; |
cf8feb78 |
300 | } |
6f12eb6d |
301 | |
302 | |
303 | { # 20020220 mjd-perl-patch+@plover.com |
304 | my @n; |
305 | tie @n => 'NegIndex', ('A' .. 'E'); |
306 | |
307 | # FETCH |
308 | print "not " unless $n[0] eq 'C'; |
309 | print "ok ", $test++,"\n"; |
310 | print "not " unless $n[1] eq 'D'; |
311 | print "ok ", $test++,"\n"; |
312 | print "not " unless $n[2] eq 'E'; |
313 | print "ok ", $test++,"\n"; |
314 | print "not " unless $n[-1] eq 'B'; |
315 | print "ok ", $test++,"\n"; |
316 | print "not " unless $n[-2] eq 'A'; |
317 | print "ok ", $test++,"\n"; |
318 | |
319 | # STORE |
320 | $n[-2] = 'a'; |
321 | print "not " unless $n[-2] eq 'a'; |
322 | print "ok ", $test++,"\n"; |
323 | $n[-1] = 'b'; |
324 | print "not " unless $n[-1] eq 'b'; |
325 | print "ok ", $test++,"\n"; |
326 | $n[0] = 'c'; |
327 | print "not " unless $n[0] eq 'c'; |
328 | print "ok ", $test++,"\n"; |
329 | $n[1] = 'd'; |
330 | print "not " unless $n[1] eq 'd'; |
331 | print "ok ", $test++,"\n"; |
332 | $n[2] = 'e'; |
333 | print "not " unless $n[2] eq 'e'; |
334 | print "ok ", $test++,"\n"; |
335 | |
336 | # DELETE and EXISTS |
337 | for (-2 .. 2) { |
338 | print exists($n[$_]) ? "ok $test\n" : "not ok $test\n"; |
339 | $test++; |
340 | delete $n[$_]; |
341 | print defined($n[$_]) ? "not ok $test\n" : "ok $test\n"; |
342 | $test++; |
343 | print exists($n[$_]) ? "not ok $test\n" : "ok $test\n"; |
344 | $test++; |
345 | } |
346 | } |
347 | |
348 | |
a60c0954 |
349 | |
22846ab4 |
350 | { |
351 | tie my @dummy, "NegFetchsize"; |
352 | eval { "@dummy"; }; |
353 | print "# $@" if $@; |
354 | print "not " unless $@ =~ /^FETCHSIZE returned a negative value/; |
355 | print "ok ", $test++, " - croak on negative FETCHSIZE\n"; |
356 | } |
357 | |
6f12eb6d |
358 | print "not " unless $seen{'DESTROY'} == 3; |
a60c0954 |
359 | print "ok ", $test++,"\n"; |
93965878 |
360 | |