From: Adriano Ferreira <a.r.ferreira@gmail.com>
Date: Tue, 24 Jul 2007 16:29:21 +0000 (-0300)
Subject: [perl #39420] [PATCH] Data::Dumper fails to escape bless class name
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d0c214fd302df80d664768cde328944208c90c47;p=p5sagit%2Fp5-mst-13.2.git

[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
--- 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
--- 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
--- 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
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");
+}
+
+}