[perl #39420] [PATCH] Data::Dumper fails to escape bless class name

From: "Adriano Ferreira" <a.r.ferreira@gmail.com>
Message-ID: <73ddeb6c0707241229of8f87d7r9315855344451b05@mail.gmail.com>

p4raw-id: //depot/perl@31651

diff --git a/MANIFEST b/MANIFEST
index 74494ae..9840242 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -176,6 +176,7 @@ ext/Data/Dumper/Changes             Data pretty printer, changelog
 ext/Data/Dumper/Dumper.pm      Data pretty printer, module
 ext/Data/Dumper/Dumper.xs      Data pretty printer, externals
 ext/Data/Dumper/Makefile.PL    Data pretty printer, makefile writer
+ext/Data/Dumper/t/bless.t      See if Data::Dumper works
 ext/Data/Dumper/t/bugs.t       See if Data::Dumper works
 ext/Data/Dumper/t/dumper.t     See if Data::Dumper works
 ext/Data/Dumper/t/freezer.t    See if $Data::Dumper::Freezer works

diff --git a/ext/Data/Dumper/Dumper.pm b/ext/Data/Dumper/Dumper.pm
index 19ac1c4..15d504d 100644 (file)
--- a/ext/Data/Dumper/Dumper.pm
+++ b/ext/Data/Dumper/Dumper.pm
@@ -9,7 +9,7 @@
 
 package Data::Dumper;
 
-$VERSION = '2.121_13';
+$VERSION = '2.121_14';
 
 #$| = 1;
 
@@ -253,6 +253,13 @@ sub Dumpperl {
   return wantarray ? @out : join('', @out);
 }
 
+# wrap string in single quotes (escaping if needed)
+sub _quote {
+    my $val = shift;
+    $val =~ s/([\\\'])/\\$1/g;
+    return  "'" . $val .  "'";
+}
+
 #
 # twist, toil and turn;
 # and recurse, of course.
@@ -438,7 +445,7 @@ sub _dump {
     }
     
     if ($realpack) { # we have a blessed ref
-      $out .= ', \'' . $realpack . '\'' . ' )';
+      $out .= ', ' . _quote($realpack) . ' )';
       $out .= '->' . $s->{toaster} . '()'  if $s->{toaster} ne '';
       $s->{apad} = $blesspad;
     }
@@ -502,8 +509,7 @@ sub _dump {
        $out .= qquote($val, $s->{useqq});
       }
       else {
-       $val =~ s/([\\\'])/\\$1/g;
-       $out .= '\'' . $val .  '\'';
+        $out .= _quote($val);
       }
     }
   }

diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs
index dff007b..fdb523b 100644 (file)
--- a/ext/Data/Dumper/Dumper.xs
+++ b/ext/Data/Dumper/Dumper.xs
@@ -780,12 +780,32 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
        }
 
        if (realpack) {  /* free blessed allocs */
+           I32 plen;
+           I32 pticks;
+
            if (indent >= 2) {
                SvREFCNT_dec(apad);
                apad = blesspad;
            }
            sv_catpvn(retval, ", '", 3);
-           sv_catpvn(retval, realpack, strlen(realpack));
+
+           plen = strlen(realpack);
+           pticks = num_q(realpack, plen);
+           if (pticks) { // needs escaping
+               char *npack;
+               char *npack_buffer = NULL;
+
+               New(0, npack_buffer, plen+pticks+1, char);
+               npack = npack_buffer;
+               plen += esc_q(npack, realpack, plen);
+               npack[plen] = '\0';
+
+               sv_catpvn(retval, npack, plen);
+               Safefree(npack_buffer);
+           }
+           else {
+               sv_catpvn(retval, realpack, strlen(realpack));
+           }
            sv_catpvn(retval, "' )", 3);
            if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
                sv_catpvn(retval, "->", 2);

diff --git a/ext/Data/Dumper/t/bless.t b/ext/Data/Dumper/t/bless.t
new file mode 100644 (file)
index 0000000..12d19e2
--- /dev/null
+++ b/ext/Data/Dumper/t/bless.t
@@ -0,0 +1,41 @@
+#!perl
+
+use Test::More 0.60;
+
+# Test::More 0.60 required because:
+# - is_deeply(undef, $not_undef); now works. [rt.cpan.org 9441]
+
+BEGIN { plan tests => 1+4*2; }
+
+BEGIN { use_ok('Data::Dumper') };
+
+# RT 39420: Data::Dumper fails to escape bless class name
+
+# test under XS and pure Perl version
+foreach $Data::Dumper::Useperl (0, 1) {
+
+diag("\$Data::Dumper::Useperl = $Data::Dumper::Useperl");
+
+{
+my $t = bless( {}, q{a'b} );
+my $dt = Dumper($t);
+my $o = <<'PERL';
+$VAR1 = bless( {}, 'a\'b' );
+PERL
+
+is($dt, $o, "package name in bless is escaped if needed");
+is_deeply(scalar eval($dt), $t, "eval reverts dump");
+}
+
+{
+my $t = bless( {}, q{a\\} );
+my $dt = Dumper($t);
+my $o = <<'PERL';
+$VAR1 = bless( {}, 'a\\' );
+PERL
+
+is($dt, $o, "package name in bless is escaped if needed");
+is_deeply(scalar eval($dt), $t, "eval reverts dump");
+}
+
+}