Commit | Line | Data |
---|---|---|
8d063cd8 LW |
1 | #!./perl |
2 | ||
f9a63242 JH |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
677fb045 | 5 | require './test.pl'; |
624c42e2 | 6 | set_up_inc('../lib'); |
c4d5f83a | 7 | } |
f9a63242 | 8 | |
d86b3122 | 9 | plan tests => 59; |
8d063cd8 LW |
10 | |
11 | $h{'abc'} = 'ABC'; | |
12 | $h{'def'} = 'DEF'; | |
a687059c LW |
13 | $h{'jkl','mno'} = "JKL\034MNO"; |
14 | $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); | |
8d063cd8 LW |
15 | $h{'a'} = 'A'; |
16 | $h{'b'} = 'B'; | |
17 | $h{'c'} = 'C'; | |
18 | $h{'d'} = 'D'; | |
19 | $h{'e'} = 'E'; | |
20 | $h{'f'} = 'F'; | |
21 | $h{'g'} = 'G'; | |
22 | $h{'h'} = 'H'; | |
23 | $h{'i'} = 'I'; | |
24 | $h{'j'} = 'J'; | |
25 | $h{'k'} = 'K'; | |
26 | $h{'l'} = 'L'; | |
27 | $h{'m'} = 'M'; | |
28 | $h{'n'} = 'N'; | |
29 | $h{'o'} = 'O'; | |
30 | $h{'p'} = 'P'; | |
31 | $h{'q'} = 'Q'; | |
32 | $h{'r'} = 'R'; | |
33 | $h{'s'} = 'S'; | |
34 | $h{'t'} = 'T'; | |
35 | $h{'u'} = 'U'; | |
36 | $h{'v'} = 'V'; | |
37 | $h{'w'} = 'W'; | |
38 | $h{'x'} = 'X'; | |
39 | $h{'y'} = 'Y'; | |
40 | $h{'z'} = 'Z'; | |
41 | ||
a687059c LW |
42 | @keys = keys %h; |
43 | @values = values %h; | |
8d063cd8 | 44 | |
59e20782 NC |
45 | is ($#keys, 29, "keys"); |
46 | is ($#values, 29, "values"); | |
8d063cd8 | 47 | |
75039078 | 48 | $i = 0; # stop -w complaints |
49 | ||
50 | while (($key,$value) = each(%h)) { | |
9d116dd7 JH |
51 | if ($key eq $keys[$i] && $value eq $values[$i] |
52 | && (('a' lt 'A' && $key lt $value) || $key gt $value)) { | |
8d063cd8 LW |
53 | $key =~ y/a-z/A-Z/; |
54 | $i++ if $key eq $value; | |
55 | } | |
56 | } | |
57 | ||
59e20782 | 58 | is ($i, 30, "each count"); |
378cc40b | 59 | |
a687059c | 60 | @keys = ('blurfl', keys(%h), 'dyick'); |
59e20782 | 61 | is ($#keys, 31, "added a key"); |
75039078 | 62 | |
cf8db57b JH |
63 | SKIP: { |
64 | skip "no Hash::Util on miniperl", 4, if is_miniperl; | |
65 | require Hash::Util; | |
66 | sub Hash::Util::num_buckets (\%); | |
67 | ||
68 | $size = Hash::Util::num_buckets(%h); | |
69 | keys %h = $size * 5; | |
70 | $newsize = Hash::Util::num_buckets(%h); | |
71 | is ($newsize, $size * 8, "resize"); | |
72 | keys %h = 1; | |
73 | $size = Hash::Util::num_buckets(%h); | |
74 | is ($size, $newsize, "same size"); | |
75 | %h = (1,1); | |
76 | $size = Hash::Util::num_buckets(%h); | |
77 | is ($size, $newsize, "still same size"); | |
78 | undef %h; | |
79 | %h = (1,1); | |
80 | $size = Hash::Util::num_buckets(%h); | |
81 | is ($size, 8, "size 8"); | |
82 | } | |
3524d3b9 TP |
83 | |
84 | # test scalar each | |
85 | %hash = 1..20; | |
86 | $total = 0; | |
87 | $total += $key while $key = each %hash; | |
59e20782 | 88 | is ($total, 100, "test scalar each"); |
3524d3b9 TP |
89 | |
90 | for (1..3) { @foo = each %hash } | |
91 | keys %hash; | |
92 | $total = 0; | |
93 | $total += $key while $key = each %hash; | |
59e20782 | 94 | is ($total, 100, "test scalar keys resets iterator"); |
3524d3b9 TP |
95 | |
96 | for (1..3) { @foo = each %hash } | |
97 | $total = 0; | |
98 | $total += $key while $key = each %hash; | |
59e20782 | 99 | isnt ($total, 100, "test iterator of each is being maintained"); |
3524d3b9 TP |
100 | |
101 | for (1..3) { @foo = each %hash } | |
102 | values %hash; | |
103 | $total = 0; | |
104 | $total += $key while $key = each %hash; | |
59e20782 | 105 | is ($total, 100, "test values keys resets iterator"); |
3524d3b9 | 106 | |
cf8db57b JH |
107 | SKIP: { |
108 | skip "no Hash::Util on miniperl", 3, if is_miniperl; | |
109 | require Hash::Util; | |
110 | sub Hash::Util::num_buckets (\%); | |
111 | ||
112 | $size = Hash::Util::num_buckets(%hash); | |
113 | keys(%hash) = $size / 2; | |
114 | is ($size, Hash::Util::num_buckets(%hash), | |
115 | "assign to keys does not shrink hash bucket array"); | |
116 | keys(%hash) = $size + 100; | |
117 | isnt ($size, Hash::Util::num_buckets(%hash), | |
118 | "assignment to keys of a number not large enough does not change size"); | |
119 | is (keys(%hash), 10, "keys (%hash)"); | |
120 | } | |
3524d3b9 | 121 | |
677fb045 | 122 | @tests = (&next_test, &next_test, &next_test); |
59af0135 GS |
123 | { |
124 | package Obj; | |
677fb045 | 125 | sub DESTROY { print "ok $::tests[1] # DESTROY called\n"; } |
59af0135 GS |
126 | { |
127 | my $h = { A => bless [], __PACKAGE__ }; | |
128 | while (my($k,$v) = each %$h) { | |
677fb045 | 129 | print "ok $::tests[0]\n" if $k eq 'A' and ref($v) eq 'Obj'; |
59af0135 GS |
130 | } |
131 | } | |
677fb045 | 132 | print "ok $::tests[2]\n"; |
59af0135 GS |
133 | } |
134 | ||
f2b0cce7 JH |
135 | # Check for Unicode hash keys. |
136 | %u = ("\x{12}", "f", "\x{123}", "fo", "\x{1234}", "foo"); | |
137 | $u{"\x{12345}"} = "bar"; | |
b851fbc1 | 138 | @u{"\x{10FFFD}"} = "zap"; |
f2b0cce7 | 139 | |
677fb045 | 140 | my %u2; |
f2b0cce7 | 141 | foreach (keys %u) { |
59e20782 | 142 | is (length(), 1, "Check length of " . _qq $_); |
677fb045 | 143 | $u2{$_} = $u{$_}; |
f2b0cce7 | 144 | } |
677fb045 | 145 | ok (eq_hash(\%u, \%u2), "copied unicode hash keys correctly?"); |
ca9dc00c IH |
146 | |
147 | $a = "\xe3\x81\x82"; $A = "\x{3042}"; | |
148 | %b = ( $a => "non-utf8"); | |
149 | %u = ( $A => "utf8"); | |
150 | ||
59e20782 NC |
151 | is (exists $b{$A}, '', "utf8 key in bytes hash"); |
152 | is (exists $u{$a}, '', "bytes key in utf8 hash"); | |
169da838 | 153 | print "# $b{$_}\n" for keys %b; # Used to core dump before change #8056. |
677fb045 | 154 | pass ("if we got here change 8056 worked"); |
169da838 | 155 | print "# $u{$_}\n" for keys %u; # Used to core dump before change #8056. |
677fb045 | 156 | pass ("change 8056 is thanks to Inaba Hiroto"); |
f9a63242 | 157 | |
ffbc6a93 JH |
158 | # on EBCDIC chars are mapped differently so pick something that needs encoding |
159 | # there too. | |
160 | $d = pack("U*", 0xe3, 0x81, 0xAF); | |
169da838 | 161 | { use bytes; $ol = bytes::length($d) } |
59e20782 | 162 | cmp_ok ($ol, '>', 3, "check encoding on EBCDIC"); |
ef9edfd0 | 163 | %u = ($d => "downgrade"); |
f9a63242 | 164 | for (keys %u) { |
59e20782 | 165 | is (length, 3, "check length"); |
9caa78f3 | 166 | is ($_, pack("U*", 0xe3, 0x81, 0xAF), "check value"); |
f9a63242 | 167 | } |
ef9edfd0 | 168 | { |
59e20782 | 169 | { use bytes; is (bytes::length($d), $ol) } |
ef9edfd0 | 170 | } |
3ea3bee8 JH |
171 | |
172 | { | |
173 | my %u; | |
174 | my $u0 = pack("U0U", 0x00FF); | |
175 | my $b0 = "\xC3\xBF"; # 0xCB 0xBF is U+00FF in UTF-8 | |
176 | my $u1 = pack("U0U", 0x0100); | |
177 | my $b1 = "\xC4\x80"; # 0xC4 0x80 is U+0100 in UTF-8 | |
178 | ||
179 | $u{$u0} = 1; | |
180 | $u{$b0} = 2; | |
181 | $u{$u1} = 3; | |
182 | $u{$b1} = 4; | |
183 | ||
184 | is(scalar keys %u, 4, "four different Unicode keys"); | |
185 | is($u{$u0}, 1, "U+00FF -> 1"); | |
186 | is($u{$b0}, 2, "U+00C3 U+00BF -> 2"); | |
187 | is($u{$u1}, 3, "U+0100 -> 3 "); | |
188 | is($u{$b1}, 4, "U+00C4 U+0080 -> 4"); | |
189 | } | |
a916b302 RGS |
190 | |
191 | # test for syntax errors | |
192 | for my $k (qw(each keys values)) { | |
193 | eval $k; | |
194 | like($@, qr/^Not enough arguments for $k/, "$k demands argument"); | |
195 | } | |
867fa1e2 YO |
196 | |
197 | { | |
198 | my %foo=(1..10); | |
199 | my ($k,$v); | |
200 | my $count=keys %foo; | |
201 | my ($k1,$v1)=each(%foo); | |
202 | my $yes = 0; | |
203 | if (%foo) { $yes++ } | |
204 | my ($k2,$v2)=each(%foo); | |
205 | my $rest=0; | |
206 | while (each(%foo)) {$rest++}; | |
8bf4c401 YO |
207 | is($yes,1,"if(%foo) was true - my"); |
208 | isnt($k1,$k2,"if(%foo) didnt mess with each (key) - my"); | |
209 | isnt($v1,$v2,"if(%foo) didnt mess with each (value) - my"); | |
210 | is($rest,3,"Got the expected number of keys - my"); | |
867fa1e2 | 211 | my $hsv=1 && %foo; |
8bf4c401 | 212 | is($hsv,$count,"Got the count of keys from %foo in scalar assignment context - my"); |
aaf643ce | 213 | my @arr=%foo&&%foo; |
8bf4c401 | 214 | is(@arr,10,"Got expected number of elements in list context - my"); |
867fa1e2 YO |
215 | } |
216 | { | |
217 | our %foo=(1..10); | |
218 | my ($k,$v); | |
219 | my $count=keys %foo; | |
220 | my ($k1,$v1)=each(%foo); | |
221 | my $yes = 0; | |
222 | if (%foo) { $yes++ } | |
223 | my ($k2,$v2)=each(%foo); | |
224 | my $rest=0; | |
225 | while (each(%foo)) {$rest++}; | |
8bf4c401 YO |
226 | is($yes,1,"if(%foo) was true - our"); |
227 | isnt($k1,$k2,"if(%foo) didnt mess with each (key) - our"); | |
228 | isnt($v1,$v2,"if(%foo) didnt mess with each (value) - our"); | |
229 | is($rest,3,"Got the expected number of keys - our"); | |
867fa1e2 | 230 | my $hsv=1 && %foo; |
8bf4c401 | 231 | is($hsv,$count,"Got the count of keys from %foo in scalar assignment context - our"); |
aaf643ce | 232 | my @arr=%foo&&%foo; |
8bf4c401 | 233 | is(@arr,10,"Got expected number of elements in list context - our"); |
867fa1e2 | 234 | } |
00a1a643 DM |
235 | { |
236 | # make sure a deleted active iterator gets freed timely, even if the | |
237 | # hash is otherwise empty | |
238 | ||
239 | package Single; | |
240 | ||
241 | my $c = 0; | |
242 | sub DESTROY { $c++ }; | |
243 | ||
244 | { | |
245 | my %h = ("a" => bless []); | |
246 | my ($k,$v) = each %h; | |
247 | delete $h{$k}; | |
248 | ::is($c, 0, "single key not yet freed"); | |
249 | } | |
250 | ::is($c, 1, "single key now freed"); | |
251 | } | |
41aa816f FC |
252 | |
253 | { | |
254 | # Make sure each() does not leave the iterator in an inconsistent state | |
255 | # (RITER set to >= 0, with EITER null) if the active iterator is | |
256 | # deleted, leaving the hash apparently empty. | |
257 | my %h; | |
258 | $h{1} = 2; | |
259 | each %h; | |
260 | delete $h{1}; | |
261 | each %h; | |
262 | $h{1}=2; | |
263 | is join ("-", each %h), '1-2', | |
264 | 'each on apparently empty hash does not leave RITER set'; | |
265 | } | |
a7b39f85 YO |
266 | { |
267 | my $warned= 0; | |
268 | local $SIG{__WARN__}= sub { | |
269 | /\QUse of each() on hash after insertion without resetting hash iterator results in undefined behavior\E/ | |
270 | and $warned++ for @_; | |
271 | }; | |
272 | my %h= map { $_ => $_ } "A".."F"; | |
273 | while (my ($k, $v)= each %h) { | |
274 | $h{"$k$k"}= $v; | |
275 | } | |
276 | ok($warned,"each() after insert produces warnings"); | |
277 | no warnings 'internal'; | |
278 | $warned= 0; | |
279 | %h= map { $_ => $_ } "A".."F"; | |
280 | while (my ($k, $v)= each %h) { | |
281 | $h{"$k$k"}= $v; | |
282 | } | |
283 | ok(!$warned, "no warnings 'internal' silences each() after insert warnings"); | |
284 | } | |
d86b3122 FC |
285 | |
286 | use feature 'refaliasing'; | |
287 | no warnings 'experimental::refaliasing'; | |
288 | $a = 7; | |
289 | \$h2{f} = \$a; | |
290 | ($a, $b) = (each %h2); | |
291 | is "$a $b", "f 7", 'each in list assignment'; | |
292 | $a = 7; | |
293 | ($a, $b) = (3, values %h2); | |
294 | is "$a $b", "3 7", 'values in list assignment'; |