Merge bd0e204 into 1f6b8a9

Perl · May 15, 2021 · b4f5e29 · b4f5e29
2 parents 1f6b8a9 + bd0e204
commit b4f5e29
Show file tree

Hide file tree

Showing 3 changed files with 39 additions and 22 deletions.
diff --git a/dist/Data-Dumper/Dumper.pm b/dist/Data-Dumper/Dumper.pm
@@ -29,7 +29,7 @@ our ( $Indent, $Trailingcomma, $Purity, $Pad, $Varname, $Useqq, $Terse, $Freezer
 our ( @ISA, @EXPORT, @EXPORT_OK, $VERSION );
 
 BEGIN {
-    $VERSION = '2.178'; # Don't forget to set version and release
+    $VERSION = '2.179'; # Don't forget to set version and release
                         # date in POD below!
 
     @ISA = qw(Exporter);
@@ -394,7 +394,9 @@ sub _dump {
         else {
           $pat = "$val";
         }
-        $pat =~ s <(\\.)|/> { $1 || '\\/' }ge;
+        $pat =~ s <(\\.)|(/)|([^[:ascii:]])> {
+            $1 // (defined $2 ? '\\/' : sprintf '\x{%x}', ord $3)
+        }ge;
         $out .= "qr/$pat/$flags";
     }
     elsif ($realtype eq 'SCALAR' || $realtype eq 'REF'
@@ -1476,7 +1478,7 @@ modify it under the same terms as Perl itself.
 
 =head1 VERSION
 
-Version 2.178
+Version 2.179
 
 =head1 SEE ALSO
 

diff --git a/dist/Data-Dumper/Dumper.xs b/dist/Data-Dumper/Dumper.xs
@@ -618,8 +618,10 @@ dump_regexp(pTHX_ SV *retval, SV *val)
     SV *sv_flags = NULL;
     const char *rval;
     const char *rend;
-    const char *slash;
+    const char *p;
     CV *re_pattern_cv = get_cv("re::regexp_pattern", 0);
+    int is_utf8;
+    int increment;
 
     if (!re_pattern_cv) {
         sv_pattern = val;
@@ -651,25 +653,34 @@ dump_regexp(pTHX_ SV *retval, SV *val)
 
     assert(sv_pattern);
 
-    if (SvUTF8(sv_pattern)) {
-        sv_utf8_upgrade(retval);
-    }
+    is_utf8 = SvUTF8(sv_pattern);
 
-    rval = SvPV(sv_pattern, rlen);
-    rend = rval+rlen;
-    slash = rval;
     sv_catpvs(retval, "qr/");
 
-    for ( ; slash < rend; slash++) {
-        if (*slash == '\\') {
-            ++slash;
-            continue;
+    rval = SvPV(sv_pattern, rlen);
+    rend = rval+rlen;
+    for (p = rval; p < rend; p += increment) {
+        UV k = *(U8 *)p;
+        if (k == '\\') {
+            increment = 1 + UTF8SKIP(p + 1);
         }
-        if (*slash == '/') {
-            sv_catpvn(retval, rval, slash-rval);
+        else if (k == '/') {
+            sv_catpvn(retval, rval, p - rval);
             sv_catpvs(retval, "\\/");
-            rlen -= slash-rval+1;
-            rval = slash+1;
+            rlen -= p-rval+1;
+            rval = p+1;
+            increment = 1;
+        }
+        else if (is_utf8 && ! isASCII(k) && k > ' ') {
+            sv_catpvn(retval, rval, p - rval);
+            increment = UTF8SKIP(p);
+            rlen -= p-rval+increment;
+            rval = p+increment;
+            k = utf8_to_uvchr_buf((U8*)p, (U8*) rend, NULL);
+            sv_catpvf(retval, "\\x{%" UVxf "}", k);
+        }
+        else {
+            increment = 1;
         }
     }
 

diff --git a/dist/Data-Dumper/t/dumper.t b/dist/Data-Dumper/t/dumper.t
@@ -1709,6 +1709,7 @@ EOW
 #############
 {
   # [github #18614 - handling of Unicode characters in regexes]
+  # [github #18764 - … without breaking subsequent Latin-1]
   if ($] lt '5.010') {
       SKIP_TEST "Incomplete support for UTF-8 in old perls";
       SKIP_TEST "Incomplete support for UTF-8 in old perls";
@@ -1717,15 +1718,18 @@ EOW
 $WANT = <<"EOW";
 #\$VAR1 = [
 #  "\\x{41f}",
-#  qr/\x{8b80}/,
-#  qr/\x{41f}/
+#  qr/\\x{8b80}/,
+#  qr/\\x{41f}/,
+#  qr/\\x{e4}/,
+#  '\xE4'
 #];
 EOW
   $WANT =~ s{/(,?)$}{/u$1}mg if $] gt '5.014';
-  TEST qq(Data::Dumper->Dump([ [qq/\x{41f}/, qr/\x{8b80}/, qr/\x{41f}/] ])),
+  TEST qq(Data::Dumper->Dump([ [qq/\x{41f}/, qr/\x{8b80}/, qr/\x{41f}/, qr/\x{e4}/, "\xE4"] ])),
     "string with Unicode + regexp with Unicode";
 
-  TEST qq(Data::Dumper->Dumpxs([ [qq/\x{41f}/, qr/\x{8b80}/, qr/\x{41f}/] ])),
+  $WANT =~ s/'\xE4'/"\\x{e4}"/;
+  TEST qq(Data::Dumper->Dumpxs([ [qq/\x{41f}/, qr/\x{8b80}/, qr/\x{41f}/, qr/\x{e4}/, "\xE4"] ])),
     "string with Unicode + regexp with Unicode, XS"
     if $XS;
 }