Allow COW with magical and blessed scalars (among others)

Under PERL_NEW_COPY_ON_WRITE (and I suspect under
PERL_OLD_COPY_ON_WRITE, too, but have not confirmed) it is harmless to
do copy-on-write with a magical or blessed scalar.

Also, under PERL_NEW_COPY_ON_WRITE, it is safe to do copy-on-write
with scalars that have numbers in them as well as strings (though not
under PERL_OLD_COPY_ON_WRITE).

So redefine CAN_COW_MASK under PERL_NEW_COPY_ON_WRITE to be less
restrictive.  We still can’t do it when the SvOOK hack is in place,
and I don’t feel comfortable doing it with regexps, even if it could
be proven feasible (regexps are SVf_FAKE, so that covers them).

Anything SvROK cannot be SvPOK, so obviously we can’t COW with that,
but I left SVf_ROK in for good measure.

This change to CAN_COW_MASK affects whether non-cow scalars will be
turned into cows in sv_setsv_flags.  It is already possible for exist-
ing cows to become magical, blessed or numeric elsewhere.

Also, we don’t need to check the flags on the lhs in sv_setsv_flags,
except for SVf_BREAK.  This is similar to ecd5fa70f3, but applies to
another branch just below it.

pp_subst needs a little bit of adjustment, as it is not expecting a
vstring to turn into a cow.

diff --git a/pp_hot.c b/pp_hot.c
index 4f9ad84..e991567 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2296,8 +2296,9 @@ PP(pp_subst)
 
 #ifdef PERL_ANY_COW
        if (SvIsCOW(TARG)) {
-           assert (!force_on_match);
+         if (!force_on_match)
            goto have_a_cow;
+         assert(SvVOK(TARG));
        }
 #endif
        if (force_on_match) {

diff --git a/sv.c b/sv.c
index 207b759..6a700e6 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4257,10 +4257,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 #ifdef PERL_ANY_COW
             && ((flags & SV_COW_SHARED_HASH_KEYS)
                ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
-                    && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
 # ifdef PERL_OLD_COPY_ON_WRITE
+                    && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
                     && SvTYPE(sstr) >= SVt_PVIV
 # else
+                    && !(SvFLAGS(dstr) & SVf_BREAK)
                     && !(sflags & SVf_IsCOW)
                     && GE_COW_THRESHOLD(cur) && cur+1 < len
                     && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)

diff --git a/sv.h b/sv.h
index a44b831..cb5ac62 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1837,6 +1837,11 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
 #  define SvRELEASE_IVX_(sv)   SvRELEASE_IVX(sv),
 #  define SvCANCOW(sv) \
        (SvIsCOW(sv) || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)
+/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
+   on-write.  */
+#  define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
+                        SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
+                        SVf_OOK|SVf_BREAK|SVf_READONLY)
 #else
 #  define SvRELEASE_IVX(sv)   0
 /* This little game brought to you by the need to shut this warning up:
@@ -1859,14 +1864,11 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect
 #   ifndef SV_COWBUF_THRESHOLD
 #    define SV_COWBUF_THRESHOLD        1250    /* min string length for cow */
 #   endif                              /* over existing buffer */
+#   define CAN_COW_MASK        (SVf_POK|SVf_ROK|SVp_POK|SVf_FAKE| \
+                        SVf_OOK|SVf_BREAK|SVf_READONLY)
 #  endif
 #endif /* PERL_OLD_COPY_ON_WRITE */
 
-/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
-   on-write.  */
-#define CAN_COW_MASK   (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
-                        SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
-                        SVf_OOK|SVf_BREAK|SVf_READONLY)
 #define CAN_COW_FLAGS  (SVp_POK|SVf_POK)
 
 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) \