From b183d514e3e9929ed0c33d4178f16937e6dcbbe1 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 21 Nov 2013 16:46:19 +1100
Subject: [PATCH] [perl #82948] use re::regexp_pattern in list context for
 dumping qr//

---
 dist/Data-Dumper/Dumper.pm  | 18 ++++--------------
 dist/Data-Dumper/Dumper.xs  | 42 +++++++++++++++++++++++++++++++++++++++---
 dist/Data-Dumper/t/bless.t  |  4 ++--
 dist/Data-Dumper/t/dumper.t | 21 +++++++++++++++++++--
 4 files changed, 64 insertions(+), 21 deletions(-)

diff --git a/dist/Data-Dumper/Dumper.pm b/dist/Data-Dumper/Dumper.pm
index 5b31d2c..0f85393 100644
--- 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
--- 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
--- 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
--- 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
-- 
2.7.4