Integrate changes #9544,9547,9549(perlio),9550,9551 from

maintperl into mainline.

"double" should be "NV"; standard typemap is missing entry
for NV

s/djSP/dSP/

Downgrade "Wide character in print" to a warning.

B::Deparse fix for ${^FOO} and documentation for PVX() method
(from Robin Houston)

tr/// doesn't null-terminate the result in some situations
(from Gisle Aas)

p4raw-link: @9549 on //depot/perlio: ae79846703a543a04b4fe449abfd6b1e08a9e149
p4raw-link: @9547 on //depot/maint-5.6/perl: 5976aebc9f997fdf4f4889f497e528a90c8a7dc3
p4raw-link: @9544 on //depot/maint-5.6/perl: 405f61b82790e3c0b3cb02962f34aa8522c5a18e

p4raw-id: //depot/perl@9553
p4raw-integrated: from //depot/maint-5.6/perl@9552 'copy in'
	ext/B/B/C.pm (@9235..) 'merge in' lib/ExtUtils/typemap
	(@8151..) ext/Thread/Thread.xs (@8606..) t/op/tr.t (@9152..)
	doop.c (@9288..) ext/B/B.pm ext/B/B/Deparse.pm (@9548..)
p4raw-integrated: from //depot/maint-5.6/perl@9544 'merge in'
	ext/B/B.xs (@8621..)

9 files changed, 40 insertions, 14 deletions

diff --git a/doio.c b/doio.c
index f6566bb521..631149db41 100644
--- a/doio.c
+++ b/doio.c
@@ -1204,8 +1204,11 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
 	    if (!SvUTF8(sv))
 		sv_utf8_upgrade(sv = sv_mortalcopy(sv));
 	}
-	else if (DO_UTF8(sv))
-	    sv_utf8_downgrade((sv = sv_mortalcopy(sv)), FALSE);
+	else if (DO_UTF8(sv)) {
+	    if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)) {
+		Perl_warner(aTHX_ WARN_UTF8, "Wide character in print");
+	    }
+	}
 	tmps = SvPV(sv, len);
 	break;
     }
diff --git a/doop.c b/doop.c
index 266411a009..d7baecc792 100644
--- a/doop.c
+++ b/doop.c
@@ -184,6 +184,7 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
 		s++;
 	    }
 	}
+	*d = '\0';
 	SvCUR_set(sv, d - dstart);
     }
     else { /* isutf8 */
diff --git a/ext/B/B.pm b/ext/B/B.pm
index 41ba5d6597..ad8699f803 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -365,8 +365,22 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>).
 
 =item PV
 
+This method is the one you usually want. It constructs a
+string using the length and offset information in the struct:
+for ordinary scalars it will return the string that you'd see
+from Perl, even if it contains null characters.
+
 =item PVX
 
+This method is less often useful. It assumes that the string
+stored in the struct is null-terminated, and disregards the
+length information.
+
+It is the appropriate method to use if you need to get the name
+of a lexical variable from a padname array. Lexical variable names
+are always stored with a null terminator, and the length field
+(SvCUR) is overloaded for other purposes and can't be relied on here.
+
 =back
 
 =head2 B::PVMG METHODS
diff --git a/ext/B/B.xs b/ext/B/B.xs
index 51ce983422..39b579f51b 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -885,11 +885,11 @@ packiv(sv)
 
 MODULE = B	PACKAGE = B::NV		PREFIX = Sv
 
-double
+NV
 SvNV(sv)
 	B::NV	sv
 
-double
+NV
 SvNVX(sv)
 	B::NV	sv
 
diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
index 50088752ab..4befe7988b 100644
--- a/ext/B/B/C.pm
+++ b/ext/B/B/C.pm
@@ -1048,15 +1048,15 @@ typedef struct {
     STRLEN	xpv_cur;	/* length of xp_pv as a C string */
     STRLEN	xpv_len;	/* allocated size */
     IV		xof_off;	/* integer value */
-    double	xnv_nv;		/* numeric value, if any */
+    NV		xnv_nv;		/* numeric value, if any */
     MAGIC*	xmg_magic;	/* magic for scalar array */
     HV*		xmg_stash;	/* class package */
 
     HV *	xcv_stash;
     OP *	xcv_start;
     OP *	xcv_root;
-    void      (*xcv_xsub) (CV*);
-    void *	xcv_xsubany;
+    void      (*xcv_xsub) (pTHXo_ CV*);
+    ANY		xcv_xsubany;
     GV *	xcv_gv;
     char *	xcv_file;
     long	xcv_depth;	/* >= 2 indicates recursive call */
diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index 32baa50f3d..eb8eb60f20 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -782,8 +782,9 @@ sub gv_name {
     } else {
 	$stash = $stash . "::";
     }
-    if ($name =~ /^([\cA-\cZ])$/) {
-	$name = "^" . chr(64 + ord($1));
+    if ($name =~ /^([\cA-\cZ])(.*)$/) {
+	$name = "^" . chr(64 + ord($1)) . $2;
+	$name = "{$name}" if length($2);	# ${^WARNING_BITS} etc
     }
     return $stash . $name;
 }
@@ -2418,7 +2419,7 @@ sub pp_const {
     my $sv = $self->const_sv($op);
 #    return const($sv);
     my $c = const $sv; 
-    return $c < 0 ? $self->maybe_parens($c, $cx, 21) : $c;
+    return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
 }
 
 sub dq {
diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs
index c117c60a42..f87e7c4a31 100644
--- a/ext/Thread/Thread.xs
+++ b/ext/Thread/Thread.xs
@@ -82,7 +82,7 @@ threadstart(void *arg)
 #else
     Thread thr = (Thread) arg;
     LOGOP myop;
-    djSP;
+    dSP;
     I32 oldmark = TOPMARK;
     I32 oldscope = PL_scopestack_ix;
     I32 retval;
diff --git a/t/io/utf8.t b/t/io/utf8.t
index 52b641d2f1..ac5cde7a6e 100755
--- a/t/io/utf8.t
+++ b/t/io/utf8.t
@@ -135,8 +135,9 @@ print "ok 21\n";
 
 # Now let's make it suffer.
 open F, ">", "a" or die $!;
-eval { print F $a; };
-print "not " unless $@ and $@ =~ /Wide character in print/i;
+my $w;
+eval {local $SIG{__WARN__} = sub { $w = $_[0] };  print F $a; };
+print "not " if ($@ || $w !~ /Wide character in print/i);
 print "ok 22\n";
 }
 
diff --git a/t/op/tr.t b/t/op/tr.t
index c7b446196c..90b03706e2 100755
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..66\n";
+print "1..67\n";
 
 $_ = "abcdefghijklmnopqrstuvwxyz";
 
@@ -370,3 +370,9 @@ print "ok 65\n";
 $a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
 print "not " unless $a eq "\x{1ff}\x{1fe}";
 print "ok 66\n";
+
+# From David Dyck
+($a = "R0_001") =~ tr/R_//d;
+print "not " if hex($a) != 1;
+print "ok 67\n";
+