Integrate mainline

p4raw-id: //depot/perlio@11657

11 files changed, 132 insertions, 49 deletions

diff --git a/t/op/concat.t b/t/op/concat.t
index 76074e0f28..5ae7da51b9 100644
--- a/t/op/concat.t
+++ b/t/op/concat.t
@@ -28,7 +28,6 @@ my $test = 4;
     $_ = $dx = "\x{10f2}";
     s/($dx)/$dx$1/;
     {
-	use bytes;
 	print "not " unless $_ eq "$dx$dx";
 	print "ok $test\n";
 	$test++;
@@ -37,7 +36,6 @@ my $test = 4;
     $_ = $dx = "\x{10f2}";
     s/($dx)/$1$dx/;
     {
-	use bytes;
 	print "not " unless $_ eq "$dx$dx";
 	print "ok $test\n";
 	$test++;
@@ -47,7 +45,6 @@ my $test = 4;
     $_  = "\x{10f2}\x{10f2}";
     s/($dx)($dx)/$1$2/;
     {
-	use bytes;
 	print "not " unless $_ eq "$dx$dx";
 	print "ok $test\n";
 	$test++;
diff --git a/t/op/each.t b/t/op/each.t
index 6dd1ceae8c..eb2dce0ce4 100755
--- a/t/op/each.t
+++ b/t/op/each.t
@@ -158,27 +158,23 @@ print "not " if exists $b{$A};
 print "ok 21\n";
 print "not " if exists $u{$a};
 print "ok 22\n";
-print "#$b{$_}\n" for keys %b; # Used to core dump before change #8056.
+print "# $b{$_}\n" for keys %b; # Used to core dump before change #8056.
 print "ok 23\n";
-print "#$u{$_}\n" for keys %u; # Used to core dump before change #8056.
+print "# $u{$_}\n" for keys %u; # Used to core dump before change #8056.
 print "ok 24\n";
 
-use bytes ();
-
 # on EBCDIC chars are mapped differently so pick something that needs encoding
 # there too.
 $d = pack("U*", 0xe3, 0x81, 0xAF);
-$ol = bytes::length($d);
+{ use bytes; $ol = bytes::length($d) }
 print "not " unless $ol > 3;
 print "ok 25\n";
 %u = ($d => "downgrade");
 for (keys %u) {
-    use bytes;
     print "not " if length ne 3 or $_ ne "\xe3\x81\xAF";
     print "ok 26\n";
 }
 {
-    use bytes;
-    print "not " if length($d) != $ol;
+    { use bytes; print "not " if bytes::length($d) != $ol }
     print "ok 27\n";
 }
diff --git a/t/op/lc.t b/t/op/lc.t
new file mode 100644
index 0000000000..2db3a8a905
--- /dev/null
+++ b/t/op/lc.t
@@ -0,0 +1,59 @@
+#!./perl
+
+print "1..40\n";
+
+$a = "HELLO.* world";
+$b = "hello.* WORLD";
+
+print "ok 1\n"  if "\Q$a\E."      eq "HELLO\\.\\*\\ world.";
+print "ok 2\n"  if "\u$a"         eq "HELLO\.\* world";
+print "ok 3\n"  if "\l$a"         eq "hELLO\.\* world";
+print "ok 4\n"  if "\U$a"         eq "HELLO\.\* WORLD";
+print "ok 5\n"  if "\L$a"         eq "hello\.\* world";
+
+print "ok 6\n"  if quotemeta($a)  eq "HELLO\\.\\*\\ world";
+print "ok 7\n"  if ucfirst($a)    eq "HELLO\.\* world";
+print "ok 8\n"  if lcfirst($a)    eq "hELLO\.\* world";
+print "ok 9\n"  if uc($a)         eq "HELLO\.\* WORLD";
+print "ok 10\n" if lc($a)         eq "hello\.\* world";
+
+print "ok 11\n"  if "\Q$b\E."     eq "hello\\.\\*\\ WORLD.";
+print "ok 12\n"  if "\u$b"        eq "Hello\.\* WORLD";
+print "ok 13\n"  if "\l$b"        eq "hello\.\* WORLD";
+print "ok 14\n"  if "\U$b"        eq "HELLO\.\* WORLD";
+print "ok 15\n"  if "\L$b"        eq "hello\.\* world";
+
+print "ok 16\n"  if quotemeta($b) eq "hello\\.\\*\\ WORLD";
+print "ok 17\n"  if ucfirst($b)   eq "Hello\.\* WORLD";
+print "ok 18\n"  if lcfirst($b)   eq "hello\.\* WORLD";
+print "ok 19\n"  if uc($b)        eq "HELLO\.\* WORLD";
+print "ok 20\n"  if lc($b)        eq "hello\.\* world";
+
+$a = "\x{100}\x{101}\x{41}\x{61}";
+$b = "\x{101}\x{100}\x{61}\x{41}";
+
+print "ok 21\n" if "\Q$a\E."      eq "\x{100}\x{101}\x{41}\x{61}.";
+print "ok 22\n" if "\u$a"         eq "\x{100}\x{101}\x{41}\x{61}";
+print "ok 23\n" if "\l$a"         eq "\x{101}\x{101}\x{41}\x{61}";
+print "ok 24\n" if "\U$a"         eq "\x{100}\x{100}\x{41}\x{41}";
+print "ok 25\n" if "\L$a"         eq "\x{101}\x{101}\x{61}\x{61}";
+
+print "ok 26\n" if quotemeta($a)  eq "\x{100}\x{101}\x{41}\x{61}";
+print "ok 27\n" if ucfirst($a)    eq "\x{100}\x{101}\x{41}\x{61}";
+print "ok 28\n" if lcfirst($a)    eq "\x{101}\x{101}\x{41}\x{61}";
+print "ok 29\n" if uc($a)         eq "\x{100}\x{100}\x{41}\x{41}";
+print "ok 30\n" if lc($a)         eq "\x{101}\x{101}\x{61}\x{61}";
+
+print "ok 31\n" if "\Q$b\E."      eq "\x{101}\x{100}\x{61}\x{41}.";
+print "ok 32\n" if "\u$b"         eq "\x{100}\x{100}\x{61}\x{41}";
+print "ok 33\n" if "\l$b"         eq "\x{101}\x{100}\x{61}\x{41}";
+print "ok 34\n" if "\U$b"         eq "\x{100}\x{100}\x{41}\x{41}";
+print "ok 35\n" if "\L$b"         eq "\x{101}\x{101}\x{61}\x{61}";
+
+print "ok 36\n"  if quotemeta($b) eq "\x{101}\x{100}\x{61}\x{41}";
+print "ok 37\n"  if ucfirst($b)   eq "\x{100}\x{100}\x{61}\x{41}";
+print "ok 38\n"  if lcfirst($b)   eq "\x{101}\x{100}\x{61}\x{41}";
+print "ok 39\n"  if uc($b)        eq "\x{100}\x{100}\x{41}\x{41}";
+print "ok 40\n"  if lc($b)        eq "\x{101}\x{101}\x{61}\x{61}";
+
+
diff --git a/t/op/misc.t b/t/op/misc.t
index 86c8162fc9..38690305cf 100755
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -532,35 +532,8 @@ print "ok\n";
 EXPECT
 ok
 ########
-my @l = qw(hello.* world);
-my $x;
-
-foreach $x (@l) {
-    print "before - $x\n";
-    $x = "\Q$x\E";
-    print "quotemeta - $x\n";
-    $x = "\u$x";
-    print "ucfirst - $x\n";
-    $x = "\l$x";
-    print "lcfirst - $x\n";
-    $x = "\U$x\E";
-    print "uc - $x\n";
-    $x = "\L$x\E";
-    print "lc - $x\n";
-}
+# moved to op/lc.t
 EXPECT
-before - hello.*
-quotemeta - hello\.\*
-ucfirst - Hello\.\*
-lcfirst - hello\.\*
-uc - HELLO\.\*
-lc - hello\.\*
-before - world
-quotemeta - world
-ucfirst - World
-lcfirst - world
-uc - WORLD
-lc - world
 ########
 sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next }
 my $x = "foo";
diff --git a/t/op/pat.t b/t/op/pat.t
index 270d65a2e9..bed2f376ff 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -1287,7 +1287,7 @@ print "ok 247\n";
 	    "#latin[$latin]\nnot ok $test\n";
 	$test++;
 	$latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a
-	use utf8;
+	use utf8; # needed for the raw UTF-8
 	$latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a
     }
 }
diff --git a/t/op/readdir.t b/t/op/readdir.t
index 00199b0fec..39d4e4cb00 100755
--- a/t/op/readdir.t
+++ b/t/op/readdir.t
@@ -24,7 +24,7 @@ closedir(OP);
 ## This range will have to adjust as the number of tests expands,
 ## as it's counting the number of .t files in src/t
 ##
-if (@D > 90 && @D < 110) { print "ok 2\n"; } else { print "not ok 2\n"; }
+if (@D > 100 && @D < 120) { print "ok 2\n"; } else { print "not ok 2\n"; }
 
 @R = sort @D;
 @G = sort <op/*.t>;
diff --git a/t/op/regmesg.t b/t/op/regmesg.t
index 24f6f31f77..82f6ee9e7b 100644
--- a/t/op/regmesg.t
+++ b/t/op/regmesg.t
@@ -61,7 +61,7 @@ my @death =
 
  '/\p{x/' => 'Missing right brace on \p{} in regex; marked by {#} in m/\p{{#}x/',
 
- 'use utf8; /[\p{x]/' => 'Missing right brace on \p{} in regex; marked by {#} in m/[\p{{#}x]/',
+ '/[\p{x]/' => 'Missing right brace on \p{} in regex; marked by {#} in m/[\p{{#}x]/',
 
  '/(x)\2/' => 'Reference to nonexistent group in regex; marked by {#} in m/(x)\2{#}/',
 
@@ -69,7 +69,7 @@ my @death =
 
  '/\x{1/' => 'Missing right brace on \x{} in regex; marked by {#} in m/\x{{#}1/',
 
- 'use utf8; /[\x{X]/' => 'Missing right brace on \x{} in regex; marked by {#} in m/[\x{{#}X]/',
+ '/[\x{X]/' => 'Missing right brace on \x{} in regex; marked by {#} in m/[\x{{#}X]/',
 
  '/[[:barf:]]/' => 'POSIX class [:barf:] unknown in regex; marked by {#} in m/[[:barf:]{#}]/',
 
diff --git a/t/op/sprintf.t b/t/op/sprintf.t
index 89992d62d0..01b36fe7e5 100755
--- a/t/op/sprintf.t
+++ b/t/op/sprintf.t
@@ -4,7 +4,7 @@
 # doubles (if supported), of machine-specific short and long
 # integers, machine-specific floating point exceptions (infinity,
 # not-a-number ...), of the effects of locale, and of features
-# specific to multi-byte characters (under use utf8 and such).
+# specific to multi-byte characters (under the utf8 pragma and such).
 
 BEGIN {
     chdir 't' if -d 't';
diff --git a/t/op/taint.t b/t/op/taint.t
index effb12c3b0..592bb2aae5 100755
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -109,7 +109,7 @@ print PROG 'print "@ARGV\n"', "\n";
 close PROG;
 my $echo = "$Invoke_Perl $ECHO";
 
-print "1..174\n";
+print "1..175\n";
 
 # First, let's make sure that Perl is checking the dangerous
 # environment variables. Maybe they aren't set yet, so we'll
@@ -839,3 +839,36 @@ else {
     print "ok 174\n";
 }
 
+
+{
+    # Bug ID 20010730.010
+
+    my $i = 0;
+
+    sub Tie::TIESCALAR {
+        my $class =  shift;
+        my $arg   =  shift;
+
+        bless \$arg => $class;
+    }
+
+    sub Tie::FETCH {
+        $i ++;
+        ${$_ [0]}
+    }
+
+ 
+    package main;
+ 
+    my $bar = "The Big Bright Green Pleasure Machine";
+    taint_these $bar;
+    tie my ($foo), Tie => $bar;
+
+    my $baz = $foo;
+
+    print $i == 1 ? "ok 175\n" : "not ok 175\n"
+
+}
+
+
+
diff --git a/t/op/tiehandle.t b/t/op/tiehandle.t
index cb9a290de6..7ae33514c9 100755
--- a/t/op/tiehandle.t
+++ b/t/op/tiehandle.t
@@ -77,7 +77,7 @@ package main;
 
 use Symbol;
 
-print "1..35\n";
+print "1..38\n";
 
 my $fh = gensym;
 
@@ -189,3 +189,31 @@ ok($r == 1);
     untie *STDIN;
 }
 
+
+{
+    # test for change 11639: Can't localize *FH, then tie it
+    {
+	local *foo;
+	tie %foo, 'Blah';
+    }
+    ok(!tied %foo);
+
+    {
+	local *bar;
+	tie @bar, 'Blah';
+    }
+    ok(!tied @bar);
+
+    {
+	local *BAZ;
+	tie *BAZ, 'Blah';
+    }
+    ok(!tied *BAZ);
+
+    package Blah;
+
+    sub TIEHANDLE {bless {}}
+    sub TIEHASH   {bless {}}
+    sub TIEARRAY  {bless {}}
+}
+
diff --git a/t/op/tr.t b/t/op/tr.t
index 1e30365eeb..6390f6a9e5 100755
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -80,9 +80,6 @@ else {
 print "ok 10\n";
 
 {
-if (ord("\t") == 9) { # ASCII
-    use utf8;
-}
 # 11 - changing UTF8 characters in a UTF8 string, same length.
 my $l = chr(300); my $r = chr(400);
 $x = 200.300.400;