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..)

diff --git a/doio.c b/doio.c
index f6566bb..631149d 100644 (file)
--- 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 266411a..d7baecc 100644 (file)
--- 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 41ba5d6..ad8699f 100644 (file)
--- 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 51ce983..39b579f 100644 (file)
--- 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 5008875..4befe79 100644 (file)
--- 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 32baa50..eb8eb60 100644 (file)
--- 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 c117c60..f87e7c4 100644 (file)
--- 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 52b641d..ac5cde7 100755 (executable)
--- 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 c7b4461..90b0370 100755 (executable)
--- 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";
+