[perl #82948] use re::regexp_pattern in list context for dumping qr//

diff --git a/dist/Data-Dumper/Dumper.pm b/dist/Data-Dumper/Dumper.pm
index 5b31d2c..0f85393 100644 (file)
--- a/dist/Data-Dumper/Dumper.pm
+++ b/dist/Data-Dumper/Dumper.pm
@@ -363,25 +363,15 @@ sub _dump {
 
     if ($is_regex) {
         my $pat;
-        # This really sucks, re:regexp_pattern is in ext/re/re.xs and not in
-        # universal.c, and even worse we cant just require that re to be loaded
-        # we *have* to use() it.
-        # We should probably move it to universal.c for 5.10.1 and fix this.
-        # Currently we only use re::regexp_pattern when the re is blessed into another
-        # package. This has the disadvantage of meaning that a DD dump won't round trip
-        # as the pattern will be repeatedly wrapped with the same modifiers.
-        # This is an aesthetic issue so we will leave it for now, but we could use
-        # regexp_pattern() in list context to get the modifiers separately.
-        # But since this means loading the full debugging engine in process we wont
-        # bother unless its necessary for accuracy.
-        if (($realpack ne 'Regexp') && defined(*re::regexp_pattern{CODE})) {
-          $pat = re::regexp_pattern($val);
+        my $flags = "";
+        if (defined(*re::regexp_pattern{CODE})) {
+          ($pat, $flags) = re::regexp_pattern($val);
         }
         else {
           $pat = "$val";
         }
         $pat =~ s <(\\.)|/> { $1 || '\\/' }ge;
-        $out .= "qr/$pat/";
+        $out .= "qr/$pat/$flags";
     }
     elsif ($realtype eq 'SCALAR' || $realtype eq 'REF'
     || $realtype eq 'VSTRING') {

diff --git a/dist/Data-Dumper/Dumper.xs b/dist/Data-Dumper/Dumper.xs
index 65d37c6..0bdcbe0 100644 (file)
--- a/dist/Data-Dumper/Dumper.xs
+++ b/dist/Data-Dumper/Dumper.xs
@@ -585,9 +585,43 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
         if (is_regex) 
         {
             STRLEN rlen;
-           const char *rval = SvPV(val, rlen);
-           const char * const rend = rval+rlen;
-           const char *slash = rval;
+           SV *sv_pattern = NULL;
+           SV *sv_flags = NULL;
+           CV *re_pattern_cv;
+           const char *rval;
+           const char *rend;
+           const char *slash;
+
+           if ((re_pattern_cv = get_cv("re::regexp_pattern", 0))) {
+             dSP;
+             I32 count;
+             ENTER;
+             SAVETMPS;
+             PUSHMARK(SP);
+             XPUSHs(val);
+             PUTBACK;
+             count = call_sv((SV*)re_pattern_cv, G_ARRAY);
+             SPAGAIN;
+             if (count >= 2) {
+               sv_flags = POPs;
+               sv_pattern = POPs;
+               SvREFCNT_inc(sv_flags);
+               SvREFCNT_inc(sv_pattern);
+             }
+             PUTBACK;
+             FREETMPS;
+             LEAVE;
+             if (sv_pattern) {
+               sv_2mortal(sv_pattern);
+               sv_2mortal(sv_flags);
+             }
+           }
+           else {
+             sv_pattern = val;
+           }
+           rval = SvPV(sv_pattern, rlen);
+           rend = rval+rlen;
+           slash = rval;
            sv_catpvn(retval, "qr/", 3);
            for (;slash < rend; slash++) {
              if (*slash == '\\') { ++slash; continue; }
@@ -600,6 +634,8 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
            }
            sv_catpvn(retval, rval, rlen);
            sv_catpvn(retval, "/", 1);
+           if (sv_flags)
+             sv_catsv(retval, sv_flags);
        } 
         else if (
 #if PERL_VERSION < 9

diff --git a/dist/Data-Dumper/t/bless.t b/dist/Data-Dumper/t/bless.t
index 9866ea7..364b615 100644 (file)
--- a/dist/Data-Dumper/t/bless.t
+++ b/dist/Data-Dumper/t/bless.t
@@ -49,8 +49,8 @@ SKIP: {
 
 my $t = bless( qr//, 'foo');
 my $dt = Dumper($t);
-my $o = ($] >= 5.013006 ? <<'PERL' : <<'PERL_LEGACY');
-$VAR1 = bless( qr/(?^:)/, 'foo' );
+my $o = ($] > 5.010 ? <<'PERL' : <<'PERL_LEGACY');
+$VAR1 = bless( qr//, 'foo' );
 PERL
 $VAR1 = bless( qr/(?-xism:)/, 'foo' );
 PERL_LEGACY

diff --git a/dist/Data-Dumper/t/dumper.t b/dist/Data-Dumper/t/dumper.t
index dbc6d5e..85609f1 100644 (file)
--- a/dist/Data-Dumper/t/dumper.t
+++ b/dist/Data-Dumper/t/dumper.t
@@ -83,11 +83,11 @@ sub SKIP_TEST {
 $Data::Dumper::Useperl = 1;
 if (defined &Data::Dumper::Dumpxs) {
   print "### XS extension loaded, will run XS tests\n";
-  $TMAX = 426; $XS = 1;
+  $TMAX = 432; $XS = 1;
 }
 else {
   print "### XS extensions not loaded, will NOT run XS tests\n";
-  $TMAX = 213; $XS = 0;
+  $TMAX = 216; $XS = 0;
 }
 
 print "1..$TMAX\n";
@@ -1573,3 +1573,20 @@ EOW
     "numbers and number-like scalars"
     if $XS;
 }
+############# 426
+{
+  # [perl #82948]
+  # re::regexp_pattern was moved to universal.c in v5.10.0-252-g192c1e2
+  # and apparently backported to maint-5.10
+  $WANT = $] > 5.010 ? <<'NEW' : <<'OLD';
+#$VAR1 = qr/abc/;
+#$VAR2 = qr/abc/i;
+NEW
+#$VAR1 = qr/(?-xism:abc)/;
+#$VAR2 = qr/(?i-xsm:abc)/;
+OLD
+  TEST q(Data::Dumper->Dump([ qr/abc/, qr/abc/i ])), "qr//";
+  TEST q(Data::Dumper->Dumpxs([ qr/abc/, qr/abc/i ])), "qr// xs"
+    if $XS;
+}
+############# 432