1#!./perl 2 3use strict; 4use warnings; 5 6BEGIN { 7 chdir 't' if -d 't'; 8 require './test.pl'; 9 require './charset_tools.pl'; 10 set_up_inc('../lib'); 11} 12 13my %h; 14$h{'abc'} = 'ABC'; 15$h{'def'} = 'DEF'; 16$h{'jkl','mno'} = "JKL\034MNO"; 17$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); 18$h{'a'} = 'A'; 19$h{'b'} = 'B'; 20$h{'c'} = 'C'; 21$h{'d'} = 'D'; 22$h{'e'} = 'E'; 23$h{'f'} = 'F'; 24$h{'g'} = 'G'; 25$h{'h'} = 'H'; 26$h{'i'} = 'I'; 27$h{'j'} = 'J'; 28$h{'k'} = 'K'; 29$h{'l'} = 'L'; 30$h{'m'} = 'M'; 31$h{'n'} = 'N'; 32$h{'o'} = 'O'; 33$h{'p'} = 'P'; 34$h{'q'} = 'Q'; 35$h{'r'} = 'R'; 36$h{'s'} = 'S'; 37$h{'t'} = 'T'; 38$h{'u'} = 'U'; 39$h{'v'} = 'V'; 40$h{'w'} = 'W'; 41$h{'x'} = 'X'; 42$h{'y'} = 'Y'; 43$h{'z'} = 'Z'; 44 45my @keys = keys %h; 46my @values = values %h; 47 48is ($#keys, 29, "keys"); 49is ($#values, 29, "values"); 50 51my $i = 0; # stop -w complaints 52 53while (my ($key,$value) = each(%h)) { 54 if ($key eq $keys[$i] && $value eq $values[$i] 55 && (('a' lt 'A' && $key lt $value) || $key gt $value)) { 56 $key =~ y/a-z/A-Z/; 57 $i++ if $key eq $value; 58 } 59} 60 61is ($i, 30, "each count"); 62 63@keys = ('blurfl', keys(%h), 'dyick'); 64is ($#keys, 31, "added a key"); 65 66SKIP: { 67 skip "no Hash::Util on miniperl", 4, if is_miniperl; 68 require Hash::Util; 69 sub Hash::Util::num_buckets (\%); 70 71 my $size = Hash::Util::num_buckets(%h); 72 keys %h = $size * 5; 73 my $newsize = Hash::Util::num_buckets(%h); 74 is ($newsize, $size * 8, "resize"); 75 keys %h = 1; 76 $size = Hash::Util::num_buckets(%h); 77 is ($size, $newsize, "same size"); 78 %h = (1,1); 79 $size = Hash::Util::num_buckets(%h); 80 is ($size, $newsize, "still same size"); 81 undef %h; 82 %h = (1,1); 83 $size = Hash::Util::num_buckets(%h); 84 is ($size, 8, "size 8"); 85} 86 87# test scalar each 88my %hash = 1..20; 89my $total = 0; 90my $key; 91$total += $key while $key = each %hash; 92is ($total, 100, "test scalar each"); 93 94for (1..3) { my @foo = each %hash } 95keys %hash; 96$total = 0; 97$total += $key while $key = each %hash; 98is ($total, 100, "test scalar keys resets iterator"); 99 100for (1..3) { my @foo = each %hash } 101$total = 0; 102$total += $key while $key = each %hash; 103isnt ($total, 100, "test iterator of each is being maintained"); 104 105for (1..3) { my @foo = each %hash } 106values %hash; 107$total = 0; 108$total += $key while $key = each %hash; 109is ($total, 100, "test values keys resets iterator"); 110 111is (keys(%hash), 10, "keys (%hash)"); 112SKIP: { 113 skip "no Hash::Util on miniperl", 8, if is_miniperl; 114 require Hash::Util; 115 sub Hash::Util::num_buckets (\%); 116 117 my $size = Hash::Util::num_buckets(%hash); 118 cmp_ok($size, '>=', keys %hash, 'sanity check - more buckets than keys'); 119 %hash = (); 120 is(Hash::Util::num_buckets(%hash), $size, 121 "size doesn't change when hash is emptied"); 122 123 %hash = split /, /, 'Pugh, Pugh, Barney McGrew, Cuthbert, Dibble, Grubb'; 124 is (keys(%hash), 3, "now 3 keys"); 125 # 3 keys won't be enough to trigger any "must grow" criteria: 126 is(Hash::Util::num_buckets(%hash), $size, 127 "size doesn't change with 3 keys"); 128 129 keys(%hash) = keys(%hash); 130 is (Hash::Util::num_buckets(%hash), $size, 131 "assign to keys does not shrink hash bucket array"); 132 is (keys(%hash), 3, "still 3 keys"); 133 keys(%hash) = $size + 100; 134 cmp_ok(Hash::Util::num_buckets(%hash), '>', $size, 135 "assign to keys will grow hash bucket array"); 136 is (keys(%hash), 3, "but still 3 keys"); 137} 138 139@::tests = (&next_test, &next_test, &next_test); 140{ 141 package Obj; 142 sub DESTROY { print "ok $::tests[1] # DESTROY called\n"; } 143 { 144 my $h = { A => bless [], __PACKAGE__ }; 145 while (my($k,$v) = each %$h) { 146 print "ok $::tests[0]\n" if $k eq 'A' and ref($v) eq 'Obj'; 147 } 148 } 149 print "ok $::tests[2]\n"; 150} 151 152# Check for Unicode hash keys. 153my %u = ("\x{12}", "f", "\x{123}", "fo", "\x{1234}", "foo"); 154$u{"\x{12345}"} = "bar"; 155@u{"\x{10FFFD}"} = "zap"; 156 157my %u2; 158foreach (keys %u) { 159 is (length(), 1, "Check length of " . _qq $_); 160 $u2{$_} = $u{$_}; 161} 162ok (eq_hash(\%u, \%u2), "copied unicode hash keys correctly?"); 163 164my $a = byte_utf8a_to_utf8n("\xe3\x81\x82"); my $A = "\x{3042}"; 165my %b = ( $a => "non-utf8"); 166%u = ( $A => "utf8"); 167 168is (exists $b{$A}, '', "utf8 key in bytes hash"); 169is (exists $u{$a}, '', "bytes key in utf8 hash"); 170print "# $b{$_}\n" for keys %b; # Used to core dump before change #8056. 171pass ("if we got here change 8056 worked"); 172print "# $u{$_}\n" for keys %u; # Used to core dump before change #8056. 173pass ("change 8056 is thanks to Inaba Hiroto"); 174 175{ 176 my %u; 177 my $u0 = pack("U0U", 0x00B6); 178 my $b0 = byte_utf8a_to_utf8n("\xC2\xB6"); # 0xC2 0xB6 is U+00B6 in UTF-8 179 my $u1 = pack("U0U", 0x0100); 180 my $b1 = byte_utf8a_to_utf8n("\xC4\x80"); # 0xC4 0x80 is U+0100 in UTF-8 181 182 $u{$u0} = 1; 183 $u{$b0} = 2; 184 $u{$u1} = 3; 185 $u{$b1} = 4; 186 187 is(scalar keys %u, 4, "four different Unicode keys"); 188 is($u{$u0}, 1, "U+00B6 -> 1"); 189 is($u{$b0}, 2, "U+00C2 U+00B6 -> 2"); 190 is($u{$u1}, 3, "U+0100 -> 3 "); 191 is($u{$b1}, 4, "U+00C4 U+0080 -> 4"); 192} 193 194# test for syntax errors 195for my $k (qw(each keys values)) { 196 eval $k; 197 like($@, qr/^Not enough arguments for $k/, "$k demands argument"); 198} 199 200{ 201 my %foo=(1..10); 202 my ($k,$v); 203 my $count=keys %foo; 204 my ($k1,$v1)=each(%foo); 205 my $yes = 0; 206 if (%foo) { $yes++ } 207 my ($k2,$v2)=each(%foo); 208 my $rest=0; 209 while (each(%foo)) {$rest++}; 210 is($yes,1,"if(%foo) was true - my"); 211 isnt($k1,$k2,"if(%foo) didnt mess with each (key) - my"); 212 isnt($v1,$v2,"if(%foo) didnt mess with each (value) - my"); 213 is($rest,3,"Got the expected number of keys - my"); 214 my $hsv=1 && %foo; 215 is($hsv,$count,"Got the count of keys from %foo in scalar assignment context - my"); 216 my @arr=%foo&&%foo; 217 is(@arr,10,"Got expected number of elements in list context - my"); 218} 219{ 220 our %foo=(1..10); 221 my ($k,$v); 222 my $count=keys %foo; 223 my ($k1,$v1)=each(%foo); 224 my $yes = 0; 225 if (%foo) { $yes++ } 226 my ($k2,$v2)=each(%foo); 227 my $rest=0; 228 while (each(%foo)) {$rest++}; 229 is($yes,1,"if(%foo) was true - our"); 230 isnt($k1,$k2,"if(%foo) didnt mess with each (key) - our"); 231 isnt($v1,$v2,"if(%foo) didnt mess with each (value) - our"); 232 is($rest,3,"Got the expected number of keys - our"); 233 my $hsv=1 && %foo; 234 is($hsv,$count,"Got the count of keys from %foo in scalar assignment context - our"); 235 my @arr=%foo&&%foo; 236 is(@arr,10,"Got expected number of elements in list context - our"); 237} 238{ 239 # make sure a deleted active iterator gets freed timely, even if the 240 # hash is otherwise empty 241 242 package Single; 243 244 my $c = 0; 245 sub DESTROY { $c++ }; 246 247 { 248 my %h = ("a" => bless []); 249 my ($k,$v) = each %h; 250 delete $h{$k}; 251 ::is($c, 0, "single key not yet freed"); 252 } 253 ::is($c, 1, "single key now freed"); 254} 255 256{ 257 # Make sure each() does not leave the iterator in an inconsistent state 258 # (RITER set to >= 0, with EITER null) if the active iterator is 259 # deleted, leaving the hash apparently empty. 260 my %h; 261 $h{1} = 2; 262 each %h; 263 delete $h{1}; 264 each %h; 265 $h{1}=2; 266 is join ("-", each %h), '1-2', 267 'each on apparently empty hash does not leave RITER set'; 268} 269{ 270 my $warned= 0; 271 local $SIG{__WARN__}= sub { 272 /\QUse of each() on hash after insertion without resetting hash iterator results in undefined behavior\E/ 273 and $warned++ for @_; 274 }; 275 my %h= map { $_ => $_ } "A".."F"; 276 while (my ($k, $v)= each %h) { 277 $h{"$k$k"}= $v; 278 } 279 ok($warned,"each() after insert produces warnings"); 280 no warnings 'internal'; 281 $warned= 0; 282 %h= map { $_ => $_ } "A".."F"; 283 while (my ($k, $v)= each %h) { 284 $h{"$k$k"}= $v; 285 } 286 ok(!$warned, "no warnings 'internal' silences each() after insert warnings"); 287} 288{ 289 # Test that the call to hv_iternext_flags() that calls prime_env_iter() 290 # produces the results consistent with subsequent iterations of %ENV 291 my $raw = run_perl(switches => ['-l'], 292 prog => 'for (1,2) { @a = keys %ENV; print scalar @a; print for @a }'); 293 my @lines = split /\n/, $raw; 294 my $count1 = shift @lines; 295 my @got1 = splice @lines, 0, $count1; 296 my $count2 = shift @lines; 297 is($count1, $count2, 'both iterations of %ENV returned the same count of keys'); 298 is(scalar @lines, $count2, 'second iteration of %ENV printed all keys'); 299 is(join("\n", sort @got1), join("\n", sort @lines), 'both iterations of %ENV returned identical keys'); 300} 301 302fresh_perl_like('$a = keys %ENV; $b = () = keys %ENV; $c = keys %ENV; print qq=$a,$b,$c=', 303 qr/^([1-9][0-9]*),\1,\1$/, 304 undef, 305 'keys %ENV in scalar context triggers prime_env_iter if needed'); 306fresh_perl_like('$a = $ENV{PATH}; $a = $ENV{q=DCL$PATH=}; $a = keys %ENV; $b = () = keys %ENV; $c = keys %ENV; print qq=$a,$b,$c=', 307 qr/^([1-9][0-9]*),\1,\1$/, 308 undef, 309 '%ENV lookup, and keys %ENV in scalar context remain consistent'); 310 311use feature 'refaliasing'; 312no warnings 'experimental::refaliasing'; 313$a = 7; 314my %h2; 315\$h2{f} = \$a; 316($a, $b) = (each %h2); 317is "$a $b", "f 7", 'each in list assignment'; 318$a = 7; 319($a, $b) = (3, values %h2); 320is "$a $b", "3 7", 'values in list assignment'; 321 322done_testing(); 323