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