add verbose stack display option, -Dvs

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

diff --git a/op.c b/op.c
index 0038680..75cff4b 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1243,6 +1243,7 @@ Perl_scalarvoid(pTHX_ OP *o)
 
     case OP_OR:
     case OP_AND:
+    case OP_DOR:
     case OP_COND_EXPR:
        for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
            scalarvoid(kid);
@@ -1612,7 +1613,6 @@ Perl_mod(pTHX_ OP *o, I32 type)
     case OP_AASSIGN:
     case OP_NEXTSTATE:
     case OP_DBSTATE:
-    case OP_CHOMP:
        PL_modcount = RETURN_UNLIMITED_NUMBER;
        break;
     case OP_RV2SV:
@@ -1626,6 +1626,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
     case OP_SASSIGN:
     case OP_ANDASSIGN:
     case OP_ORASSIGN:
+    case OP_DORASSIGN:
     case OP_AELEMFAST:
        PL_modcount++;
        break;
@@ -2088,19 +2089,19 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
     } else if (type == OP_RV2SV ||     /* "our" declaration */
               type == OP_RV2AV ||
               type == OP_RV2HV) { /* XXX does this let anything illegal in? */
-      if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
-           yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
-        }
-        if (attrs) {
-            GV *gv = cGVOPx_gv(cUNOPo->op_first);
-            PL_in_my = FALSE;
-            PL_in_my_stash = Nullhv;
-            apply_attrs(GvSTASH(gv),
-                        (type == OP_RV2SV ? GvSV(gv) :
-                         type == OP_RV2AV ? (SV*)GvAV(gv) :
-                         type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
-                        attrs, FALSE);
-        }
+       if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
+           yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
+                       OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
+       } else if (attrs) {
+           GV *gv = cGVOPx_gv(cUNOPo->op_first);
+           PL_in_my = FALSE;
+           PL_in_my_stash = Nullhv;
+           apply_attrs(GvSTASH(gv),
+                       (type == OP_RV2SV ? GvSV(gv) :
+                        type == OP_RV2AV ? (SV*)GvAV(gv) :
+                        type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
+                       attrs, FALSE);
+       }
        o->op_private |= OPpOUR_INTRO;
        return o;
     }
@@ -3617,7 +3618,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
     OP *o;
 
     if (optype) {
-       if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
+       if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
            return newLOGOP(optype, 0,
                mod(scalar(left), optype),
                newUNOP(OP_SASSIGN, 0, scalar(right)));
@@ -3899,12 +3900,6 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
            return first;
        }
     }
-    else if (first->op_type == OP_WANTARRAY) {
-       if (type == OP_AND)
-           list(other);
-       else
-           scalar(other);
-    }
     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
        OP *k1 = ((UNOP*)first)->op_first;
        OP *k2 = k1->op_sibling;
@@ -3946,7 +3941,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
     if (!other)
        return first;
 
-    if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
+    if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
        other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
 
     NewOp(1101, logop, 1, LOGOP);
@@ -3983,6 +3978,10 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
 
     scalarboolean(first);
     if (first->op_type == OP_CONST) {
+        if (first->op_private & OPpCONST_BARE &&
+           first->op_private & OPpCONST_STRICT) {
+           no_bareword_allowed(first);
+       }
        if (SvTRUE(((SVOP*)first)->op_sv)) {
            op_free(first);
            op_free(falseop);
@@ -3994,10 +3993,6 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
            return falseop;
        }
     }
-    else if (first->op_type == OP_WANTARRAY) {
-       list(trueop);
-       scalar(falseop);
-    }
     NewOp(1101, logop, 1, LOGOP);
     logop->op_type = OP_COND_EXPR;
     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
@@ -4344,6 +4339,10 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 void
 Perl_cv_undef(pTHX_ CV *cv)
 {
+    CV *outsidecv;
+    CV *freecv = Nullcv;
+    bool is_eval = CvEVAL(cv) && !CvGV(cv);    /* is this eval"" ? */
+
 #ifdef USE_5005THREADS
     if (CvMUTEXP(cv)) {
        MUTEX_DESTROY(CvMUTEXP(cv));
@@ -4379,13 +4378,14 @@ Perl_cv_undef(pTHX_ CV *cv)
     }
     SvPOK_off((SV*)cv);                /* forget prototype */
     CvGV(cv) = Nullgv;
+    outsidecv = CvOUTSIDE(cv);
     /* Since closure prototypes have the same lifetime as the containing
      * CV, they don't hold a refcount on the outside CV.  This avoids
      * the refcount loop between the outer CV (which keeps a refcount to
      * the closure prototype in the pad entry for pp_anoncode()) and the
      * closure prototype, and the ensuing memory leak.  --GSAR */
     if (!CvANON(cv) || CvCLONED(cv))
-       SvREFCNT_dec(CvOUTSIDE(cv));
+        freecv = outsidecv;
     CvOUTSIDE(cv) = Nullcv;
     if (CvCONST(cv)) {
        SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
@@ -4394,10 +4394,40 @@ Perl_cv_undef(pTHX_ CV *cv)
     if (CvPADLIST(cv)) {
        /* may be during global destruction */
        if (SvREFCNT(CvPADLIST(cv))) {
-           I32 i = AvFILLp(CvPADLIST(cv));
-           while (i >= 0) {
-               SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
-               SV* sv = svp ? *svp : Nullsv;
+           AV *padlist = CvPADLIST(cv);
+           I32 ix;
+           /* pads may be cleared out already during global destruction */
+           if (is_eval && !PL_dirty) {
+               /* inner references to eval's cv must be fixed up */
+               AV *comppad_name = (AV*)AvARRAY(padlist)[0];
+               AV *comppad = (AV*)AvARRAY(padlist)[1];
+               SV **namepad = AvARRAY(comppad_name);
+               SV **curpad = AvARRAY(comppad);
+               for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+                   SV *namesv = namepad[ix];
+                   if (namesv && namesv != &PL_sv_undef
+                       && *SvPVX(namesv) == '&'
+                       && ix <= AvFILLp(comppad))
+                   {
+                       CV *innercv = (CV*)curpad[ix];
+                       if (innercv && SvTYPE(innercv) == SVt_PVCV
+                           && CvOUTSIDE(innercv) == cv)
+                       {
+                           CvOUTSIDE(innercv) = outsidecv;
+                           if (!CvANON(innercv) || CvCLONED(innercv)) {
+                               (void)SvREFCNT_inc(outsidecv);
+                               if (SvREFCNT(cv))
+                                   SvREFCNT_dec(cv);
+                           }
+                       }
+                   }
+               }
+           }
+           if (freecv)
+               SvREFCNT_dec(freecv);
+           ix = AvFILLp(padlist);
+           while (ix >= 0) {
+               SV* sv = AvARRAY(padlist)[ix--];
                if (!sv)
                    continue;
                if (sv == (SV*)PL_comppad_name)
@@ -4412,6 +4442,8 @@ Perl_cv_undef(pTHX_ CV *cv)
        }
        CvPADLIST(cv) = Nullav;
     }
+    else if (freecv)
+       SvREFCNT_dec(freecv);
     if (CvXSUB(cv)) {
         CvXSUB(cv) = 0;
     }
@@ -7114,8 +7146,10 @@ Perl_peep(pTHX_ register OP *o)
        case OP_GREPWHILE:
        case OP_AND:
        case OP_OR:
+       case OP_DOR:
        case OP_ANDASSIGN:
        case OP_ORASSIGN:
+       case OP_DORASSIGN:
        case OP_COND_EXPR:
        case OP_RANGE:
            o->op_seq = PL_op_seqmax++;