Avoid assert fail with s// $target = \3 /e

When the substitution target is assigned to in pp_substcont, it is
assumed that SvPV_free and SvPOK_only_UTF8 can be used on that target.
Only COW scalars are sent through sv_force_normal.

Changing the target in the replacement code can render those assump-
tions untrue:

$  ./perl -Ilib -e '$h = 3; $h =~ s/3/$h=\3;4/e'
Assertion failed: (!((targ)->sv_flags & 0x00000800) || !(*({ SV *const _svrv = ((SV *)({ void *_p = (targ); _p; })); (__builtin_expect(!(PL_valid_types_RV[((svtype)((_svrv)->sv_flags & 0xff)) & 0xf]), 0) ? __assert_rtn(__func__, "pp_ctl.c", 269, "PL_valid_types_RV[SvTYPE(_svrv) & SVt_MASK]") : (void)0); (__builtin_expect(!(!((((_svrv)->sv_flags & (0x00004000|0x00008000)) == 0x00008000) && (((svtype)((_svrv)->sv_flags & 0xff)) == SVt_PVGV || ((svtype)((_svrv)->sv_flags & 0xff)) == SVt_PVLV))), 0) ? __assert_rtn(__func__, "pp_ctl.c", 269, "!isGV_with_GP(_svrv)") : (void)0); (__builtin_expect(!(!(((svtype)((_svrv)->sv_flags & 0xff)) == SVt_PVIO && !(((XPVIO*) (_svrv)->sv_any)->xio_flags & 64))), 0) ? __assert_rtn(__func__, "pp_ctl.c", 269, "!(SvTYPE(_svrv) == SVt_PVIO && !(IoFLAGS(_svrv) & IOf_FAKE_DIRP))") : (void)0); &((_svrv)->sv_u.svu_rv); }))), function Perl_pp_substcont, file pp_ctl.c, line 269.
Abort trap: 6

Also, matching against a hash key and locking that key with Hash::Util
within the replacement code can cause the substitution to modify that
hash key without triggering ‘Modification of a read-only value’.  But
this only happens if it is not a copy-on-write scalar:

$ ./perl -Ilib -MHash::Util=lock_hash -le '$h{foo} = 3; $h{foo} =~ s/3/$h{foo} = 3; lock_hash %h; 4/e; print $h{foo}'
4

We need to do a regular SV_THINKFIRST_COW_DROP check here, just as we
do in sv_setsv with regular scalar assignment.

Also, we need to take into account real globs:

$ ./perl -Ilib -MHash::Util=lock_hash -le '$::{foo} =~ s//*{"foo"}; 4/e'
Assertion failed: (!isGV_with_GP(targ)), function Perl_pp_substcont, file pp_ctl.c, line 259.
Abort trap: 6

diff --git a/pp_ctl.c b/pp_ctl.c
index 1f9432b..85149fe 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -250,12 +250,9 @@ PP(pp_substcont)
                targ = dstr;
            }
            else {
-               if (SvIsCOW(targ)) {
-                   sv_force_normal_flags(targ, SV_COW_DROP_PV);
-               } else
-               {
-                   SvPV_free(targ);
-               }
+               SV_CHECK_THINKFIRST_COW_DROP(targ);
+               if (isGV(targ)) Perl_croak_no_modify();
+               SvPV_free(targ);
                SvPV_set(targ, SvPVX(dstr));
                SvCUR_set(targ, SvCUR(dstr));
                SvLEN_set(targ, SvLEN(dstr));

diff --git a/t/re/subst.t b/t/re/subst.t
index 44fde78..912dacc 100644 (file)
--- a/t/re/subst.t
+++ b/t/re/subst.t
@@ -7,7 +7,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan( tests => 231 );
+plan( tests => 235 );
 
 $_ = 'david';
 $a = s/david/rules/r;
@@ -974,3 +974,24 @@ $@ = "\x{30cb}eval 18";
 $@ =~ s/eval \d+/eval 11/;
 is $@, "\x{30cb}eval 11",
   'loading utf8 tables does not interfere with matches against $@';
+
+$reftobe = 3;
+$reftobe =~ s/3/$reftobe=\ 3;4/e;
+is $reftobe, '4', 'clobbering target with ref in s//.../e';
+$locker{key} = 3;
+SKIP:{
+    skip "no Hash::Util under miniperl", 2 if is_miniperl;
+    require Hash::Util;
+    eval {
+       $locker{key} =~ s/3/
+           $locker{key} = 3;
+           &Hash::Util::lock_hash(\%locker);4
+       /e;
+    };
+    is $locker{key}, '3', 'locking target in $hash{key} =~ s//.../e';
+    like $@, qr/^Modification of a read-only value/, 'err msg';
+}
+delete $::{does_not_exist}; # just in case
+eval { no warnings; $::{does_not_exist}=~s/(?:)/*{"does_not_exist"}; 4/e };
+like $@, qr/^Modification of a read-only value/,
+    'vivifying stash elem in $that::{elem} =~ s//.../e';