t/op/local.t

   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