1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = qw(. ../lib); 6 require './test.pl'; 7} 8plan tests => 296; 9 10my $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 16sub foo { 17 local($a, $b) = @_; 18 local($c, $d); 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; 25} 26 27$a = "a 5"; 28$b = "b 6"; 29$c = "c 7"; 30$d = "d 8"; 31 32my @res; 33@res = &foo("a 1","b 2"); 34is($res[0], "c 3"); 35is($res[1], "d 4"); 36 37is($a, "a 5"); 38is($b, "b 6"); 39is($c, "c 7"); 40is($d, "d 8"); 41is($x, "a 9"); 42is($y, "c 10"); 43 44# same thing, only with arrays and associative arrays 45 46sub foo2 { 47 local($a, @b) = @_; 48 local(@c, %d); 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{''}; 55} 56 57$a = "a 5"; 58@b = "b 6"; 59@c = "c 7"; 60$d{''} = "d 8"; 61 62@res = &foo2("a 1","b 2"); 63is($res[0], "c 3"); 64is($res[1], "d 4"); 65 66is($a, "a 5"); 67is("@b", "b 6"); 68is($c[0], "c 7"); 69is($d{''}, "d 8"); 70is($x, "a 19"); 71is($y, "c 20"); 72 73 74eval 'local($$e)'; 75like($@, qr/Can't localize through a reference/); 76 77eval '$e = []; local(@$e)'; 78like($@, qr/Can't localize through a reference/); 79 80eval '$e = {}; local(%$e)'; 81like($@, qr/Can't localize through a reference/); 82 83# Array and hash elements 84 85@a = ('a', 'b', 'c'); 86{ 87 local($a[1]) = 'foo'; 88 local($a[2]) = $a[2]; 89 is($a[1], 'foo'); 90 is($a[2], 'c'); 91 undef @a; 92} 93is($a[1], 'b'); 94is($a[2], 'c'); 95ok(!defined $a[0]); 96 97@a = ('a', 'b', 'c'); 98{ 99 local($a[4]) = 'x'; 100 ok(!defined $a[3]); 101 is($a[4], 'x'); 102} 103is(scalar(@a), 3); 104ok(!exists $a[3]); 105ok(!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} 115is(scalar(@a), 5); 116ok(!defined $a[3]); 117is($a[4], 'y'); 118ok(!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} 128is(scalar(@a), 3); 129ok(!exists $a[3]); 130ok(!exists $a[4]); 131ok(!exists $a[5]); 132ok(!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} 143is(scalar(@a), 6); 144ok(!defined $a[3]); 145ok(!defined $a[4]); 146is($a[5], 'y'); 147ok(!exists $a[6]); 148 149@a = ('a', 'b', 'c'); 150{ 151 local($a[1]) = "X"; 152 shift @a; 153} 154is($a[0].$a[1], "Xb"); 155{ 156 my $d = "@a"; 157 local @a = @a; 158 is("@a", $d); 159} 160 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} 193is(scalar(@a), 5); 194is($a[0], 'a'); 195is($a[1], 'b'); 196is($a[2], 'c'); 197ok(!defined($a[3])); 198is($a[4], 'd'); 199ok(!exists($a[5])); 200ok(!exists($a[888])); 201ok(!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} 233is(scalar(keys(%h)), 4); 234is($h{a}, 1); 235is($h{b}, 2); 236is($h{c}, 3); 237ok($h{d}, 4); 238ok(!exists($h{yyy})); 239ok(!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} 255is(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} 262is($h{c}, 2); 263 264%h = ('a' => 1, 'b' => 2, 'c' => 3); 265{ 266 local($h{'a'}) = 'foo'; 267 local($h{'b'}) = $h{'b'}; 268 is($h{'a'}, 'foo'); 269 is($h{'b'}, 2); 270 local($h{'c'}); 271 delete $h{'c'}; 272} 273is($h{'a'}, 1); 274is($h{'b'}, 2); 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} 280is($h{'c'}, 3); 281 282# check for scope leakage 283$a = 'outer'; 284if (1) { local $a = 'inner' } 285is($a, 'outer'); 286 287# see if localization works when scope unwinds 288local $m = 5; 289eval { 290 for $m (6) { 291 local $m = 7; 292 die "bye"; 293 } 294}; 295is($m, 5); 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 } 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]}) } 308 sub EXTEND {} 309} 310 311tie @a, 'TA'; 312@a = ('a', 'b', 'c'); 313{ 314 local($a[1]) = 'foo'; 315 local($a[2]) = $a[2]; 316 is($a[1], 'foo'); 317 is($a[2], 'c'); 318 @a = (); 319} 320is($a[1], 'b'); 321is($a[2], 'c'); 322ok(!defined $a[0]); 323{ 324 my $d = "@a"; 325 local @a = @a; 326 is("@a", $d); 327} 328 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} 336is(scalar(@a), 3); 337ok(!exists $a[3]); 338ok(!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} 348is(scalar(@a), 5); 349ok(!defined $a[3]); 350is($a[4], 'y'); 351ok(!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} 361is(scalar(@a), 3); 362ok(!exists $a[3]); 363ok(!exists $a[4]); 364ok(!exists $a[5]); 365ok(!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} 376is(scalar(@a), 6); 377ok(!defined $a[3]); 378ok(!defined $a[4]); 379is($a[5], 'y'); 380ok(!exists $a[6]); 381 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} 414is(scalar(@a), 5); 415is($a[0], 'a'); 416is($a[1], 'b'); 417is($a[2], 'c'); 418ok(!defined($a[3])); 419is($a[4], 'd'); 420ok(!exists($a[5])); 421ok(!exists($a[888])); 422ok(!exists($a[999])); 423 424# see if localization works on tied hashes 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 } 430 sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; } 431 sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } 432 sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } 433 sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} } 434 sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} } 435} 436 437tie %h, 'TH'; 438%h = ('a' => 1, 'b' => 2, 'c' => 3); 439 440{ 441 local($h{'a'}) = 'foo'; 442 local($h{'b'}) = $h{'b'}; 443 local($h{'y'}); 444 local($h{'z'}) = 33; 445 is($h{'a'}, 'foo'); 446 is($h{'b'}, 2); 447 local($h{'c'}); 448 delete $h{'c'}; 449} 450is($h{'a'}, 1); 451is($h{'b'}, 2); 452is($h{'c'}, 3); 453# local() should preserve the existenceness of tied hash elements 454ok(! exists $h{'y'}); 455ok(! exists $h{'z'}); 456TODO: { 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} 462 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} 493is(scalar(keys(%h)), 4); 494is($h{a}, 1); 495is($h{b}, 2); 496is($h{c}, 3); 497ok($h{d}, 4); 498ok(!exists($h{yyy})); 499ok(!exists($h{zzz})); 500 501@a = ('a', 'b', 'c'); 502{ 503 local($a[1]) = "X"; 504 shift @a; 505} 506is($a[0].$a[1], "Xb"); 507 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__}; 517 is($SIG{TERM}, 'main::foo'); 518 is($SIG{INT}, \&foo); 519 is($SIG{__WARN__}, \&foo); 520 local($SIG{INT}); 521 delete $SIG{__WARN__}; 522} 523is($SIG{TERM}, 'main::foo'); 524is($SIG{INT}, \&foo); 525is($SIG{__WARN__}, \&foo); 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} 531 532# and for %ENV 533 534$ENV{_X_} = 'a'; 535$ENV{_Y_} = 'b'; 536$ENV{_Z_} = 'c'; 537{ 538 local($ENV{_A_}); 539 local($ENV{_B_}) = 'foo'; 540 local($ENV{_X_}) = 'foo'; 541 local($ENV{_Y_}) = $ENV{_Y_}; 542 is($ENV{_X_}, 'foo'); 543 is($ENV{_Y_}, 'b'); 544 local($ENV{_Z_}); 545 delete $ENV{_Z_}; 546} 547is($ENV{_X_}, 'a'); 548is($ENV{_Y_}, 'b'); 549is($ENV{_Z_}, 'c'); 550# local() should preserve the existenceness of %ENV elements 551ok(! exists $ENV{_A_}); 552ok(! exists $ENV{_B_}); 553 554SKIP: { 555 skip("Can't make list assignment to \%ENV on this system") 556 unless $list_assignment_supported; 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} 561 562# does implicit localization in foreach skip magic? 563 564$_ = "o 0,o 1,"; 565my $iter = 0; 566while (/(o.+?),/gc) { 567 is($1, "o $iter"); 568 foreach (1..1) { $iter++ } 569 if ($iter > 2) { fail("endless loop"); last; } 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__; 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) ) { 592 eval { &$code }; 593 main::ok(($ok xor $@), "Underscore '$name'"); 594 } 595 untie $_; 596} 597 598{ 599 # BUG 20001205.22 600 my %x; 601 $x{a} = 1; 602 { local $x{b} = 1; } 603 ok(! exists $x{b}); 604 { local @x{c,d,e}; } 605 ok(! exists $x{c}); 606} 607 608# local() and readonly magic variables 609 610eval { local $1 = 1 }; 611like($@, qr/Modification of a read-only value attempted/); 612 613eval { for ($1) { local $_ = 1 } }; 614like($@, qr/Modification of a read-only value attempted/); 615 616# make sure $1 is still read-only 617eval { for ($1) { local $_ = 1 } }; 618like($@, qr/Modification of a read-only value attempted/); 619 620# The s/// adds 'g' magic to $_, but it should remain non-readonly 621eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } }; 622is($@, ""); 623 624# RT #4342 Special local() behavior for $[ 625{ 626 no warnings 'deprecated'; 627 local $[ = 1; 628 ok(1 == $[, 'lexcical scope of local $['); 629 f(); 630} 631 632sub f { ok(0 == $[); } 633 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" }); 654 ::ok(f1() eq "j1", "localised sub via stash slice"); 655 ::ok(f2() eq "j2", "localised sub via stash slice"); 656 } 657 ::ok(f1() eq "f1", "localised sub restored"); 658 ::ok(f2() eq "f2", "localised sub restored"); 659} 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} 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} 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 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} 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} 744 745like( runperl(stderr => 1, 746 prog => 'use constant foo => q(a);' . 747 'index(q(a), foo);' . 748 'local *g=${::}{foo};print q(ok);'), "ok", "[perl #52740]"); 749 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 758