6818f4
From 69beb4272d324bb0724b140b5ddca517e90d89b9 Mon Sep 17 00:00:00 2001
6818f4
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
6818f4
Date: Tue, 5 Dec 2017 10:59:42 +0100
6818f4
Subject: [PATCH] in Data-Dumper, quote glob names better
6818f4
MIME-Version: 1.0
6818f4
Content-Type: text/plain; charset=UTF-8
6818f4
Content-Transfer-Encoding: 8bit
6818f4
6818f4
Ported to Data-Dumper-1.167 from perl git tree:
6818f4
6818f4
commit abda9fe0fe75ae824723761c1c98af958f17a41c
6818f4
Author: Zefram <zefram@fysh.org>
6818f4
Date:   Fri Dec 1 17:35:35 2017 +0000
6818f4
6818f4
    in Data-Dumper, quote glob names better
6818f4
6818f4
    Glob name quoting should obey Useqq.  Fixes [perl #119831].
6818f4
6818f4
Signed-off-by: Petr Písař <ppisar@redhat.com>
6818f4
---
6818f4
 Dumper.pm  |  4 ++--
6818f4
 Dumper.xs  | 22 +++++++---------------
6818f4
 t/dumper.t | 35 ++++++++++++++++++++++++++++++++++-
6818f4
 3 files changed, 43 insertions(+), 18 deletions(-)
6818f4
6818f4
diff --git a/Dumper.pm b/Dumper.pm
6818f4
index 00f6326..696964a 100644
6818f4
--- a/Dumper.pm
6818f4
+++ b/Dumper.pm
6818f4
@@ -527,8 +527,8 @@ sub _dump {
6818f4
     $ref = \$val;
6818f4
     if (ref($ref) eq 'GLOB') {  # glob
6818f4
       my $name = substr($val, 1);
6818f4
-      if ($name =~ /^[A-Za-z_][\w:]*$/ && $name ne 'main::') {
6818f4
-        $name =~ s/^main::/::/;
6818f4
+      $name =~ s/^main::(?!\z)/::/;
6818f4
+      if ($name =~ /\A(?:[A-Z_a-z][0-9A-Z_a-z]*)?::(?:[0-9A-Z_a-z]+::)*[0-9A-Z_a-z]*\z/ && $name ne 'main::') {
6818f4
         $sname = $name;
6818f4
       }
6818f4
       else {
6818f4
diff --git a/Dumper.xs b/Dumper.xs
6818f4
index 5a21721..8a16e04 100644
6818f4
--- a/Dumper.xs
6818f4
+++ b/Dumper.xs
6818f4
@@ -1300,29 +1300,21 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
6818f4
 		    i = 0; else i -= 4;
6818f4
 	    }
6818f4
             if (globname_needs_quote(c,i)) {
6818f4
-#ifdef GvNAMEUTF8
6818f4
-	      if (GvNAMEUTF8(val)) {
6818f4
 		sv_grow(retval, SvCUR(retval)+2);
6818f4
 		r = SvPVX(retval)+SvCUR(retval);
6818f4
 		r[0] = '*'; r[1] = '{';
6818f4
 		SvCUR_set(retval, SvCUR(retval)+2);
6818f4
-                esc_q_utf8(aTHX_ retval, c, i, 1, style->useqq);
6818f4
+                esc_q_utf8(aTHX_ retval, c, i,
6818f4
+#ifdef GvNAMEUTF8
6818f4
+			!!GvNAMEUTF8(val)
6818f4
+#else
6818f4
+			0
6818f4
+#endif
6818f4
+			, style->useqq);
6818f4
 		sv_grow(retval, SvCUR(retval)+2);
6818f4
 		r = SvPVX(retval)+SvCUR(retval);
6818f4
 		r[0] = '}'; r[1] = '\0';
6818f4
 		i = 1;
6818f4
-	      }
6818f4
-	      else
6818f4
-#endif
6818f4
-	      {
6818f4
-		sv_grow(retval, SvCUR(retval)+6+2*i);
6818f4
-		r = SvPVX(retval)+SvCUR(retval);
6818f4
-		r[0] = '*'; r[1] = '{';	r[2] = '\'';
6818f4
-		i += esc_q(r+3, c, i);
6818f4
-		i += 3;
6818f4
-		r[i++] = '\''; r[i++] = '}';
6818f4
-		r[i] = '\0';
6818f4
-	      }
6818f4
 	    }
6818f4
 	    else {
6818f4
 		sv_grow(retval, SvCUR(retval)+i+2);
6818f4
diff --git a/t/dumper.t b/t/dumper.t
6818f4
index 643160a..0c12f34 100644
6818f4
--- a/t/dumper.t
6818f4
+++ b/t/dumper.t
6818f4
@@ -108,7 +108,7 @@ sub SKIP_TEST {
6818f4
   ++$TNUM; print "ok $TNUM # skip $reason\n";
6818f4
 }
6818f4
 
6818f4
-$TMAX = 450;
6818f4
+$TMAX = 456;
6818f4
 
6818f4
 # Force Data::Dumper::Dump to use perl. We test Dumpxs explicitly by calling
6818f4
 # it direct. Out here it lets us knobble the next if to test that the perl
6818f4
@@ -1740,3 +1740,36 @@ EOT
6818f4
         TEST (qq(Dumper("\n")), '\n alone');
6818f4
         TEST (qq(Data::Dumper::DumperX("\n")), '\n alone') if $XS;
6818f4
 }
6818f4
+#############
6818f4
+our @globs = map { $_, \$_ } map { *$_ } map { $_, "s::$_" }
6818f4
+		"foo", "\1bar", "L\x{e9}on", "m\x{100}cron", "snow\x{2603}";
6818f4
+$WANT = <<'EOT';
6818f4
+#$globs = [
6818f4
+#  *::foo,
6818f4
+#  \*::foo,
6818f4
+#  *s::foo,
6818f4
+#  \*s::foo,
6818f4
+#  *{"::\1bar"},
6818f4
+#  \*{"::\1bar"},
6818f4
+#  *{"s::\1bar"},
6818f4
+#  \*{"s::\1bar"},
6818f4
+#  *{"::L\351on"},
6818f4
+#  \*{"::L\351on"},
6818f4
+#  *{"s::L\351on"},
6818f4
+#  \*{"s::L\351on"},
6818f4
+#  *{"::m\x{100}cron"},
6818f4
+#  \*{"::m\x{100}cron"},
6818f4
+#  *{"s::m\x{100}cron"},
6818f4
+#  \*{"s::m\x{100}cron"},
6818f4
+#  *{"::snow\x{2603}"},
6818f4
+#  \*{"::snow\x{2603}"},
6818f4
+#  *{"s::snow\x{2603}"},
6818f4
+#  \*{"s::snow\x{2603}"}
6818f4
+#];
6818f4
+EOT
6818f4
+{
6818f4
+  local $Data::Dumper::Useqq = 1;
6818f4
+  TEST (q(Data::Dumper->Dump([\@globs], ["globs"])), 'globs: Dump()');
6818f4
+  TEST (q(Data::Dumper->Dumpxs([\@globs], ["globs"])), 'globs: Dumpxs()')
6818f4
+    if $XS;
6818f4
+}
6818f4
-- 
6818f4
2.13.6
6818f4