Change 28404 broke the construct s/foo/<<BAR/e. So, try to be more

[p5sagit/p5-mst-13.2.git] / t / op / local.t

diff --git a/t/op/local.t b/t/op/local.t
index f4a613b..1e5ba85 100755 (executable)
--- a/t/op/local.t
+++ b/t/op/local.t
@@ -4,7 +4,13 @@ BEGIN {
     chdir 't' if -d 't';
     require './test.pl';
 }
-plan tests => 79;
+plan tests => 114;
+
+my $list_assignment_supported = 1;
+
+#mg.c says list assignment not supported on VMS, EPOC, and SYMBIAN.
+$list_assignment_supported = 0 if ($^O eq 'VMS');
+
 
 sub foo {
     local($a, $b) = @_;
@@ -93,6 +99,11 @@ ok(!defined $a[0]);
     shift @a;
 }
 is($a[0].$a[1], "Xb");
+{
+    my $d = "@a";
+    local @a = @a;
+    is("@a", $d);
+}
 
 %h = ('a' => 1, 'b' => 2, 'c' => 3);
 {
@@ -105,6 +116,11 @@ is($a[0].$a[1], "Xb");
 }
 is($h{'a'}, 1);
 is($h{'b'}, 2);
+{
+    my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h);
+    local %h = %h;
+    is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d);
+}
 is($h{'c'}, 3);
 
 # check for scope leakage
@@ -146,6 +162,11 @@ tie @a, 'TA';
 is($a[1], 'b');
 is($a[2], 'c');
 ok(!defined $a[0]);
+{
+    my $d = "@a";
+    local @a = @a;
+    is("@a", $d);
+}
 
 {
     package TH;
@@ -155,6 +176,8 @@ ok(!defined $a[0]);
     sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; }
     sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; }
     sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); }
+    sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} }
+    sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} }
 }
 
 # see if localization works on tied hashes
@@ -177,6 +200,12 @@ is($h{'c'}, 3);
 # local() should preserve the existenceness of tied hash elements
 ok(! exists $h{'y'});
 ok(! exists $h{'z'});
+TODO: {
+    todo_skip("Localize entire tied hash");
+    my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h);
+    local %h = %h;
+    is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d);
+}
 
 @a = ('a', 'b', 'c');
 {
@@ -203,6 +232,11 @@ $SIG{__WARN__} = $SIG{INT};
 is($SIG{TERM}, 'main::foo');
 is($SIG{INT}, \&foo);
 is($SIG{__WARN__}, \&foo);
+{
+    my $d = join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG);
+    local %SIG = %SIG;
+    is(join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG), $d);
+}
 
 # and for %ENV
 
@@ -226,6 +260,14 @@ is($ENV{_Z_}, 'c');
 ok(! exists $ENV{_A_});
 ok(! exists $ENV{_B_});
 
+SKIP: {
+    skip("Can't make list assignment to \%ENV on this system")
+       unless $list_assignment_supported;
+    my $d = join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV);
+    local %ENV = %ENV;
+    is(join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV), $d);
+}
+
 # does implicit localization in foreach skip magic?
 
 $_ = "o 0,o 1,";
@@ -287,3 +329,101 @@ like($@, qr/Modification of a read-only value attempted/);
 # The s/// adds 'g' magic to $_, but it should remain non-readonly
 eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } };
 is($@, "");
+
+# Special local() behavior for $[
+# (see RT #38207 - Useless localization of constant ($[) in getopts.pl}
+{
+    local $[ = 1;
+    local $TODO = "local() not currently working correctly with \$[";
+    ok(1 == $[);
+    undef $TODO;
+    f();
+}
+
+sub f { ok(0 == $[); }
+
+# sub localisation
+{
+       package Other;
+
+       sub f1 { "f1" }
+       sub f2 { "f2" }
+
+       no warnings "redefine";
+       {
+               local *f1 = sub  { "g1" };
+               ::ok(f1() eq "g1", "localised sub via glob");
+       }
+       ::ok(f1() eq "f1", "localised sub restored");
+       {
+               local $Other::{"f1"} = sub { "h1" };
+               ::ok(f1() eq "h1", "localised sub via stash");
+       }
+       ::ok(f1() eq "f1", "localised sub restored");
+       {
+               local @Other::{qw/ f1 f2 /} = (sub { "j1" }, sub { "j2" });
+               ::ok(f1() eq "j1", "localised sub via stash slice");
+               ::ok(f2() eq "j2", "localised sub via stash slice");
+       }
+       ::ok(f1() eq "f1", "localised sub restored");
+       ::ok(f2() eq "f2", "localised sub restored");
+}
+
+# Localising unicode keys (bug #38815)
+{
+    my %h;
+    $h{"\243"} = "pound";
+    $h{"\302\240"} = "octects";
+    is(scalar keys %h, 2);
+    {
+       my $unicode = chr 256;
+       my $ambigous = "\240" . $unicode;
+       chop $ambigous;
+       local $h{$unicode} = 256;
+       local $h{$ambigous} = 160;
+
+       is(scalar keys %h, 4);
+       is($h{"\243"}, "pound");
+       is($h{$unicode}, 256);
+       is($h{$ambigous}, 160);
+       is($h{"\302\240"}, "octects");
+    }
+    is(scalar keys %h, 2);
+    is($h{"\243"}, "pound");
+    is($h{"\302\240"}, "octects");
+}
+
+# And with slices
+{
+    my %h;
+    $h{"\243"} = "pound";
+    $h{"\302\240"} = "octects";
+    is(scalar keys %h, 2);
+    {
+       my $unicode = chr 256;
+       my $ambigous = "\240" . $unicode;
+       chop $ambigous;
+       local @h{$unicode, $ambigous} = (256, 160);
+
+       is(scalar keys %h, 4);
+       is($h{"\243"}, "pound");
+       is($h{$unicode}, 256);
+       is($h{$ambigous}, 160);
+       is($h{"\302\240"}, "octects");
+    }
+    is(scalar keys %h, 2);
+    is($h{"\243"}, "pound");
+    is($h{"\302\240"}, "octects");
+}
+
+# [perl #39012] localizing @_ element then shifting frees element too # soon
+
+{
+    my $x;
+    my $y = bless [], 'X39012';
+    sub X39012::DESTROY { $x++ }
+    sub { local $_[0]; shift }->($y);
+    ok(!$x,  '[perl #39012]');
+    
+}
+