| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | require './test.pl'; |
| 6 | } |
| 7 | plan tests => 114; |
| 8 | |
| 9 | my $list_assignment_supported = 1; |
| 10 | |
| 11 | #mg.c says list assignment not supported on VMS, EPOC, and SYMBIAN. |
| 12 | $list_assignment_supported = 0 if ($^O eq 'VMS'); |
| 13 | |
| 14 | |
| 15 | sub foo { |
| 16 | local($a, $b) = @_; |
| 17 | local($c, $d); |
| 18 | $c = "c 3"; |
| 19 | $d = "d 4"; |
| 20 | { local($a,$c) = ("a 9", "c 10"); ($x, $y) = ($a, $c); } |
| 21 | is($a, "a 1"); |
| 22 | is($b, "b 2"); |
| 23 | $c, $d; |
| 24 | } |
| 25 | |
| 26 | $a = "a 5"; |
| 27 | $b = "b 6"; |
| 28 | $c = "c 7"; |
| 29 | $d = "d 8"; |
| 30 | |
| 31 | my @res; |
| 32 | @res = &foo("a 1","b 2"); |
| 33 | is($res[0], "c 3"); |
| 34 | is($res[1], "d 4"); |
| 35 | |
| 36 | is($a, "a 5"); |
| 37 | is($b, "b 6"); |
| 38 | is($c, "c 7"); |
| 39 | is($d, "d 8"); |
| 40 | is($x, "a 9"); |
| 41 | is($y, "c 10"); |
| 42 | |
| 43 | # same thing, only with arrays and associative arrays |
| 44 | |
| 45 | sub foo2 { |
| 46 | local($a, @b) = @_; |
| 47 | local(@c, %d); |
| 48 | @c = "c 3"; |
| 49 | $d{''} = "d 4"; |
| 50 | { local($a,@c) = ("a 19", "c 20"); ($x, $y) = ($a, @c); } |
| 51 | is($a, "a 1"); |
| 52 | is("@b", "b 2"); |
| 53 | $c[0], $d{''}; |
| 54 | } |
| 55 | |
| 56 | $a = "a 5"; |
| 57 | @b = "b 6"; |
| 58 | @c = "c 7"; |
| 59 | $d{''} = "d 8"; |
| 60 | |
| 61 | @res = &foo2("a 1","b 2"); |
| 62 | is($res[0], "c 3"); |
| 63 | is($res[1], "d 4"); |
| 64 | |
| 65 | is($a, "a 5"); |
| 66 | is("@b", "b 6"); |
| 67 | is($c[0], "c 7"); |
| 68 | is($d{''}, "d 8"); |
| 69 | is($x, "a 19"); |
| 70 | is($y, "c 20"); |
| 71 | |
| 72 | |
| 73 | eval 'local($$e)'; |
| 74 | like($@, qr/Can't localize through a reference/); |
| 75 | |
| 76 | eval '$e = []; local(@$e)'; |
| 77 | like($@, qr/Can't localize through a reference/); |
| 78 | |
| 79 | eval '$e = {}; local(%$e)'; |
| 80 | like($@, qr/Can't localize through a reference/); |
| 81 | |
| 82 | # Array and hash elements |
| 83 | |
| 84 | @a = ('a', 'b', 'c'); |
| 85 | { |
| 86 | local($a[1]) = 'foo'; |
| 87 | local($a[2]) = $a[2]; |
| 88 | is($a[1], 'foo'); |
| 89 | is($a[2], 'c'); |
| 90 | undef @a; |
| 91 | } |
| 92 | is($a[1], 'b'); |
| 93 | is($a[2], 'c'); |
| 94 | ok(!defined $a[0]); |
| 95 | |
| 96 | @a = ('a', 'b', 'c'); |
| 97 | { |
| 98 | local($a[1]) = "X"; |
| 99 | shift @a; |
| 100 | } |
| 101 | is($a[0].$a[1], "Xb"); |
| 102 | { |
| 103 | my $d = "@a"; |
| 104 | local @a = @a; |
| 105 | is("@a", $d); |
| 106 | } |
| 107 | |
| 108 | %h = ('a' => 1, 'b' => 2, 'c' => 3); |
| 109 | { |
| 110 | local($h{'a'}) = 'foo'; |
| 111 | local($h{'b'}) = $h{'b'}; |
| 112 | is($h{'a'}, 'foo'); |
| 113 | is($h{'b'}, 2); |
| 114 | local($h{'c'}); |
| 115 | delete $h{'c'}; |
| 116 | } |
| 117 | is($h{'a'}, 1); |
| 118 | is($h{'b'}, 2); |
| 119 | { |
| 120 | my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); |
| 121 | local %h = %h; |
| 122 | is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); |
| 123 | } |
| 124 | is($h{'c'}, 3); |
| 125 | |
| 126 | # check for scope leakage |
| 127 | $a = 'outer'; |
| 128 | if (1) { local $a = 'inner' } |
| 129 | is($a, 'outer'); |
| 130 | |
| 131 | # see if localization works when scope unwinds |
| 132 | local $m = 5; |
| 133 | eval { |
| 134 | for $m (6) { |
| 135 | local $m = 7; |
| 136 | die "bye"; |
| 137 | } |
| 138 | }; |
| 139 | is($m, 5); |
| 140 | |
| 141 | # see if localization works on tied arrays |
| 142 | { |
| 143 | package TA; |
| 144 | sub TIEARRAY { bless [], $_[0] } |
| 145 | sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] } |
| 146 | sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v } |
| 147 | sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); } |
| 148 | sub FETCHSIZE { scalar(@{$_[0]}) } |
| 149 | sub SHIFT { shift (@{$_[0]}) } |
| 150 | sub EXTEND {} |
| 151 | } |
| 152 | |
| 153 | tie @a, 'TA'; |
| 154 | @a = ('a', 'b', 'c'); |
| 155 | { |
| 156 | local($a[1]) = 'foo'; |
| 157 | local($a[2]) = $a[2]; |
| 158 | is($a[1], 'foo'); |
| 159 | is($a[2], 'c'); |
| 160 | @a = (); |
| 161 | } |
| 162 | is($a[1], 'b'); |
| 163 | is($a[2], 'c'); |
| 164 | ok(!defined $a[0]); |
| 165 | { |
| 166 | my $d = "@a"; |
| 167 | local @a = @a; |
| 168 | is("@a", $d); |
| 169 | } |
| 170 | |
| 171 | { |
| 172 | package TH; |
| 173 | sub TIEHASH { bless {}, $_[0] } |
| 174 | sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] } |
| 175 | sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v } |
| 176 | sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; } |
| 177 | sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } |
| 178 | sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } |
| 179 | sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} } |
| 180 | sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} } |
| 181 | } |
| 182 | |
| 183 | # see if localization works on tied hashes |
| 184 | tie %h, 'TH'; |
| 185 | %h = ('a' => 1, 'b' => 2, 'c' => 3); |
| 186 | |
| 187 | { |
| 188 | local($h{'a'}) = 'foo'; |
| 189 | local($h{'b'}) = $h{'b'}; |
| 190 | local($h{'y'}); |
| 191 | local($h{'z'}) = 33; |
| 192 | is($h{'a'}, 'foo'); |
| 193 | is($h{'b'}, 2); |
| 194 | local($h{'c'}); |
| 195 | delete $h{'c'}; |
| 196 | } |
| 197 | is($h{'a'}, 1); |
| 198 | is($h{'b'}, 2); |
| 199 | is($h{'c'}, 3); |
| 200 | # local() should preserve the existenceness of tied hash elements |
| 201 | ok(! exists $h{'y'}); |
| 202 | ok(! exists $h{'z'}); |
| 203 | TODO: { |
| 204 | todo_skip("Localize entire tied hash"); |
| 205 | my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h); |
| 206 | local %h = %h; |
| 207 | is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d); |
| 208 | } |
| 209 | |
| 210 | @a = ('a', 'b', 'c'); |
| 211 | { |
| 212 | local($a[1]) = "X"; |
| 213 | shift @a; |
| 214 | } |
| 215 | is($a[0].$a[1], "Xb"); |
| 216 | |
| 217 | # now try the same for %SIG |
| 218 | |
| 219 | $SIG{TERM} = 'foo'; |
| 220 | $SIG{INT} = \&foo; |
| 221 | $SIG{__WARN__} = $SIG{INT}; |
| 222 | { |
| 223 | local($SIG{TERM}) = $SIG{TERM}; |
| 224 | local($SIG{INT}) = $SIG{INT}; |
| 225 | local($SIG{__WARN__}) = $SIG{__WARN__}; |
| 226 | is($SIG{TERM}, 'main::foo'); |
| 227 | is($SIG{INT}, \&foo); |
| 228 | is($SIG{__WARN__}, \&foo); |
| 229 | local($SIG{INT}); |
| 230 | delete $SIG{__WARN__}; |
| 231 | } |
| 232 | is($SIG{TERM}, 'main::foo'); |
| 233 | is($SIG{INT}, \&foo); |
| 234 | is($SIG{__WARN__}, \&foo); |
| 235 | { |
| 236 | my $d = join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG); |
| 237 | local %SIG = %SIG; |
| 238 | is(join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG), $d); |
| 239 | } |
| 240 | |
| 241 | # and for %ENV |
| 242 | |
| 243 | $ENV{_X_} = 'a'; |
| 244 | $ENV{_Y_} = 'b'; |
| 245 | $ENV{_Z_} = 'c'; |
| 246 | { |
| 247 | local($ENV{_A_}); |
| 248 | local($ENV{_B_}) = 'foo'; |
| 249 | local($ENV{_X_}) = 'foo'; |
| 250 | local($ENV{_Y_}) = $ENV{_Y_}; |
| 251 | is($ENV{_X_}, 'foo'); |
| 252 | is($ENV{_Y_}, 'b'); |
| 253 | local($ENV{_Z_}); |
| 254 | delete $ENV{_Z_}; |
| 255 | } |
| 256 | is($ENV{_X_}, 'a'); |
| 257 | is($ENV{_Y_}, 'b'); |
| 258 | is($ENV{_Z_}, 'c'); |
| 259 | # local() should preserve the existenceness of %ENV elements |
| 260 | ok(! exists $ENV{_A_}); |
| 261 | ok(! exists $ENV{_B_}); |
| 262 | |
| 263 | SKIP: { |
| 264 | skip("Can't make list assignment to \%ENV on this system") |
| 265 | unless $list_assignment_supported; |
| 266 | my $d = join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV); |
| 267 | local %ENV = %ENV; |
| 268 | is(join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV), $d); |
| 269 | } |
| 270 | |
| 271 | # does implicit localization in foreach skip magic? |
| 272 | |
| 273 | $_ = "o 0,o 1,"; |
| 274 | my $iter = 0; |
| 275 | while (/(o.+?),/gc) { |
| 276 | is($1, "o $iter"); |
| 277 | foreach (1..1) { $iter++ } |
| 278 | if ($iter > 2) { fail("endless loop"); last; } |
| 279 | } |
| 280 | |
| 281 | { |
| 282 | package UnderScore; |
| 283 | sub TIESCALAR { bless \my $self, shift } |
| 284 | sub FETCH { die "read \$_ forbidden" } |
| 285 | sub STORE { die "write \$_ forbidden" } |
| 286 | tie $_, __PACKAGE__; |
| 287 | my @tests = ( |
| 288 | "Nesting" => sub { print '#'; for (1..3) { print } |
| 289 | print "\n" }, 1, |
| 290 | "Reading" => sub { print }, 0, |
| 291 | "Matching" => sub { $x = /badness/ }, 0, |
| 292 | "Concat" => sub { $_ .= "a" }, 0, |
| 293 | "Chop" => sub { chop }, 0, |
| 294 | "Filetest" => sub { -x }, 0, |
| 295 | "Assignment" => sub { $_ = "Bad" }, 0, |
| 296 | # XXX whether next one should fail is debatable |
| 297 | "Local \$_" => sub { local $_ = 'ok?'; print }, 0, |
| 298 | "for local" => sub { for("#ok?\n"){ print } }, 1, |
| 299 | ); |
| 300 | while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) { |
| 301 | eval { &$code }; |
| 302 | main::ok(($ok xor $@), "Underscore '$name'"); |
| 303 | } |
| 304 | untie $_; |
| 305 | } |
| 306 | |
| 307 | { |
| 308 | # BUG 20001205.22 |
| 309 | my %x; |
| 310 | $x{a} = 1; |
| 311 | { local $x{b} = 1; } |
| 312 | ok(! exists $x{b}); |
| 313 | { local @x{c,d,e}; } |
| 314 | ok(! exists $x{c}); |
| 315 | } |
| 316 | |
| 317 | # local() and readonly magic variables |
| 318 | |
| 319 | eval { local $1 = 1 }; |
| 320 | like($@, qr/Modification of a read-only value attempted/); |
| 321 | |
| 322 | eval { for ($1) { local $_ = 1 } }; |
| 323 | like($@, qr/Modification of a read-only value attempted/); |
| 324 | |
| 325 | # make sure $1 is still read-only |
| 326 | eval { for ($1) { local $_ = 1 } }; |
| 327 | like($@, qr/Modification of a read-only value attempted/); |
| 328 | |
| 329 | # The s/// adds 'g' magic to $_, but it should remain non-readonly |
| 330 | eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } }; |
| 331 | is($@, ""); |
| 332 | |
| 333 | # Special local() behavior for $[ |
| 334 | # (see RT #38207 - Useless localization of constant ($[) in getopts.pl} |
| 335 | { |
| 336 | local $[ = 1; |
| 337 | local $TODO = "local() not currently working correctly with \$["; |
| 338 | ok(1 == $[); |
| 339 | undef $TODO; |
| 340 | f(); |
| 341 | } |
| 342 | |
| 343 | sub f { ok(0 == $[); } |
| 344 | |
| 345 | # sub localisation |
| 346 | { |
| 347 | package Other; |
| 348 | |
| 349 | sub f1 { "f1" } |
| 350 | sub f2 { "f2" } |
| 351 | |
| 352 | no warnings "redefine"; |
| 353 | { |
| 354 | local *f1 = sub { "g1" }; |
| 355 | ::ok(f1() eq "g1", "localised sub via glob"); |
| 356 | } |
| 357 | ::ok(f1() eq "f1", "localised sub restored"); |
| 358 | { |
| 359 | local $Other::{"f1"} = sub { "h1" }; |
| 360 | ::ok(f1() eq "h1", "localised sub via stash"); |
| 361 | } |
| 362 | ::ok(f1() eq "f1", "localised sub restored"); |
| 363 | { |
| 364 | local @Other::{qw/ f1 f2 /} = (sub { "j1" }, sub { "j2" }); |
| 365 | ::ok(f1() eq "j1", "localised sub via stash slice"); |
| 366 | ::ok(f2() eq "j2", "localised sub via stash slice"); |
| 367 | } |
| 368 | ::ok(f1() eq "f1", "localised sub restored"); |
| 369 | ::ok(f2() eq "f2", "localised sub restored"); |
| 370 | } |
| 371 | |
| 372 | # Localising unicode keys (bug #38815) |
| 373 | { |
| 374 | my %h; |
| 375 | $h{"\243"} = "pound"; |
| 376 | $h{"\302\240"} = "octects"; |
| 377 | is(scalar keys %h, 2); |
| 378 | { |
| 379 | my $unicode = chr 256; |
| 380 | my $ambigous = "\240" . $unicode; |
| 381 | chop $ambigous; |
| 382 | local $h{$unicode} = 256; |
| 383 | local $h{$ambigous} = 160; |
| 384 | |
| 385 | is(scalar keys %h, 4); |
| 386 | is($h{"\243"}, "pound"); |
| 387 | is($h{$unicode}, 256); |
| 388 | is($h{$ambigous}, 160); |
| 389 | is($h{"\302\240"}, "octects"); |
| 390 | } |
| 391 | is(scalar keys %h, 2); |
| 392 | is($h{"\243"}, "pound"); |
| 393 | is($h{"\302\240"}, "octects"); |
| 394 | } |
| 395 | |
| 396 | # And with slices |
| 397 | { |
| 398 | my %h; |
| 399 | $h{"\243"} = "pound"; |
| 400 | $h{"\302\240"} = "octects"; |
| 401 | is(scalar keys %h, 2); |
| 402 | { |
| 403 | my $unicode = chr 256; |
| 404 | my $ambigous = "\240" . $unicode; |
| 405 | chop $ambigous; |
| 406 | local @h{$unicode, $ambigous} = (256, 160); |
| 407 | |
| 408 | is(scalar keys %h, 4); |
| 409 | is($h{"\243"}, "pound"); |
| 410 | is($h{$unicode}, 256); |
| 411 | is($h{$ambigous}, 160); |
| 412 | is($h{"\302\240"}, "octects"); |
| 413 | } |
| 414 | is(scalar keys %h, 2); |
| 415 | is($h{"\243"}, "pound"); |
| 416 | is($h{"\302\240"}, "octects"); |
| 417 | } |
| 418 | |
| 419 | # [perl #39012] localizing @_ element then shifting frees element too # soon |
| 420 | |
| 421 | { |
| 422 | my $x; |
| 423 | my $y = bless [], 'X39012'; |
| 424 | sub X39012::DESTROY { $x++ } |
| 425 | sub { local $_[0]; shift }->($y); |
| 426 | ok(!$x, '[perl #39012]'); |
| 427 | |
| 428 | } |
| 429 | |