Front page | perl.perl5.porters |
Postings from June 2008
Re: Change 32881: Make Data::Dumper handle blessed regexesproperly, bump version as well. This may not be entirely correct onolder perls, needs further investigation.
Thread Next
From:
Dave Mitchell
Date:
June 1, 2008 03:53
Subject:
Re: Change 32881: Make Data::Dumper handle blessed regexesproperly, bump version as well. This may not be entirely correct onolder perls, needs further investigation.
Message ID:
20080601105334.GC24467@iabyn.com
Note that the change below causes maint-5.10 to SEGV:
[davem@pigeon perl]$ ./perl -Ilib ext/Data/Dumper/t/bless.t
1..11
ok 1 - use Data::Dumper;
ok 2 - package name in bless is escaped if needed
ok 3 - eval reverts dump
ok 4 - package name in bless is escaped if needed
ok 5 - eval reverts dump
Segmentation fault
> Change 32881 by demerphq@demerphq-gemini on 2008/01/06 20:34:41
>
> Make Data::Dumper handle blessed regexes properly, bump version as well. This may not be entirely correct on older perls, needs further investigation.
>
> Affected files ...
>
> ... //depot/perl/ext/Data/Dumper/Dumper.pm#50 edit
> ... //depot/perl/ext/Data/Dumper/Dumper.xs#73 edit
> ... //depot/perl/ext/Data/Dumper/t/bless.t#3 edit
>
> Differences ...
>
> ==== //depot/perl/ext/Data/Dumper/Dumper.pm#50 (text) ====
> Index: perl/ext/Data/Dumper/Dumper.pm
> --- perl/ext/Data/Dumper/Dumper.pm#49~31651~ 2007-07-24 13:42:14.000000000 -0700
> +++ perl/ext/Data/Dumper/Dumper.pm 2008-01-06 12:34:41.000000000 -0800
> @@ -9,7 +9,7 @@
>
> package Data::Dumper;
>
> -$VERSION = '2.121_14';
> +$VERSION = '2.121_15';
>
> #$| = 1;
>
> @@ -326,11 +326,11 @@
> $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 @@
> }
>
> # 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 @@
> $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 @@
> 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;
>
> ==== //depot/perl/ext/Data/Dumper/Dumper.xs#73 (text) ====
> Index: perl/ext/Data/Dumper/Dumper.xs
> --- perl/ext/Data/Dumper/Dumper.xs#72~31662~ 2007-07-26 03:01:31.000000000 -0700
> +++ perl/ext/Data/Dumper/Dumper.xs 2008-01-06 12:34:41.000000000 -0800
> @@ -272,6 +272,11 @@
> 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 @@
> 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 @@
> 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 @@
> (*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 @@
> warn("cannot handle ref type %ld", realtype);
> }
>
> - if (realpack) { /* free blessed allocs */
> + if (realpack && !no_bless) { /* free blessed allocs */
> I32 plen;
> I32 pticks;
>
>
> ==== //depot/perl/ext/Data/Dumper/t/bless.t#3 (text) ====
> Index: perl/ext/Data/Dumper/t/bless.t
> --- perl/ext/Data/Dumper/t/bless.t#2~31660~ 2007-07-25 18:49:15.000000000 -0700
> +++ perl/ext/Data/Dumper/t/bless.t 2008-01-06 12:34:41.000000000 -0800
> @@ -5,7 +5,7 @@
> # 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 @@
> 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");
>
> }
> +}
> End of Patch.
--
A walk of a thousand miles begins with a single step...
then continues for another 1,999,999 or so.
Thread Next