Fix assertion failure on failed magic eval - eg FETCH {eval'('}

[p5sagit/p5-mst-13.2.git] / op.c

diff --git a/op.c b/op.c
index 30fb7fc..d0c1c8b 100644 (file)
--- a/op.c
+++ b/op.c
@@ -423,7 +423,7 @@ Perl_op_free(pTHX_ OP *o)
     dVAR;
     OPCODE type;
 
-    if (!o || o->op_static)
+    if (!o)
        return;
     if (o->op_latefreed) {
        if (o->op_latefree)
@@ -799,7 +799,8 @@ Perl_scalar(pTHX_ OP *o)
     OP *kid;
 
     /* assumes no premature commitment */
-    if (!o || PL_error_count || (o->op_flags & OPf_WANT)
+    if (!o || (PL_parser && PL_parser->error_count)
+        || (o->op_flags & OPf_WANT)
         || o->op_type == OP_RETURN)
     {
        return o;
@@ -897,7 +898,8 @@ Perl_scalarvoid(pTHX_ OP *o)
 
     /* assumes no premature commitment */
     want = o->op_flags & OPf_WANT;
-    if ((want && want != OPf_WANT_SCALAR) || PL_error_count
+    if ((want && want != OPf_WANT_SCALAR)
+        || (PL_parser && PL_parser->error_count)
         || o->op_type == OP_RETURN)
     {
        return o;
@@ -1142,7 +1144,8 @@ Perl_list(pTHX_ OP *o)
     OP *kid;
 
     /* assumes no premature commitment */
-    if (!o || (o->op_flags & OPf_WANT) || PL_error_count
+    if (!o || (o->op_flags & OPf_WANT)
+        || (PL_parser && PL_parser->error_count)
         || o->op_type == OP_RETURN)
     {
        return o;
@@ -1268,7 +1271,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
     int localize = -1;
 
-    if (!o || PL_error_count)
+    if (!o || (PL_parser && PL_parser->error_count))
        return o;
 
     if ((o->op_private & OPpTARGET_MY)
@@ -1697,7 +1700,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
     dVAR;
     OP *kid;
 
-    if (!o || PL_error_count)
+    if (!o || (PL_parser && PL_parser->error_count))
        return o;
 
     switch (o->op_type) {
@@ -1945,7 +1948,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
     dVAR;
     I32 type;
 
-    if (!o || PL_error_count)
+    if (!o || (PL_parser && PL_parser->error_count))
        return o;
 
     type = o->op_type;
@@ -2373,7 +2376,7 @@ Perl_fold_constants(pTHX_ register OP *o)
            goto nope;
     }
 
-    if (PL_error_count)
+    if (PL_parser && PL_parser->error_count)
        goto nope;              /* Don't try to run w/ errors */
 
     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
@@ -2459,7 +2462,7 @@ Perl_gen_constant_list(pTHX_ register OP *o)
     const I32 oldtmps_floor = PL_tmps_floor;
 
     list(o);
-    if (PL_error_count)
+    if (PL_parser && PL_parser->error_count)
        return o;               /* Don't attempt to run with errors */
 
     PL_op = curop = LINKLIST(o);
@@ -3421,32 +3424,15 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
     pm = (PMOP*)o;
 
     if (expr->op_type == OP_CONST) {
-       STRLEN plen;
        SV * const pat = ((SVOP*)expr)->op_sv;
-       const char *p = SvPV_const(pat, plen);
        U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
-       if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
-           U32 was_readonly = SvREADONLY(pat);
-
-           if (was_readonly) {
-               if (SvFAKE(pat)) {
-                   sv_force_normal_flags(pat, 0);
-                   assert(!SvREADONLY(pat));
-                   was_readonly = 0;
-               } else {
-                   SvREADONLY_off(pat);
-               }
-           }   
 
-           sv_setpvn(pat, "\\s+", 3);
+       if (o->op_flags & OPf_SPECIAL)
+           pm_flags |= RXf_SPLIT;
 
-           SvFLAGS(pat) |= was_readonly;
-
-           p = SvPV_const(pat, plen);
-           pm_flags |= RXf_SKIPWHITE;
-       }
-        if (DO_UTF8(pat))
+       if (DO_UTF8(pat))
            pm_flags |= RXf_UTF8;
+
        PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
 
 #ifdef PERL_MAD
@@ -3494,8 +3480,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
        OP *curop;
        if (pm->op_pmflags & PMf_EVAL) {
            curop = NULL;
-           if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
-               CopLINE_set(PL_curcop, (line_t)PL_multi_end);
+           if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
+               CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
        }
        else if (repl->op_type == OP_CONST)
            curop = repl;
@@ -4073,7 +4059,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
                o->op_private |= OPpASSIGN_COMMON;
        }
 
-       if (right && right->op_type == OP_SPLIT) {
+       if (right && right->op_type == OP_SPLIT && !PL_madskills) {
            OP* tmpop = ((LISTOP*)right)->op_first;
            if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
                PMOP * const pm = (PMOP*)tmpop;
@@ -4103,11 +4089,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
                        tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
                        tmpop->op_sibling = NULL;       /* don't free split */
                        right->op_next = tmpop->op_next;  /* fix starting loc */
-#ifdef PERL_MAD
-                       op_getmad(o,right,'R');         /* blow off assign */
-#else
                        op_free(o);                     /* blow off assign */
-#endif
                        right->op_flags &= ~OPf_WANT;
                                /* "I don't know and I don't care." */
                        return right;
@@ -4240,7 +4222,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
     if (first->op_type == OP_NOT
        && (first->op_flags & OPf_SPECIAL)
-       && (first->op_flags & OPf_KIDS)) {
+       && (first->op_flags & OPf_KIDS)
+       && !PL_madskills) {
        if (type == OP_AND || type == OP_OR) {
            if (type == OP_AND)
                type = OP_OR;
@@ -4251,11 +4234,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
            if (o->op_next)
                first->op_next = o->op_next;
            cUNOPo->op_first = NULL;
-#ifdef PERL_MAD
-           op_getmad(o,first,'O');
-#else
            op_free(o);
-#endif
        }
     }
     if (first->op_type == OP_CONST) {
@@ -5116,6 +5095,9 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
     dVAR;
     SV *sv = NULL;
 
+    if (PL_madskills)
+       return NULL;
+
     if (!o)
        return NULL;
 
@@ -5462,7 +5444,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     if (ps)
        sv_setpvn((SV*)cv, ps, ps_len);
 
-    if (PL_error_count) {
+    if (PL_parser && PL_parser->error_count) {
        op_free(block);
        block = NULL;
        if (name) {
@@ -5547,7 +5529,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            }
        }
 
-       if (name && !PL_error_count)
+       if (name && ! (PL_parser && PL_parser->error_count))
            process_special_blocks(name, gv, cv);
     }
 
@@ -6250,7 +6232,8 @@ Perl_ck_exists(pTHX_ OP *o)
        OP * const kid = cUNOPo->op_first;
        if (kid->op_type == OP_ENTERSUB) {
            (void) ref(kid, o->op_type);
-           if (kid->op_type != OP_RV2CV && !PL_error_count)
+           if (kid->op_type != OP_RV2CV
+                       && !(PL_parser && PL_parser->error_count))
                Perl_croak(aTHX_ "%s argument is not a subroutine name",
                            OP_DESC(o));
            o->op_private |= OPpEXISTS_SUB;
@@ -6766,7 +6749,7 @@ Perl_ck_grep(pTHX_ OP *o)
     PADOFFSET offset;
 
     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
-    /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
+    /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
 
     if (o->op_flags & OPf_STACKED) {
        OP* k;
@@ -6787,7 +6770,7 @@ Perl_ck_grep(pTHX_ OP *o)
     else
        scalar(kid);
     o = ck_fun(o);
-    if (PL_error_count)
+    if (PL_parser && PL_parser->error_count)
        return o;
     kid = cLISTOPo->op_first->op_sibling;
     if (kid->op_type != OP_NULL)
@@ -7510,26 +7493,6 @@ Perl_ck_subr(pTHX_ OP *o)
                    proto = SvPV((SV*)cv, len);
                    proto_end = proto + len;
                }
-               if (CvASSERTION(cv)) {
-                   U32 asserthints = 0;
-                   HV *const hinthv = GvHV(PL_hintgv);
-                   if (hinthv) {
-                       SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
-                       if (svp && *svp)
-                           asserthints = SvUV(*svp);
-                   }
-                   if (asserthints & HINT_ASSERTING) {
-                       if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
-                           o->op_private |= OPpENTERSUB_DB;
-                   }
-                   else {
-                       delete_op = 1;
-                       if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
-                           Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
-                                       "Impossible to activate assertion call");
-                       }
-                   }
-               }
            }
        }
     }
@@ -8427,7 +8390,7 @@ Perl_peep(pTHX_ register OP *o)
     LEAVE;
 }
 
-char*
+const char*
 Perl_custom_op_name(pTHX_ const OP* o)
 {
     dVAR;
@@ -8447,7 +8410,7 @@ Perl_custom_op_name(pTHX_ const OP* o)
     return SvPV_nolen(HeVAL(he));
 }
 
-char*
+const char*
 Perl_custom_op_desc(pTHX_ const OP* o)
 {
     dVAR;