Implement the bipolar read-only system

This fixes bugs related to Hash::Util::unlock accidentally unlocking
internal scalars (e.g., that returned by undef()) and allowing them to
be modified.

Internal read-only values are now marked by two flags, the regular
read-only flag, and the new ‘protected’ flag.

Before this SvREADONLY served two purposes:

1) The code would use it to protect things that must not be modi-
   fied, ever (except when the core sees fit to do so).
2) Hash::Util and everybody else would use it to make this unmodifia-
   ble temporarily when requested by the user.

Internals::SvREADONLY serves the latter purpose and only flips the
read-only flag, so things that need to stay read-only will remain so,
because of the ‘other’ read-only flag, that CPAN doesn’t know about.
(If you are a CPAN author, do not read this.)

diff --git a/mg.c b/mg.c
index e18ec01..5566372 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -84,8 +84,7 @@ void setegid(uid_t id);
 struct magic_state {
     SV* mgs_sv;
     I32 mgs_ss_ix;
-    U32 mgs_magical;
-    bool mgs_readonly;
+    U32 mgs_flags;
     bool mgs_bumped;
 };
 /* MGS is typedef'ed to struct magic_state in perl.h */
@@ -115,8 +114,7 @@ S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
 
     mgs = SSPTR(mgs_ix, MGS*);
     mgs->mgs_sv = sv;
-    mgs->mgs_magical = SvMAGICAL(sv);
-    mgs->mgs_readonly = SvREADONLY(sv) != 0;
+    mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
     mgs->mgs_bumped = bumped;
 
@@ -201,13 +199,15 @@ Perl_mg_get(pTHX_ SV *sv)
            /* guard against magic having been deleted - eg FETCH calling
             * untie */
            if (!SvMAGIC(sv)) {
-               (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
+               /* recalculate flags */
+               (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
                break;
            }
 
            /* recalculate flags if this entry was deleted. */
            if (mg->mg_flags & MGf_GSKIP)
-               (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
+               (SSPTR(mgs_ix, MGS *))->mgs_flags &=
+                    ~(SVs_GMG|SVs_SMG|SVs_RMG);
        }
        else if (vtbl == &PL_vtbl_utf8) {
            /* get-magic can reallocate the PV */
@@ -231,7 +231,8 @@ Perl_mg_get(pTHX_ SV *sv)
            have_new = 1;
            cur = mg;
            mg  = newmg;
-           (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
+           /* recalculate flags */
+           (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
        }
     }
 
@@ -267,7 +268,7 @@ Perl_mg_set(pTHX_ SV *sv)
        nextmg = mg->mg_moremagic;      /* it may delete itself */
        if (mg->mg_flags & MGf_GSKIP) {
            mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
-           (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
+           (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
        }
        if (PL_localizing == 2
            && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
@@ -3254,10 +3255,8 @@ S_restore_magic(pTHX_ const void *p)
        if (SvIsCOW(sv))
            sv_force_normal_flags(sv, 0);
 #endif
-       if (mgs->mgs_readonly)
-           SvREADONLY_on(sv);
-       if (mgs->mgs_magical)
-           SvFLAGS(sv) |= mgs->mgs_magical;
+       if (mgs->mgs_flags)
+           SvFLAGS(sv) |= mgs->mgs_flags;
        else
            mg_magical(sv);
     }

diff --git a/scope.c b/scope.c
index a9c73a4..cf656c0 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -986,7 +986,7 @@ Perl_leave_scope(pTHX_ I32 base)
                     /* these flags are the union of all the relevant flags
                      * in the individual conditions within */
                     if (UNLIKELY(SvFLAGS(sv) & (
-                            SVf_READONLY /* for SvREADONLY_off() */
+                            SVf_READONLY|SVf_PROTECT /*for SvREADONLY_off*/
                           | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */
                           | SVf_OOK
                           | SVf_THINKFIRST)))

diff --git a/sv.c b/sv.c
index 8e88d31..53b4f8b 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4499,7 +4499,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
                                /* slated for free anyway (and not COW)? */
                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
                                 /* or a swipable TARG */
-                 || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW))
+                 || ((sflags &
+                           (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
                        == SVs_PADTMP
                                 /* whose buffer is worth stealing */
                      && CHECK_COWBUF_THRESHOLD(cur,len)
@@ -10071,7 +10072,7 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
     if (!SvROK(sv))
         Perl_croak(aTHX_ "Can't bless non-reference value");
     tmpRef = SvRV(sv);
-    if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
+    if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY|SVf_PROTECT)) {
        if (SvREADONLY(tmpRef))
            Perl_croak_no_modify();
        if (SvOBJECT(tmpRef)) {
@@ -14875,18 +14876,18 @@ void
 Perl_init_constants(pTHX)
 {
     SvREFCNT(&PL_sv_undef)     = SvREFCNT_IMMORTAL;
-    SvFLAGS(&PL_sv_undef)      = SVf_READONLY|SVt_NULL;
+    SvFLAGS(&PL_sv_undef)      = SVf_READONLY|SVf_PROTECT|SVt_NULL;
     SvANY(&PL_sv_undef)                = NULL;
 
     SvANY(&PL_sv_no)           = new_XPVNV();
     SvREFCNT(&PL_sv_no)                = SvREFCNT_IMMORTAL;
-    SvFLAGS(&PL_sv_no)         = SVt_PVNV|SVf_READONLY
+    SvFLAGS(&PL_sv_no)         = SVt_PVNV|SVf_READONLY|SVf_PROTECT
                                  |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
                                  |SVp_POK|SVf_POK;
 
     SvANY(&PL_sv_yes)          = new_XPVNV();
     SvREFCNT(&PL_sv_yes)       = SvREFCNT_IMMORTAL;
-    SvFLAGS(&PL_sv_yes)                = SVt_PVNV|SVf_READONLY
+    SvFLAGS(&PL_sv_yes)                = SVt_PVNV|SVf_READONLY|SVf_PROTECT
                                  |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
                                  |SVp_POK|SVf_POK;
 

diff --git a/sv.h b/sv.h
index 0bc089d..f198d99 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -395,7 +395,8 @@ perform the upgrade if necessary.  See C<svtype>.
 
 
 
-#define SVf_THINKFIRST (SVf_READONLY|SVf_ROK|SVf_FAKE|SVs_RMG|SVf_IsCOW)
+#define SVf_THINKFIRST (SVf_READONLY|SVf_PROTECT|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)
@@ -1070,9 +1071,14 @@ sv_force_normal does nothing.
 #define SvOBJECT_on(sv)                (SvFLAGS(sv) |= SVs_OBJECT)
 #define SvOBJECT_off(sv)       (SvFLAGS(sv) &= ~SVs_OBJECT)
 
-#define SvREADONLY(sv)         (SvFLAGS(sv) & SVf_READONLY)
-#define SvREADONLY_on(sv)      (SvFLAGS(sv) |= SVf_READONLY)
-#define SvREADONLY_off(sv)     (SvFLAGS(sv) &= ~SVf_READONLY)
+#define SvREADONLY(sv)         (SvFLAGS(sv) & (SVf_READONLY|SVf_PROTECT))
+#ifdef PERL_CORE
+# define SvREADONLY_on(sv)     (SvFLAGS(sv) |= (SVf_READONLY|SVf_PROTECT))
+# define SvREADONLY_off(sv)    (SvFLAGS(sv) &=~(SVf_READONLY|SVf_PROTECT))
+#else
+# define SvREADONLY_on(sv)     (SvFLAGS(sv) |= SVf_READONLY)
+# define SvREADONLY_off(sv)    (SvFLAGS(sv) &= ~SVf_READONLY)
+#endif
 
 #define SvSCREAM(sv) ((SvFLAGS(sv) & (SVp_SCREAM|SVp_POK)) == (SVp_SCREAM|SVp_POK))
 #define SvSCREAM_on(sv)                (SvFLAGS(sv) |= SVp_SCREAM)
@@ -1900,7 +1906,7 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
    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)
+                        SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_PROTECT)
 #else
 #  define SvRELEASE_IVX(sv)   0
 /* This little game brought to you by the need to shut this warning up:
@@ -1918,7 +1924,7 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect
 #   define CowREFCNT(sv)       (*(U8 *)(SvPVX(sv)+SvLEN(sv)-1))
 #   define SV_COW_REFCNT_MAX   ((1 << sizeof(U8)*8) - 1)
 #   define CAN_COW_MASK        (SVf_POK|SVf_ROK|SVp_POK|SVf_FAKE| \
-                        SVf_OOK|SVf_BREAK|SVf_READONLY)
+                        SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_PROTECT)
 #  endif
 #endif /* PERL_OLD_COPY_ON_WRITE */
 

diff --git a/t/lib/universal.t b/t/lib/universal.t
index 19f8f28..55fda06 100644 (file)
--- a/t/lib/universal.t
+++ b/t/lib/universal.t
@@ -6,7 +6,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan( tests => 13 );
+    plan( tests => 15 );
 }
 
 for my $arg ('', 'q[]', qw( 1 undef )) {
@@ -60,3 +60,9 @@ Internals::SvREADONLY($h{b},0);
 $h{b} =~ y/ia/ao/;
 is __PACKAGE__, 'main',
   'turning off a cow’s readonliness did not affect sharers of the same PV';
+
+&Internals::SvREADONLY(\!0, 0);
+eval { ${\!0} = 7 };
+like $@, qr "^Modification of a read-only value",
+    'protected values still croak on assignment after SvREADONLY(..., 0)';
+is ${\3} == 3, "1", 'attempt to modify failed';

diff --git a/universal.c b/universal.c
index 906f74c..94169a6 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -565,12 +565,12 @@ XS(XS_Internals_SvREADONLY)       /* This is dangerous stuff. */
 #ifdef PERL_OLD_COPY_ON_WRITE
            if (SvIsCOW(sv)) sv_force_normal(sv);
 #endif
-           SvREADONLY_on(sv);
+           SvFLAGS(sv) |= SVf_READONLY;
            XSRETURN_YES;
        }
        else {
            /* I hope you really know what you are doing. */
-           SvREADONLY_off(sv);
+           SvFLAGS(sv) &=~ SVf_READONLY;
            XSRETURN_NO;
        }
     }