This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix Data-Dumper postentry for quoted glob
authorZefram <zefram@fysh.org>
Wed, 10 Jan 2018 21:09:45 +0000 (21:09 +0000)
committerZefram <zefram@fysh.org>
Wed, 10 Jan 2018 21:09:45 +0000 (21:09 +0000)
In Data-Dumper, where a glob with a quoted name required a postentry,
the name part of the postentry was being emitted as just "}".  This was
an old bug affecting upgraded glob names, which the recent commit
abda9fe0fe75ae824723761c1c98af958f17a41c made affect all quoted glob
names.  Fix the postentry name to encompass the entire quoted name.
Fixes [perl #132695].

dist/Data-Dumper/Dumper.pm
dist/Data-Dumper/Dumper.xs
dist/Data-Dumper/t/dumper.t

index 41433fc..00c99ec 100644 (file)
@@ -10,7 +10,7 @@
 package Data::Dumper;
 
 BEGIN {
-    $VERSION = '2.169'; # Don't forget to set version and release
+    $VERSION = '2.170'; # Don't forget to set version and release
 }               # date in POD below!
 
 #$| = 1;
@@ -1474,7 +1474,7 @@ modify it under the same terms as Perl itself.
 
 =head1 VERSION
 
-Version 2.169
+Version 2.170
 
 =head1 SEE ALSO
 
index 319f00e..174562c 100644 (file)
@@ -1314,11 +1314,11 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
                    i = 0; else i -= 4;
            }
             if (globname_needs_quote(c,i)) {
-               sv_grow(retval, SvCUR(retval)+2);
+               sv_grow(retval, SvCUR(retval)+3);
                r = SvPVX(retval)+SvCUR(retval);
-               r[0] = '*'; r[1] = '{';
+               r[0] = '*'; r[1] = '{'; r[2] = 0;
                SvCUR_set(retval, SvCUR(retval)+2);
-                esc_q_utf8(aTHX_ retval, c, i,
+                i = 3 + esc_q_utf8(aTHX_ retval, c, i,
 #ifdef GvNAMEUTF8
                        !!GvNAMEUTF8(val)
 #else
@@ -1328,15 +1328,16 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
                sv_grow(retval, SvCUR(retval)+2);
                r = SvPVX(retval)+SvCUR(retval);
                r[0] = '}'; r[1] = '\0';
-               i = 1;
+               SvCUR_set(retval, SvCUR(retval)+1);
+               r = r+1 - i;
            }
            else {
                sv_grow(retval, SvCUR(retval)+i+2);
                r = SvPVX(retval)+SvCUR(retval);
                r[0] = '*'; strlcpy(r+1, c, SvLEN(retval));
                i++;
+               SvCUR_set(retval, SvCUR(retval)+i);
            }
-           SvCUR_set(retval, SvCUR(retval)+i);
 
             if (style->purity) {
                static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
index 0c12f34..e09a2dd 100644 (file)
@@ -108,7 +108,7 @@ sub SKIP_TEST {
   ++$TNUM; print "ok $TNUM # skip $reason\n";
 }
 
-$TMAX = 456;
+$TMAX = 468;
 
 # Force Data::Dumper::Dump to use perl. We test Dumpxs explicitly by calling
 # it direct. Out here it lets us knobble the next if to test that the perl
@@ -1773,3 +1773,33 @@ EOT
   TEST (q(Data::Dumper->Dumpxs([\@globs], ["globs"])), 'globs: Dumpxs()')
     if $XS;
 }
+#############
+$WANT = <<'EOT';
+#$v = {
+#  a => \*::ppp,
+#  b => \*{'::a/b'},
+#  c => \*{"::a\x{2603}b"}
+#};
+#*::ppp = {
+#  a => 1
+#};
+#*{'::a/b'} = {
+#  b => 3
+#};
+#*{"::a\x{2603}b"} = {
+#  c => 5
+#};
+EOT
+{
+  *ppp = { a => 1 };
+  *{"a/b"} = { b => 3 };
+  *{"a\x{2603}b"} = { c => 5 };
+  our $v = { a => \*ppp, b => \*{"a/b"}, c => \*{"a\x{2603}b"} };
+  local $Data::Dumper::Purity = 1;
+  TEST (q(Data::Dumper->Dump([$v], ["v"])), 'glob purity: Dump()');
+  TEST (q(Data::Dumper->Dumpxs([$v], ["v"])), 'glob purity: Dumpxs()') if $XS;
+  $WANT =~ tr/'/"/;
+  local $Data::Dumper::Useqq = 1;
+  TEST (q(Data::Dumper->Dump([$v], ["v"])), 'glob purity: Dump()');
+  TEST (q(Data::Dumper->Dumpxs([$v], ["v"])), 'glob purity: Dumpxs()') if $XS;
+}