10 my $list_assignment_supported = 1;
12 #mg.c says list assignment not supported on VMS, EPOC, and SYMBIAN.
13 $list_assignment_supported = 0 if ($^O eq 'VMS');
21 { local($a,$c) = ("a 9", "c 10"); ($x, $y) = ($a, $c); }
33 @res = &foo("a 1","b 2");
44 # same thing, only with arrays and associative arrays
51 { local($a,@c) = ("a 19", "c 20"); ($x, $y) = ($a, @c); }
62 @res = &foo2("a 1","b 2");
75 like($@, qr/Can't localize through a reference/);
77 eval '$e = []; local(@$e)';
78 like($@, qr/Can't localize through a reference/);
80 eval '$e = {}; local(%$e)';
81 like($@, qr/Can't localize through a reference/);
83 # Array and hash elements
107 @a = ('a', 'b', 'c');
120 @a = ('a', 'b', 'c');
122 local(@a[4,6]) = ('x', 'z');
134 @a = ('a', 'b', 'c');
136 local(@a[4,6]) = ('x', 'z');
149 @a = ('a', 'b', 'c');
154 is($a[0].$a[1], "Xb");
161 @a = ('a', 'b', 'c');
172 ok(!exists($a[888]));
173 delete local $a[888];
175 ok(!exists($a[888]));
177 ok(!exists($a[999]));
178 my ($d, $zzz) = delete local @a[4, 999];
181 ok(!exists($a[999]));
185 my $c = delete local $a[2];
200 ok(!exists($a[888]));
201 ok(!exists($a[999]));
203 %h = (a => 1, b => 2, c => 3, d => 4);
206 is(scalar(keys(%h)), 3);
212 ok(!exists($h{yyy}));
213 delete local $h{yyy};
214 is(scalar(keys(%h)), 3);
215 ok(!exists($h{yyy}));
217 ok(!exists($h{zzz}));
218 my ($d, $zzz) = delete local @h{qw/d zzz/};
219 is(scalar(keys(%h)), 2);
221 ok(!exists($h{zzz}));
225 my $c = delete local $h{c};
226 is(scalar(keys(%h)), 1);
233 is(scalar(keys(%h)), 4);
238 ok(!exists($h{yyy}));
239 ok(!exists($h{zzz}));
241 %h = ('a' => { 'b' => 1 }, 'c' => 2);
243 my $a = delete local $h{a};
244 is(scalar(keys(%h)), 1);
247 is(scalar(keys(%$a)), 1);
249 my $b = delete local $a->{b};
250 is(scalar(keys(%$a)), 0);
255 is(scalar(keys(%h)), 2);
258 is(scalar(keys(%$a)), 2);
264 %h = ('a' => 1, 'b' => 2, 'c' => 3);
266 local($h{'a'}) = 'foo';
267 local($h{'b'}) = $h{'b'};
276 my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h);
278 is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d);
282 # check for scope leakage
284 if (1) { local $a = 'inner' }
287 # see if localization works when scope unwinds
297 # see if localization works on tied arrays
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 }
303 sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->[$_[1]]; }
304 sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->[$_[1]]; }
305 sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); }
306 sub FETCHSIZE { scalar(@{$_[0]}) }
307 sub SHIFT { shift (@{$_[0]}) }
312 @a = ('a', 'b', 'c');
314 local($a[1]) = 'foo';
315 local($a[2]) = $a[2];
328 # RT #7938: localising an array should make it temporarily untied
332 is("@a", "6 7 8", 'local @a assigned 6,7,8');
335 local *TA::STORE = sub { $c++ };
337 is($c, 0, 'STORE not called after array localised');
339 is("@a", "9 7 8", 'local @a should now be 9 7 8');
341 is("@a", "a b c", '@a should now contain original value');
344 # local() should preserve the existenceness of tied array elements
345 @a = ('a', 'b', 'c');
355 @a = ('a', 'b', 'c');
368 @a = ('a', 'b', 'c');
370 local(@a[4,6]) = ('x', 'z');
382 @a = ('a', 'b', 'c');
384 local(@a[4,6]) = ('x', 'z');
397 @a = ('a', 'b', 'c');
408 ok(!exists($a[888]));
409 delete local $a[888];
411 ok(!exists($a[888]));
413 ok(!exists($a[999]));
414 my ($d, $zzz) = delete local @a[4, 999];
417 ok(!exists($a[999]));
421 my $c = delete local $a[2];
436 ok(!exists($a[888]));
437 ok(!exists($a[999]));
439 # see if localization works on tied hashes
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 }
445 sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; }
446 sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; }
447 sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); }
448 sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} }
449 sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} }
453 %h = ('a' => 1, 'b' => 2, 'c' => 3);
456 local($h{'a'}) = 'foo';
457 local($h{'b'}) = $h{'b'};
469 # local() should preserve the existenceness of tied hash elements
470 ok(! exists $h{'y'});
471 ok(! exists $h{'z'});
473 todo_skip("Localize entire tied hash");
474 my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h);
476 is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d);
479 # RT #7939: localising a hash should make it temporarily untied
481 %h = qw(a 1 b 2 c 3);
482 local %h = qw(x 6 y 7 z 8);
483 is(join('', sort keys %h), "xyz", 'local %h has new keys');
484 is(join('', sort values %h), "678", 'local %h has new values');
487 local *TH::STORE = sub { $c++ };
489 is($c, 0, 'STORE not called after hash localised');
491 is($h{x}, 9, '$h{x} should now be 9');
493 is(join('', sort keys %h), "abc", 'restored %h has original keys');
494 is(join('', sort values %h), "123", 'restored %h has original values');
497 %h = (a => 1, b => 2, c => 3, d => 4);
500 is(scalar(keys(%h)), 3);
506 ok(!exists($h{yyy}));
507 delete local $h{yyy};
508 is(scalar(keys(%h)), 3);
509 ok(!exists($h{yyy}));
511 ok(!exists($h{zzz}));
512 my ($d, $zzz) = delete local @h{qw/d zzz/};
513 is(scalar(keys(%h)), 2);
515 ok(!exists($h{zzz}));
519 my $c = delete local $h{c};
520 is(scalar(keys(%h)), 1);
527 is(scalar(keys(%h)), 4);
532 ok(!exists($h{yyy}));
533 ok(!exists($h{zzz}));
535 @a = ('a', 'b', 'c');
540 is($a[0].$a[1], "Xb");
542 # now try the same for %SIG
546 $SIG{__WARN__} = $SIG{INT};
548 local($SIG{TERM}) = $SIG{TERM};
549 local($SIG{INT}) = $SIG{INT};
550 local($SIG{__WARN__}) = $SIG{__WARN__};
551 is($SIG{TERM}, 'main::foo');
552 is($SIG{INT}, \&foo);
553 is($SIG{__WARN__}, \&foo);
555 delete $SIG{__WARN__};
557 is($SIG{TERM}, 'main::foo');
558 is($SIG{INT}, \&foo);
559 is($SIG{__WARN__}, \&foo);
561 my $d = join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG);
563 is(join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG), $d);
573 local($ENV{_B_}) = 'foo';
574 local($ENV{_X_}) = 'foo';
575 local($ENV{_Y_}) = $ENV{_Y_};
576 is($ENV{_X_}, 'foo');
584 # local() should preserve the existenceness of %ENV elements
585 ok(! exists $ENV{_A_});
586 ok(! exists $ENV{_B_});
589 skip("Can't make list assignment to \%ENV on this system")
590 unless $list_assignment_supported;
591 my $d = join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV);
593 is(join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV), $d);
596 # does implicit localization in foreach skip magic?
600 while (/(o.+?),/gc) {
602 foreach (1..1) { $iter++ }
603 if ($iter > 2) { fail("endless loop"); last; }
608 sub TIESCALAR { bless \my $self, shift }
609 sub FETCH { die "read \$_ forbidden" }
610 sub STORE { die "write \$_ forbidden" }
613 "Nesting" => sub { print '#'; for (1..3) { print }
615 "Reading" => sub { print }, 0,
616 "Matching" => sub { $x = /badness/ }, 0,
617 "Concat" => sub { $_ .= "a" }, 0,
618 "Chop" => sub { chop }, 0,
619 "Filetest" => sub { -x }, 0,
620 "Assignment" => sub { $_ = "Bad" }, 0,
621 # XXX whether next one should fail is debatable
622 "Local \$_" => sub { local $_ = 'ok?'; print }, 0,
623 "for local" => sub { for("#ok?\n"){ print } }, 1,
625 while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) {
627 main::ok(($ok xor $@), "Underscore '$name'");
642 # local() and readonly magic variables
644 eval { local $1 = 1 };
645 like($@, qr/Modification of a read-only value attempted/);
647 eval { for ($1) { local $_ = 1 } };
648 like($@, qr/Modification of a read-only value attempted/);
650 # make sure $1 is still read-only
651 eval { for ($1) { local $_ = 1 } };
652 like($@, qr/Modification of a read-only value attempted/);
654 # The s/// adds 'g' magic to $_, but it should remain non-readonly
655 eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } };
658 # RT #4342 Special local() behavior for $[
660 no warnings 'deprecated';
662 ok(1 == $[, 'lexcical scope of local $[');
666 sub f { ok(0 == $[); }
675 no warnings "redefine";
677 local *f1 = sub { "g1" };
678 ::ok(f1() eq "g1", "localised sub via glob");
680 ::ok(f1() eq "f1", "localised sub restored");
682 local $Other::{"f1"} = sub { "h1" };
683 ::ok(f1() eq "h1", "localised sub via stash");
685 ::ok(f1() eq "f1", "localised sub restored");
687 local @Other::{qw/ f1 f2 /} = (sub { "j1" }, sub { "j2" });
688 ::ok(f1() eq "j1", "localised sub via stash slice");
689 ::ok(f2() eq "j2", "localised sub via stash slice");
691 ::ok(f1() eq "f1", "localised sub restored");
692 ::ok(f2() eq "f2", "localised sub restored");
695 # Localising unicode keys (bug #38815)
698 $h{"\243"} = "pound";
699 $h{"\302\240"} = "octects";
700 is(scalar keys %h, 2);
702 my $unicode = chr 256;
703 my $ambigous = "\240" . $unicode;
705 local $h{$unicode} = 256;
706 local $h{$ambigous} = 160;
708 is(scalar keys %h, 4);
709 is($h{"\243"}, "pound");
710 is($h{$unicode}, 256);
711 is($h{$ambigous}, 160);
712 is($h{"\302\240"}, "octects");
714 is(scalar keys %h, 2);
715 is($h{"\243"}, "pound");
716 is($h{"\302\240"}, "octects");
722 $h{"\243"} = "pound";
723 $h{"\302\240"} = "octects";
724 is(scalar keys %h, 2);
726 my $unicode = chr 256;
727 my $ambigous = "\240" . $unicode;
729 local @h{$unicode, $ambigous} = (256, 160);
731 is(scalar keys %h, 4);
732 is($h{"\243"}, "pound");
733 is($h{$unicode}, 256);
734 is($h{$ambigous}, 160);
735 is($h{"\302\240"}, "octects");
737 is(scalar keys %h, 2);
738 is($h{"\243"}, "pound");
739 is($h{"\302\240"}, "octects");
742 # [perl #39012] localizing @_ element then shifting frees element too # soon
746 my $y = bless [], 'X39012';
747 sub X39012::DESTROY { $x++ }
748 sub { local $_[0]; shift }->($y);
749 ok(!$x, '[perl #39012]');
753 # when localising a hash element, the key should be copied, not referenced
764 ok(! exists($h{'k2'}));
769 our $k = 'k1'; # try dynamic too
775 ok(! exists($h{'k2'}));
779 like( runperl(stderr => 1,
780 prog => 'use constant foo => q(a);' .
781 'index(q(a), foo);' .
782 'local *g=${::}{foo};print q(ok);'), "ok", "[perl #52740]");
784 # localising a tied scalar should give you an untied var
787 sub TIESCALAR { bless \my $self, shift }
790 sub FETCH { $s .= ":F=${$_[0]}"; ${$_[0]} }
791 sub STORE { $s .= ":S($_[1])"; ${$_[0]} = $_[1]; }
800 is($ts, undef, 'local tied scalar initially undef');
802 is($ts, 2, 'local tied scalar now has a value');
805 is($ts, 1, 'restored tied scalar has correct value');
807 is($s, ':S(1):L1:F=1:L2:E:F=1:S(3)',
808 "local tied scalar shouldn't call methods");
811 # Keep this test last, as it can SEGV
814 pass("Localised *@");
816 pass("Can eval with *@ localised");