[perl #112966] Crash on delete local; other local bugs

[perl5.git] / op.c

diff --git a/op.c b/op.c
index c984139..5756eeb 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2827,9 +2827,6 @@ Perl_newPROG(pTHX_ OP *o)
        else
            scalar(PL_eval_root);
 
-       /* don't use LINKLIST, since PL_eval_root might indirect through
-        * a rather expensive function call and LINKLIST evaluates its
-        * argument more than once */
        PL_eval_start = op_linklist(PL_eval_root);
        PL_eval_root->op_private |= OPpREFCOUNTED;
        OpREFCNT_set(PL_eval_root, 1);
@@ -4396,7 +4393,10 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
        else {
            /* compile-time pattern that includes literal code blocks */
            REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
-                                       rx_flags, pm->op_pmflags);
+                       rx_flags,
+                       (pm->op_pmflags |
+                           ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
+                   );
            PM_SETRE(pm, re);
            if (pm->op_pmflags & PMf_HAS_CV) {
                CV *cv;
@@ -4437,10 +4437,13 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
            pm->op_pmflags |= PMf_CODELIST_PRIVATE;
        }
 
-       if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
-           expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
-                           ? OP_REGCRESET
-                           : OP_REGCMAYBE),0,expr);
+       /* the OP_REGCMAYBE is a placeholder in the non-threaded case
+        * to allow its op_next to be pointed past the regcomp and
+        * preceding stacking ops;
+        * OP_REGCRESET is there to reset taint before executing the
+        * stacking ops */
+       if (pm->op_pmflags & PMf_KEEP || PL_tainting)
+           expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
 
        if (pm->op_pmflags & PMf_HAS_CV) {
            /* we have a runtime qr with literal code. This means
@@ -4807,7 +4810,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
     OP *imop;
     OP *veop;
 #ifdef PERL_MAD
-    OP *pegop = newOP(OP_NULL,0);
+    OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
 #endif
     SV *use_version = NULL;
 
@@ -4942,11 +4945,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
        PL_cop_seqmax++;
 
 #ifdef PERL_MAD
-    if (!PL_madskills) {
-       /* FIXME - don't allocate pegop if !PL_madskills */
-       op_free(pegop);
-       return NULL;
-    }
     return pegop;
 #endif
 }
@@ -6721,13 +6719,15 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     U32 ps_utf8 = 0;
     register CV *cv = NULL;
     SV *const_sv;
+    const bool ec = PL_parser && PL_parser->error_count;
     /* If the subroutine has no body, no attributes, and no builtin attributes
        then it's just a sub declaration, and we may be able to get away with
        storing with a placeholder scalar in the symbol table, rather than a
        full GV and CV.  If anything is present then it will take a full CV to
        store it.  */
     const I32 gv_fetch_flags
-       = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+       = ec ? GV_NOADD_NOINIT :
+        (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
           || PL_madskills)
        ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
     STRLEN namlen = 0;
@@ -6776,6 +6776,27 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            SAVEFREEOP(attrs);
     }
 
+    if (ec) {
+       op_free(block);
+       if (name && block) {
+           const char *s = strrchr(name, ':');
+           s = s ? s+1 : name;
+           if (strEQ(s, "BEGIN")) {
+               const char not_safe[] =
+                   "BEGIN not safe after errors--compilation aborted";
+               if (PL_in_eval & EVAL_KEEPERR)
+                   Perl_croak(aTHX_ not_safe);
+               else {
+                   /* force display of errors found but not reported */
+                   sv_catpv(ERRSV, not_safe);
+                   Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
+               }
+           }
+       }
+       cv = PL_compcv;
+       goto done;
+    }
+
     if (SvTYPE(gv) != SVt_PVGV) {      /* Maybe prototype now, and had at
                                           maximum a prototype before. */
        if (SvTYPE(gv) > SVt_NULL) {
@@ -6858,7 +6879,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
        }
     }
     if (const_sv) {
-       HV *stash;
        SvREFCNT_inc_simple_void_NN(const_sv);
        if (cv) {
            assert(!CvROOT(cv) && !CvCONST(cv));
@@ -6875,14 +6895,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
                const_sv
            );
        }
-       stash =
-            (CvGV(cv) && GvSTASH(CvGV(cv)))
-                ? GvSTASH(CvGV(cv))
-                : CvSTASH(cv)
-                    ? CvSTASH(cv)
-                    : PL_curstash;
-       if (HvENAME_HEK(stash))
-            mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
        if (PL_madskills)
            goto install_block;
        op_free(block);
@@ -6960,25 +6972,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
     }
 
-    if (PL_parser && PL_parser->error_count) {
-       op_free(block);
-       block = NULL;
-       if (name) {
-           const char *s = strrchr(name, ':');
-           s = s ? s+1 : name;
-           if (strEQ(s, "BEGIN")) {
-               const char not_safe[] =
-                   "BEGIN not safe after errors--compilation aborted";
-               if (PL_in_eval & EVAL_KEEPERR)
-                   Perl_croak(aTHX_ not_safe);
-               else {
-                   /* force display of errors found but not reported */
-                   sv_catpv(ERRSV, not_safe);
-                   Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
-               }
-           }
-       }
-    }
  install_block:
     if (!block)
        goto attrs;
@@ -7303,6 +7296,23 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
     return cv;
 }
 
+CV *
+Perl_newSTUB(pTHX_ GV *gv, bool fake)
+{
+    register CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+    PERL_ARGS_ASSERT_NEWSTUB;
+    assert(!GvCVu(gv));
+    GvCV_set(gv, cv);
+    GvCVGEN(gv) = 0;
+    if (!fake && HvENAME_HEK(GvSTASH(gv)))
+       mro_method_changed_in(GvSTASH(gv));
+    CvGV_set(cv, gv);
+    CvFILE_set_from_cop(cv, PL_curcop);
+    CvSTASH_set(cv, PL_curstash);
+    GvMULTI_on(gv);
+    return cv;
+}
+
 /*
 =for apidoc U||newXS