Make Data::Dumper handle blessed regexes properly, bump version as well. This may not be entirely correct on older perls, needs further investigation.

p4raw-id: //depot/perl@32881

3 files changed, 83 insertions, 30 deletions

diff --git a/ext/Data/Dumper/Dumper.pm b/ext/Data/Dumper/Dumper.pm
index 15d504d977..462884f898 100644
--- a/ext/Data/Dumper/Dumper.pm
+++ b/ext/Data/Dumper/Dumper.pm
@@ -9,7 +9,7 @@
 
 package Data::Dumper;
 
-$VERSION = '2.121_14';
+$VERSION = '2.121_15';
 
 #$| = 1;
 
@@ -326,11 +326,11 @@ sub _dump {
 			    $val ];
       }
     }
-
-    if ($realpack and $realpack eq 'Regexp') {
-	$out = "$val";
-	$out =~ s,/,\\/,g;
-	return "qr/$out/";
+    my $no_bless = 0; 
+    my $is_regex = 0;
+    if ( $realpack and ($] >= 5.009005 ? re::is_regexp($val) : $realpack eq 'Regexp') ) {
+        $is_regex = 1;
+        $no_bless = $realpack eq 'Regexp';
     }
 
     # If purity is not set and maxdepth is set, then check depth: 
@@ -345,7 +345,7 @@ sub _dump {
     }
 
     # we have a blessed ref
-    if ($realpack) {
+    if ($realpack and !$no_bless) {
       $out = $s->{'bless'} . '( ';
       $blesspad = $s->{apad};
       $s->{apad} .= '       ' if ($s->{indent} >= 2);
@@ -354,7 +354,30 @@ sub _dump {
     $s->{level}++;
     $ipad = $s->{xpad} x $s->{level};
 
-    if ($realtype eq 'SCALAR' || $realtype eq 'REF') {
+    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' and $] > 5.009005) {
+            defined *re::regexp_pattern{CODE} 
+                or do { eval 'use re (regexp_pattern); 1' or die $@ };
+            $pat = re::regexp_pattern($val);
+        } else {
+            $pat = "$val";
+        }
+        $pat =~ s,/,\\/,g;
+        $out .= "qr/$pat/";
+    }
+    elsif ($realtype eq 'SCALAR' || $realtype eq 'REF') {
       if ($realpack) {
 	$out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}';
       }
@@ -444,7 +467,7 @@ sub _dump {
       croak "Can\'t handle $realtype type.";
     }
     
-    if ($realpack) { # we have a blessed ref
+    if ($realpack and !$no_bless) { # we have a blessed ref
       $out .= ', ' . _quote($realpack) . ' )';
       $out .= '->' . $s->{toaster} . '()'  if $s->{toaster} ne '';
       $s->{apad} = $blesspad;
diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs
index 100778bb4d..d1e9401919 100644
--- a/ext/Data/Dumper/Dumper.xs
+++ b/ext/Data/Dumper/Dumper.xs
@@ -272,6 +272,11 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
     char *iname;
     STRLEN inamelen, idlen = 0;
     U32 realtype;
+    bool no_bless = 0; /* when a qr// is blessed into Regexp we dont want to bless it.
+                          in later perls we should actually check the classname of the 
+                          engine. this gets tricky as it involves lexical issues that arent so
+                          easy to resolve */
+    bool is_regex = 0; /* we are dumping a regex, we need to know this before we bless */
 
     if (!val)
 	return 0;
@@ -394,23 +399,23 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
 		SvREFCNT_dec(seenentry);
 	    }
 	}
-
-	if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
-	    STRLEN rlen;
-	    const char *rval = SvPV(val, rlen);
-	    const char *slash = strchr(rval, '/');
-	    sv_catpvn(retval, "qr/", 3);
-	    while (slash) {
-		sv_catpvn(retval, rval, slash-rval);
-		sv_catpvn(retval, "\\/", 2);
-		rlen -= slash-rval+1;
-		rval = slash+1;
-		slash = strchr(rval, '/');
-	    }
-	    sv_catpvn(retval, rval, rlen);
-	    sv_catpvn(retval, "/", 1);
-	    return 1;
-	}
+        /* regexps dont have to be blessed into package "Regexp"
+         * they can be blessed into any package. 
+         */
+#if PERL_VERSION < 8
+	if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) 
+#elif PERL_VERSION < 11
+        if (realpack && realtype == SVt_PVMG && mg_find(sv, PERL_MAGIC_qr))
+#else        
+        if (realpack && realtype == SVt_REGEXP) 
+#endif
+        {
+            is_regex = 1;
+            if (strEQ(realpack, "Regexp")) 
+                no_bless = 1;
+            else
+                no_bless = 0;
+        }
 
 	/* If purity is not set and maxdepth is set, then check depth:
 	 * if we have reached maximum depth, return the string
@@ -426,7 +431,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	    return 1;
 	}
 
-	if (realpack) {				/* we have a blessed ref */
+	if (realpack && !no_bless) {				/* we have a blessed ref */
 	    STRLEN blesslen;
 	    const char * const blessstr = SvPV(bless, blesslen);
 	    sv_catpvn(retval, blessstr, blesslen);
@@ -441,7 +446,23 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	(*levelp)++;
 	ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
 
-	if (
+        if (is_regex) 
+        {
+            STRLEN rlen;
+	    const char *rval = SvPV(val, rlen);
+	    const char *slash = strchr(rval, '/');
+	    sv_catpvn(retval, "qr/", 3);
+	    while (slash) {
+		sv_catpvn(retval, rval, slash-rval);
+		sv_catpvn(retval, "\\/", 2);
+		rlen -= slash-rval+1;
+		rval = slash+1;
+		slash = strchr(rval, '/');
+	    }
+	    sv_catpvn(retval, rval, rlen);
+	    sv_catpvn(retval, "/", 1);
+	} 
+        else if (
 #if PERL_VERSION < 9
 		realtype <= SVt_PVBM
 #else
@@ -779,7 +800,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	    warn("cannot handle ref type %ld", realtype);
 	}
 
-	if (realpack) {  /* free blessed allocs */
+	if (realpack && !no_bless) {  /* free blessed allocs */
 	    I32 plen;
 	    I32 pticks;
 
diff --git a/ext/Data/Dumper/t/bless.t b/ext/Data/Dumper/t/bless.t
index ed4a606e9f..5dc3e86768 100644
--- a/ext/Data/Dumper/t/bless.t
+++ b/ext/Data/Dumper/t/bless.t
@@ -5,7 +5,7 @@ use Test::More 0.60;
 # Test::More 0.60 required because:
 # - is_deeply(undef, $not_undef); now works. [rt.cpan.org 9441]
 
-BEGIN { plan tests => 1+4*2; }
+BEGIN { plan tests => 1+5*2; }
 
 BEGIN { use_ok('Data::Dumper') };
 
@@ -37,5 +37,14 @@ PERL
 is($dt, $o, "package name in bless is escaped if needed");
 is_deeply(scalar eval($dt), $t, "eval reverts dump");
 }
+{
+my $t = bless( qr//, 'foo');
+my $dt = Dumper($t);
+my $o = <<'PERL';
+$VAR1 = bless( qr/(?-xism:)/, 'foo' );
+PERL
+
+is($dt, $o, "We can dump blessed qr//'s properly");
 
 }
+}