[RT #129069] Perl_yylex: Fix two use-after-free bugs
[perl.git] / t / op / each.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 plan tests => 59;
10
11 $h{'abc'} = 'ABC';
12 $h{'def'} = 'DEF';
13 $h{'jkl','mno'} = "JKL\034MNO";
14 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
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
42 @keys = keys %h;
43 @values = values %h;
44
45 is ($#keys, 29, "keys");
46 is ($#values, 29, "values");
47
48 $i = 0;         # stop -w complaints
49
50 while (($key,$value) = each(%h)) {
51     if ($key eq $keys[$i] && $value eq $values[$i]
52         && (('a' lt 'A' && $key lt $value) || $key gt $value)) {
53         $key =~ y/a-z/A-Z/;
54         $i++ if $key eq $value;
55     }
56 }
57
58 is ($i, 30, "each count");
59
60 @keys = ('blurfl', keys(%h), 'dyick');
61 is ($#keys, 31, "added a key");
62
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 }
83
84 # test scalar each
85 %hash = 1..20;
86 $total = 0;
87 $total += $key while $key = each %hash;
88 is ($total, 100, "test scalar each");
89
90 for (1..3) { @foo = each %hash }
91 keys %hash;
92 $total = 0;
93 $total += $key while $key = each %hash;
94 is ($total, 100, "test scalar keys resets iterator");
95
96 for (1..3) { @foo = each %hash }
97 $total = 0;
98 $total += $key while $key = each %hash;
99 isnt ($total, 100, "test iterator of each is being maintained");
100
101 for (1..3) { @foo = each %hash }
102 values %hash;
103 $total = 0;
104 $total += $key while $key = each %hash;
105 is ($total, 100, "test values keys resets iterator");
106
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 }
121
122 @tests = (&next_test, &next_test, &next_test);
123 {
124     package Obj;
125     sub DESTROY { print "ok $::tests[1] # DESTROY called\n"; }
126     {
127         my $h = { A => bless [], __PACKAGE__ };
128         while (my($k,$v) = each %$h) {
129             print "ok $::tests[0]\n" if $k eq 'A' and ref($v) eq 'Obj';
130         }
131     }
132     print "ok $::tests[2]\n";
133 }
134
135 # Check for Unicode hash keys.
136 %u = ("\x{12}", "f", "\x{123}", "fo", "\x{1234}",  "foo");
137 $u{"\x{12345}"}  = "bar";
138 @u{"\x{10FFFD}"} = "zap";
139
140 my %u2;
141 foreach (keys %u) {
142     is (length(), 1, "Check length of " . _qq $_);
143     $u2{$_} = $u{$_};
144 }
145 ok (eq_hash(\%u, \%u2), "copied unicode hash keys correctly?");
146
147 $a = "\xe3\x81\x82"; $A = "\x{3042}";
148 %b = ( $a => "non-utf8");
149 %u = ( $A => "utf8");
150
151 is (exists $b{$A}, '', "utf8 key in bytes hash");
152 is (exists $u{$a}, '', "bytes key in utf8 hash");
153 print "# $b{$_}\n" for keys %b; # Used to core dump before change #8056.
154 pass ("if we got here change 8056 worked");
155 print "# $u{$_}\n" for keys %u; # Used to core dump before change #8056.
156 pass ("change 8056 is thanks to Inaba Hiroto");
157
158 # on EBCDIC chars are mapped differently so pick something that needs encoding
159 # there too.
160 $d = pack("U*", 0xe3, 0x81, 0xAF);
161 { use bytes; $ol = bytes::length($d) }
162 cmp_ok ($ol, '>', 3, "check encoding on EBCDIC");
163 %u = ($d => "downgrade");
164 for (keys %u) {
165     is (length, 3, "check length"); 
166     is ($_, pack("U*", 0xe3, 0x81, 0xAF), "check value");
167 }
168 {
169     { use bytes; is (bytes::length($d), $ol) }
170 }
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 }
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 }
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++};
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");
211     my $hsv=1 && %foo;
212     is($hsv,$count,"Got the count of keys from %foo in scalar assignment context - my");
213     my @arr=%foo&&%foo;
214     is(@arr,10,"Got expected number of elements in list context - my");
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++};
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");
230     my $hsv=1 && %foo;
231     is($hsv,$count,"Got the count of keys from %foo in scalar assignment context - our");
232     my @arr=%foo&&%foo;
233     is(@arr,10,"Got expected number of elements in list context - our");
234 }    
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 }
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 }
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 }
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';