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 | |
22846ab4 |
150 | print "1..62\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 | |
238 | my $t = 0; |
239 | foreach $n (@ary) |
240 | { |
241 | print "not " unless $n == ++$t; |
242 | print "ok ", $test++,"\n"; |
243 | } |
244 | |
cf8feb78 |
245 | # (30-33) 20020303 mjd-perl-patch+@plover.com |
8c204006 |
246 | @ary = (); |
247 | $seen{POP} = 0; |
248 | pop @ary; # this didn't used to call POP at all |
249 | print "not " unless $seen{POP} == 1; |
250 | print "ok ", $test++,"\n"; |
251 | $seen{SHIFT} = 0; |
252 | shift @ary; # this didn't used to call SHIFT at all |
253 | print "not " unless $seen{SHIFT} == 1; |
254 | print "ok ", $test++,"\n"; |
255 | $seen{PUSH} = 0; |
256 | push @ary; # this didn't used to call PUSH at all |
257 | print "not " unless $seen{PUSH} == 1; |
258 | print "ok ", $test++,"\n"; |
259 | $seen{UNSHIFT} = 0; |
260 | unshift @ary; # this didn't used to call UNSHIFT at all |
261 | print "not " unless $seen{UNSHIFT} == 1; |
262 | print "ok ", $test++,"\n"; |
263 | |
a60c0954 |
264 | @ary = qw(3 2 1); |
265 | print "not " unless join(':',@ary) eq '3:2:1'; |
266 | print "ok ", $test++,"\n"; |
93965878 |
267 | |
a60c0954 |
268 | untie @ary; |
93965878 |
269 | |
270 | } |
cf8feb78 |
271 | |
272 | # 20020401 mjd-perl-patch+@plover.com |
11ec0460 |
273 | # Thanks to Dave Mitchell for the small test case and the fix |
74d0c54f |
274 | { |
cf8feb78 |
275 | my @a; |
276 | |
277 | sub X::TIEARRAY { bless {}, 'X' } |
278 | |
279 | sub X::SPLICE { |
280 | do '/dev/null'; |
281 | die; |
282 | } |
283 | |
284 | tie @a, 'X'; |
285 | eval { splice(@a) }; |
74d0c54f |
286 | # If we survived this far. |
287 | print "ok ", $test++, "\n"; |
cf8feb78 |
288 | } |
6f12eb6d |
289 | |
290 | |
291 | { # 20020220 mjd-perl-patch+@plover.com |
292 | my @n; |
293 | tie @n => 'NegIndex', ('A' .. 'E'); |
294 | |
295 | # FETCH |
296 | print "not " unless $n[0] eq 'C'; |
297 | print "ok ", $test++,"\n"; |
298 | print "not " unless $n[1] eq 'D'; |
299 | print "ok ", $test++,"\n"; |
300 | print "not " unless $n[2] eq 'E'; |
301 | print "ok ", $test++,"\n"; |
302 | print "not " unless $n[-1] eq 'B'; |
303 | print "ok ", $test++,"\n"; |
304 | print "not " unless $n[-2] eq 'A'; |
305 | print "ok ", $test++,"\n"; |
306 | |
307 | # STORE |
308 | $n[-2] = 'a'; |
309 | print "not " unless $n[-2] eq 'a'; |
310 | print "ok ", $test++,"\n"; |
311 | $n[-1] = 'b'; |
312 | print "not " unless $n[-1] eq 'b'; |
313 | print "ok ", $test++,"\n"; |
314 | $n[0] = 'c'; |
315 | print "not " unless $n[0] eq 'c'; |
316 | print "ok ", $test++,"\n"; |
317 | $n[1] = 'd'; |
318 | print "not " unless $n[1] eq 'd'; |
319 | print "ok ", $test++,"\n"; |
320 | $n[2] = 'e'; |
321 | print "not " unless $n[2] eq 'e'; |
322 | print "ok ", $test++,"\n"; |
323 | |
324 | # DELETE and EXISTS |
325 | for (-2 .. 2) { |
326 | print exists($n[$_]) ? "ok $test\n" : "not ok $test\n"; |
327 | $test++; |
328 | delete $n[$_]; |
329 | print defined($n[$_]) ? "not ok $test\n" : "ok $test\n"; |
330 | $test++; |
331 | print exists($n[$_]) ? "not ok $test\n" : "ok $test\n"; |
332 | $test++; |
333 | } |
334 | } |
335 | |
336 | |
a60c0954 |
337 | |
22846ab4 |
338 | { |
339 | tie my @dummy, "NegFetchsize"; |
340 | eval { "@dummy"; }; |
341 | print "# $@" if $@; |
342 | print "not " unless $@ =~ /^FETCHSIZE returned a negative value/; |
343 | print "ok ", $test++, " - croak on negative FETCHSIZE\n"; |
344 | } |
345 | |
6f12eb6d |
346 | print "not " unless $seen{'DESTROY'} == 3; |
a60c0954 |
347 | print "ok ", $test++,"\n"; |
93965878 |
348 | |