Commit | Line | Data |
---|---|---|
a687059c LW |
1 | #!./perl |
2 | ||
d441d3db RD |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
28e491ba | 5 | @INC = qw(. ../lib); |
d441d3db RD |
6 | require './test.pl'; |
7 | } | |
7332a6c4 | 8 | plan tests => 296; |
a687059c | 9 | |
13414bd5 JM |
10 | my $list_assignment_supported = 1; |
11 | ||
12 | #mg.c says list assignment not supported on VMS, EPOC, and SYMBIAN. | |
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 | } | |
4e4c362e | 328 | |
4ad10a0b VP |
329 | # local() should preserve the existenceness of tied array elements |
330 | @a = ('a', 'b', 'c'); | |
331 | { | |
332 | local($a[4]) = 'x'; | |
333 | ok(!defined $a[3]); | |
334 | is($a[4], 'x'); | |
335 | } | |
336 | is(scalar(@a), 3); | |
337 | ok(!exists $a[3]); | |
338 | ok(!exists $a[4]); | |
339 | ||
340 | @a = ('a', 'b', 'c'); | |
341 | { | |
342 | local($a[5]) = 'z'; | |
343 | $a[4] = 'y'; | |
344 | ok(!defined $a[3]); | |
345 | is($a[4], 'y'); | |
346 | is($a[5], 'z'); | |
347 | } | |
348 | is(scalar(@a), 5); | |
349 | ok(!defined $a[3]); | |
350 | is($a[4], 'y'); | |
351 | ok(!exists $a[5]); | |
352 | ||
353 | @a = ('a', 'b', 'c'); | |
354 | { | |
355 | local(@a[4,6]) = ('x', 'z'); | |
356 | ok(!defined $a[3]); | |
357 | is($a[4], 'x'); | |
358 | ok(!defined $a[5]); | |
359 | is($a[6], 'z'); | |
360 | } | |
361 | is(scalar(@a), 3); | |
362 | ok(!exists $a[3]); | |
363 | ok(!exists $a[4]); | |
364 | ok(!exists $a[5]); | |
365 | ok(!exists $a[6]); | |
366 | ||
367 | @a = ('a', 'b', 'c'); | |
368 | { | |
369 | local(@a[4,6]) = ('x', 'z'); | |
370 | $a[5] = 'y'; | |
371 | ok(!defined $a[3]); | |
372 | is($a[4], 'x'); | |
373 | is($a[5], 'y'); | |
374 | is($a[6], 'z'); | |
375 | } | |
376 | is(scalar(@a), 6); | |
377 | ok(!defined $a[3]); | |
378 | ok(!defined $a[4]); | |
379 | is($a[5], 'y'); | |
380 | ok(!exists $a[6]); | |
381 | ||
7332a6c4 VP |
382 | @a = ('a', 'b', 'c'); |
383 | $a[4] = 'd'; | |
384 | { | |
385 | delete local $a[1]; | |
386 | is(scalar(@a), 5); | |
387 | is($a[0], 'a'); | |
388 | ok(!exists($a[1])); | |
389 | is($a[2], 'c'); | |
390 | ok(!exists($a[3])); | |
391 | is($a[4], 'd'); | |
392 | ||
393 | ok(!exists($a[888])); | |
394 | delete local $a[888]; | |
395 | is(scalar(@a), 5); | |
396 | ok(!exists($a[888])); | |
397 | ||
398 | ok(!exists($a[999])); | |
399 | my ($d, $zzz) = delete local @a[4, 999]; | |
400 | is(scalar(@a), 3); | |
401 | ok(!exists($a[4])); | |
402 | ok(!exists($a[999])); | |
403 | is($d, 'd'); | |
404 | is($zzz, undef); | |
405 | ||
406 | my $c = delete local $a[2]; | |
407 | is(scalar(@a), 1); | |
408 | ok(!exists($a[2])); | |
409 | is($c, 'c'); | |
410 | ||
411 | $a[888] = 'yyy'; | |
412 | $a[999] = 'zzz'; | |
413 | } | |
414 | is(scalar(@a), 5); | |
415 | is($a[0], 'a'); | |
416 | is($a[1], 'b'); | |
417 | is($a[2], 'c'); | |
418 | ok(!defined($a[3])); | |
419 | is($a[4], 'd'); | |
420 | ok(!exists($a[5])); | |
421 | ok(!exists($a[888])); | |
422 | ok(!exists($a[999])); | |
423 | ||
4ad10a0b | 424 | # see if localization works on tied hashes |
4e4c362e GS |
425 | { |
426 | package TH; | |
427 | sub TIEHASH { bless {}, $_[0] } | |
428 | sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] } | |
429 | sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v } | |
c39e6ab0 | 430 | sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; } |
4e4c362e GS |
431 | sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } |
432 | sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } | |
d60c5a05 RD |
433 | sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} } |
434 | sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} } | |
4e4c362e GS |
435 | } |
436 | ||
4e4c362e GS |
437 | tie %h, 'TH'; |
438 | %h = ('a' => 1, 'b' => 2, 'c' => 3); | |
439 | ||
440 | { | |
441 | local($h{'a'}) = 'foo'; | |
be6c24e0 | 442 | local($h{'b'}) = $h{'b'}; |
159ad915 DM |
443 | local($h{'y'}); |
444 | local($h{'z'}) = 33; | |
d441d3db RD |
445 | is($h{'a'}, 'foo'); |
446 | is($h{'b'}, 2); | |
4e4c362e GS |
447 | local($h{'c'}); |
448 | delete $h{'c'}; | |
449 | } | |
d441d3db RD |
450 | is($h{'a'}, 1); |
451 | is($h{'b'}, 2); | |
452 | is($h{'c'}, 3); | |
453 | # local() should preserve the existenceness of tied hash elements | |
454 | ok(! exists $h{'y'}); | |
455 | ok(! exists $h{'z'}); | |
d60c5a05 RD |
456 | TODO: { |
457 | todo_skip("Localize entire tied hash"); | |
458 | my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); | |
459 | local %h = %h; | |
460 | is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); | |
461 | } | |
4e4c362e | 462 | |
7332a6c4 VP |
463 | %h = (a => 1, b => 2, c => 3, d => 4); |
464 | { | |
465 | delete local $h{b}; | |
466 | is(scalar(keys(%h)), 3); | |
467 | is($h{a}, 1); | |
468 | ok(!exists($h{b})); | |
469 | is($h{c}, 3); | |
470 | is($h{d}, 4); | |
471 | ||
472 | ok(!exists($h{yyy})); | |
473 | delete local $h{yyy}; | |
474 | is(scalar(keys(%h)), 3); | |
475 | ok(!exists($h{yyy})); | |
476 | ||
477 | ok(!exists($h{zzz})); | |
478 | my ($d, $zzz) = delete local @h{qw/d zzz/}; | |
479 | is(scalar(keys(%h)), 2); | |
480 | ok(!exists($h{d})); | |
481 | ok(!exists($h{zzz})); | |
482 | is($d, 4); | |
483 | is($zzz, undef); | |
484 | ||
485 | my $c = delete local $h{c}; | |
486 | is(scalar(keys(%h)), 1); | |
487 | ok(!exists($h{c})); | |
488 | is($c, 3); | |
489 | ||
490 | $h{yyy} = 888; | |
491 | $h{zzz} = 999; | |
492 | } | |
493 | is(scalar(keys(%h)), 4); | |
494 | is($h{a}, 1); | |
495 | is($h{b}, 2); | |
496 | is($h{c}, 3); | |
497 | ok($h{d}, 4); | |
498 | ok(!exists($h{yyy})); | |
499 | ok(!exists($h{zzz})); | |
500 | ||
4e4c362e GS |
501 | @a = ('a', 'b', 'c'); |
502 | { | |
503 | local($a[1]) = "X"; | |
504 | shift @a; | |
505 | } | |
d441d3db | 506 | is($a[0].$a[1], "Xb"); |
4e4c362e | 507 | |
be6c24e0 GS |
508 | # now try the same for %SIG |
509 | ||
510 | $SIG{TERM} = 'foo'; | |
511 | $SIG{INT} = \&foo; | |
512 | $SIG{__WARN__} = $SIG{INT}; | |
513 | { | |
514 | local($SIG{TERM}) = $SIG{TERM}; | |
515 | local($SIG{INT}) = $SIG{INT}; | |
516 | local($SIG{__WARN__}) = $SIG{__WARN__}; | |
d441d3db RD |
517 | is($SIG{TERM}, 'main::foo'); |
518 | is($SIG{INT}, \&foo); | |
519 | is($SIG{__WARN__}, \&foo); | |
be6c24e0 GS |
520 | local($SIG{INT}); |
521 | delete $SIG{__WARN__}; | |
522 | } | |
d441d3db RD |
523 | is($SIG{TERM}, 'main::foo'); |
524 | is($SIG{INT}, \&foo); | |
525 | is($SIG{__WARN__}, \&foo); | |
d60c5a05 RD |
526 | { |
527 | my $d = join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG); | |
528 | local %SIG = %SIG; | |
529 | is(join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG), $d); | |
530 | } | |
be6c24e0 GS |
531 | |
532 | # and for %ENV | |
533 | ||
534 | $ENV{_X_} = 'a'; | |
535 | $ENV{_Y_} = 'b'; | |
536 | $ENV{_Z_} = 'c'; | |
537 | { | |
159ad915 DM |
538 | local($ENV{_A_}); |
539 | local($ENV{_B_}) = 'foo'; | |
be6c24e0 GS |
540 | local($ENV{_X_}) = 'foo'; |
541 | local($ENV{_Y_}) = $ENV{_Y_}; | |
d441d3db RD |
542 | is($ENV{_X_}, 'foo'); |
543 | is($ENV{_Y_}, 'b'); | |
be6c24e0 GS |
544 | local($ENV{_Z_}); |
545 | delete $ENV{_Z_}; | |
546 | } | |
d441d3db RD |
547 | is($ENV{_X_}, 'a'); |
548 | is($ENV{_Y_}, 'b'); | |
549 | is($ENV{_Z_}, 'c'); | |
550 | # local() should preserve the existenceness of %ENV elements | |
551 | ok(! exists $ENV{_A_}); | |
552 | ok(! exists $ENV{_B_}); | |
13414bd5 JM |
553 | |
554 | SKIP: { | |
555 | skip("Can't make list assignment to \%ENV on this system") | |
556 | unless $list_assignment_supported; | |
d60c5a05 RD |
557 | my $d = join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV); |
558 | local %ENV = %ENV; | |
559 | is(join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV), $d); | |
560 | } | |
be6c24e0 | 561 | |
0214ae40 GS |
562 | # does implicit localization in foreach skip magic? |
563 | ||
d441d3db | 564 | $_ = "o 0,o 1,"; |
0214ae40 GS |
565 | my $iter = 0; |
566 | while (/(o.+?),/gc) { | |
d441d3db | 567 | is($1, "o $iter"); |
0214ae40 | 568 | foreach (1..1) { $iter++ } |
d441d3db | 569 | if ($iter > 2) { fail("endless loop"); last; } |
0214ae40 GS |
570 | } |
571 | ||
572 | { | |
573 | package UnderScore; | |
574 | sub TIESCALAR { bless \my $self, shift } | |
575 | sub FETCH { die "read \$_ forbidden" } | |
576 | sub STORE { die "write \$_ forbidden" } | |
577 | tie $_, __PACKAGE__; | |
0214ae40 GS |
578 | my @tests = ( |
579 | "Nesting" => sub { print '#'; for (1..3) { print } | |
580 | print "\n" }, 1, | |
581 | "Reading" => sub { print }, 0, | |
582 | "Matching" => sub { $x = /badness/ }, 0, | |
583 | "Concat" => sub { $_ .= "a" }, 0, | |
584 | "Chop" => sub { chop }, 0, | |
585 | "Filetest" => sub { -x }, 0, | |
586 | "Assignment" => sub { $_ = "Bad" }, 0, | |
587 | # XXX whether next one should fail is debatable | |
588 | "Local \$_" => sub { local $_ = 'ok?'; print }, 0, | |
589 | "for local" => sub { for("#ok?\n"){ print } }, 1, | |
590 | ); | |
591 | while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) { | |
0214ae40 | 592 | eval { &$code }; |
d441d3db | 593 | main::ok(($ok xor $@), "Underscore '$name'"); |
0214ae40 GS |
594 | } |
595 | untie $_; | |
596 | } | |
597 | ||
1f5346dc SC |
598 | { |
599 | # BUG 20001205.22 | |
600 | my %x; | |
601 | $x{a} = 1; | |
602 | { local $x{b} = 1; } | |
d441d3db | 603 | ok(! exists $x{b}); |
1f5346dc | 604 | { local @x{c,d,e}; } |
d441d3db | 605 | ok(! exists $x{c}); |
1f5346dc | 606 | } |
159ad915 | 607 | |
33f3c7b8 RGS |
608 | # local() and readonly magic variables |
609 | ||
610 | eval { local $1 = 1 }; | |
d441d3db | 611 | like($@, qr/Modification of a read-only value attempted/); |
33f3c7b8 RGS |
612 | |
613 | eval { for ($1) { local $_ = 1 } }; | |
d441d3db | 614 | like($@, qr/Modification of a read-only value attempted/); |
33f3c7b8 | 615 | |
0cbee0a4 | 616 | # make sure $1 is still read-only |
33f3c7b8 | 617 | eval { for ($1) { local $_ = 1 } }; |
d441d3db | 618 | like($@, qr/Modification of a read-only value attempted/); |
ac117f44 RGS |
619 | |
620 | # The s/// adds 'g' magic to $_, but it should remain non-readonly | |
621 | eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } }; | |
d441d3db | 622 | is($@, ""); |
4cb09e0a | 623 | |
503de470 | 624 | # RT #4342 Special local() behavior for $[ |
4cb09e0a | 625 | { |
4521bb06 | 626 | no warnings 'deprecated'; |
4cb09e0a | 627 | local $[ = 1; |
503de470 | 628 | ok(1 == $[, 'lexcical scope of local $['); |
4cb09e0a SP |
629 | f(); |
630 | } | |
631 | ||
632 | sub f { ok(0 == $[); } | |
633 | ||
985d6f61 HS |
634 | # sub localisation |
635 | { | |
636 | package Other; | |
637 | ||
638 | sub f1 { "f1" } | |
639 | sub f2 { "f2" } | |
640 | ||
641 | no warnings "redefine"; | |
642 | { | |
643 | local *f1 = sub { "g1" }; | |
644 | ::ok(f1() eq "g1", "localised sub via glob"); | |
645 | } | |
646 | ::ok(f1() eq "f1", "localised sub restored"); | |
647 | { | |
648 | local $Other::{"f1"} = sub { "h1" }; | |
649 | ::ok(f1() eq "h1", "localised sub via stash"); | |
650 | } | |
651 | ::ok(f1() eq "f1", "localised sub restored"); | |
652 | { | |
653 | local @Other::{qw/ f1 f2 /} = (sub { "j1" }, sub { "j2" }); | |
985d6f61 HS |
654 | ::ok(f1() eq "j1", "localised sub via stash slice"); |
655 | ::ok(f2() eq "j2", "localised sub via stash slice"); | |
985d6f61 HS |
656 | } |
657 | ::ok(f1() eq "f1", "localised sub restored"); | |
658 | ::ok(f2() eq "f2", "localised sub restored"); | |
659 | } | |
7d654f43 NC |
660 | |
661 | # Localising unicode keys (bug #38815) | |
662 | { | |
663 | my %h; | |
664 | $h{"\243"} = "pound"; | |
665 | $h{"\302\240"} = "octects"; | |
666 | is(scalar keys %h, 2); | |
667 | { | |
668 | my $unicode = chr 256; | |
669 | my $ambigous = "\240" . $unicode; | |
670 | chop $ambigous; | |
671 | local $h{$unicode} = 256; | |
672 | local $h{$ambigous} = 160; | |
673 | ||
674 | is(scalar keys %h, 4); | |
675 | is($h{"\243"}, "pound"); | |
676 | is($h{$unicode}, 256); | |
677 | is($h{$ambigous}, 160); | |
678 | is($h{"\302\240"}, "octects"); | |
679 | } | |
680 | is(scalar keys %h, 2); | |
681 | is($h{"\243"}, "pound"); | |
682 | is($h{"\302\240"}, "octects"); | |
683 | } | |
919acde0 NC |
684 | |
685 | # And with slices | |
686 | { | |
687 | my %h; | |
688 | $h{"\243"} = "pound"; | |
689 | $h{"\302\240"} = "octects"; | |
690 | is(scalar keys %h, 2); | |
691 | { | |
692 | my $unicode = chr 256; | |
693 | my $ambigous = "\240" . $unicode; | |
694 | chop $ambigous; | |
695 | local @h{$unicode, $ambigous} = (256, 160); | |
696 | ||
697 | is(scalar keys %h, 4); | |
698 | is($h{"\243"}, "pound"); | |
699 | is($h{$unicode}, 256); | |
700 | is($h{$ambigous}, 160); | |
701 | is($h{"\302\240"}, "octects"); | |
702 | } | |
703 | is(scalar keys %h, 2); | |
704 | is($h{"\243"}, "pound"); | |
705 | is($h{"\302\240"}, "octects"); | |
706 | } | |
658aef79 DM |
707 | |
708 | # [perl #39012] localizing @_ element then shifting frees element too # soon | |
709 | ||
710 | { | |
711 | my $x; | |
712 | my $y = bless [], 'X39012'; | |
713 | sub X39012::DESTROY { $x++ } | |
714 | sub { local $_[0]; shift }->($y); | |
715 | ok(!$x, '[perl #39012]'); | |
716 | ||
717 | } | |
718 | ||
b2096149 BL |
719 | # when localising a hash element, the key should be copied, not referenced |
720 | ||
721 | { | |
722 | my %h=('k1' => 111); | |
723 | my $k='k1'; | |
724 | { | |
725 | local $h{$k}=222; | |
726 | ||
727 | is($h{'k1'},222); | |
728 | $k='k2'; | |
729 | } | |
730 | ok(! exists($h{'k2'})); | |
731 | is($h{'k1'},111); | |
732 | } | |
46c458a0 HS |
733 | { |
734 | my %h=('k1' => 111); | |
735 | our $k = 'k1'; # try dynamic too | |
736 | { | |
737 | local $h{$k}=222; | |
738 | is($h{'k1'},222); | |
739 | $k='k2'; | |
740 | } | |
741 | ok(! exists($h{'k2'})); | |
742 | is($h{'k1'},111); | |
743 | } | |
72651472 | 744 | |
07a28ea7 B |
745 | like( runperl(stderr => 1, |
746 | prog => 'use constant foo => q(a);' . | |
747 | 'index(q(a), foo);' . | |
45f2a18c | 748 | 'local *g=${::}{foo};print q(ok);'), "ok", "[perl #52740]"); |
07a28ea7 | 749 | |
72651472 NC |
750 | # Keep this test last, as it can SEGV |
751 | { | |
752 | local *@; | |
753 | pass("Localised *@"); | |
754 | eval {1}; | |
755 | pass("Can eval with *@ localised"); | |
756 | } | |
757 |