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 | } |
4ad10a0b |
8 | plan tests => 183; |
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 | |
161 | %h = ('a' => 1, 'b' => 2, 'c' => 3); |
162 | { |
163 | local($h{'a'}) = 'foo'; |
164 | local($h{'b'}) = $h{'b'}; |
d441d3db |
165 | is($h{'a'}, 'foo'); |
166 | is($h{'b'}, 2); |
161b7d16 |
167 | local($h{'c'}); |
168 | delete $h{'c'}; |
169 | } |
d441d3db |
170 | is($h{'a'}, 1); |
171 | is($h{'b'}, 2); |
d60c5a05 |
172 | { |
173 | my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); |
174 | local %h = %h; |
175 | is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); |
176 | } |
d441d3db |
177 | is($h{'c'}, 3); |
2bb40b7f |
178 | |
179 | # check for scope leakage |
180 | $a = 'outer'; |
181 | if (1) { local $a = 'inner' } |
d441d3db |
182 | is($a, 'outer'); |
2bb40b7f |
183 | |
184 | # see if localization works when scope unwinds |
185 | local $m = 5; |
186 | eval { |
187 | for $m (6) { |
188 | local $m = 7; |
189 | die "bye"; |
190 | } |
191 | }; |
d441d3db |
192 | is($m, 5); |
4e4c362e |
193 | |
194 | # see if localization works on tied arrays |
195 | { |
196 | package TA; |
197 | sub TIEARRAY { bless [], $_[0] } |
198 | sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] } |
199 | sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v } |
4ad10a0b |
200 | sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->[$_[1]]; } |
201 | sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->[$_[1]]; } |
4e4c362e |
202 | sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); } |
203 | sub FETCHSIZE { scalar(@{$_[0]}) } |
204 | sub SHIFT { shift (@{$_[0]}) } |
205 | sub EXTEND {} |
206 | } |
207 | |
208 | tie @a, 'TA'; |
209 | @a = ('a', 'b', 'c'); |
210 | { |
211 | local($a[1]) = 'foo'; |
be6c24e0 |
212 | local($a[2]) = $a[2]; |
d441d3db |
213 | is($a[1], 'foo'); |
214 | is($a[2], 'c'); |
4e4c362e |
215 | @a = (); |
216 | } |
d441d3db |
217 | is($a[1], 'b'); |
218 | is($a[2], 'c'); |
219 | ok(!defined $a[0]); |
d60c5a05 |
220 | { |
221 | my $d = "@a"; |
222 | local @a = @a; |
223 | is("@a", $d); |
224 | } |
4e4c362e |
225 | |
4ad10a0b |
226 | # local() should preserve the existenceness of tied array elements |
227 | @a = ('a', 'b', 'c'); |
228 | { |
229 | local($a[4]) = 'x'; |
230 | ok(!defined $a[3]); |
231 | is($a[4], 'x'); |
232 | } |
233 | is(scalar(@a), 3); |
234 | ok(!exists $a[3]); |
235 | ok(!exists $a[4]); |
236 | |
237 | @a = ('a', 'b', 'c'); |
238 | { |
239 | local($a[5]) = 'z'; |
240 | $a[4] = 'y'; |
241 | ok(!defined $a[3]); |
242 | is($a[4], 'y'); |
243 | is($a[5], 'z'); |
244 | } |
245 | is(scalar(@a), 5); |
246 | ok(!defined $a[3]); |
247 | is($a[4], 'y'); |
248 | ok(!exists $a[5]); |
249 | |
250 | @a = ('a', 'b', 'c'); |
251 | { |
252 | local(@a[4,6]) = ('x', 'z'); |
253 | ok(!defined $a[3]); |
254 | is($a[4], 'x'); |
255 | ok(!defined $a[5]); |
256 | is($a[6], 'z'); |
257 | } |
258 | is(scalar(@a), 3); |
259 | ok(!exists $a[3]); |
260 | ok(!exists $a[4]); |
261 | ok(!exists $a[5]); |
262 | ok(!exists $a[6]); |
263 | |
264 | @a = ('a', 'b', 'c'); |
265 | { |
266 | local(@a[4,6]) = ('x', 'z'); |
267 | $a[5] = 'y'; |
268 | ok(!defined $a[3]); |
269 | is($a[4], 'x'); |
270 | is($a[5], 'y'); |
271 | is($a[6], 'z'); |
272 | } |
273 | is(scalar(@a), 6); |
274 | ok(!defined $a[3]); |
275 | ok(!defined $a[4]); |
276 | is($a[5], 'y'); |
277 | ok(!exists $a[6]); |
278 | |
279 | # see if localization works on tied hashes |
4e4c362e |
280 | { |
281 | package TH; |
282 | sub TIEHASH { bless {}, $_[0] } |
283 | sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] } |
284 | sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v } |
c39e6ab0 |
285 | sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; } |
4e4c362e |
286 | sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } |
287 | sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } |
d60c5a05 |
288 | sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} } |
289 | sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} } |
4e4c362e |
290 | } |
291 | |
4e4c362e |
292 | tie %h, 'TH'; |
293 | %h = ('a' => 1, 'b' => 2, 'c' => 3); |
294 | |
295 | { |
296 | local($h{'a'}) = 'foo'; |
be6c24e0 |
297 | local($h{'b'}) = $h{'b'}; |
159ad915 |
298 | local($h{'y'}); |
299 | local($h{'z'}) = 33; |
d441d3db |
300 | is($h{'a'}, 'foo'); |
301 | is($h{'b'}, 2); |
4e4c362e |
302 | local($h{'c'}); |
303 | delete $h{'c'}; |
304 | } |
d441d3db |
305 | is($h{'a'}, 1); |
306 | is($h{'b'}, 2); |
307 | is($h{'c'}, 3); |
308 | # local() should preserve the existenceness of tied hash elements |
309 | ok(! exists $h{'y'}); |
310 | ok(! exists $h{'z'}); |
d60c5a05 |
311 | TODO: { |
312 | todo_skip("Localize entire tied hash"); |
313 | my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); |
314 | local %h = %h; |
315 | is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); |
316 | } |
4e4c362e |
317 | |
318 | @a = ('a', 'b', 'c'); |
319 | { |
320 | local($a[1]) = "X"; |
321 | shift @a; |
322 | } |
d441d3db |
323 | is($a[0].$a[1], "Xb"); |
4e4c362e |
324 | |
be6c24e0 |
325 | # now try the same for %SIG |
326 | |
327 | $SIG{TERM} = 'foo'; |
328 | $SIG{INT} = \&foo; |
329 | $SIG{__WARN__} = $SIG{INT}; |
330 | { |
331 | local($SIG{TERM}) = $SIG{TERM}; |
332 | local($SIG{INT}) = $SIG{INT}; |
333 | local($SIG{__WARN__}) = $SIG{__WARN__}; |
d441d3db |
334 | is($SIG{TERM}, 'main::foo'); |
335 | is($SIG{INT}, \&foo); |
336 | is($SIG{__WARN__}, \&foo); |
be6c24e0 |
337 | local($SIG{INT}); |
338 | delete $SIG{__WARN__}; |
339 | } |
d441d3db |
340 | is($SIG{TERM}, 'main::foo'); |
341 | is($SIG{INT}, \&foo); |
342 | is($SIG{__WARN__}, \&foo); |
d60c5a05 |
343 | { |
344 | my $d = join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG); |
345 | local %SIG = %SIG; |
346 | is(join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG), $d); |
347 | } |
be6c24e0 |
348 | |
349 | # and for %ENV |
350 | |
351 | $ENV{_X_} = 'a'; |
352 | $ENV{_Y_} = 'b'; |
353 | $ENV{_Z_} = 'c'; |
354 | { |
159ad915 |
355 | local($ENV{_A_}); |
356 | local($ENV{_B_}) = 'foo'; |
be6c24e0 |
357 | local($ENV{_X_}) = 'foo'; |
358 | local($ENV{_Y_}) = $ENV{_Y_}; |
d441d3db |
359 | is($ENV{_X_}, 'foo'); |
360 | is($ENV{_Y_}, 'b'); |
be6c24e0 |
361 | local($ENV{_Z_}); |
362 | delete $ENV{_Z_}; |
363 | } |
d441d3db |
364 | is($ENV{_X_}, 'a'); |
365 | is($ENV{_Y_}, 'b'); |
366 | is($ENV{_Z_}, 'c'); |
367 | # local() should preserve the existenceness of %ENV elements |
368 | ok(! exists $ENV{_A_}); |
369 | ok(! exists $ENV{_B_}); |
13414bd5 |
370 | |
371 | SKIP: { |
372 | skip("Can't make list assignment to \%ENV on this system") |
373 | unless $list_assignment_supported; |
d60c5a05 |
374 | my $d = join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV); |
375 | local %ENV = %ENV; |
376 | is(join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV), $d); |
377 | } |
be6c24e0 |
378 | |
0214ae40 |
379 | # does implicit localization in foreach skip magic? |
380 | |
d441d3db |
381 | $_ = "o 0,o 1,"; |
0214ae40 |
382 | my $iter = 0; |
383 | while (/(o.+?),/gc) { |
d441d3db |
384 | is($1, "o $iter"); |
0214ae40 |
385 | foreach (1..1) { $iter++ } |
d441d3db |
386 | if ($iter > 2) { fail("endless loop"); last; } |
0214ae40 |
387 | } |
388 | |
389 | { |
390 | package UnderScore; |
391 | sub TIESCALAR { bless \my $self, shift } |
392 | sub FETCH { die "read \$_ forbidden" } |
393 | sub STORE { die "write \$_ forbidden" } |
394 | tie $_, __PACKAGE__; |
0214ae40 |
395 | my @tests = ( |
396 | "Nesting" => sub { print '#'; for (1..3) { print } |
397 | print "\n" }, 1, |
398 | "Reading" => sub { print }, 0, |
399 | "Matching" => sub { $x = /badness/ }, 0, |
400 | "Concat" => sub { $_ .= "a" }, 0, |
401 | "Chop" => sub { chop }, 0, |
402 | "Filetest" => sub { -x }, 0, |
403 | "Assignment" => sub { $_ = "Bad" }, 0, |
404 | # XXX whether next one should fail is debatable |
405 | "Local \$_" => sub { local $_ = 'ok?'; print }, 0, |
406 | "for local" => sub { for("#ok?\n"){ print } }, 1, |
407 | ); |
408 | while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) { |
0214ae40 |
409 | eval { &$code }; |
d441d3db |
410 | main::ok(($ok xor $@), "Underscore '$name'"); |
0214ae40 |
411 | } |
412 | untie $_; |
413 | } |
414 | |
1f5346dc |
415 | { |
416 | # BUG 20001205.22 |
417 | my %x; |
418 | $x{a} = 1; |
419 | { local $x{b} = 1; } |
d441d3db |
420 | ok(! exists $x{b}); |
1f5346dc |
421 | { local @x{c,d,e}; } |
d441d3db |
422 | ok(! exists $x{c}); |
1f5346dc |
423 | } |
159ad915 |
424 | |
33f3c7b8 |
425 | # local() and readonly magic variables |
426 | |
427 | eval { local $1 = 1 }; |
d441d3db |
428 | like($@, qr/Modification of a read-only value attempted/); |
33f3c7b8 |
429 | |
430 | eval { for ($1) { local $_ = 1 } }; |
d441d3db |
431 | like($@, qr/Modification of a read-only value attempted/); |
33f3c7b8 |
432 | |
0cbee0a4 |
433 | # make sure $1 is still read-only |
33f3c7b8 |
434 | eval { for ($1) { local $_ = 1 } }; |
d441d3db |
435 | like($@, qr/Modification of a read-only value attempted/); |
ac117f44 |
436 | |
437 | # The s/// adds 'g' magic to $_, but it should remain non-readonly |
438 | eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } }; |
d441d3db |
439 | is($@, ""); |
4cb09e0a |
440 | |
503de470 |
441 | # RT #4342 Special local() behavior for $[ |
4cb09e0a |
442 | { |
443 | local $[ = 1; |
503de470 |
444 | ok(1 == $[, 'lexcical scope of local $['); |
4cb09e0a |
445 | f(); |
446 | } |
447 | |
448 | sub f { ok(0 == $[); } |
449 | |
985d6f61 |
450 | # sub localisation |
451 | { |
452 | package Other; |
453 | |
454 | sub f1 { "f1" } |
455 | sub f2 { "f2" } |
456 | |
457 | no warnings "redefine"; |
458 | { |
459 | local *f1 = sub { "g1" }; |
460 | ::ok(f1() eq "g1", "localised sub via glob"); |
461 | } |
462 | ::ok(f1() eq "f1", "localised sub restored"); |
463 | { |
464 | local $Other::{"f1"} = sub { "h1" }; |
465 | ::ok(f1() eq "h1", "localised sub via stash"); |
466 | } |
467 | ::ok(f1() eq "f1", "localised sub restored"); |
468 | { |
469 | local @Other::{qw/ f1 f2 /} = (sub { "j1" }, sub { "j2" }); |
985d6f61 |
470 | ::ok(f1() eq "j1", "localised sub via stash slice"); |
471 | ::ok(f2() eq "j2", "localised sub via stash slice"); |
985d6f61 |
472 | } |
473 | ::ok(f1() eq "f1", "localised sub restored"); |
474 | ::ok(f2() eq "f2", "localised sub restored"); |
475 | } |
7d654f43 |
476 | |
477 | # Localising unicode keys (bug #38815) |
478 | { |
479 | my %h; |
480 | $h{"\243"} = "pound"; |
481 | $h{"\302\240"} = "octects"; |
482 | is(scalar keys %h, 2); |
483 | { |
484 | my $unicode = chr 256; |
485 | my $ambigous = "\240" . $unicode; |
486 | chop $ambigous; |
487 | local $h{$unicode} = 256; |
488 | local $h{$ambigous} = 160; |
489 | |
490 | is(scalar keys %h, 4); |
491 | is($h{"\243"}, "pound"); |
492 | is($h{$unicode}, 256); |
493 | is($h{$ambigous}, 160); |
494 | is($h{"\302\240"}, "octects"); |
495 | } |
496 | is(scalar keys %h, 2); |
497 | is($h{"\243"}, "pound"); |
498 | is($h{"\302\240"}, "octects"); |
499 | } |
919acde0 |
500 | |
501 | # And with slices |
502 | { |
503 | my %h; |
504 | $h{"\243"} = "pound"; |
505 | $h{"\302\240"} = "octects"; |
506 | is(scalar keys %h, 2); |
507 | { |
508 | my $unicode = chr 256; |
509 | my $ambigous = "\240" . $unicode; |
510 | chop $ambigous; |
511 | local @h{$unicode, $ambigous} = (256, 160); |
512 | |
513 | is(scalar keys %h, 4); |
514 | is($h{"\243"}, "pound"); |
515 | is($h{$unicode}, 256); |
516 | is($h{$ambigous}, 160); |
517 | is($h{"\302\240"}, "octects"); |
518 | } |
519 | is(scalar keys %h, 2); |
520 | is($h{"\243"}, "pound"); |
521 | is($h{"\302\240"}, "octects"); |
522 | } |
658aef79 |
523 | |
524 | # [perl #39012] localizing @_ element then shifting frees element too # soon |
525 | |
526 | { |
527 | my $x; |
528 | my $y = bless [], 'X39012'; |
529 | sub X39012::DESTROY { $x++ } |
530 | sub { local $_[0]; shift }->($y); |
531 | ok(!$x, '[perl #39012]'); |
532 | |
533 | } |
534 | |
b2096149 |
535 | # when localising a hash element, the key should be copied, not referenced |
536 | |
537 | { |
538 | my %h=('k1' => 111); |
539 | my $k='k1'; |
540 | { |
541 | local $h{$k}=222; |
542 | |
543 | is($h{'k1'},222); |
544 | $k='k2'; |
545 | } |
546 | ok(! exists($h{'k2'})); |
547 | is($h{'k1'},111); |
548 | } |
46c458a0 |
549 | { |
550 | my %h=('k1' => 111); |
551 | our $k = 'k1'; # try dynamic too |
552 | { |
553 | local $h{$k}=222; |
554 | is($h{'k1'},222); |
555 | $k='k2'; |
556 | } |
557 | ok(! exists($h{'k2'})); |
558 | is($h{'k1'},111); |
559 | } |
72651472 |
560 | |
07a28ea7 |
561 | like( runperl(stderr => 1, |
562 | prog => 'use constant foo => q(a);' . |
563 | 'index(q(a), foo);' . |
45f2a18c |
564 | 'local *g=${::}{foo};print q(ok);'), "ok", "[perl #52740]"); |
07a28ea7 |
565 | |
72651472 |
566 | # Keep this test last, as it can SEGV |
567 | { |
568 | local *@; |
569 | pass("Localised *@"); |
570 | eval {1}; |
571 | pass("Can eval with *@ localised"); |
572 | } |
573 | |