Change cop_warnings from an SV holding the warnings bitmask to a

directly (shared) malloc()ed buffer holding the warnings bitmask.
This avoids bugs/crashes when the interpreter that created an optree
is freed but the optree remains in use by other interpreters.

p4raw-id: //depot/perl@27779

diff --git a/cop.h b/cop.h
index fc69b91..a6749a0 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -146,7 +146,8 @@ struct cop {
     U32                cop_seq;        /* parse sequence number */
     I32                cop_arybase;    /* array base this line was compiled with */
     line_t      cop_line;       /* line # of this command */
-    SV *       cop_warnings;   /* lexical warnings bitmask */
+    /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *:  */
+    STRLEN *   cop_warnings;   /* lexical warnings bitmask */
     SV *       cop_io;         /* lexical IO defaults */
     /* compile time state of %^H.  See the comment in op.c for how this is
        used to recreate a hash to return from caller.  */

diff --git a/embed.fnc b/embed.fnc
index 4d038e4..9544007 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1666,6 +1666,8 @@ Ap        |GV*    |gv_SVadd       |NN GV* gv
 #endif
 Apo    |bool   |ckwarn         |U32 w
 Apo    |bool   |ckwarn_d       |U32 w
+nopMa  |STRLEN *|new_warnings_bitfield|NULLOK STRLEN *buffer \
+                               |NN const char *const bits|STRLEN size
 
 p      |void   |offer_nice_chunk       |NN void *chunk|U32 chunk_size
 

diff --git a/embed.h b/embed.h
index cfb43fe..1f8d310 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -3907,6 +3907,8 @@
 #define gv_SVadd(a)            Perl_gv_SVadd(aTHX_ a)
 #endif
 #ifdef PERL_CORE
+#endif
+#ifdef PERL_CORE
 #define offer_nice_chunk(a,b)  Perl_offer_nice_chunk(aTHX_ a,b)
 #endif
 #ifndef SPRINTF_RETURNS_STRLEN

diff --git a/mg.c b/mg.c
index c0ebd1b..1921902 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -826,7 +826,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
                }
            }
             else {
-               sv_setsv(sv, PL_compiling.cop_warnings);
+               sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
+                         *PL_compiling.cop_warnings);
            }
            SvPOK_only(sv);
        }
@@ -2274,15 +2275,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                    }
                    if (!accumulate)
                        PL_compiling.cop_warnings = pWARN_NONE;
-                   else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
+                   /* Yuck. I can't see how to abstract this:  */
+                   else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
+                                      WARN_ALL) && !any_fatals) {
                        PL_compiling.cop_warnings = pWARN_ALL;
                        PL_dowarn |= G_WARN_ONCE ;
                    }
                     else {
-                       if (specialWARN(PL_compiling.cop_warnings))
-                           PL_compiling.cop_warnings = newSVsv(sv) ;
-                       else
-                           sv_setsv(PL_compiling.cop_warnings, sv);
+                       STRLEN len;
+                       const char *const p = SvPV_const(sv, len);
+
+                       PL_compiling.cop_warnings
+                           = Perl_new_warnings_bitfield(PL_compiling.cop_warnings,
+                                                        p, len);
+
                        if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
                            PL_dowarn |= G_WARN_ONCE ;
                    }

diff --git a/op.c b/op.c
index da99916..3bb789b 100644 (file)
--- a/op.c
+++ b/op.c
@@ -506,7 +506,7 @@ S_cop_free(pTHX_ COP* cop)
     CopFILE_free(cop);
     CopSTASH_free(cop);
     if (! specialWARN(cop->cop_warnings))
-       SvREFCNT_dec(cop->cop_warnings);
+       PerlMemShared_free(cop->cop_warnings);
     if (! specialCopIO(cop->cop_io)) {
 #ifdef USE_ITHREADS
        /*EMPTY*/
@@ -1974,7 +1974,7 @@ Perl_scope(pTHX_ OP *o)
     }
     return o;
 }
-
+       
 int
 Perl_block_start(pTHX_ int full)
 {
@@ -1983,11 +1983,8 @@ Perl_block_start(pTHX_ int full)
     pad_block_start(full);
     SAVEHINTS();
     PL_hints &= ~HINT_BLOCK_SCOPE;
-    SAVESPTR(PL_compiling.cop_warnings);
-    if (! specialWARN(PL_compiling.cop_warnings)) {
-        PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
-        SAVEFREESV(PL_compiling.cop_warnings) ;
-    }
+    SAVECOPWARNINGS(&PL_compiling);
+    PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
     SAVESPTR(PL_compiling.cop_io);
     if (! specialCopIO(PL_compiling.cop_io)) {
         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
@@ -3946,10 +3943,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
     }
     cop->cop_seq = seq;
     CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
-    if (specialWARN(PL_curcop->cop_warnings))
-        cop->cop_warnings = PL_curcop->cop_warnings ;
-    else
-        cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
+    cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
     if (specialCopIO(PL_curcop->cop_io))
         cop->cop_io = PL_curcop->cop_io;
     else

diff --git a/perl.c b/perl.c
index bd667ee..83baace 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1035,7 +1035,7 @@ perl_destruct(pTHXx)
     PL_utf8_idcont     = NULL;
 
     if (!specialWARN(PL_compiling.cop_warnings))
-       SvREFCNT_dec(PL_compiling.cop_warnings);
+       PerlMemShared_free(PL_compiling.cop_warnings);
     PL_compiling.cop_warnings = NULL;
     if (!specialCopIO(PL_compiling.cop_io))
        SvREFCNT_dec(PL_compiling.cop_io);
@@ -2037,7 +2037,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #endif
 
     if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
-       PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
+        PL_compiling.cop_warnings
+           = Perl_new_warnings_bitfield(NULL, WARN_TAINTstring, WARNsize);
     }
 
     if (!scriptname)
@@ -3369,14 +3370,14 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
     case 'W':
        PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
         if (!specialWARN(PL_compiling.cop_warnings))
-            SvREFCNT_dec(PL_compiling.cop_warnings);
+            PerlMemShared_free(PL_compiling.cop_warnings);
        PL_compiling.cop_warnings = pWARN_ALL ;
        s++;
        return s;
     case 'X':
        PL_dowarn = G_WARN_ALL_OFF;
         if (!specialWARN(PL_compiling.cop_warnings))
-            SvREFCNT_dec(PL_compiling.cop_warnings);
+            PerlMemShared_free(PL_compiling.cop_warnings);
        PL_compiling.cop_warnings = pWARN_NONE ;
        s++;
        return s;

diff --git a/pp_ctl.c b/pp_ctl.c
index 0cb3787..19c2ac5 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1698,7 +1698,7 @@ PP(pp_caller)
     PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
     {
        SV * mask ;
-       SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
+       STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
 
        if  (old_warnings == pWARN_NONE ||
                (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
@@ -1717,7 +1717,7 @@ PP(pp_caller)
            }
        }
         else
-            mask = newSVsv(old_warnings);
+            mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
         PUSHs(sv_2mortal(mask));
     }
 
@@ -3363,13 +3363,15 @@ PP(pp_require)
     PL_rsfp = tryrsfp;
     SAVEHINTS();
     PL_hints = 0;
-    SAVESPTR(PL_compiling.cop_warnings);
+    SAVECOPWARNINGS(&PL_compiling);
     if (PL_dowarn & G_WARN_ALL_ON)
         PL_compiling.cop_warnings = pWARN_ALL ;
     else if (PL_dowarn & G_WARN_ALL_OFF)
         PL_compiling.cop_warnings = pWARN_NONE ;
-    else if (PL_taint_warn)
-        PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
+    else if (PL_taint_warn) {
+        PL_compiling.cop_warnings
+           = Perl_new_warnings_bitfield(NULL, WARN_TAINTstring, WARNsize);
+    }
     else
         PL_compiling.cop_warnings = pWARN_STD ;
     SAVESPTR(PL_compiling.cop_io);
@@ -3461,13 +3463,8 @@ PP(pp_entereval)
     PL_hints = PL_op->op_targ;
     if (saved_hh)
        GvHV(PL_hintgv) = saved_hh;
-    SAVESPTR(PL_compiling.cop_warnings);
-    if (specialWARN(PL_curcop->cop_warnings))
-        PL_compiling.cop_warnings = PL_curcop->cop_warnings;
-    else {
-        PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
-        SAVEFREESV(PL_compiling.cop_warnings);
-    }
+    SAVECOPWARNINGS(&PL_compiling);
+    PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
     SAVESPTR(PL_compiling.cop_io);
     if (specialCopIO(PL_curcop->cop_io))
         PL_compiling.cop_io = PL_curcop->cop_io;

diff --git a/proto.h b/proto.h
index 6b73242..30f1fb0 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4293,6 +4293,11 @@ PERL_CALLCONV GV*        Perl_gv_SVadd(pTHX_ GV* gv)
 #endif
 PERL_CALLCONV bool     Perl_ckwarn(pTHX_ U32 w);
 PERL_CALLCONV bool     Perl_ckwarn_d(pTHX_ U32 w);
+PERL_CALLCONV STRLEN * Perl_new_warnings_bitfield(STRLEN *buffer, const char *const bits, STRLEN size)
+                       __attribute__malloc__
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(2);
+
 
 PERL_CALLCONV void     Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
                        __attribute__nonnull__(pTHX_1);

diff --git a/scope.c b/scope.c
index be926c8..ebea9e1 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -764,6 +764,10 @@ Perl_leave_scope(pTHX_ I32 base)
            ptr = SSPOPPTR;
            Safefree(ptr);
            break;
+       case SAVEt_FREESHAREDPV:
+           ptr = SSPOPPTR;
+           PerlMemShared_free(ptr);
+           break;
        case SAVEt_CLEARSV:
            ptr = (void*)&PL_curpad[SSPOPLONG];
            sv = *(SV**)ptr;
@@ -984,6 +988,17 @@ Perl_leave_scope(pTHX_ I32 base)
            i = SSPOPINT;
            CopARYBASE_set((COP *)ptr, i);
            break;
+       case SAVEt_COP_WARNINGS:
+           {
+               COP *const cop = SSPOPPTR;
+               ptr = SSPOPPTR;
+
+               if (!specialWARN(cop->cop_warnings))
+                   PerlMemShared_free(cop->cop_warnings);
+
+               cop->cop_warnings = ptr;
+           }
+           break;
        case SAVEt_RE_STATE:
            {
                const struct re_save_state *const state

diff --git a/scope.h b/scope.h
index e5160e1..5efb8fc 100644 (file)
--- a/scope.h
+++ b/scope.h
@@ -51,6 +51,8 @@
 #define SAVEt_SAVESWITCHSTACK  40
 #define SAVEt_COP_ARYBASE      41
 #define SAVEt_RE_STATE         42
+#define SAVEt_FREESHAREDPV     43
+#define SAVEt_COP_WARNINGS     44
 
 #ifndef SCOPE_SAVES_SIGNAL_MASK
 #define SCOPE_SAVES_SIGNAL_MASK 0
@@ -192,6 +194,25 @@ Closing bracket on a callback.  See C<ENTER> and L<perlcall>.
        SSPUSHINT(SAVEt_COP_ARYBASE);                   \
     } STMT_END
 
+#define SAVEFREESHAREDPV(pv)                           \
+    STMT_START {                                       \
+       SSCHECK(2);                                     \
+       SSPUSHPTR(pv);                                  \
+       SSPUSHINT(SAVEt_FREESHAREDPV);                  \
+    } STMT_END
+
+/* Need to do the cop warnings like this, rather than SAVEFREESHAREDPV,
+   because realloc() means that the value can actually change. Possibly
+   could have done savefreesharedpvREF, but this way actually seems cleaner,
+   as it simplifies the code that does the saves, and reduces the load on the
+   save stack.  */
+#define SAVECOPWARNINGS(c) \
+    STMT_START {                                       \
+       SSCHECK(3);                                     \
+       SSPUSHPTR((c)->cop_warnings);                   \
+       SSPUSHPTR(c);                                   \
+       SSPUSHINT(SAVEt_COP_WARNINGS);                  \
+    } STMT_END
 
 #ifdef USE_ITHREADS
 #  define SAVECOPSTASH(c)      SAVEPPTR(CopSTASHPV(c))

diff --git a/sv.c b/sv.c
index d6135ed..b32121a 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -10936,8 +10936,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
 
     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
-    if (!specialWARN(PL_compiling.cop_warnings))
-       PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
+    PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
     if (!specialCopIO(PL_compiling.cop_io))
        PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
     if (PL_compiling.cop_hints) {

diff --git a/util.c b/util.c
index b4ed7f2..abd0db9 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1531,7 +1531,18 @@ Perl_ckwarn_d(pTHX_ U32 w)
        ;
 }
 
-
+/* Set buffer=NULL to get a new one.  */
+STRLEN *
+Perl_new_warnings_bitfield(STRLEN *buffer, const char *const bits,
+                          STRLEN size) {
+    const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
+
+    buffer = specialWARN(buffer) ? PerlMemShared_malloc(len_wanted)
+       : PerlMemShared_realloc(buffer, len_wanted);
+    buffer[0] = size;
+    Copy(bits, (buffer + 1), size, char);
+    return buffer;
+}
 
 /* since we've already done strlen() for both nam and val
  * we can use that info to make things faster than

diff --git a/warnings.h b/warnings.h
index 7ef3c04..aa830c0 100644 (file)
--- a/warnings.h
+++ b/warnings.h
@@ -18,8 +18,8 @@
 #define G_WARN_ALL_MASK                (G_WARN_ALL_ON|G_WARN_ALL_OFF)
 
 #define pWARN_STD              NULL
-#define pWARN_ALL              (((SV*)0)+1)    /* use warnings 'all' */
-#define pWARN_NONE             (((SV*)0)+2)    /* no  warnings 'all' */
+#define pWARN_ALL              (((STRLEN*)0)+1)    /* use warnings 'all' */
+#define pWARN_NONE             (((STRLEN*)0)+2)    /* no  warnings 'all' */
 
 #define specialWARN(x)         ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
                                 (x) == pWARN_NONE)
@@ -85,8 +85,12 @@
 #define isLEXWARN_on   (PL_curcop->cop_warnings != pWARN_STD)
 #define isLEXWARN_off  (PL_curcop->cop_warnings == pWARN_STD)
 #define isWARN_ONCE    (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
-#define isWARN_on(c,x) (IsSet(SvPVX_const(c), 2*(x)))
-#define isWARNf_on(c,x)        (IsSet(SvPVX_const(c), 2*(x)+1))
+#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
+#define isWARNf_on(c,x)        (IsSet((U8 *)(c + 1), 2*(x)+1))
+
+#define DUP_WARNINGS(p)                \
+    specialWARN(p) ? (p)       \
+    : CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, char)
 
 #define ckWARN(w)              Perl_ckwarn(aTHX_ packWARN(w))
 #define ckWARN2(w1,w2)         Perl_ckwarn(aTHX_ packWARN2(w1,w2))

diff --git a/warnings.pl b/warnings.pl
index 1265972..853a04a 100644 (file)
--- a/warnings.pl
+++ b/warnings.pl
@@ -277,8 +277,8 @@ print WARN <<'EOM' ;
 #define G_WARN_ALL_MASK                (G_WARN_ALL_ON|G_WARN_ALL_OFF)
 
 #define pWARN_STD              NULL
-#define pWARN_ALL              (((SV*)0)+1)    /* use warnings 'all' */
-#define pWARN_NONE             (((SV*)0)+2)    /* no  warnings 'all' */
+#define pWARN_ALL              (((STRLEN*)0)+1)    /* use warnings 'all' */
+#define pWARN_NONE             (((STRLEN*)0)+2)    /* no  warnings 'all' */
 
 #define specialWARN(x)         ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
                                 (x) == pWARN_NONE)
@@ -325,8 +325,12 @@ print WARN <<'EOM';
 #define isLEXWARN_on   (PL_curcop->cop_warnings != pWARN_STD)
 #define isLEXWARN_off  (PL_curcop->cop_warnings == pWARN_STD)
 #define isWARN_ONCE    (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
-#define isWARN_on(c,x) (IsSet(SvPVX_const(c), 2*(x)))
-#define isWARNf_on(c,x)        (IsSet(SvPVX_const(c), 2*(x)+1))
+#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
+#define isWARNf_on(c,x)        (IsSet((U8 *)(c + 1), 2*(x)+1))
+
+#define DUP_WARNINGS(p)                \
+    specialWARN(p) ? (p)       \
+    : CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, char)
 
 #define ckWARN(w)              Perl_ckwarn(aTHX_ packWARN(w))
 #define ckWARN2(w1,w2)         Perl_ckwarn(aTHX_ packWARN2(w1,w2))