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.

diff --git a/dump.c b/dump.c
index 0159983..7a435e7 100644 (file)
--- a/dump.c
+++ b/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,"},

diff --git a/ext/XS-APItest/core_or_not.inc b/ext/XS-APItest/core_or_not.inc
index efc7caa..9c1cf56 100644 (file)
--- a/ext/XS-APItest/core_or_not.inc
+++ b/ext/XS-APItest/core_or_not.inc
@@ -16,7 +16,7 @@ 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));
@@ -24,7 +24,7 @@ CAT2(sv_setsv_cow_hashkey_, SUFFIX) () {
 
     sv_setsv(destination, source);
 
-    result = SvREADONLY(destination) && SvFAKE(destination);
+    result = !!SvIsCOW(destination);
 
     SvREFCNT_dec(source);
     SvREFCNT_dec(destination);

diff --git a/mro.c b/mro.c
index 8ed73f6..1264754 100644 (file)
--- a/mro.c
+++ b/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);

diff --git a/op.c b/op.c
index 3480a6c..23f7aff 100644 (file)
--- a/op.c
+++ b/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;
 }
 

diff --git a/op.h b/op.h
index 210521e..935e126 100644 (file)
--- a/op.h
+++ b/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 \

diff --git a/pp.c b/pp.c
index 6088a11..52f5d39 100644 (file)
--- a/pp.c
+++ b/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)) {

diff --git a/pp_hot.c b/pp_hot.c
index 0cf1b7d..aefe455 100644 (file)
--- a/pp_hot.c
+++ b/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.
             */

diff --git a/pp_sys.c b/pp_sys.c
index 938aafe..54fe661 100644 (file)
--- a/pp_sys.c
+++ b/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),

diff --git a/sv.c b/sv.c
index 4a57a9a..682ac45 100644 (file)
--- a/sv.c
+++ b/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)),

diff --git a/sv.h b/sv.h
index d159334..5e41ecb 100644 (file)
--- a/sv.h
+++ b/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) \

diff --git a/t/op/tr.t b/t/op/tr.t
index 41746fc..057be47 100644 (file)
--- a/t/op/tr.t
+++ b/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" );
 }