Commit | Line | Data |
a687059c |
1 | #!./perl |
2 | |
d441d3db |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
28e491ba |
5 | @INC = qw(. ../lib); |
d441d3db |
6 | require './test.pl'; |
7 | } |
7332a6c4 |
8 | plan tests => 296; |
a687059c |
9 | |
13414bd5 |
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 |
16 | sub foo { |
17 | local($a, $b) = @_; |
18 | local($c, $d); |
d441d3db |
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 |
25 | } |
26 | |
d441d3db |
27 | $a = "a 5"; |
28 | $b = "b 6"; |
29 | $c = "c 7"; |
30 | $d = "d 8"; |
a687059c |
31 | |
d441d3db |
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 |
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 |
43 | |
44 | # same thing, only with arrays and associative arrays |
45 | |
46 | sub foo2 { |
47 | local($a, @b) = @_; |
48 | local(@c, %d); |
d441d3db |
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 |
55 | } |
56 | |
d441d3db |
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 |
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 |
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 |
83 | # Array and hash elements |
84 | |
85 | @a = ('a', 'b', 'c'); |
86 | { |
87 | local($a[1]) = 'foo'; |
88 | local($a[2]) = $a[2]; |
d441d3db |
89 | is($a[1], 'foo'); |
90 | is($a[2], 'c'); |
161b7d16 |
91 | undef @a; |
92 | } |
d441d3db |
93 | is($a[1], 'b'); |
94 | is($a[2], 'c'); |
95 | ok(!defined $a[0]); |
161b7d16 |
96 | |
97 | @a = ('a', 'b', 'c'); |
98 | { |
4ad10a0b |
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 |
151 | local($a[1]) = "X"; |
152 | shift @a; |
153 | } |
d441d3db |
154 | is($a[0].$a[1], "Xb"); |
d60c5a05 |
155 | { |
156 | my $d = "@a"; |
157 | local @a = @a; |
158 | is("@a", $d); |
159 | } |
161b7d16 |
160 | |
7332a6c4 |
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 |
264 | %h = ('a' => 1, 'b' => 2, 'c' => 3); |
265 | { |
266 | local($h{'a'}) = 'foo'; |
267 | local($h{'b'}) = $h{'b'}; |
d441d3db |
268 | is($h{'a'}, 'foo'); |
269 | is($h{'b'}, 2); |
161b7d16 |
270 | local($h{'c'}); |
271 | delete $h{'c'}; |
272 | } |
d441d3db |
273 | is($h{'a'}, 1); |
274 | is($h{'b'}, 2); |
d60c5a05 |
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 |
281 | |
282 | # check for scope leakage |
283 | $a = 'outer'; |
284 | if (1) { local $a = 'inner' } |
d441d3db |
285 | is($a, 'outer'); |
2bb40b7f |
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 |
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 |
303 | sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->[$_[1]]; } |
304 | sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->[$_[1]]; } |
4e4c362e |
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 |
316 | is($a[1], 'foo'); |
317 | is($a[2], 'c'); |
4e4c362e |
318 | @a = (); |
319 | } |
d441d3db |
320 | is($a[1], 'b'); |
321 | is($a[2], 'c'); |
322 | ok(!defined $a[0]); |
d60c5a05 |
323 | { |
324 | my $d = "@a"; |
325 | local @a = @a; |
326 | is("@a", $d); |
327 | } |
4e4c362e |
328 | |
4ad10a0b |
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 |
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 |
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 |
431 | sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } |
432 | sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } |
d60c5a05 |
433 | sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} } |
434 | sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} } |
4e4c362e |
435 | } |
436 | |
4e4c362e |
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 |
443 | local($h{'y'}); |
444 | local($h{'z'}) = 33; |
d441d3db |
445 | is($h{'a'}, 'foo'); |
446 | is($h{'b'}, 2); |
4e4c362e |
447 | local($h{'c'}); |
448 | delete $h{'c'}; |
449 | } |
d441d3db |
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 |
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 |
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 |
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 |
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 |
517 | is($SIG{TERM}, 'main::foo'); |
518 | is($SIG{INT}, \&foo); |
519 | is($SIG{__WARN__}, \&foo); |
be6c24e0 |
520 | local($SIG{INT}); |
521 | delete $SIG{__WARN__}; |
522 | } |
d441d3db |
523 | is($SIG{TERM}, 'main::foo'); |
524 | is($SIG{INT}, \&foo); |
525 | is($SIG{__WARN__}, \&foo); |
d60c5a05 |
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 |
531 | |
532 | # and for %ENV |
533 | |
534 | $ENV{_X_} = 'a'; |
535 | $ENV{_Y_} = 'b'; |
536 | $ENV{_Z_} = 'c'; |
537 | { |
159ad915 |
538 | local($ENV{_A_}); |
539 | local($ENV{_B_}) = 'foo'; |
be6c24e0 |
540 | local($ENV{_X_}) = 'foo'; |
541 | local($ENV{_Y_}) = $ENV{_Y_}; |
d441d3db |
542 | is($ENV{_X_}, 'foo'); |
543 | is($ENV{_Y_}, 'b'); |
be6c24e0 |
544 | local($ENV{_Z_}); |
545 | delete $ENV{_Z_}; |
546 | } |
d441d3db |
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 |
553 | |
554 | SKIP: { |
555 | skip("Can't make list assignment to \%ENV on this system") |
556 | unless $list_assignment_supported; |
d60c5a05 |
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 |
562 | # does implicit localization in foreach skip magic? |
563 | |
d441d3db |
564 | $_ = "o 0,o 1,"; |
0214ae40 |
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 |
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 |
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 |
594 | } |
595 | untie $_; |
596 | } |
597 | |
1f5346dc |
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 |
608 | # local() and readonly magic variables |
609 | |
610 | eval { local $1 = 1 }; |
d441d3db |
611 | like($@, qr/Modification of a read-only value attempted/); |
33f3c7b8 |
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 |
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 | { |
626 | local $[ = 1; |
503de470 |
627 | ok(1 == $[, 'lexcical scope of local $['); |
4cb09e0a |
628 | f(); |
629 | } |
630 | |
631 | sub f { ok(0 == $[); } |
632 | |
985d6f61 |
633 | # sub localisation |
634 | { |
635 | package Other; |
636 | |
637 | sub f1 { "f1" } |
638 | sub f2 { "f2" } |
639 | |
640 | no warnings "redefine"; |
641 | { |
642 | local *f1 = sub { "g1" }; |
643 | ::ok(f1() eq "g1", "localised sub via glob"); |
644 | } |
645 | ::ok(f1() eq "f1", "localised sub restored"); |
646 | { |
647 | local $Other::{"f1"} = sub { "h1" }; |
648 | ::ok(f1() eq "h1", "localised sub via stash"); |
649 | } |
650 | ::ok(f1() eq "f1", "localised sub restored"); |
651 | { |
652 | local @Other::{qw/ f1 f2 /} = (sub { "j1" }, sub { "j2" }); |
985d6f61 |
653 | ::ok(f1() eq "j1", "localised sub via stash slice"); |
654 | ::ok(f2() eq "j2", "localised sub via stash slice"); |
985d6f61 |
655 | } |
656 | ::ok(f1() eq "f1", "localised sub restored"); |
657 | ::ok(f2() eq "f2", "localised sub restored"); |
658 | } |
7d654f43 |
659 | |
660 | # Localising unicode keys (bug #38815) |
661 | { |
662 | my %h; |
663 | $h{"\243"} = "pound"; |
664 | $h{"\302\240"} = "octects"; |
665 | is(scalar keys %h, 2); |
666 | { |
667 | my $unicode = chr 256; |
668 | my $ambigous = "\240" . $unicode; |
669 | chop $ambigous; |
670 | local $h{$unicode} = 256; |
671 | local $h{$ambigous} = 160; |
672 | |
673 | is(scalar keys %h, 4); |
674 | is($h{"\243"}, "pound"); |
675 | is($h{$unicode}, 256); |
676 | is($h{$ambigous}, 160); |
677 | is($h{"\302\240"}, "octects"); |
678 | } |
679 | is(scalar keys %h, 2); |
680 | is($h{"\243"}, "pound"); |
681 | is($h{"\302\240"}, "octects"); |
682 | } |
919acde0 |
683 | |
684 | # And with slices |
685 | { |
686 | my %h; |
687 | $h{"\243"} = "pound"; |
688 | $h{"\302\240"} = "octects"; |
689 | is(scalar keys %h, 2); |
690 | { |
691 | my $unicode = chr 256; |
692 | my $ambigous = "\240" . $unicode; |
693 | chop $ambigous; |
694 | local @h{$unicode, $ambigous} = (256, 160); |
695 | |
696 | is(scalar keys %h, 4); |
697 | is($h{"\243"}, "pound"); |
698 | is($h{$unicode}, 256); |
699 | is($h{$ambigous}, 160); |
700 | is($h{"\302\240"}, "octects"); |
701 | } |
702 | is(scalar keys %h, 2); |
703 | is($h{"\243"}, "pound"); |
704 | is($h{"\302\240"}, "octects"); |
705 | } |
658aef79 |
706 | |
707 | # [perl #39012] localizing @_ element then shifting frees element too # soon |
708 | |
709 | { |
710 | my $x; |
711 | my $y = bless [], 'X39012'; |
712 | sub X39012::DESTROY { $x++ } |
713 | sub { local $_[0]; shift }->($y); |
714 | ok(!$x, '[perl #39012]'); |
715 | |
716 | } |
717 | |
b2096149 |
718 | # when localising a hash element, the key should be copied, not referenced |
719 | |
720 | { |
721 | my %h=('k1' => 111); |
722 | my $k='k1'; |
723 | { |
724 | local $h{$k}=222; |
725 | |
726 | is($h{'k1'},222); |
727 | $k='k2'; |
728 | } |
729 | ok(! exists($h{'k2'})); |
730 | is($h{'k1'},111); |
731 | } |
46c458a0 |
732 | { |
733 | my %h=('k1' => 111); |
734 | our $k = 'k1'; # try dynamic too |
735 | { |
736 | local $h{$k}=222; |
737 | is($h{'k1'},222); |
738 | $k='k2'; |
739 | } |
740 | ok(! exists($h{'k2'})); |
741 | is($h{'k1'},111); |
742 | } |
72651472 |
743 | |
07a28ea7 |
744 | like( runperl(stderr => 1, |
745 | prog => 'use constant foo => q(a);' . |
746 | 'index(q(a), foo);' . |
45f2a18c |
747 | 'local *g=${::}{foo};print q(ok);'), "ok", "[perl #52740]"); |
07a28ea7 |
748 | |
72651472 |
749 | # Keep this test last, as it can SEGV |
750 | { |
751 | local *@; |
752 | pass("Localised *@"); |
753 | eval {1}; |
754 | pass("Can eval with *@ localised"); |
755 | } |
756 | |