develooper 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


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About