t/op/local.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6 }
   7 plan tests => 79;
   8
   9 sub foo {
  10     local($a, $b) = @_;
  11     local($c, $d);
  12     $c = "c 3";
  13     $d = "d 4";
  14     { local($a,$c) = ("a 9", "c 10"); ($x, $y) = ($a, $c); }
  15     is($a, "a 1");
  16     is($b, "b 2");
  17     $c, $d;
  18 }
  19
  20 $a = "a 5";
  21 $b = "b 6";
  22 $c = "c 7";
  23 $d = "d 8";
  24
  25 my @res;
  26 @res =  &foo("a 1","b 2");
  27 is($res[0], "c 3");
  28 is($res[1], "d 4");
  29
  30 is($a, "a 5");
  31 is($b, "b 6");
  32 is($c, "c 7");
  33 is($d, "d 8");
  34 is($x, "a 9");
  35 is($y, "c 10");
  36
  37 # same thing, only with arrays and associative arrays
  38
  39 sub foo2 {
  40     local($a, @b) = @_;
  41     local(@c, %d);
  42     @c = "c 3";
  43     $d{''} = "d 4";
  44     { local($a,@c) = ("a 19", "c 20"); ($x, $y) = ($a, @c); }
  45     is($a, "a 1");
  46     is("@b", "b 2");
  47     $c[0], $d{''};
  48 }
  49
  50 $a = "a 5";
  51 @b = "b 6";
  52 @c = "c 7";
  53 $d{''} = "d 8";
  54
  55 @res = &foo2("a 1","b 2");
  56 is($res[0], "c 3");
  57 is($res[1], "d 4");
  58
  59 is($a, "a 5");
  60 is("@b", "b 6");
  61 is($c[0], "c 7");
  62 is($d{''}, "d 8");
  63 is($x, "a 19");
  64 is($y, "c 20");
  65
  66
  67 eval 'local($$e)';
  68 like($@, qr/Can't localize through a reference/);
  69
  70 eval '$e = []; local(@$e)';
  71 like($@, qr/Can't localize through a reference/);
  72
  73 eval '$e = {}; local(%$e)';
  74 like($@, qr/Can't localize through a reference/);
  75
  76 # Array and hash elements
  77
  78 @a = ('a', 'b', 'c');
  79 {
  80     local($a[1]) = 'foo';
  81     local($a[2]) = $a[2];
  82     is($a[1], 'foo');
  83     is($a[2], 'c');
  84     undef @a;
  85 }
  86 is($a[1], 'b');
  87 is($a[2], 'c');
  88 ok(!defined $a[0]);
  89
  90 @a = ('a', 'b', 'c');
  91 {
  92     local($a[1]) = "X";
  93     shift @a;
  94 }
  95 is($a[0].$a[1], "Xb");
  96
  97 %h = ('a' => 1, 'b' => 2, 'c' => 3);
  98 {
  99     local($h{'a'}) = 'foo';
 100     local($h{'b'}) = $h{'b'};
 101     is($h{'a'}, 'foo');
 102     is($h{'b'}, 2);
 103     local($h{'c'});
 104     delete $h{'c'};
 105 }
 106 is($h{'a'}, 1);
 107 is($h{'b'}, 2);
 108 is($h{'c'}, 3);
 109
 110 # check for scope leakage
 111 $a = 'outer';
 112 if (1) { local $a = 'inner' }
 113 is($a, 'outer');
 114
 115 # see if localization works when scope unwinds
 116 local $m = 5;
 117 eval {
 118     for $m (6) {
 119         local $m = 7;
 120         die "bye";
 121     }
 122 };
 123 is($m, 5);
 124
 125 # see if localization works on tied arrays
 126 {
 127     package TA;
 128     sub TIEARRAY { bless [], $_[0] }
 129     sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] }
 130     sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v }
 131     sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); }
 132     sub FETCHSIZE { scalar(@{$_[0]}) }
 133     sub SHIFT { shift (@{$_[0]}) }
 134     sub EXTEND {}
 135 }
 136
 137 tie @a, 'TA';
 138 @a = ('a', 'b', 'c');
 139 {
 140     local($a[1]) = 'foo';
 141     local($a[2]) = $a[2];
 142     is($a[1], 'foo');
 143     is($a[2], 'c');
 144     @a = ();
 145 }
 146 is($a[1], 'b');
 147 is($a[2], 'c');
 148 ok(!defined $a[0]);
 149
 150 {
 151     package TH;
 152     sub TIEHASH { bless {}, $_[0] }
 153     sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] }
 154     sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v }
 155     sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; }
 156     sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; }
 157     sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); }
 158 }
 159
 160 # see if localization works on tied hashes
 161 tie %h, 'TH';
 162 %h = ('a' => 1, 'b' => 2, 'c' => 3);
 163
 164 {
 165     local($h{'a'}) = 'foo';
 166     local($h{'b'}) = $h{'b'};
 167     local($h{'y'});
 168     local($h{'z'}) = 33;
 169     is($h{'a'}, 'foo');
 170     is($h{'b'}, 2);
 171     local($h{'c'});
 172     delete $h{'c'};
 173 }
 174 is($h{'a'}, 1);
 175 is($h{'b'}, 2);
 176 is($h{'c'}, 3);
 177 # local() should preserve the existenceness of tied hash elements
 178 ok(! exists $h{'y'});
 179 ok(! exists $h{'z'});
 180
 181 @a = ('a', 'b', 'c');
 182 {
 183     local($a[1]) = "X";
 184     shift @a;
 185 }
 186 is($a[0].$a[1], "Xb");
 187
 188 # now try the same for %SIG
 189
 190 $SIG{TERM} = 'foo';
 191 $SIG{INT} = \&foo;
 192 $SIG{__WARN__} = $SIG{INT};
 193 {
 194     local($SIG{TERM}) = $SIG{TERM};
 195     local($SIG{INT}) = $SIG{INT};
 196     local($SIG{__WARN__}) = $SIG{__WARN__};
 197     is($SIG{TERM}, 'main::foo');
 198     is($SIG{INT}, \&foo);
 199     is($SIG{__WARN__}, \&foo);
 200     local($SIG{INT});
 201     delete $SIG{__WARN__};
 202 }
 203 is($SIG{TERM}, 'main::foo');
 204 is($SIG{INT}, \&foo);
 205 is($SIG{__WARN__}, \&foo);
 206
 207 # and for %ENV
 208
 209 $ENV{_X_} = 'a';
 210 $ENV{_Y_} = 'b';
 211 $ENV{_Z_} = 'c';
 212 {
 213     local($ENV{_A_});
 214     local($ENV{_B_}) = 'foo';
 215     local($ENV{_X_}) = 'foo';
 216     local($ENV{_Y_}) = $ENV{_Y_};
 217     is($ENV{_X_}, 'foo');
 218     is($ENV{_Y_}, 'b');
 219     local($ENV{_Z_});
 220     delete $ENV{_Z_};
 221 }
 222 is($ENV{_X_}, 'a');
 223 is($ENV{_Y_}, 'b');
 224 is($ENV{_Z_}, 'c');
 225 # local() should preserve the existenceness of %ENV elements
 226 ok(! exists $ENV{_A_});
 227 ok(! exists $ENV{_B_});
 228
 229 # does implicit localization in foreach skip magic?
 230
 231 $_ = "o 0,o 1,";
 232 my $iter = 0;
 233 while (/(o.+?),/gc) {
 234     is($1, "o $iter");
 235     foreach (1..1) { $iter++ }
 236     if ($iter > 2) { fail("endless loop"); last; }
 237 }
 238
 239 {
 240     package UnderScore;
 241     sub TIESCALAR { bless \my $self, shift }
 242     sub FETCH { die "read  \$_ forbidden" }
 243     sub STORE { die "write \$_ forbidden" }
 244     tie $_, __PACKAGE__;
 245     my @tests = (
 246         "Nesting"     => sub { print '#'; for (1..3) { print }
 247                                print "\n" },                    1,
 248         "Reading"     => sub { print },                         0,
 249         "Matching"    => sub { $x = /badness/ },                0,
 250         "Concat"      => sub { $_ .= "a" },                     0,
 251         "Chop"        => sub { chop },                          0,
 252         "Filetest"    => sub { -x },                            0,
 253         "Assignment"  => sub { $_ = "Bad" },                    0,
 254         # XXX whether next one should fail is debatable
 255         "Local \$_"   => sub { local $_  = 'ok?'; print },      0,
 256         "for local"   => sub { for("#ok?\n"){ print } },        1,
 257     );
 258     while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) {
 259         eval { &$code };
 260         main::ok(($ok xor $@), "Underscore '$name'");
 261     }
 262     untie $_;
 263 }
 264
 265 {
 266     # BUG 20001205.22
 267     my %x;
 268     $x{a} = 1;
 269     { local $x{b} = 1; }
 270     ok(! exists $x{b});
 271     { local @x{c,d,e}; }
 272     ok(! exists $x{c});
 273 }
 274
 275 # local() and readonly magic variables
 276
 277 eval { local $1 = 1 };
 278 like($@, qr/Modification of a read-only value attempted/);
 279
 280 eval { for ($1) { local $_ = 1 } };
 281 like($@, qr/Modification of a read-only value attempted/);
 282
 283 # make sure $1 is still read-only
 284 eval { for ($1) { local $_ = 1 } };
 285 like($@, qr/Modification of a read-only value attempted/);
 286
 287 # The s/// adds 'g' magic to $_, but it should remain non-readonly
 288 eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } };
 289 is($@, "");