Commit | Line | Data |
---|---|---|
5d5aaa5e | 1 | #!./perl |
10c8fecd | 2 | |
6d822dc4 MS |
3 | # This test was originally for pseudo-hashes. It now exists to ensure |
4 | # they were properly removed in 5.9. | |
5 | ||
a60c0954 NIS |
6 | BEGIN { |
7 | chdir 't' if -d 't'; | |
20822f61 | 8 | @INC = '../lib'; |
a60c0954 NIS |
9 | } |
10 | ||
11 | require Tie::Array; | |
5d5aaa5e | 12 | |
a60c0954 NIS |
13 | package Tie::BasicArray; |
14 | @ISA = 'Tie::Array'; | |
5d5aaa5e | 15 | sub TIEARRAY { bless [], $_[0] } |
a60c0954 NIS |
16 | sub STORE { $_[0]->[$_[1]] = $_[2] } |
17 | sub FETCH { $_[0]->[$_[1]] } | |
18 | sub FETCHSIZE { scalar(@{$_[0]})} | |
6d822dc4 | 19 | sub STORESIZE { $#{$_[0]} = $_[1]+1 } |
5d5aaa5e JP |
20 | |
21 | package main; | |
22 | ||
6d822dc4 MS |
23 | require './test.pl'; |
24 | plan(tests => 40); | |
25 | ||
26 | # Helper function to check the typical error message. | |
27 | sub not_hash { | |
28 | my($err) = shift; | |
29 | like( $err, qr/^Not a HASH reference / ) || | |
30 | printf STDERR "# at %s line %d.\n", (caller)[1,2]; | |
31 | } | |
32 | ||
33 | # Something to place inside if blocks and while loops that won't get | |
34 | # compiled out. | |
35 | my $foo = 42; | |
36 | sub no_op { $foo++ } | |
37 | ||
5d5aaa5e JP |
38 | |
39 | $sch = { | |
40 | 'abc' => 1, | |
41 | 'def' => 2, | |
42 | 'jkl' => 3, | |
43 | }; | |
44 | ||
45 | # basic normal array | |
46 | $a = []; | |
47 | $a->[0] = $sch; | |
48 | ||
6d822dc4 MS |
49 | eval { |
50 | $a->{'abc'} = 'ABC'; | |
51 | }; | |
52 | not_hash($@); | |
5d5aaa5e | 53 | |
6d822dc4 MS |
54 | eval { |
55 | $a->{'def'} = 'DEF'; | |
56 | }; | |
57 | not_hash($@); | |
5d5aaa5e | 58 | |
6d822dc4 MS |
59 | eval { |
60 | $a->{'jkl'} = 'JKL'; | |
61 | }; | |
62 | not_hash($@); | |
5d5aaa5e | 63 | |
6d822dc4 MS |
64 | eval { |
65 | @keys = keys %$a; | |
66 | }; | |
67 | not_hash($@); | |
68 | ||
69 | eval { | |
70 | @values = values %$a; | |
71 | }; | |
72 | not_hash($@); | |
5d5aaa5e | 73 | |
6d822dc4 MS |
74 | eval { |
75 | while( my($k,$v) = each %$a ) { | |
76 | no_op; | |
5d5aaa5e | 77 | } |
6d822dc4 MS |
78 | }; |
79 | not_hash($@); | |
5d5aaa5e | 80 | |
5d5aaa5e JP |
81 | |
82 | # quick check with tied array | |
83 | tie @fake, 'Tie::StdArray'; | |
84 | $a = \@fake; | |
85 | $a->[0] = $sch; | |
86 | ||
6d822dc4 MS |
87 | eval { |
88 | $a->{'abc'} = 'ABC'; | |
89 | }; | |
90 | not_hash($@); | |
91 | ||
92 | eval { | |
93 | if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) } | |
94 | }; | |
95 | not_hash($@); | |
5d5aaa5e | 96 | |
a60c0954 NIS |
97 | # quick check with tied array |
98 | tie @fake, 'Tie::BasicArray'; | |
99 | $a = \@fake; | |
100 | $a->[0] = $sch; | |
101 | ||
6d822dc4 MS |
102 | eval { |
103 | $a->{'abc'} = 'ABC'; | |
104 | }; | |
105 | not_hash($@); | |
106 | ||
107 | eval { | |
108 | if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) } | |
109 | }; | |
110 | not_hash($@); | |
a60c0954 | 111 | |
5d5aaa5e | 112 | # quick check with tied array & tied hash |
5d5aaa5e JP |
113 | require Tie::Hash; |
114 | tie %fake, Tie::StdHash; | |
115 | %fake = %$sch; | |
116 | $a->[0] = \%fake; | |
117 | ||
6d822dc4 MS |
118 | eval { |
119 | $a->{'abc'} = 'ABC'; | |
120 | }; | |
121 | not_hash($@); | |
122 | ||
123 | eval { | |
124 | if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) } | |
125 | }; | |
126 | not_hash($@); | |
127 | ||
800e9ae0 JP |
128 | |
129 | # hash slice | |
6d822dc4 MS |
130 | eval { |
131 | my $slice = join('', 'x',@$a{'abc','def'},'x'); | |
132 | }; | |
133 | not_hash($@); | |
134 | ||
4b154ab5 GA |
135 | |
136 | # evaluation in scalar context | |
137 | my $avhv = [{}]; | |
6d822dc4 MS |
138 | |
139 | eval { | |
140 | () = %$avhv; | |
141 | }; | |
142 | not_hash($@); | |
4b154ab5 GA |
143 | |
144 | push @$avhv, "a"; | |
6d822dc4 MS |
145 | eval { |
146 | () = %$avhv; | |
147 | }; | |
148 | not_hash($@); | |
4b154ab5 GA |
149 | |
150 | $avhv = []; | |
151 | eval { $a = %$avhv }; | |
6d822dc4 | 152 | not_hash($@); |
4b154ab5 GA |
153 | |
154 | $avhv = [{foo=>1, bar=>2}]; | |
6d822dc4 MS |
155 | eval { |
156 | %$avhv =~ m,^\d+/\d+,; | |
157 | }; | |
158 | not_hash($@); | |
74e13ce4 GS |
159 | |
160 | # check if defelem magic works | |
161 | sub f { | |
162 | print "not " unless $_[0] eq 'a'; | |
163 | $_[0] = 'b'; | |
164 | print "ok 11\n"; | |
165 | } | |
166 | $a = [{key => 1}, 'a']; | |
6d822dc4 MS |
167 | eval { |
168 | f($a->{key}); | |
169 | }; | |
170 | not_hash($@); | |
74e13ce4 | 171 | |
4bd46447 GS |
172 | # check if exists() is behaving properly |
173 | $avhv = [{foo=>1,bar=>2,pants=>3}]; | |
6d822dc4 MS |
174 | eval { |
175 | no_op if exists $avhv->{bar}; | |
176 | }; | |
177 | not_hash($@); | |
178 | ||
179 | eval { | |
180 | $avhv->{pants} = undef; | |
181 | }; | |
182 | not_hash($@); | |
4bd46447 | 183 | |
6d822dc4 MS |
184 | eval { |
185 | no_op if exists $avhv->{pants}; | |
186 | }; | |
187 | not_hash($@); | |
188 | ||
189 | eval { | |
190 | no_op if exists $avhv->{bar}; | |
191 | }; | |
192 | not_hash($@); | |
01020589 | 193 | |
6d822dc4 MS |
194 | eval { |
195 | $avhv->{bar} = 10; | |
196 | }; | |
197 | not_hash($@); | |
01020589 | 198 | |
6d822dc4 MS |
199 | eval { |
200 | no_op unless exists $avhv->{bar} and $avhv->{bar} == 10; | |
201 | }; | |
202 | not_hash($@); | |
01020589 | 203 | |
6d822dc4 MS |
204 | eval { |
205 | $v = delete $avhv->{bar}; | |
206 | }; | |
207 | not_hash($@); | |
01020589 | 208 | |
6d822dc4 MS |
209 | eval { |
210 | no_op if exists $avhv->{bar}; | |
211 | }; | |
212 | not_hash($@); | |
01020589 | 213 | |
6d822dc4 MS |
214 | eval { |
215 | $avhv->{foo} = 'xxx'; | |
216 | }; | |
217 | not_hash($@); | |
218 | eval { | |
219 | $avhv->{bar} = 'yyy'; | |
220 | }; | |
221 | not_hash($@); | |
222 | eval { | |
223 | $avhv->{pants} = 'zzz'; | |
224 | }; | |
225 | not_hash($@); | |
226 | eval { | |
227 | @x = delete @{$avhv}{'foo','pants'}; | |
228 | }; | |
229 | not_hash($@); | |
230 | eval { | |
231 | no_op unless "$avhv->{bar}" eq "yyy"; | |
232 | }; | |
233 | not_hash($@); | |
10c8fecd GS |
234 | |
235 | # hash assignment | |
6d822dc4 MS |
236 | eval { |
237 | %$avhv = (); | |
238 | }; | |
239 | not_hash($@); | |
10c8fecd | 240 | |
6d822dc4 MS |
241 | eval { |
242 | %hv = %$avhv; | |
243 | }; | |
244 | not_hash($@); | |
10c8fecd | 245 | |
6d822dc4 MS |
246 | eval { |
247 | %$avhv = (foo => 29, pants => 2, bar => 0); | |
248 | }; | |
249 | not_hash($@); | |
10c8fecd GS |
250 | |
251 | my $extra; | |
252 | my @extra; | |
6d822dc4 MS |
253 | eval { |
254 | ($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!"); | |
255 | }; | |
256 | not_hash($@); | |
257 | ||
258 | eval { | |
259 | %$avhv = (); | |
260 | (%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!"); | |
261 | }; | |
262 | not_hash($@); | |
263 | ||
264 | eval { | |
265 | @extra = qw(whatever and stuff); | |
266 | %$avhv = (); | |
267 | }; | |
268 | not_hash($@); | |
269 | eval { | |
270 | (%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!"); | |
271 | }; | |
272 | not_hash($@); | |
273 | ||
274 | eval { | |
275 | (@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!"); | |
276 | }; | |
277 | not_hash($@); | |
e43e3698 RH |
278 | |
279 | # Check hash slices (BUG ID 20010423.002) | |
280 | $avhv = [{foo=>1, bar=>2}]; | |
6d822dc4 MS |
281 | eval { |
282 | @$avhv{"foo", "bar"} = (42, 53); | |
283 | }; | |
284 | not_hash($@); |