Commit | Line | Data |
---|---|---|
93965878 NIS |
1 | #!./perl |
2 | ||
a60c0954 | 3 | |
93965878 NIS |
4 | BEGIN { |
5 | chdir 't' if -d 't'; | |
20822f61 | 6 | @INC = '../lib'; |
93965878 NIS |
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 NIS |
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 NIS |
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 NIS |
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 NIS |
71 | @{$_[0]} = (); |
72 | } | |
73 | ||
74 | sub DESTROY | |
75 | { | |
76 | $seen{'DESTROY'}++; | |
93965878 NIS |
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 MJD |
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 AB |
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 MJD |
148 | package main; |
149 | ||
22846ab4 | 150 | print "1..62\n"; |
93965878 NIS |
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 NIS |
179 | print "not " unless join(':',@ary) eq '1:2:3'; |
180 | print "ok ", $test++,"\n"; | |
181 | ||
1c0b011c NIS |
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 NIS |
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 NIS |
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 NIS |
226 | print "not " unless $seen{'UNSHIFT'} == 1; |
227 | print "ok ", $test++,"\n"; | |
a60c0954 NIS |
228 | print "not " unless $n == 4; |
229 | print "ok ", $test++,"\n"; | |
230 | print "not " unless join(':',@ary) eq '5:6:7:4'; | |
93965878 NIS |
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 NIS |
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 MJD |
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 NIS |
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 NIS |
269 | |
270 | } | |
cf8feb78 MJD |
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 MJD |
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 JH |
286 | # If we survived this far. |
287 | print "ok ", $test++, "\n"; | |
cf8feb78 | 288 | } |
6f12eb6d MJD |
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 AB |
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 |