This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #127635] s///r with -DPERL_NO_COW attempts to modify source SV
authorTony Cook <tony@develop-help.com>
Mon, 29 Feb 2016 23:41:46 +0000 (10:41 +1100)
committerTony Cook <tony@develop-help.com>
Tue, 1 Mar 2016 03:55:40 +0000 (14:55 +1100)
based on work done by bulk88, per his notes below:

I found pp_subst with a -DPERL_NO_COW build on an experimental perl branch
would die in ../dist/SelfLoader/t/03taint.t in this line
"my $file = __FILE__ =~ s/[\w.]+\z/01SelfLoader.t/r;" with a attempt to
modify since sv_force_normal_flags checks for readonlyness. The
-DPERL_NO_COW exclusive logic seems faulty, since the COW branch right
above stores the cow status and doesn't call sv_force_normal_flags until
it actually wants to modify the source SV, and pp_subst wont modify the
source SV if PMf_NONDESTRUCT is on.

So fix the die by only de-COWing if !PMf_NONDESTRUCT. Do not deCOW the
source SV if PMf_NONDESTRUCT. The
"my $file = __FILE__ =~ s/[\w.]+\z/01SelfLoader.t/r;" fatal die can not be
reproduced in blead perl with -DPERL_NO_COW, only in my experimental branch
so I rewrote the test to use a const sub that is folded to a
HEK COW RO SV * instead of the __FILE__ token which is not a HEK COW on
blead perl. The subst.t test only fails if perl is compiled with
-DPERL_NO_COW. To avoid an extra !(rpm->op_pmflags & PMf_NONDESTRUCT) check
on a NO_COW build, restructure the logic so
!(rpm->op_pmflags & PMf_NONDESTRUCT) is tested only once. Filed as
[perl #127635].

pp_hot.c
t/re/subst.t

index 6a280ab..5a6f95c 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2914,16 +2914,18 @@ PP(pp_subst)
     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
        because they make integers such as 256 "false".  */
     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
-#else
-    if (SvIsCOW(TARG))
-       sv_force_normal_flags(TARG,0);
 #endif
-    if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
-       && (SvREADONLY(TARG)
-           || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
-                 || SvTYPE(TARG) > SVt_PVLV)
-                && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
-       Perl_croak_no_modify();
+    if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
+#ifndef PERL_ANY_COW
+       if (SvIsCOW(TARG))
+           sv_force_normal_flags(TARG,0);
+#endif
+       if ((SvREADONLY(TARG)
+               || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
+                     || SvTYPE(TARG) > SVt_PVLV)
+                    && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
+           Perl_croak_no_modify();
+    }
     PUTBACK;
 
     orig = SvPV_nomg(TARG, len);
index 7826ecb..26a78c7 100644 (file)
@@ -5,11 +5,13 @@ BEGIN {
     require './test.pl';
     set_up_inc('../lib');
     require Config; import Config;
+    require constant;
+    constant->import(constcow => *Config::{NAME});
     require './charset_tools.pl';
     require './loc_tools.pl';
 }
 
-plan( tests => 269 );
+plan( tests => 270 );
 
 $_ = 'david';
 $a = s/david/rules/r;
@@ -18,6 +20,11 @@ ok( $_ eq 'david' && $a eq 'rules', 'non-destructive substitute' );
 $a = "david" =~ s/david/rules/r;
 ok( $a eq 'rules', 's///r with constant' );
 
+#[perl #127635] failed with -DPERL_NO_COW perl build (George smoker uses flag)
+#Modification of a read-only value attempted at ../t/re/subst.t line 23.
+$a = constcow =~ s/Config/David/r;
+ok( $a eq 'David::', 's///r with COW constant' );
+
 $a = "david" =~ s/david/"is"."great"/er;
 ok( $a eq 'isgreat', 's///er' );