Integrate mainline

p4raw-id: //depot/perlio@12788

5 files changed, 289 insertions, 38 deletions

diff --git a/t/op/lc.t b/t/op/lc.t
index b0d0aa0f31..18c805fbf9 100644
--- a/t/op/lc.t
+++ b/t/op/lc.t
@@ -51,32 +51,32 @@ ok(lc($b)         eq "hello\.\* world",      'lc');
 # \x{100} is LATIN CAPITAL LETTER A WITH MACRON; its bijective lowercase is
 # \x{101}, LATIN SMALL LETTER A WITH MACRON.
 
-$a = "\x{100}\x{101}\x{41}\x{61}";
-$b = "\x{101}\x{100}\x{61}\x{41}";
-
-ok("\Q$a\E."      eq "\x{100}\x{101}\x{41}\x{61}.", '\Q\E \x{100}\x{101}\x{41}\x{61}');
-ok("\u$a"         eq "\x{100}\x{101}\x{41}\x{61}",  '\u');
-ok("\l$a"         eq "\x{101}\x{101}\x{41}\x{61}",  '\l');
-ok("\U$a"         eq "\x{100}\x{100}\x{41}\x{41}",  '\U');
-ok("\L$a"         eq "\x{101}\x{101}\x{61}\x{61}",  '\L');
-
-ok(quotemeta($a)  eq "\x{100}\x{101}\x{41}\x{61}",  'quotemeta');
-ok(ucfirst($a)    eq "\x{100}\x{101}\x{41}\x{61}",  'ucfirst');
-ok(lcfirst($a)    eq "\x{101}\x{101}\x{41}\x{61}",  'lcfirst');
-ok(uc($a)         eq "\x{100}\x{100}\x{41}\x{41}",  'uc');
-ok(lc($a)         eq "\x{101}\x{101}\x{61}\x{61}",  'lc');
-
-ok("\Q$b\E."      eq "\x{101}\x{100}\x{61}\x{41}.", '\Q\E \x{101}\x{100}\x{61}\x{41}');
-ok("\u$b"         eq "\x{100}\x{100}\x{61}\x{41}",  '\u');
-ok("\l$b"         eq "\x{101}\x{100}\x{61}\x{41}",  '\l');
-ok("\U$b"         eq "\x{100}\x{100}\x{41}\x{41}",  '\U');
-ok("\L$b"         eq "\x{101}\x{101}\x{61}\x{61}",  '\L');
-
-ok(quotemeta($b)  eq "\x{101}\x{100}\x{61}\x{41}",  'quotemeta');
-ok(ucfirst($b)    eq "\x{100}\x{100}\x{61}\x{41}",  'ucfirst');
-ok(lcfirst($b)    eq "\x{101}\x{100}\x{61}\x{41}",  'lcfirst');
-ok(uc($b)         eq "\x{100}\x{100}\x{41}\x{41}",  'uc');
-ok(lc($b)         eq "\x{101}\x{101}\x{61}\x{61}",  'lc');
+$a = "\x{100}\x{101}Aa";
+$b = "\x{101}\x{100}aA";
+
+ok("\Q$a\E."      eq "\x{100}\x{101}Aa.", '\Q\E \x{100}\x{101}Aa');
+ok("\u$a"         eq "\x{100}\x{101}Aa",  '\u');
+ok("\l$a"         eq "\x{101}\x{101}Aa",  '\l');
+ok("\U$a"         eq "\x{100}\x{100}AA",  '\U');
+ok("\L$a"         eq "\x{101}\x{101}aa",  '\L');
+
+ok(quotemeta($a)  eq "\x{100}\x{101}Aa",  'quotemeta');
+ok(ucfirst($a)    eq "\x{100}\x{101}Aa",  'ucfirst');
+ok(lcfirst($a)    eq "\x{101}\x{101}Aa",  'lcfirst');
+ok(uc($a)         eq "\x{100}\x{100}AA",  'uc');
+ok(lc($a)         eq "\x{101}\x{101}aa",  'lc');
+
+ok("\Q$b\E."      eq "\x{101}\x{100}aA.", '\Q\E \x{101}\x{100}aA');
+ok("\u$b"         eq "\x{100}\x{100}aA",  '\u');
+ok("\l$b"         eq "\x{101}\x{100}aA",  '\l');
+ok("\U$b"         eq "\x{100}\x{100}AA",  '\U');
+ok("\L$b"         eq "\x{101}\x{101}aa",  '\L');
+
+ok(quotemeta($b)  eq "\x{101}\x{100}aA",  'quotemeta');
+ok(ucfirst($b)    eq "\x{100}\x{100}aA",  'ucfirst');
+ok(lcfirst($b)    eq "\x{101}\x{100}aA",  'lcfirst');
+ok(uc($b)         eq "\x{100}\x{100}AA",  'uc');
+ok(lc($b)         eq "\x{101}\x{101}aa",  'lc');
 
 # \x{DF} is LATIN SMALL LETTER SHARP S, its uppercase is SS or \x{53}\x{53};
 # \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its uppercase is
diff --git a/t/op/pack.t b/t/op/pack.t
index cfb55018e4..7cc4353e96 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -49,7 +49,7 @@ sub ok {
   } else {
     if ($err) {
       chomp $err;
-      print "not ok $test # \$\@ = $err\n";
+      print "not ok $test # $err\n";
     } else {
       if (defined $wrong) {
         $wrong = ", got $wrong";
@@ -556,20 +556,24 @@ ok ("@{[unpack('U*', pack('U*', 100, 200, 300))]}" eq "100 200 300");
 # is unpack U the reverse of pack U for byte string?
 ok ("@{[unpack('U*', pack('U*', 100, 200))]}" eq "100 200");
 
-# does unpack C unravel pack U?
-ok ("@{[unpack('C*', pack('U*', 100, 200))]}" eq "100 195 136");
+if (ord('A') == 193) {
+    ok(1, undef, "skipped") for 1..4; # EBCDIC
+} else {
+    # does unpack C unravel pack U?
+    ok ("@{[unpack('C*', pack('U*', 100, 200))]}" eq "100 195 136");
 
-# does pack U0C create Unicode?
-ok ("@{[pack('U0C*', 100, 195, 136)]}" eq v100.v200);
+    # does pack U0C create Unicode?
+     ok ("@{[pack('U0C*', 100, 195, 136)]}" eq v100.v200);
 
-# does pack C0U create characters?
-ok ("@{[pack('C0U*', 100, 200)]}" eq pack("C*", 100, 195, 136));
+    # does pack C0U create characters?
+    ok ("@{[pack('C0U*', 100, 200)]}" eq pack("C*", 100, 195, 136));
 
-# does unpack U0U on byte data warn?
-{
-    local $SIG{__WARN__} = sub { $@ = "@_" };
-    my @null = unpack('U0U', chr(255));
-    ok ($@ =~ /^Malformed UTF-8 character /, undef, $@);
+    # does unpack U0U on byte data warn?
+    {
+        local $SIG{__WARN__} = sub { $@ = "@_" };
+        my @null = unpack('U0U', chr(255));
+        ok ($@ =~ /^Malformed UTF-8 character /, undef, $@);
+    }
 }
 
 {
diff --git a/t/op/system.t b/t/op/system.t
new file mode 100644
index 0000000000..22dcd8bbfa
--- /dev/null
+++ b/t/op/system.t
@@ -0,0 +1,134 @@
+#!perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    # XXX this could be further munged to enable some parts on other
+    # platforms
+    unless ($^O =~ /^MSWin/) {
+	print "1..0 # skipped: windows specific test\n";
+	exit 0;
+    }
+}
+
+use File::Path;
+use File::Copy;
+use Config;
+use Cwd;
+use strict;
+
+$| = 1;
+
+my $cwd = cwd();
+
+my $testdir = "t e s t";
+my $exename = "showav";
+my $plxname = "showargv";
+rmtree($testdir);
+mkdir($testdir);
+
+open(my $F, ">$testdir/$exename.c")
+    or die "Can't create $testdir/$exename.c: $!";
+print $F <<'EOT';
+#include <stdio.h>
+int
+main(int ac, char **av)
+{
+    int i;
+    for (i = 0; i < ac; i++)
+	printf("[%s]", av[i]);
+    printf("\n");
+    return 0;
+}
+EOT
+
+open($F, ">$testdir/$plxname.bat")
+    or die "Can't create $testdir/$plxname.bat: $!";
+print $F <<'EOT';
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+EOT
+
+print $F <<EOT;
+"$^X" -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+"$^X" -x -S %0 %*
+EOT
+print $F <<'EOT';
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+print "[$_]" for ($0, @ARGV);
+print "\n";
+__END__
+:endofperl
+EOT
+
+close $F;
+
+# build the executable
+chdir($testdir);
+END {
+    chdir($cwd);
+    rmtree($testdir);
+}
+if (open(my $EIN, "$cwd/op/${exename}_exe.uu")) {
+    print "# Unpacking $exename.exe\n";
+    my $e;
+    {
+	local $/;
+	$e = unpack "u", <$EIN>;
+	close $EIN;
+    }
+    open my $EOUT, ">$exename.exe" or die "Can't write $exename.exe: $!";
+    binmode $EOUT;
+    print $EOUT $e;
+    close $EOUT;
+}
+else {
+    print "# Compiling $exename.c\n";
+    if (system("$Config{cc} $Config{ccflags} $exename.c 2>&1 >nul") != 0) {
+	print "# Could not compile $exename.c, status $?\n"
+	     ."# Where is your C compiler?\n"
+	     ."1..0 # skipped: can't build test executable\n";
+    }
+}
+copy("$plxname.bat","$plxname.cmd");
+chdir($cwd);
+
+open my $T, "$^X -I../lib -w op/system_tests |"
+    or die "Can't spawn op/system_tests: $!";
+my $expect;
+my $comment = "";
+my $test = 0;
+while (<$T>) {
+    chomp;
+    if (/^1\.\./) {
+	print "$_\n";
+    }
+    elsif (/^#+\s(.*)$/) {
+	$comment = $1;
+    }
+    elsif (/^</) {
+	$expect = $_;
+	$expect =~ tr/<>/[]/;
+	$expect =~ s/\Q$plxname\E]/$plxname.bat]/;
+    }
+    else {
+	if ($expect ne $_) {
+	    print "# $comment\n" if $comment;
+	    print "# want: $expect\n";
+	    print "# got : $_\n";
+	    print "not ";
+	}
+	++$test;
+	print "ok $test\n";
+    }
+}
+close $T;
diff --git a/t/op/system_tests b/t/op/system_tests
new file mode 100644
index 0000000000..8df87707b0
--- /dev/null
+++ b/t/op/system_tests
@@ -0,0 +1,110 @@
+#!perl
+
+use Cwd;
+use strict;
+
+$| = 1;
+
+my $cwdb = my $cwd = cwd();
+$cwd =~ s,\\,/,g;
+$cwdb =~ s,/,\\,g;
+
+my $testdir = "t e s t";
+my $exename = "showav";
+my $plxname = "showargv";
+
+my $exe = "$testdir/$exename";
+my $exex = $exe . ".exe";
+(my $exeb = $exe) =~ s,/,\\,g;
+my $exebx = $exeb . ".exe";
+
+my $bat = "$testdir/$plxname";
+my $batx = $bat . ".bat";
+(my $batb = $bat) =~ s,/,\\,g;
+my $batbx = $batb . ".bat";
+
+my $cmdx = $bat . ".cmd";
+my $cmdb = $batb;
+my $cmdbx = $cmdb . ".cmd";
+
+my @commands = (
+  $exe,
+  $exex,
+  $exeb,
+  $exebx,
+  "./$exe",
+  "./$exex",
+  ".\\$exeb",
+  ".\\$exebx",
+  "$cwd/$exe",
+  "$cwd/$exex",
+  "$cwdb\\$exeb",
+  "$cwdb\\$exebx",
+  $bat,
+  $batx,
+  $batb,
+  $batbx,
+  "./$bat",
+  "./$batx",
+  ".\\$batb",
+  ".\\$batbx",
+  "$cwd/$bat",
+  "$cwd/$batx",
+  "$cwdb\\$batb",
+  "$cwdb\\$batbx",
+  $cmdx,
+  $cmdbx,
+  "./$cmdx",
+  ".\\$cmdbx",
+  "$cwd/$cmdx",
+  "$cwdb\\$cmdbx",
+  [$^X, $batx],
+  [$^X, $batbx],
+  [$^X, "./$batx"],
+  [$^X, ".\\$batbx"],
+  [$^X, "$cwd/$batx"],
+  [$^X, "$cwdb\\$batbx"],
+);
+
+my @av = (
+  undef,
+  "",
+  " ",
+  "abc",
+  "a b\tc",
+  "\tabc",
+  "abc\t",
+  " abc\t",
+  "\ta b c ",
+  ["\ta b c ", ""],
+  ["\ta b c ", " "],
+  ["", "\ta b c ", "abc"],
+  [" ", "\ta b c ", "abc"],
+);
+
+print "1.." . (@commands * @av * 2) . "\n";
+for my $cmds (@commands) {
+    for my $args (@av) {
+	my @all_args;
+	my @cmds = defined($cmds) ? (ref($cmds) ? @$cmds : $cmds) : ();
+	my @args = defined($args) ? (ref($args) ? @$args : $args) : ();
+	print "######## [@cmds]\n";
+	print "<", join('><', $cmds[$#cmds], @args), ">\n";
+	if (system(@cmds,@args) != 0) {
+	    print "Failed, status($?)\n";
+#	    print "Running again in debug mode\n";
+#	    $^D = 1; # -Dp
+#	    system(@cmds,@args);
+	}
+	$^D = 0;
+	my $cmdstr = join " ", map { /\s|^$/ ? qq["$_"] : $_ } @cmds, @args;
+	print "######## '$cmdstr'\n";
+	if (system($cmdstr) != 0) {
+	    print "Failed, status($?)\n";
+#	    print "Running again in debug mode\n";
+#	    $^D = 1; # -Dp
+#	    system($cmdstr);
+	}
+	$^D = 0;
+    }
+}
diff --git a/t/op/tr.t b/t/op/tr.t
index 6390f6a9e5..124c08a94e 100755
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -286,6 +286,7 @@ print "ok 49\n";
 
 # UTF8 range tests from Inaba Hiroto
 
+# Not working in EBCDIC as of 12674.
 ($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
 print "not " unless $a eq v192.196.172.194.197.172;
 print "ok 50\n";
@@ -326,10 +327,12 @@ print "ok 57\n";
 # (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
 # from Karsten Sperling.
 
+# Not working in EBCDIC as of 12674.
 $c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
 print "not " unless $c == 8 and $a eq "XXXXXXXX";
 print "ok 58\n";
    
+# Not working in EBCDIC as of 12674.
 $c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
 print "not " unless $c == 8 and $a eq "XXXXXXXX";
 print "ok 59\n";