Commit | Line | Data |
---|---|---|
93965878 NIS |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
20822f61 | 5 | @INC = '../lib'; |
af5c7f63 | 6 | require './test.pl'; |
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 | ||
0bf6a637 | 150 | plan(tests => 69); |
93965878 NIS |
151 | |
152 | {my @ary; | |
153 | ||
154 | { my $ob = tie @ary,'Implement',3,2,1; | |
af5c7f63 NC |
155 | ok($ob); |
156 | is(tied(@ary), $ob); | |
93965878 NIS |
157 | } |
158 | ||
af5c7f63 NC |
159 | is(@ary, 3); |
160 | is($#ary, 2); | |
161 | is(join(':',@ary), '3:2:1'); | |
162 | cmp_ok($seen{'FETCH'}, '>=', 3); | |
93965878 NIS |
163 | |
164 | @ary = (1,2,3); | |
165 | ||
af5c7f63 NC |
166 | cmp_ok($seen{'STORE'}, '>=', 3); |
167 | is(join(':',@ary), '1:2:3'); | |
93965878 | 168 | |
1c0b011c | 169 | {my @thing = @ary; |
af5c7f63 | 170 | is(join(':',@thing), '1:2:3'); |
1c0b011c NIS |
171 | |
172 | tie @thing,'Implement'; | |
173 | @thing = @ary; | |
af5c7f63 | 174 | is(join(':',@thing), '1:2:3'); |
1c0b011c NIS |
175 | } |
176 | ||
af5c7f63 NC |
177 | is(pop(@ary), 3); |
178 | is($seen{'POP'}, 1); | |
179 | is(join(':',@ary), '1:2'); | |
93965878 | 180 | |
0bf6a637 | 181 | is(push(@ary,4), 3); |
af5c7f63 NC |
182 | is($seen{'PUSH'}, 1); |
183 | is(join(':',@ary), '1:2:4'); | |
93965878 NIS |
184 | |
185 | my @x = splice(@ary,1,1,7); | |
186 | ||
af5c7f63 NC |
187 | is($seen{'SPLICE'}, 1); |
188 | is(@x, 1); | |
189 | is($x[0], 2); | |
190 | is(join(':',@ary), '1:7:4'); | |
93965878 | 191 | |
af5c7f63 NC |
192 | is(shift(@ary), 1); |
193 | is($seen{'SHIFT'}, 1); | |
194 | is(join(':',@ary), '7:4'); | |
93965878 | 195 | |
a60c0954 | 196 | my $n = unshift(@ary,5,6); |
af5c7f63 NC |
197 | is($seen{'UNSHIFT'}, 1); |
198 | is($n, 4); | |
199 | is(join(':',@ary), '5:6:7:4'); | |
93965878 NIS |
200 | |
201 | @ary = split(/:/,'1:2:3'); | |
af5c7f63 | 202 | is(join(':',@ary), '1:2:3'); |
8c204006 | 203 | |
a60c0954 NIS |
204 | my $t = 0; |
205 | foreach $n (@ary) | |
206 | { | |
af5c7f63 | 207 | is($n, ++$t); |
a60c0954 NIS |
208 | } |
209 | ||
cf8feb78 | 210 | # (30-33) 20020303 mjd-perl-patch+@plover.com |
8c204006 MJD |
211 | @ary = (); |
212 | $seen{POP} = 0; | |
213 | pop @ary; # this didn't used to call POP at all | |
af5c7f63 | 214 | is($seen{POP}, 1); |
8c204006 MJD |
215 | $seen{SHIFT} = 0; |
216 | shift @ary; # this didn't used to call SHIFT at all | |
af5c7f63 | 217 | is($seen{SHIFT}, 1); |
8c204006 | 218 | $seen{PUSH} = 0; |
0bf6a637 NC |
219 | my $got = push @ary; # this didn't used to call PUSH at all |
220 | is($got, 0); | |
af5c7f63 | 221 | is($seen{PUSH}, 1); |
8c204006 | 222 | $seen{UNSHIFT} = 0; |
0bf6a637 NC |
223 | $got = unshift @ary; # this didn't used to call UNSHIFT at all |
224 | is($got, 0); | |
af5c7f63 | 225 | is($seen{UNSHIFT}, 1); |
8c204006 | 226 | |
a60c0954 | 227 | @ary = qw(3 2 1); |
af5c7f63 | 228 | is(join(':',@ary), '3:2:1'); |
93965878 | 229 | |
28c5b5bc | 230 | $#ary = 1; |
af5c7f63 NC |
231 | is($seen{'STORESIZE'}, 1, 'seen STORESIZE'); |
232 | is(join(':',@ary), '3:2'); | |
28c5b5bc RGS |
233 | |
234 | sub arysize :lvalue { $#ary } | |
235 | arysize()--; | |
af5c7f63 NC |
236 | is($seen{'STORESIZE'}, 2, 'seen STORESIZE'); |
237 | is(join(':',@ary), '3'); | |
28c5b5bc | 238 | |
a60c0954 | 239 | untie @ary; |
93965878 NIS |
240 | |
241 | } | |
cf8feb78 MJD |
242 | |
243 | # 20020401 mjd-perl-patch+@plover.com | |
11ec0460 | 244 | # Thanks to Dave Mitchell for the small test case and the fix |
74d0c54f | 245 | { |
cf8feb78 MJD |
246 | my @a; |
247 | ||
248 | sub X::TIEARRAY { bless {}, 'X' } | |
249 | ||
250 | sub X::SPLICE { | |
251 | do '/dev/null'; | |
252 | die; | |
253 | } | |
254 | ||
255 | tie @a, 'X'; | |
256 | eval { splice(@a) }; | |
74d0c54f | 257 | # If we survived this far. |
af5c7f63 | 258 | pass(); |
cf8feb78 | 259 | } |
6f12eb6d | 260 | |
6f12eb6d MJD |
261 | { # 20020220 mjd-perl-patch+@plover.com |
262 | my @n; | |
263 | tie @n => 'NegIndex', ('A' .. 'E'); | |
264 | ||
265 | # FETCH | |
af5c7f63 NC |
266 | is($n[0], 'C'); |
267 | is($n[1], 'D'); | |
268 | is($n[2], 'E'); | |
269 | is($n[-1], 'B'); | |
270 | is($n[-2], 'A'); | |
6f12eb6d MJD |
271 | |
272 | # STORE | |
273 | $n[-2] = 'a'; | |
af5c7f63 | 274 | is($n[-2], 'a'); |
6f12eb6d | 275 | $n[-1] = 'b'; |
af5c7f63 | 276 | is($n[-1], 'b'); |
6f12eb6d | 277 | $n[0] = 'c'; |
af5c7f63 | 278 | is($n[0], 'c'); |
6f12eb6d | 279 | $n[1] = 'd'; |
af5c7f63 | 280 | is($n[1], 'd'); |
6f12eb6d | 281 | $n[2] = 'e'; |
af5c7f63 | 282 | is($n[2], 'e'); |
6f12eb6d MJD |
283 | |
284 | # DELETE and EXISTS | |
285 | for (-2 .. 2) { | |
af5c7f63 | 286 | ok($n[$_]); |
6f12eb6d | 287 | delete $n[$_]; |
af5c7f63 NC |
288 | is(defined($n[$_]), ''); |
289 | is(exists($n[$_]), ''); | |
6f12eb6d MJD |
290 | } |
291 | } | |
6f12eb6d | 292 | |
22846ab4 AB |
293 | { |
294 | tie my @dummy, "NegFetchsize"; | |
295 | eval { "@dummy"; }; | |
af5c7f63 NC |
296 | like($@, qr/^FETCHSIZE returned a negative value/, |
297 | " - croak on negative FETCHSIZE"); | |
22846ab4 AB |
298 | } |
299 | ||
af5c7f63 | 300 | is($seen{'DESTROY'}, 3); |