Commit | Line | Data |
---|---|---|
a687059c LW |
1 | #!./perl |
2 | ||
d441d3db RD |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
5 | require './test.pl'; | |
624c42e2 | 6 | set_up_inc( qw(. ../lib) ); |
d441d3db | 7 | } |
2c5f48c2 | 8 | plan tests => 310; |
a687059c | 9 | |
13414bd5 JM |
10 | my $list_assignment_supported = 1; |
11 | ||
739a0b84 | 12 | #mg.c says list assignment not supported on VMS and SYMBIAN. |
13414bd5 JM |
13 | $list_assignment_supported = 0 if ($^O eq 'VMS'); |
14 | ||
15 | ||
a687059c LW |
16 | sub foo { |
17 | local($a, $b) = @_; | |
18 | local($c, $d); | |
d441d3db RD |
19 | $c = "c 3"; |
20 | $d = "d 4"; | |
21 | { local($a,$c) = ("a 9", "c 10"); ($x, $y) = ($a, $c); } | |
22 | is($a, "a 1"); | |
23 | is($b, "b 2"); | |
24 | $c, $d; | |
a687059c LW |
25 | } |
26 | ||
d441d3db RD |
27 | $a = "a 5"; |
28 | $b = "b 6"; | |
29 | $c = "c 7"; | |
30 | $d = "d 8"; | |
a687059c | 31 | |
d441d3db RD |
32 | my @res; |
33 | @res = &foo("a 1","b 2"); | |
34 | is($res[0], "c 3"); | |
35 | is($res[1], "d 4"); | |
a687059c | 36 | |
d441d3db RD |
37 | is($a, "a 5"); |
38 | is($b, "b 6"); | |
39 | is($c, "c 7"); | |
40 | is($d, "d 8"); | |
41 | is($x, "a 9"); | |
42 | is($y, "c 10"); | |
a687059c LW |
43 | |
44 | # same thing, only with arrays and associative arrays | |
45 | ||
46 | sub foo2 { | |
47 | local($a, @b) = @_; | |
48 | local(@c, %d); | |
d441d3db RD |
49 | @c = "c 3"; |
50 | $d{''} = "d 4"; | |
51 | { local($a,@c) = ("a 19", "c 20"); ($x, $y) = ($a, @c); } | |
52 | is($a, "a 1"); | |
53 | is("@b", "b 2"); | |
54 | $c[0], $d{''}; | |
a687059c LW |
55 | } |
56 | ||
d441d3db RD |
57 | $a = "a 5"; |
58 | @b = "b 6"; | |
59 | @c = "c 7"; | |
60 | $d{''} = "d 8"; | |
61 | ||
62 | @res = &foo2("a 1","b 2"); | |
63 | is($res[0], "c 3"); | |
64 | is($res[1], "d 4"); | |
a687059c | 65 | |
d441d3db RD |
66 | is($a, "a 5"); |
67 | is("@b", "b 6"); | |
68 | is($c[0], "c 7"); | |
69 | is($d{''}, "d 8"); | |
70 | is($x, "a 19"); | |
71 | is($y, "c 20"); | |
a687059c | 72 | |
706a304b SM |
73 | |
74 | eval 'local($$e)'; | |
d441d3db | 75 | like($@, qr/Can't localize through a reference/); |
706a304b | 76 | |
82d03984 | 77 | eval '$e = []; local(@$e)'; |
d441d3db | 78 | like($@, qr/Can't localize through a reference/); |
706a304b | 79 | |
82d03984 | 80 | eval '$e = {}; local(%$e)'; |
d441d3db | 81 | like($@, qr/Can't localize through a reference/); |
85aff577 | 82 | |
161b7d16 SM |
83 | # Array and hash elements |
84 | ||
85 | @a = ('a', 'b', 'c'); | |
86 | { | |
87 | local($a[1]) = 'foo'; | |
88 | local($a[2]) = $a[2]; | |
d441d3db RD |
89 | is($a[1], 'foo'); |
90 | is($a[2], 'c'); | |
161b7d16 SM |
91 | undef @a; |
92 | } | |
d441d3db RD |
93 | is($a[1], 'b'); |
94 | is($a[2], 'c'); | |
95 | ok(!defined $a[0]); | |
161b7d16 SM |
96 | |
97 | @a = ('a', 'b', 'c'); | |
98 | { | |
4ad10a0b VP |
99 | local($a[4]) = 'x'; |
100 | ok(!defined $a[3]); | |
101 | is($a[4], 'x'); | |
102 | } | |
103 | is(scalar(@a), 3); | |
104 | ok(!exists $a[3]); | |
105 | ok(!exists $a[4]); | |
106 | ||
107 | @a = ('a', 'b', 'c'); | |
108 | { | |
109 | local($a[5]) = 'z'; | |
110 | $a[4] = 'y'; | |
111 | ok(!defined $a[3]); | |
112 | is($a[4], 'y'); | |
113 | is($a[5], 'z'); | |
114 | } | |
115 | is(scalar(@a), 5); | |
116 | ok(!defined $a[3]); | |
117 | is($a[4], 'y'); | |
118 | ok(!exists $a[5]); | |
119 | ||
120 | @a = ('a', 'b', 'c'); | |
121 | { | |
122 | local(@a[4,6]) = ('x', 'z'); | |
123 | ok(!defined $a[3]); | |
124 | is($a[4], 'x'); | |
125 | ok(!defined $a[5]); | |
126 | is($a[6], 'z'); | |
127 | } | |
128 | is(scalar(@a), 3); | |
129 | ok(!exists $a[3]); | |
130 | ok(!exists $a[4]); | |
131 | ok(!exists $a[5]); | |
132 | ok(!exists $a[6]); | |
133 | ||
134 | @a = ('a', 'b', 'c'); | |
135 | { | |
136 | local(@a[4,6]) = ('x', 'z'); | |
137 | $a[5] = 'y'; | |
138 | ok(!defined $a[3]); | |
139 | is($a[4], 'x'); | |
140 | is($a[5], 'y'); | |
141 | is($a[6], 'z'); | |
142 | } | |
143 | is(scalar(@a), 6); | |
144 | ok(!defined $a[3]); | |
145 | ok(!defined $a[4]); | |
146 | is($a[5], 'y'); | |
147 | ok(!exists $a[6]); | |
148 | ||
149 | @a = ('a', 'b', 'c'); | |
150 | { | |
161b7d16 SM |
151 | local($a[1]) = "X"; |
152 | shift @a; | |
153 | } | |
d441d3db | 154 | is($a[0].$a[1], "Xb"); |
d60c5a05 RD |
155 | { |
156 | my $d = "@a"; | |
157 | local @a = @a; | |
158 | is("@a", $d); | |
159 | } | |
161b7d16 | 160 | |
7332a6c4 VP |
161 | @a = ('a', 'b', 'c'); |
162 | $a[4] = 'd'; | |
163 | { | |
164 | delete local $a[1]; | |
165 | is(scalar(@a), 5); | |
166 | is($a[0], 'a'); | |
167 | ok(!exists($a[1])); | |
168 | is($a[2], 'c'); | |
169 | ok(!exists($a[3])); | |
170 | is($a[4], 'd'); | |
171 | ||
172 | ok(!exists($a[888])); | |
173 | delete local $a[888]; | |
174 | is(scalar(@a), 5); | |
175 | ok(!exists($a[888])); | |
176 | ||
177 | ok(!exists($a[999])); | |
178 | my ($d, $zzz) = delete local @a[4, 999]; | |
179 | is(scalar(@a), 3); | |
180 | ok(!exists($a[4])); | |
181 | ok(!exists($a[999])); | |
182 | is($d, 'd'); | |
183 | is($zzz, undef); | |
184 | ||
185 | my $c = delete local $a[2]; | |
186 | is(scalar(@a), 1); | |
187 | ok(!exists($a[2])); | |
188 | is($c, 'c'); | |
189 | ||
190 | $a[888] = 'yyy'; | |
191 | $a[999] = 'zzz'; | |
192 | } | |
193 | is(scalar(@a), 5); | |
194 | is($a[0], 'a'); | |
195 | is($a[1], 'b'); | |
196 | is($a[2], 'c'); | |
197 | ok(!defined($a[3])); | |
198 | is($a[4], 'd'); | |
199 | ok(!exists($a[5])); | |
200 | ok(!exists($a[888])); | |
201 | ok(!exists($a[999])); | |
202 | ||
203 | %h = (a => 1, b => 2, c => 3, d => 4); | |
204 | { | |
205 | delete local $h{b}; | |
206 | is(scalar(keys(%h)), 3); | |
207 | is($h{a}, 1); | |
208 | ok(!exists($h{b})); | |
209 | is($h{c}, 3); | |
210 | is($h{d}, 4); | |
211 | ||
212 | ok(!exists($h{yyy})); | |
213 | delete local $h{yyy}; | |
214 | is(scalar(keys(%h)), 3); | |
215 | ok(!exists($h{yyy})); | |
216 | ||
217 | ok(!exists($h{zzz})); | |
218 | my ($d, $zzz) = delete local @h{qw/d zzz/}; | |
219 | is(scalar(keys(%h)), 2); | |
220 | ok(!exists($h{d})); | |
221 | ok(!exists($h{zzz})); | |
222 | is($d, 4); | |
223 | is($zzz, undef); | |
224 | ||
225 | my $c = delete local $h{c}; | |
226 | is(scalar(keys(%h)), 1); | |
227 | ok(!exists($h{c})); | |
228 | is($c, 3); | |
229 | ||
230 | $h{yyy} = 888; | |
231 | $h{zzz} = 999; | |
232 | } | |
233 | is(scalar(keys(%h)), 4); | |
234 | is($h{a}, 1); | |
235 | is($h{b}, 2); | |
236 | is($h{c}, 3); | |
237 | ok($h{d}, 4); | |
238 | ok(!exists($h{yyy})); | |
239 | ok(!exists($h{zzz})); | |
240 | ||
241 | %h = ('a' => { 'b' => 1 }, 'c' => 2); | |
242 | { | |
243 | my $a = delete local $h{a}; | |
244 | is(scalar(keys(%h)), 1); | |
245 | ok(!exists($h{a})); | |
246 | is($h{c}, 2); | |
247 | is(scalar(keys(%$a)), 1); | |
248 | ||
249 | my $b = delete local $a->{b}; | |
250 | is(scalar(keys(%$a)), 0); | |
251 | is($b, 1); | |
252 | ||
253 | $a->{d} = 3; | |
254 | } | |
255 | is(scalar(keys(%h)), 2); | |
256 | { | |
257 | my $a = $h{a}; | |
258 | is(scalar(keys(%$a)), 2); | |
259 | is($a->{b}, 1); | |
260 | is($a->{d}, 3); | |
261 | } | |
262 | is($h{c}, 2); | |
263 | ||
161b7d16 SM |
264 | %h = ('a' => 1, 'b' => 2, 'c' => 3); |
265 | { | |
266 | local($h{'a'}) = 'foo'; | |
267 | local($h{'b'}) = $h{'b'}; | |
d441d3db RD |
268 | is($h{'a'}, 'foo'); |
269 | is($h{'b'}, 2); | |
161b7d16 SM |
270 | local($h{'c'}); |
271 | delete $h{'c'}; | |
272 | } | |
d441d3db RD |
273 | is($h{'a'}, 1); |
274 | is($h{'b'}, 2); | |
d60c5a05 RD |
275 | { |
276 | my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); | |
277 | local %h = %h; | |
278 | is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); | |
279 | } | |
d441d3db | 280 | is($h{'c'}, 3); |
2bb40b7f GS |
281 | |
282 | # check for scope leakage | |
283 | $a = 'outer'; | |
284 | if (1) { local $a = 'inner' } | |
d441d3db | 285 | is($a, 'outer'); |
2bb40b7f GS |
286 | |
287 | # see if localization works when scope unwinds | |
288 | local $m = 5; | |
289 | eval { | |
290 | for $m (6) { | |
291 | local $m = 7; | |
292 | die "bye"; | |
293 | } | |
294 | }; | |
d441d3db | 295 | is($m, 5); |
4e4c362e GS |
296 | |
297 | # see if localization works on tied arrays | |
298 | { | |
299 | package TA; | |
300 | sub TIEARRAY { bless [], $_[0] } | |
301 | sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] } | |
302 | sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v } | |
4ad10a0b VP |
303 | sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->[$_[1]]; } |
304 | sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->[$_[1]]; } | |
4e4c362e GS |
305 | sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); } |
306 | sub FETCHSIZE { scalar(@{$_[0]}) } | |
307 | sub SHIFT { shift (@{$_[0]}) } | |
308 | sub EXTEND {} | |
309 | } | |
310 | ||
311 | tie @a, 'TA'; | |
312 | @a = ('a', 'b', 'c'); | |
313 | { | |
314 | local($a[1]) = 'foo'; | |
be6c24e0 | 315 | local($a[2]) = $a[2]; |
d441d3db RD |
316 | is($a[1], 'foo'); |
317 | is($a[2], 'c'); | |
4e4c362e GS |
318 | @a = (); |
319 | } | |
d441d3db RD |
320 | is($a[1], 'b'); |
321 | is($a[2], 'c'); | |
322 | ok(!defined $a[0]); | |
d60c5a05 RD |
323 | { |
324 | my $d = "@a"; | |
325 | local @a = @a; | |
326 | is("@a", $d); | |
327 | } | |
5afa72af DM |
328 | # RT #7938: localising an array should make it temporarily untied |
329 | { | |
330 | @a = qw(a b c); | |
331 | local @a = (6,7,8); | |
332 | is("@a", "6 7 8", 'local @a assigned 6,7,8'); | |
333 | { | |
334 | my $c = 0; | |
335 | local *TA::STORE = sub { $c++ }; | |
336 | $a[0] = 9; | |
337 | is($c, 0, 'STORE not called after array localised'); | |
338 | } | |
339 | is("@a", "9 7 8", 'local @a should now be 9 7 8'); | |
340 | } | |
341 | is("@a", "a b c", '@a should now contain original value'); | |
342 | ||
4e4c362e | 343 | |
4ad10a0b VP |
344 | # local() should preserve the existenceness of tied array elements |
345 | @a = ('a', 'b', 'c'); | |
346 | { | |
347 | local($a[4]) = 'x'; | |
348 | ok(!defined $a[3]); | |
349 | is($a[4], 'x'); | |
350 | } | |
351 | is(scalar(@a), 3); | |
352 | ok(!exists $a[3]); | |
353 | ok(!exists $a[4]); | |
354 | ||
355 | @a = ('a', 'b', 'c'); | |
356 | { | |
357 | local($a[5]) = 'z'; | |
358 | $a[4] = 'y'; | |
359 | ok(!defined $a[3]); | |
360 | is($a[4], 'y'); | |
361 | is($a[5], 'z'); | |
362 | } | |
363 | is(scalar(@a), 5); | |
364 | ok(!defined $a[3]); | |
365 | is($a[4], 'y'); | |
366 | ok(!exists $a[5]); | |
367 | ||
368 | @a = ('a', 'b', 'c'); | |
369 | { | |
370 | local(@a[4,6]) = ('x', 'z'); | |
371 | ok(!defined $a[3]); | |
372 | is($a[4], 'x'); | |
373 | ok(!defined $a[5]); | |
374 | is($a[6], 'z'); | |
375 | } | |
376 | is(scalar(@a), 3); | |
377 | ok(!exists $a[3]); | |
378 | ok(!exists $a[4]); | |
379 | ok(!exists $a[5]); | |
380 | ok(!exists $a[6]); | |
381 | ||
382 | @a = ('a', 'b', 'c'); | |
383 | { | |
384 | local(@a[4,6]) = ('x', 'z'); | |
385 | $a[5] = 'y'; | |
386 | ok(!defined $a[3]); | |
387 | is($a[4], 'x'); | |
388 | is($a[5], 'y'); | |
389 | is($a[6], 'z'); | |
390 | } | |
391 | is(scalar(@a), 6); | |
392 | ok(!defined $a[3]); | |
393 | ok(!defined $a[4]); | |
394 | is($a[5], 'y'); | |
395 | ok(!exists $a[6]); | |
396 | ||
7332a6c4 VP |
397 | @a = ('a', 'b', 'c'); |
398 | $a[4] = 'd'; | |
399 | { | |
400 | delete local $a[1]; | |
401 | is(scalar(@a), 5); | |
402 | is($a[0], 'a'); | |
403 | ok(!exists($a[1])); | |
404 | is($a[2], 'c'); | |
405 | ok(!exists($a[3])); | |
406 | is($a[4], 'd'); | |
407 | ||
408 | ok(!exists($a[888])); | |
409 | delete local $a[888]; | |
410 | is(scalar(@a), 5); | |
411 | ok(!exists($a[888])); | |
412 | ||
413 | ok(!exists($a[999])); | |
414 | my ($d, $zzz) = delete local @a[4, 999]; | |
415 | is(scalar(@a), 3); | |
416 | ok(!exists($a[4])); | |
417 | ok(!exists($a[999])); | |
418 | is($d, 'd'); | |
419 | is($zzz, undef); | |
420 | ||
421 | my $c = delete local $a[2]; | |
422 | is(scalar(@a), 1); | |
423 | ok(!exists($a[2])); | |
424 | is($c, 'c'); | |
425 | ||
426 | $a[888] = 'yyy'; | |
427 | $a[999] = 'zzz'; | |
428 | } | |
429 | is(scalar(@a), 5); | |
430 | is($a[0], 'a'); | |
431 | is($a[1], 'b'); | |
432 | is($a[2], 'c'); | |
433 | ok(!defined($a[3])); | |
434 | is($a[4], 'd'); | |
435 | ok(!exists($a[5])); | |
436 | ok(!exists($a[888])); | |
437 | ok(!exists($a[999])); | |
438 | ||
4ad10a0b | 439 | # see if localization works on tied hashes |
4e4c362e GS |
440 | { |
441 | package TH; | |
442 | sub TIEHASH { bless {}, $_[0] } | |
443 | sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] } | |
444 | sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v } | |
c39e6ab0 | 445 | sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; } |
4e4c362e GS |
446 | sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } |
447 | sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } | |
d60c5a05 RD |
448 | sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} } |
449 | sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} } | |
4e4c362e GS |
450 | } |
451 | ||
4e4c362e GS |
452 | tie %h, 'TH'; |
453 | %h = ('a' => 1, 'b' => 2, 'c' => 3); | |
454 | ||
455 | { | |
456 | local($h{'a'}) = 'foo'; | |
be6c24e0 | 457 | local($h{'b'}) = $h{'b'}; |
159ad915 DM |
458 | local($h{'y'}); |
459 | local($h{'z'}) = 33; | |
d441d3db RD |
460 | is($h{'a'}, 'foo'); |
461 | is($h{'b'}, 2); | |
4e4c362e GS |
462 | local($h{'c'}); |
463 | delete $h{'c'}; | |
464 | } | |
d441d3db RD |
465 | is($h{'a'}, 1); |
466 | is($h{'b'}, 2); | |
467 | is($h{'c'}, 3); | |
5afa72af | 468 | |
d441d3db RD |
469 | # local() should preserve the existenceness of tied hash elements |
470 | ok(! exists $h{'y'}); | |
471 | ok(! exists $h{'z'}); | |
22465616 | 472 | { |
d60c5a05 RD |
473 | my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); |
474 | local %h = %h; | |
475 | is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); | |
476 | } | |
4e4c362e | 477 | |
5afa72af DM |
478 | # RT #7939: localising a hash should make it temporarily untied |
479 | { | |
480 | %h = qw(a 1 b 2 c 3); | |
481 | local %h = qw(x 6 y 7 z 8); | |
482 | is(join('', sort keys %h), "xyz", 'local %h has new keys'); | |
483 | is(join('', sort values %h), "678", 'local %h has new values'); | |
484 | { | |
485 | my $c = 0; | |
486 | local *TH::STORE = sub { $c++ }; | |
487 | $h{x} = 9; | |
488 | is($c, 0, 'STORE not called after hash localised'); | |
489 | } | |
490 | is($h{x}, 9, '$h{x} should now be 9'); | |
491 | } | |
492 | is(join('', sort keys %h), "abc", 'restored %h has original keys'); | |
493 | is(join('', sort values %h), "123", 'restored %h has original values'); | |
494 | ||
495 | ||
7332a6c4 VP |
496 | %h = (a => 1, b => 2, c => 3, d => 4); |
497 | { | |
498 | delete local $h{b}; | |
499 | is(scalar(keys(%h)), 3); | |
500 | is($h{a}, 1); | |
501 | ok(!exists($h{b})); | |
502 | is($h{c}, 3); | |
503 | is($h{d}, 4); | |
504 | ||
505 | ok(!exists($h{yyy})); | |
506 | delete local $h{yyy}; | |
507 | is(scalar(keys(%h)), 3); | |
508 | ok(!exists($h{yyy})); | |
509 | ||
510 | ok(!exists($h{zzz})); | |
511 | my ($d, $zzz) = delete local @h{qw/d zzz/}; | |
512 | is(scalar(keys(%h)), 2); | |
513 | ok(!exists($h{d})); | |
514 | ok(!exists($h{zzz})); | |
515 | is($d, 4); | |
516 | is($zzz, undef); | |
517 | ||
518 | my $c = delete local $h{c}; | |
519 | is(scalar(keys(%h)), 1); | |
520 | ok(!exists($h{c})); | |
521 | is($c, 3); | |
522 | ||
523 | $h{yyy} = 888; | |
524 | $h{zzz} = 999; | |
525 | } | |
526 | is(scalar(keys(%h)), 4); | |
527 | is($h{a}, 1); | |
528 | is($h{b}, 2); | |
529 | is($h{c}, 3); | |
530 | ok($h{d}, 4); | |
531 | ok(!exists($h{yyy})); | |
532 | ok(!exists($h{zzz})); | |
533 | ||
4e4c362e GS |
534 | @a = ('a', 'b', 'c'); |
535 | { | |
536 | local($a[1]) = "X"; | |
537 | shift @a; | |
538 | } | |
d441d3db | 539 | is($a[0].$a[1], "Xb"); |
4e4c362e | 540 | |
be6c24e0 GS |
541 | # now try the same for %SIG |
542 | ||
543 | $SIG{TERM} = 'foo'; | |
544 | $SIG{INT} = \&foo; | |
545 | $SIG{__WARN__} = $SIG{INT}; | |
546 | { | |
547 | local($SIG{TERM}) = $SIG{TERM}; | |
548 | local($SIG{INT}) = $SIG{INT}; | |
549 | local($SIG{__WARN__}) = $SIG{__WARN__}; | |
d441d3db RD |
550 | is($SIG{TERM}, 'main::foo'); |
551 | is($SIG{INT}, \&foo); | |
552 | is($SIG{__WARN__}, \&foo); | |
be6c24e0 GS |
553 | local($SIG{INT}); |
554 | delete $SIG{__WARN__}; | |
555 | } | |
d441d3db RD |
556 | is($SIG{TERM}, 'main::foo'); |
557 | is($SIG{INT}, \&foo); | |
558 | is($SIG{__WARN__}, \&foo); | |
d60c5a05 RD |
559 | { |
560 | my $d = join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG); | |
561 | local %SIG = %SIG; | |
562 | is(join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG), $d); | |
563 | } | |
be6c24e0 GS |
564 | |
565 | # and for %ENV | |
566 | ||
567 | $ENV{_X_} = 'a'; | |
568 | $ENV{_Y_} = 'b'; | |
569 | $ENV{_Z_} = 'c'; | |
570 | { | |
159ad915 DM |
571 | local($ENV{_A_}); |
572 | local($ENV{_B_}) = 'foo'; | |
be6c24e0 GS |
573 | local($ENV{_X_}) = 'foo'; |
574 | local($ENV{_Y_}) = $ENV{_Y_}; | |
d441d3db RD |
575 | is($ENV{_X_}, 'foo'); |
576 | is($ENV{_Y_}, 'b'); | |
be6c24e0 GS |
577 | local($ENV{_Z_}); |
578 | delete $ENV{_Z_}; | |
579 | } | |
d441d3db RD |
580 | is($ENV{_X_}, 'a'); |
581 | is($ENV{_Y_}, 'b'); | |
582 | is($ENV{_Z_}, 'c'); | |
583 | # local() should preserve the existenceness of %ENV elements | |
584 | ok(! exists $ENV{_A_}); | |
585 | ok(! exists $ENV{_B_}); | |
13414bd5 JM |
586 | |
587 | SKIP: { | |
588 | skip("Can't make list assignment to \%ENV on this system") | |
589 | unless $list_assignment_supported; | |
d60c5a05 RD |
590 | my $d = join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV); |
591 | local %ENV = %ENV; | |
592 | is(join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV), $d); | |
593 | } | |
be6c24e0 | 594 | |
0214ae40 GS |
595 | # does implicit localization in foreach skip magic? |
596 | ||
d441d3db | 597 | $_ = "o 0,o 1,"; |
0214ae40 GS |
598 | my $iter = 0; |
599 | while (/(o.+?),/gc) { | |
d441d3db | 600 | is($1, "o $iter"); |
0214ae40 | 601 | foreach (1..1) { $iter++ } |
d441d3db | 602 | if ($iter > 2) { fail("endless loop"); last; } |
0214ae40 GS |
603 | } |
604 | ||
605 | { | |
606 | package UnderScore; | |
607 | sub TIESCALAR { bless \my $self, shift } | |
608 | sub FETCH { die "read \$_ forbidden" } | |
609 | sub STORE { die "write \$_ forbidden" } | |
610 | tie $_, __PACKAGE__; | |
0214ae40 GS |
611 | my @tests = ( |
612 | "Nesting" => sub { print '#'; for (1..3) { print } | |
613 | print "\n" }, 1, | |
614 | "Reading" => sub { print }, 0, | |
615 | "Matching" => sub { $x = /badness/ }, 0, | |
616 | "Concat" => sub { $_ .= "a" }, 0, | |
617 | "Chop" => sub { chop }, 0, | |
618 | "Filetest" => sub { -x }, 0, | |
619 | "Assignment" => sub { $_ = "Bad" }, 0, | |
0214ae40 GS |
620 | "for local" => sub { for("#ok?\n"){ print } }, 1, |
621 | ); | |
622 | while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) { | |
0214ae40 | 623 | eval { &$code }; |
d441d3db | 624 | main::ok(($ok xor $@), "Underscore '$name'"); |
0214ae40 GS |
625 | } |
626 | untie $_; | |
627 | } | |
628 | ||
1f5346dc | 629 | { |
9e4422ce | 630 | # BUG 20001205.022 (RT #4852) |
1f5346dc SC |
631 | my %x; |
632 | $x{a} = 1; | |
633 | { local $x{b} = 1; } | |
d441d3db | 634 | ok(! exists $x{b}); |
1f5346dc | 635 | { local @x{c,d,e}; } |
d441d3db | 636 | ok(! exists $x{c}); |
1f5346dc | 637 | } |
159ad915 | 638 | |
33f3c7b8 RGS |
639 | # local() and readonly magic variables |
640 | ||
641 | eval { local $1 = 1 }; | |
d441d3db | 642 | like($@, qr/Modification of a read-only value attempted/); |
33f3c7b8 | 643 | |
658a9f31 | 644 | # local($_) always strips all magic |
33f3c7b8 | 645 | eval { for ($1) { local $_ = 1 } }; |
658a9f31 | 646 | is($@, ""); |
33f3c7b8 | 647 | |
658a9f31 | 648 | { |
407287f9 | 649 | my $STORE = my $FETCH = 0; |
658a9f31 JD |
650 | package TieHash; |
651 | sub TIEHASH { bless $_[1], $_[0] } | |
407287f9 | 652 | sub FETCH { ++$FETCH; 42 } |
658a9f31 JD |
653 | sub STORE { ++$STORE } |
654 | ||
655 | package main; | |
656 | tie my %hash, "TieHash", {}; | |
657 | ||
658 | eval { for ($hash{key}) {local $_ = 2} }; | |
659 | is($STORE, 0); | |
407287f9 | 660 | is($FETCH, 0); |
658a9f31 | 661 | } |
ac117f44 RGS |
662 | |
663 | # The s/// adds 'g' magic to $_, but it should remain non-readonly | |
664 | eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } }; | |
d441d3db | 665 | is($@, ""); |
4cb09e0a | 666 | |
985d6f61 HS |
667 | # sub localisation |
668 | { | |
669 | package Other; | |
670 | ||
671 | sub f1 { "f1" } | |
672 | sub f2 { "f2" } | |
673 | ||
674 | no warnings "redefine"; | |
675 | { | |
676 | local *f1 = sub { "g1" }; | |
677 | ::ok(f1() eq "g1", "localised sub via glob"); | |
678 | } | |
679 | ::ok(f1() eq "f1", "localised sub restored"); | |
680 | { | |
681 | local $Other::{"f1"} = sub { "h1" }; | |
682 | ::ok(f1() eq "h1", "localised sub via stash"); | |
683 | } | |
684 | ::ok(f1() eq "f1", "localised sub restored"); | |
685 | { | |
686 | local @Other::{qw/ f1 f2 /} = (sub { "j1" }, sub { "j2" }); | |
985d6f61 HS |
687 | ::ok(f1() eq "j1", "localised sub via stash slice"); |
688 | ::ok(f2() eq "j2", "localised sub via stash slice"); | |
985d6f61 HS |
689 | } |
690 | ::ok(f1() eq "f1", "localised sub restored"); | |
691 | ::ok(f2() eq "f2", "localised sub restored"); | |
692 | } | |
7d654f43 NC |
693 | |
694 | # Localising unicode keys (bug #38815) | |
695 | { | |
696 | my %h; | |
697 | $h{"\243"} = "pound"; | |
698 | $h{"\302\240"} = "octects"; | |
699 | is(scalar keys %h, 2); | |
700 | { | |
701 | my $unicode = chr 256; | |
702 | my $ambigous = "\240" . $unicode; | |
703 | chop $ambigous; | |
704 | local $h{$unicode} = 256; | |
705 | local $h{$ambigous} = 160; | |
706 | ||
707 | is(scalar keys %h, 4); | |
708 | is($h{"\243"}, "pound"); | |
709 | is($h{$unicode}, 256); | |
710 | is($h{$ambigous}, 160); | |
711 | is($h{"\302\240"}, "octects"); | |
712 | } | |
713 | is(scalar keys %h, 2); | |
714 | is($h{"\243"}, "pound"); | |
715 | is($h{"\302\240"}, "octects"); | |
716 | } | |
919acde0 NC |
717 | |
718 | # And with slices | |
719 | { | |
720 | my %h; | |
721 | $h{"\243"} = "pound"; | |
722 | $h{"\302\240"} = "octects"; | |
723 | is(scalar keys %h, 2); | |
724 | { | |
725 | my $unicode = chr 256; | |
726 | my $ambigous = "\240" . $unicode; | |
727 | chop $ambigous; | |
728 | local @h{$unicode, $ambigous} = (256, 160); | |
729 | ||
730 | is(scalar keys %h, 4); | |
731 | is($h{"\243"}, "pound"); | |
732 | is($h{$unicode}, 256); | |
733 | is($h{$ambigous}, 160); | |
734 | is($h{"\302\240"}, "octects"); | |
735 | } | |
736 | is(scalar keys %h, 2); | |
737 | is($h{"\243"}, "pound"); | |
738 | is($h{"\302\240"}, "octects"); | |
739 | } | |
658aef79 DM |
740 | |
741 | # [perl #39012] localizing @_ element then shifting frees element too # soon | |
742 | ||
743 | { | |
744 | my $x; | |
745 | my $y = bless [], 'X39012'; | |
746 | sub X39012::DESTROY { $x++ } | |
747 | sub { local $_[0]; shift }->($y); | |
748 | ok(!$x, '[perl #39012]'); | |
749 | ||
750 | } | |
751 | ||
b2096149 BL |
752 | # when localising a hash element, the key should be copied, not referenced |
753 | ||
754 | { | |
755 | my %h=('k1' => 111); | |
756 | my $k='k1'; | |
757 | { | |
758 | local $h{$k}=222; | |
759 | ||
760 | is($h{'k1'},222); | |
761 | $k='k2'; | |
762 | } | |
763 | ok(! exists($h{'k2'})); | |
764 | is($h{'k1'},111); | |
765 | } | |
46c458a0 HS |
766 | { |
767 | my %h=('k1' => 111); | |
768 | our $k = 'k1'; # try dynamic too | |
769 | { | |
770 | local $h{$k}=222; | |
771 | is($h{'k1'},222); | |
772 | $k='k2'; | |
773 | } | |
774 | ok(! exists($h{'k2'})); | |
775 | is($h{'k1'},111); | |
776 | } | |
72651472 | 777 | |
07a28ea7 B |
778 | like( runperl(stderr => 1, |
779 | prog => 'use constant foo => q(a);' . | |
780 | 'index(q(a), foo);' . | |
aaa63dae | 781 | 'local *g=${::}{foo};print q(ok);'), qr/^ok$/, "[perl #52740]"); |
07a28ea7 | 782 | |
2c5f48c2 FC |
783 | # related to perl #112966 |
784 | # Magic should not cause elements not to be deleted after scope unwinding | |
785 | # when they did not exist before local() | |
786 | () = \$#squinch; # $#foo in lvalue context makes array magical | |
787 | { | |
788 | local $squinch[0]; | |
789 | local @squinch[1..2]; | |
790 | package Flibbert; | |
791 | m??; # makes stash magical | |
792 | local $Flibbert::{foo}; | |
793 | local @Flibbert::{<bar baz>}; | |
794 | } | |
795 | ok !exists $Flibbert::{foo}, | |
796 | 'local helem on magic hash does not leave elems on scope exit'; | |
797 | ok !exists $Flibbert::{bar}, | |
798 | 'local hslice on magic hash does not leave elems on scope exit'; | |
799 | ok !exists $squinch[0], | |
800 | 'local aelem on magic hash does not leave elems on scope exit'; | |
801 | ok !exists $squinch[1], | |
802 | 'local aslice on magic hash does not leave elems on scope exit'; | |
803 | ||
01433346 | 804 | # Keep these tests last, as they can SEGV |
72651472 NC |
805 | { |
806 | local *@; | |
807 | pass("Localised *@"); | |
808 | eval {1}; | |
809 | pass("Can eval with *@ localised"); | |
72651472 | 810 | |
01433346 FC |
811 | local @{"nugguton"}; |
812 | local %{"netgonch"}; | |
813 | delete $::{$_} for 'nugguton','netgonch'; | |
814 | } | |
815 | pass ('localised arrays and hashes do not crash if glob is deleted'); | |
2c5f48c2 FC |
816 | |
817 | # [perl #112966] Rmagic can cause delete local to crash | |
818 | package Grompits { | |
819 | local $SIG{__WARN__}; | |
820 | delete local $ISA[0]; | |
821 | delete local @ISA[1..10]; | |
822 | m??; # makes stash magical | |
823 | delete local $Grompits::{foo}; | |
824 | delete local @Grompits::{<foo bar>}; | |
825 | } | |
826 | pass 'rmagic does not cause delete local to crash on nonexistent elems'; |