Don’t leak the /(?[])/ parsing stack on error

[perl5.git] / pad.c

diff --git a/pad.c b/pad.c
index e25d06d..70519e4 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -196,7 +196,7 @@ sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U3
                   sv_recode_to_utf8(svrecode, PL_encoding);
                   pv1      = SvPV_const(svrecode, cur1);
              }
-              SvREFCNT_dec(svrecode);
+              SvREFCNT_dec_NN(svrecode);
         }
         if (flags & SVf_UTF8)
             return (bytes_cmp_utf8(
@@ -280,7 +280,6 @@ Perl_pad_new(pTHX_ int flags)
        padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
     }
     else {
-       padlist->xpadl_id = PL_padlist_generation++;
        av_store(pad, 0, NULL);
        padname = newAV();
     }
@@ -371,6 +370,8 @@ Perl_cv_undef(pTHX_ CV *cv)
        PAD_SAVE_SETNULLPAD();
 
        /* discard any leaked ops */
+       if (PL_parser)
+           parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
        opslab_force_free((OPSLAB *)CvSTART(cv));
        CvSTART(cv) = NULL;
 
@@ -426,7 +427,7 @@ Perl_cv_undef(pTHX_ CV *cv)
 
                        if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/  */
                            curpad[ix] = NULL;
-                           SvREFCNT_dec(innercv);
+                           SvREFCNT_dec_NN(innercv);
                            inner_rc--;
                        }
 
@@ -456,7 +457,7 @@ Perl_cv_undef(pTHX_ CV *cv)
                    PL_comppad = NULL;
                    PL_curpad = NULL;
                }
-               SvREFCNT_dec(sv);
+               SvREFCNT_dec_NN(sv);
            }
        }
        {
@@ -626,8 +627,12 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
         flags &= ~padadd_UTF8_NAME;
 
     if ((flags & padadd_NO_DUP_CHECK) == 0) {
+       ENTER;
+       SAVEFREESV(namesv); /* in case of fatal warnings */
        /* check for duplicate declaration */
        pad_check_dup(namesv, flags & padadd_OUR, ourstash);
+       SvREFCNT_inc_simple_void_NN(namesv);
+       LEAVE;
     }
 
     offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
@@ -825,7 +830,7 @@ Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
     if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
        assert(!CvWEAKOUTSIDE(func));
        CvWEAKOUTSIDE_on(func);
-       SvREFCNT_dec(CvOUTSIDE(func));
+       SvREFCNT_dec_NN(CvOUTSIDE(func));
     }
     return ix;
 }
@@ -1670,7 +1675,7 @@ S_pad_reset(pTHX)
            )
     );
 
-    if (!PL_tainting) {        /* Can't mix tainted and non-tainted temporaries. */
+    if (!TAINTING_get) {       /* Can't mix tainted and non-tainted temporaries. */
         I32 po;
        for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
            if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
@@ -1709,13 +1714,21 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
 
     ASSERT_CURPAD_ACTIVE("pad_tidy");
 
-    /* If this CV has had any 'eval-capable' ops planted in it
-     * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
-     * anon prototypes in the chain of CVs should be marked as cloneable,
-     * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
-     * the right CvOUTSIDE.
-     * If running with -d, *any* sub may potentially have an eval
-     * executed within it.
+    /* If this CV has had any 'eval-capable' ops planted in it:
+     * i.e. it contains any of:
+     *
+     *     * eval '...',
+     *     * //ee,
+     *     * use re 'eval'; /$var/
+     *     * /(?{..})/),
+     *
+     * Then any anon prototypes in the chain of CVs should be marked as
+     * cloneable, so that for example the eval's CV in
+     *
+     *    sub { eval '$x' }
+     *
+     * gets the right CvOUTSIDE.  If running with -d, *any* sub may
+     * potentially have an eval executed within it.
      */
 
     if (PL_cv_has_eval || PL_perldb) {
@@ -1811,6 +1824,7 @@ void
 Perl_pad_free(pTHX_ PADOFFSET po)
 {
     dVAR;
+    SV *sv;
     ASSERT_CURPAD_LEGAL("pad_free");
     if (!PL_curpad)
        return;
@@ -1825,9 +1839,11 @@ Perl_pad_free(pTHX_ PADOFFSET po)
            PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
     );
 
-    if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
-       SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
-    }
+
+    sv = PL_curpad[po];
+    if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
+       SvFLAGS(sv) &= ~SVs_PADTMP;
+
     if ((I32)po < PL_padix)
        PL_padix = po - 1;
 }
@@ -1960,7 +1976,7 @@ the immediately surrounding code.
 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
 
 static void
-S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
+S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
 {
     dVAR;
     I32 ix;
@@ -1994,9 +2010,10 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
        outside = CvOUTSIDE(proto);
        if ((CvCLONE(outside) && ! CvCLONED(outside))
            || !CvPADLIST(outside)
-           || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
+           || PadlistNAMES(CvPADLIST(outside))
+                != protopadlist->xpadl_outid) {
            outside = find_runcv_where(
-               FIND_RUNCV_padid_eq, (IV)protopadlist->xpadl_outid, NULL
+               FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
            );
            /* outside could be null */
        }
@@ -2009,6 +2026,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
     ENTER;
     SAVESPTR(PL_compcv);
     PL_compcv = cv;
+    if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
 
     if (CvHASEVAL(cv))
        CvOUTSIDE(cv)   = MUTABLE_CV(SvREFCNT_inc_simple(outside));
@@ -2016,7 +2034,6 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
     SAVESPTR(PL_comppad_name);
     PL_comppad_name = protopad_name;
     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
-    CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
 
     av_fill(PL_comppad, fpad);
 
@@ -2025,7 +2042,8 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
     outpad = outside && CvPADLIST(outside)
        ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
        : NULL;
-    if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
+    if (outpad)
+       CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
 
     for (ix = fpad; ix > 0; ix--) {
        SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
@@ -2103,12 +2121,16 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
                S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
        }
 
+    if (newcv) SvREFCNT_inc_simple_void_NN(cv);
     LEAVE;
 }
 
 static CV *
 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
 {
+    dVAR;
+    const bool newcv = !cv;
+
     assert(!CvUNIQUE(proto));
 
     if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
@@ -2133,7 +2155,7 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
     if (SvMAGIC(proto))
        mg_copy((SV *)proto, (SV *)cv, 0, 0);
 
-    if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside);
+    if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
 
     DEBUG_Xv(
        PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
@@ -2150,7 +2172,7 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
         */
        SV* const const_sv = op_const_sv(CvSTART(cv), cv);
        if (const_sv) {
-           SvREFCNT_dec(cv);
+           SvREFCNT_dec_NN(cv);
             /* For this calling case, op_const_sv returns a *copy*, which we
                donate to newCONSTSUB. Yes, this is ugly, and should be killed.
                Need to fix how lib/constant.pm works to eliminate this.  */
@@ -2455,7 +2477,7 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
 #endif /* USE_ITHREADS */
 
 PAD **
-Perl_padlist_store(pTHX_ register PADLIST *padlist, I32 key, PAD *val)
+Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
 {
     dVAR;
     PAD **ary;