SVf_IsCOW

As discussed in ticket #114820, instead of using READONLY+FAKE to mark
a copy-on-write string, we should make it a separate flag.

There are many modules in CPAN (and 1 in core, Compress::Raw::Zlib)
that assume that SvREADONLY means read-only.  Only one CPAN module,
POSIX::pselect will definitely be broken by this.  Others may need to
be tweaked.  But I believe this is for the better.

It causes all tests except ext/Devel-Peek/t/Peek.t (which needs a tiny
tweak still) to pass under PERL_OLD_COPY_ON_WRITE, which is a prereq-
uisite for any new COW scheme that creates COWs under the same cir-
cumstances.

dump.c

@@ -1387,6 +1387,7 @@ const struct flag_to_name second_sv_flags_names[] = {
     {SVf_OOK, "OOK,"},
     {SVf_FAKE, "FAKE,"},
     {SVf_READONLY, "READONLY,"},
+    {SVf_IsCOW, "IsCOW,"},
     {SVf_BREAK, "BREAK,"},
     {SVf_AMAGIC, "OVERLOAD,"},
     {SVp_IOK, "pIOK,"},

ext/XS-APItest/core_or_not.inc

@@ -16,15 +16,15 @@ CAT2(sv_setsv_cow_hashkey_, SUFFIX) () {
     SV *destination = newSV(0);
     bool result;
 
-    if(!SvREADONLY(source) && !SvFAKE(source)) {
+    if(!SvIsCOW(source)) {
 	SvREFCNT_dec(source);
 	Perl_croak(aTHX_ "Creating a shared hash key scalar failed when "
 	       STRINGIFY(SUFFIX) " got flags %"UVxf, (UV)SvFLAGS(source));
     }
 
     sv_setsv(destination, source);
 
-    result = SvREADONLY(destination) && SvFAKE(destination);
+    result = !!SvIsCOW(destination);
 
     SvREFCNT_dec(source);
     SvREFCNT_dec(destination);

mro.c

@@ -312,8 +312,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
 			sv_upgrade(val, SVt_PV);
 			SvPV_set(val, HEK_KEY(share_hek_hek(key)));
 			SvCUR_set(val, HEK_LEN(key));
-			SvREADONLY_on(val);
-			SvFAKE_on(val);
+			SvIsCOW_on(val);
 			SvPOK_on(val);
 			if (HEK_UTF8(key))
 			    SvUTF8_on(val);

op.c

@@ -1762,7 +1762,7 @@ S_finalize_op(pTHX_ OP* o)
 		/* If op_sv is already a PADTMP/MY then it is being used by
 		 * some pad, so make a copy. */
 		sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
-		SvREADONLY_on(PAD_SVl(ix));
+		if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
 		SvREFCNT_dec(cSVOPo->op_sv);
 	    }
 	    else if (o->op_type != OP_METHOD_NAMED
@@ -1782,7 +1782,7 @@ S_finalize_op(pTHX_ OP* o)
 		SvPADTMP_on(cSVOPo->op_sv);
 		PAD_SETSV(ix, cSVOPo->op_sv);
 		/* XXX I don't know how this isn't readonly already. */
-		SvREADONLY_on(PAD_SVl(ix));
+		if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
 	    }
 	    cSVOPo->op_sv = NULL;
 	    o->op_targ = ix;
@@ -1803,7 +1803,7 @@ S_finalize_op(pTHX_ OP* o)
 
 	/* Make the CONST have a shared SV */
 	svp = cSVOPx_svp(((BINOP*)o)->op_last);
-	if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
+	if ((!SvIsCOW(sv = *svp))
 	    && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
 	    key = SvPV_const(sv, keylen);
 	    lexname = newSVpvn_share(key,
@@ -9344,7 +9344,7 @@ Perl_ck_method(pTHX_ OP *o)
 	const char * const method = SvPVX_const(sv);
 	if (!(strchr(method, ':') || strchr(method, '\''))) {
 	    OP *cmop;
-	    if (!SvREADONLY(sv) || !SvFAKE(sv)) {
+	    if (!SvIsCOW(sv)) {
 		sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
 	    }
 	    else {
@@ -9469,14 +9469,9 @@ Perl_ck_require(pTHX_ OP *o)
 	    const char *end;
 
 	    if (was_readonly) {
-		if (SvFAKE(sv)) {
-		    sv_force_normal_flags(sv, 0);
-		    assert(!SvREADONLY(sv));
-		    was_readonly = 0;
-		} else {
 		    SvREADONLY_off(sv);
-		}
 	    }   
+	    if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
 
 	    s = SvPVX(sv);
 	    len = SvCUR(sv);
@@ -10543,7 +10538,7 @@ Perl_ck_svconst(pTHX_ OP *o)
 {
     PERL_ARGS_ASSERT_CK_SVCONST;
     PERL_UNUSED_CONTEXT;
-    SvREADONLY_on(cSVOPo->op_sv);
+    if (!SvIsCOW(cSVOPo->op_sv)) SvREADONLY_on(cSVOPo->op_sv);
     return o;
 }
 

op.h

@@ -570,7 +570,7 @@ struct loop {
 #  define	cGVOPx_gv(o)	((GV*)PAD_SVl(cPADOPx(o)->op_padix))
 #  define	IS_PADGV(v)	(v && SvTYPE(v) == SVt_PVGV && isGV_with_GP(v) \
 				 && GvIN_PAD(v))
-#  define	IS_PADCONST(v)	(v && SvREADONLY(v))
+#  define	IS_PADCONST(v)	(v && (SvREADONLY(v) || SvIsCOW(v)))
 #  define	cSVOPx_sv(v)	(cSVOPx(v)->op_sv \
 				 ? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ))
 #  define	cSVOPx_svp(v)	(cSVOPx(v)->op_sv \

pp.c

@@ -772,13 +772,11 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
 	return;
     }
     else if (SvREADONLY(sv)) {
-        if (SvFAKE(sv)) {
-            /* SV is copy-on-write */
-	    sv_force_normal_flags(sv, 0);
-        }
-        else
             Perl_croak_no_modify();
     }
+    else if (SvIsCOW(sv)) {
+	sv_force_normal_flags(sv, 0);
+    }
 
     if (PL_encoding) {
 	if (!SvUTF8(sv)) {

pp_hot.c

@@ -1695,7 +1695,7 @@ Perl_do_readline(pTHX)
 	}
 	SvUPGRADE(sv, SVt_PV);
 	tmplen = SvLEN(sv);	/* remember if already alloced */
-	if (!tmplen && !SvREADONLY(sv)) {
+	if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
             /* try short-buffering it. Please update t/op/readline.t
 	     * if you change the growth length.
 	     */

pp_sys.c

@@ -1096,12 +1096,10 @@ PP(pp_sselect)
 	SvGETMAGIC(sv);
 	if (!SvOK(sv))
 	    continue;
-	if (SvREADONLY(sv)) {
-	    if (SvIsCOW(sv))
+	if (SvIsCOW(sv))
 		sv_force_normal_flags(sv, 0);
-	    if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
+	if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
 		Perl_croak_no_modify();
-	}
 	if (!SvPOK(sv)) {
 	    if (!SvPOKp(sv))
 		Perl_ck_warner(aTHX_ packWARN(WARN_MISC),

sv.c

@@ -4199,7 +4199,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
 	       shared hash keys then we don't do the COW setup, even if the
 	       source scalar is a shared hash key scalar.  */
             (((flags & SV_COW_SHARED_HASH_KEYS)
-	       ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
+	       ? !(sflags & SVf_IsCOW)
 	       : 1 /* If making a COW copy is forbidden then the behaviour we
 		       desire is as if the source SV isn't actually already
 		       COW, even if it is.  So we act as if the source flags
@@ -4253,10 +4253,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
             }
 #ifdef PERL_OLD_COPY_ON_WRITE
             if (!isSwipe) {
-                if ((sflags & (SVf_FAKE | SVf_READONLY))
-                    != (SVf_FAKE | SVf_READONLY)) {
-                    SvREADONLY_on(sstr);
-                    SvFAKE_on(sstr);
+                if (!(sflags & SVf_IsCOW)) {
+                    SvIsCOW_on(sstr);
                     /* Make the source SV into a loop of 1.
                        (about to become 2) */
                     SV_COW_NEXT_SV_SET(sstr, sstr);
@@ -4293,8 +4291,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
 		}
                 SvLEN_set(dstr, len);
                 SvCUR_set(dstr, cur);
-                SvREADONLY_on(dstr);
-                SvFAKE_on(dstr);
+                SvIsCOW_on(dstr);
             }
             else
                 {	/* Passes the swipe test.  */
@@ -4417,8 +4414,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
     } else {
 	assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
 	SvUPGRADE(sstr, SVt_PVIV);
-	SvREADONLY_on(sstr);
-	SvFAKE_on(sstr);
+	SvIsCOW_on(sstr);
 	DEBUG_C(PerlIO_printf(Perl_debug_log,
 			      "Fast copy on write: Converting sstr to COW\n"));
 	SV_COW_NEXT_SV_SET(dstr, sstr);
@@ -4428,7 +4424,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
 
   common_exit:
     SvPV_set(dstr, new_pv);
-    SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
+    SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_IsCOW);
     if (SvUTF8(sstr))
 	SvUTF8_on(dstr);
     SvLEN_set(dstr, len);
@@ -4584,8 +4580,7 @@ Perl_sv_sethek(pTHX_ register SV *const sv, const HEK *const hek)
 	    SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
 	    SvCUR_set(sv, HEK_LEN(hek));
 	    SvLEN_set(sv, 0);
-	    SvREADONLY_on(sv);
-	    SvFAKE_on(sv);
+	    SvIsCOW_on(sv);
 	    SvPOK_on(sv);
 	    if (HEK_UTF8(hek))
 		SvUTF8_on(sv);
@@ -4699,8 +4694,7 @@ S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
             /* The SV we point to points back to us (there were only two of us
                in the loop.)
                Hence other SV is no longer copy on write either.  */
-            SvFAKE_off(after);
-            SvREADONLY_off(after);
+            SvIsCOW_off(after);
         } else {
             /* We need to follow the pointers around the loop.  */
             SV *next;
@@ -4746,6 +4740,10 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
 
 #ifdef PERL_OLD_COPY_ON_WRITE
     if (SvREADONLY(sv)) {
+	if (IN_PERL_RUNTIME)
+	    Perl_croak_no_modify(aTHX);
+    }
+    else
 	if (SvIsCOW(sv)) {
 	    const char * const pvx = SvPVX_const(sv);
 	    const STRLEN len = SvLEN(sv);
@@ -4761,8 +4759,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
                               (long) flags);
                 sv_dump(sv);
             }
-            SvFAKE_off(sv);
-            SvREADONLY_off(sv);
+            SvIsCOW_off(sv);
             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
             SvPV_set(sv, NULL);
             SvLEN_set(sv, 0);
@@ -4784,16 +4781,16 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
                 sv_dump(sv);
             }
 	}
-	else if (IN_PERL_RUNTIME)
-	    Perl_croak_no_modify();
-    }
 #else
     if (SvREADONLY(sv)) {
+	if (IN_PERL_RUNTIME)
+	    Perl_croak_no_modify();
+    }
+    else
 	if (SvIsCOW(sv)) {
 	    const char * const pvx = SvPVX_const(sv);
 	    const STRLEN len = SvCUR(sv);
-	    SvFAKE_off(sv);
-	    SvREADONLY_off(sv);
+	    SvIsCOW_off(sv);
 	    SvPV_set(sv, NULL);
 	    SvLEN_set(sv, 0);
 	    if (flags & SV_COW_DROP_PV) {
@@ -4806,9 +4803,6 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
 	    }
 	    unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
 	}
-	else if (IN_PERL_RUNTIME)
-	    Perl_croak_no_modify();
-    }
 #endif
     if (SvROK(sv))
 	sv_unref_flags(sv, flags);
@@ -6209,7 +6203,6 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
 			unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
 		    }
 
-		    SvFAKE_off(sv);
 		} else if (SvLEN(sv)) {
 		    Safefree(SvPVX_mutable(sv));
 		}
@@ -6221,7 +6214,6 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
 		Safefree(SvPVX_mutable(sv));
 	    else if (SvPVX_const(sv) && SvIsCOW(sv)) {
 		unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
-		SvFAKE_off(sv);
 	    }
 #endif
 	    break;
@@ -8482,8 +8474,7 @@ Perl_newSVhek(pTHX_ const HEK *const hek)
 	    SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
 	    SvCUR_set(sv, HEK_LEN(hek));
 	    SvLEN_set(sv, 0);
-	    SvREADONLY_on(sv);
-	    SvFAKE_on(sv);
+	    SvIsCOW_on(sv);
 	    SvPOK_on(sv);
 	    if (HEK_UTF8(hek))
 		SvUTF8_on(sv);
@@ -8531,8 +8522,7 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
     SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
     SvCUR_set(sv, len);
     SvLEN_set(sv, 0);
-    SvREADONLY_on(sv);
-    SvFAKE_on(sv);
+    SvIsCOW_on(sv);
     SvPOK_on(sv);
     if (is_utf8)
         SvUTF8_on(sv);
@@ -11797,19 +11787,16 @@ Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const pa
 	if (SvLEN(sstr)) {
 	    /* Normal PV - clone whole allocated space */
 	    SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
-	    if (SvREADONLY(sstr) && SvFAKE(sstr)) {
-		/* Not that normal - actually sstr is copy on write.
-		   But we are a true, independent SV, so:  */
-		SvREADONLY_off(dstr);
-		SvFAKE_off(dstr);
-	    }
+	    /* sstr may not be that normal, but actually copy on write.
+	       But we are a true, independent SV, so:  */
+	    SvIsCOW_off(dstr);
 	}
 	else {
 	    /* Special case - not normally malloced for some reason */
 	    if (isGV_with_GP(sstr)) {
 		/* Don't need to do anything here.  */
 	    }
-	    else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
+	    else if ((SvIsCOW(sstr))) {
 		/* A "shared" PV - clone it as "shared" PV */
 		SvPV_set(dstr,
 			 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),

sv.h

@@ -338,7 +338,8 @@ perform the upgrade if necessary.  See C<svtype>.
 				       subroutine in another package. Set the
 				       GvIMPORTED_CV_on() if it needs to be
 				       expanded to a real GV */
-/*                      0x00010000  *** FREE SLOT */
+#define SVf_IsCOW	0x00010000  /* copy on write (shared hash key if
+				       SvLEN == 0) */
 #define SVs_PADTMP	0x00020000  /* in use as tmp; only if ! SVs_PADMY */
 #define SVs_PADSTALE	0x00020000  /* lexical has gone out of scope;
 					only valid for SVs_PADMY */
@@ -353,17 +354,13 @@ perform the upgrade if necessary.  See C<svtype>.
 
 #define SVf_FAKE	0x01000000  /* 0: glob is just a copy
 				       1: SV head arena wasn't malloc()ed
-				       2: in conjunction with SVf_READONLY
-					  marks a shared hash key scalar
-					  (SvLEN == 0) or a copy on write
-					  string (SvLEN != 0) [SvIsCOW(sv)]
-				       3: For PVCV, whether CvUNIQUE(cv)
+				       2: For PVCV, whether CvUNIQUE(cv)
 					  refers to an eval or once only
 					  [CvEVAL(cv), CvSPECIAL(cv)]
-				       4: On a pad name SV, that slot in the
+				       3: On a pad name SV, that slot in the
 					  frame AV is a REFCNT'ed reference
 					  to a lexical from "outside". */
-#define SVphv_REHASH	SVf_FAKE    /* 5: On a PVHV, hash values are being
+#define SVphv_REHASH	SVf_FAKE    /* 4: On a PVHV, hash values are being
 					  recalculated */
 #define SVf_OOK		0x02000000  /* has valid offset value. For a PVHV this
 				       means that a hv_aux struct is present
@@ -377,7 +374,7 @@ perform the upgrade if necessary.  See C<svtype>.
 
 
 
-#define SVf_THINKFIRST	(SVf_READONLY|SVf_ROK|SVf_FAKE|SVs_RMG)
+#define SVf_THINKFIRST	(SVf_READONLY|SVf_ROK|SVf_FAKE|SVs_RMG|SVf_IsCOW)
 
 #define SVf_OK		(SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK| \
 			 SVp_IOK|SVp_NOK|SVp_POK|SVpgv_GP)
@@ -1765,9 +1762,9 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
 	 || (PL_Xpv->xpv_cur && *PL_Sv->sv_u.svu_pv != '0')))
 #endif /* __GNU__ */
 
-#define SvIsCOW(sv)	((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
-			   (SVf_FAKE | SVf_READONLY) && !isGV_with_GP(sv) \
-			   && SvTYPE(sv) != SVt_REGEXP)
+#define SvIsCOW(sv)		(SvFLAGS(sv) & SVf_IsCOW)
+#define SvIsCOW_on(sv)		(SvFLAGS(sv) |= SVf_IsCOW)
+#define SvIsCOW_off(sv)		(SvFLAGS(sv) &= ~SVf_IsCOW)
 #define SvIsCOW_shared_hash(sv)	(SvIsCOW(sv) && SvLEN(sv) == 0)
 
 #define SvSHARED_HEK_FROM_PV(pvx) \

t/op/tr.t

@@ -486,11 +486,11 @@ is($s, "AxBC", "utf8, DELETE");
 
 ($s) = keys %{{pie => 3}};
 SKIP: {
-    if (!eval { require B }) { skip "no B", 2 }
-    my $wasro = B::svref_2object(\$s)->FLAGS & &B::SVf_READONLY;
+    if (!eval { require XS::APItest }) { skip "no XS::APItest", 2 }
+    my $wasro = XS::APItest::SvIsCOW($s);
     ok $wasro, "have a COW";
     $s =~ tr/i//;
-    ok( B::svref_2object(\$s)->FLAGS & &B::SVf_READONLY,
+    ok( XS::APItest::SvIsCOW($s),
        "count-only tr doesn't deCOW COWs" );
 }