Integrate mainline

p4raw-id: //depot/perlio@14463

6 files changed, 83 insertions, 33 deletions

diff --git a/ext/B/B.xs b/ext/B/B.xs
index 9b7fa9d683..c731c98e18 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -251,7 +251,11 @@ cstring(pTHX_ SV *sv)
                 sprintf(escbuff, "\\%03o", '?');
                 sv_catpv(sstr, escbuff);
             }
-	    else if (*s >= ' ' && *s < 127) /* XXX not portable */
+#ifdef EBCDIC
+	    else if (isPRINT(*s))
+#else
+	    else if (*s >= ' ' && *s < 127)
+#endif /* EBCDIC */
 		sv_catpvn(sstr, s, 1);
 	    else if (*s == '\n')
 		sv_catpv(sstr, "\\n");
@@ -292,7 +296,11 @@ cchar(pTHX_ SV *sv)
 	sv_catpv(sstr, "\\'");
     else if (*s == '\\')
 	sv_catpv(sstr, "\\\\");
-    else if (*s >= ' ' && *s < 127) /* XXX not portable */
+#ifdef EBCDIC
+    else if (isPRINT(8s))
+#else
+    else if (*s >= ' ' && *s < 127)
+#endif /* EBCDIC */
 	sv_catpvn(sstr, s, 1);
     else if (*s == '\n')
 	sv_catpv(sstr, "\\n");
diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index a0f0e78020..fe1dc106a4 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -490,6 +490,8 @@ sub new {
 	    $self->{'files'}{$1} = 1;
 	} elsif ($arg eq "-p") {
 	    $self->{'parens'} = 1;
+	} elsif ($arg eq "-P") {
+	    $self->{'noproto'} = 1;
 	} elsif ($arg eq "-l") {
 	    $self->{'linenums'} = 1;
 	} elsif ($arg eq "-q") {
@@ -2779,6 +2781,7 @@ sub method {
 # or ("", $args_after_prototype_demunging) if it does.
 sub check_proto {
     my $self = shift;
+    return "&" if $self->{'noproto'};
     my($proto, @args) = @_;
     my($arg, $real);
     my $doneok = 0;
@@ -3071,7 +3074,7 @@ sub re_unback {
     my($str) = @_;
 
     # the insane complexity here is due to the behaviour of "\c\"
-    $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
+    $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[^[:print:]])/$1$2/g;
     return $str;
 }
 
@@ -3781,6 +3784,22 @@ C<B::Deparse,-p> will print
 which probably isn't what you intended (the C<'???'> is a sign that
 perl optimized away a constant value).
 
+=item B<-P>
+
+Disable prototype checking. With this option, all function calls are
+deparsed as if no prototype was defined for them. In other words,
+
+    perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
+
+will print
+
+    sub foo (\@) {
+	1;
+    }
+    &foo(\@x);
+
+making clear how the parameters are actually passed to C<foo>.
+
 =item B<-q>
 
 Expand double-quoted strings into the corresponding combinations of
diff --git a/ext/B/t/showlex.t b/ext/B/t/showlex.t
index 1322235699..afff12eac7 100755
--- a/ext/B/t/showlex.t
+++ b/ext/B/t/showlex.t
@@ -33,11 +33,6 @@ if ($is_thread) {
     print "# use5005threads: test $test skipped\n";
 } else {
     $a = `$^X $path "-MO=Showlex" -e "my \@one" $redir`;
-    if (ord('A') != 193) { # ASCIIish
-        print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*\@one.*sv_undef.*AV/s;
-    }
-    else { # EBCDICish C<1: PVNV (0x1a7ede34) "@\226\225\205">
-        print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*\@\\[0-9].*sv_undef.*AV/s;
-    }
+    print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*\@one.*sv_undef.*AV/s;
 }
 ok;
diff --git a/ext/B/t/stash.t b/ext/B/t/stash.t
index 0a32a18841..f8b5209dc6 100755
--- a/ext/B/t/stash.t
+++ b/ext/B/t/stash.t
@@ -21,7 +21,7 @@ my $test = 1;
 sub ok { print "ok $test\n"; $test++ }
 
 
-my $a;
+my $got;
 my $Is_VMS = $^O eq 'VMS';
 my $Is_MacOS = $^O eq 'MacOS';
 
@@ -29,34 +29,54 @@ my $path = join " ", map { qq["-I$_"] } @INC;
 $path = '"-I../lib" "-Iperl_root:[lib]"' if $Is_VMS;   # gets too long otherwise
 my $redir = $Is_MacOS ? "" : "2>&1";
 
+chomp($got = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
+
+$got =~ s/-u//g;
+
+print "# got = $got\n";
+
+my @got = map { s/^\S+ //; $_ }
+              sort { $a cmp $b }
+                   map { lc($_) . " " . $_ }
+                       split /,/, $got;
+
+print "# (after sorting)\n";
+print "# got = @got\n";
+
+@got = grep { ! /^(PerlIO|open)(?:::\w+)?$/ } @got;
+
+print "# (after perlio censorings)\n";
+print "# got = @got\n";
+
+@got = grep { ! /^Win32$/                     } @got  if $^O eq 'MSWin32';
+@got = grep { ! /^NetWare$/                   } @got  if $^O eq 'NetWare';
+@got = grep { ! /^(Cwd|File|File::Copy|OS2)$/ } @got  if $^O eq 'os2';
+@got = grep { ! /^Cwd$/                       } @got  if $^O eq 'cygwin';
 
-chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
-$a = join ',', sort split /,/, $a;
-$a =~ s/-u(PerlIO|open)(?:::\w+)?,//g;
-$a =~ s/-uWin32,// if $^O eq 'MSWin32';
-$a =~ s/-uNetWare,// if $^O eq 'NetWare';
-$a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
-$a =~ s/-uCwd,// if $^O eq 'cygwin';
-  $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uaccess,-uattributes,'
-     . '-umain,-uutf8,-uwarnings';
 if ($Is_VMS) {
-    $a =~ s/-uFile,-uFile::Copy,//;
-    $a =~ s/-uVMS,-uVMS::Filespec,//;
-    $a =~ s/-uvmsish,//;
-    $a =~ s/-uSocket,//; # Socket is optional/compiler version dependent
+    @got = grep { ! /^File(?:::Copy)?$/    } @got;
+    @got = grep { ! /^VMS(?:::Filespec)?$/ } @got;
+    @got = grep { ! /^vmsish$/             } @got;
+     # Socket is optional/compiler version dependent
+    @got = grep { ! /^Socket$/             } @got;
 }
 
+print "# (after platform censorings)\n";
+print "# got = @got\n";
+
+$got = "@got";
+
+my $expected = "access attributes Carp Carp::Heavy DB Exporter Exporter::Heavy main utf8 warnings";
+
 {
     no strict 'vars';
     use vars '$OS2::is_aout';
 }
+
 if ((($Config{static_ext} eq ' ') || ($Config{static_ext} eq ''))
     && !($^O eq 'os2' and $OS2::is_aout)
 	) {
-    if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
-	$b = join ',', sort split /,/, $b;
-    }
-    print "# [$a]\n# vs.\n# [$b]\nnot " if $a ne $b;
+    print "# [$got]\n# vs.\n# [$expected]\nnot " if $got ne $expected;
     ok;
 } else {
     print "ok $test # skipped: one or more static extensions\n"; $test++;
diff --git a/ext/Devel/Peek/Peek.t b/ext/Devel/Peek/Peek.t
index 9be948cae7..bd42d93c58 100644
--- a/ext/Devel/Peek/Peek.t
+++ b/ext/Devel/Peek/Peek.t
@@ -357,7 +357,7 @@ do_test(19,
     MAX = 7
     RITER = -1
     EITER = $ADDR
-    Elt "\\\241\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
+    Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
     SV = PV\\($ADDR\\) at $ADDR
       REFCNT = 1
       FLAGS = \\(POK,pPOK,UTF8\\)
diff --git a/ext/PerlIO/t/encoding.t b/ext/PerlIO/t/encoding.t
index eb523ca80d..a8550d57af 100644
--- a/ext/PerlIO/t/encoding.t
+++ b/ext/PerlIO/t/encoding.t
@@ -35,8 +35,13 @@ if (open(GRK, ">$grk")) {
 }
 
 if (open(UTF, "<$utf")) {
-    # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3)
-    print "not " unless <UTF> eq "\xce\xb1\xce\xb2\xce\xb3";
+    if (ord('A') == 193) { # EBCDIC
+	# alpha beta gamma in UTF-EBCDIC Unicode (0x3b1 0x3b2 0x3b3)
+	print "not " unless <UTF> eq "\xb4\x58\xb4\x59\xb4\x62";
+    } else {
+	# alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3)
+	print "not " unless <UTF> eq "\xce\xb1\xce\xb2\xce\xb3";
+    }
     print "ok 4\n";
     close UTF;
 }
@@ -86,11 +91,14 @@ if (open(RUSSKI, ">$russki")) {
     my $buf2;
     read(RUSSKI, $buf2, 1);
     my $offset = tell(RUSSKI);
-    if (ord($buf1) == 0x3c && ord($buf2) == 0x3f && $offset == 2) {
+    if (ord($buf1) == 0x3c &&
+	ord($buf2) == (ord('A') == 193) ? 0x6f : 0x3f &&
+	$offset == 2) {
 	print "ok 11\n";
     } else {
-	printf "not ok 11 # %#x %#x %d\n",
-	       ord($buf1), ord($buf2), $offset;
+	printf "not ok 11 # [%s] [%s] %d\n",
+	       join(" ", unpack("H*", $buf1)),
+	       join(" ", unpack("H*", $buf2)), $offset;
     }
     close(RUSSKI);
 } else {