From 4ab99479ee12f155a02b2d89051a7878a77df596 Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Sun, 6 Jan 2008 20:34:41 +0000 Subject: [PATCH] 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 --- ext/Data/Dumper/Dumper.pm | 41 ++++++++++++++++++++++++------- ext/Data/Dumper/Dumper.xs | 61 +++++++++++++++++++++++++++++++---------------- ext/Data/Dumper/t/bless.t | 11 ++++++++- 3 files changed, 83 insertions(+), 30 deletions(-) diff --git a/ext/Data/Dumper/Dumper.pm b/ext/Data/Dumper/Dumper.pm index 15d504d..462884f 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 100778b..d1e9401 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 ed4a606..5dc3e86 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"); } +} -- 1.8.3.1