t/op/each.t

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