Tests for Perl_get_vtbl()

[perl5.git] / op.c

diff --git a/op.c b/op.c
index e1bf353..b91f322 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1471,9 +1471,8 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type)
        if ((type == OP_UNDEF || type == OP_REFGEN) &&
            !(o->op_flags & OPf_STACKED)) {
            o->op_type = OP_RV2CV;              /* entersub => rv2cv */
-           /* The default is to set op_private to the number of children,
-              which for a UNOP such as RV2CV is always 1. And w're using
-              the bit for a flag in RV2CV, so we need it clear.  */
+           /* Both ENTERSUB and RV2CV use this bit, but for different pur-
+              poses, so we need it clear.  */
            o->op_private &= ~1;
            o->op_ppaddr = PL_ppaddr[OP_RV2CV];
            assert(cUNOPo->op_first->op_type == OP_NULL);
@@ -1569,7 +1568,8 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type)
     default:
       nomod:
        /* grep, foreach, subcalls, refgen */
-       if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
+       if (type == OP_GREPSTART || type == OP_ENTERSUB
+        || type == OP_REFGEN    || type == OP_LEAVESUBLV)
            break;
        yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
                     (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
@@ -1681,7 +1681,7 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type)
 
     case OP_KEYS:
     case OP_RKEYS:
-       if (type != OP_SASSIGN)
+       if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
            goto nomod;
        goto lvalue_func;
     case OP_SUBSTR:
@@ -1690,9 +1690,9 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type)
        /* FALL THROUGH */
     case OP_POS:
     case OP_VEC:
+      lvalue_func:
        if (type == OP_LEAVESUBLV)
            o->op_private |= OPpMAYBE_LVSUB;
-      lvalue_func:
        pad_free(o->op_targ);
        o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
        assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
@@ -1893,6 +1893,11 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
            o->op_flags |= OPf_SPECIAL;
            o->op_private &= ~1;
        }
+       else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
+           o->op_private |= OPpENTERSUB_DEREF;
+           o->op_flags |= OPf_MOD;
+       }
+
        break;
 
     case OP_COND_EXPR:
@@ -2238,8 +2243,19 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs)
            o = scalar(op_append_list(OP_LIST, rops, o));
            o->op_private |= OPpLVAL_INTRO;
        }
-       else
+       else {
+           /* The listop in rops might have a pushmark at the beginning,
+              which will mess up list assignment. */
+           LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
+           if (rops->op_type == OP_LIST && 
+               lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
+           {
+               OP * const pushmark = lrops->op_first;
+               lrops->op_first = pushmark->op_sibling;
+               op_free(pushmark);
+           }
            o = op_append_list(OP_LIST, o, rops);
+       }
     }
     PL_parser->in_my = FALSE;
     PL_parser->in_my_stash = NULL;
@@ -6367,14 +6383,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        exit.  */
        
     PL_breakable_sub_gen++;
-    if (CvLVALUE(cv)) {
-       CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
-                            op_lvalue(scalarseq(block), OP_LEAVESUBLV));
-       block->op_attached = 1;
-    }
-    else {
-       /* This makes sub {}; work as expected.  */
-       if (block->op_type == OP_STUB) {
+    /* This makes sub {}; work as expected.  */
+    if (block->op_type == OP_STUB) {
            OP* const newblock = newSTATEOP(0, NULL, 0);
 #ifdef PERL_MAD
            op_getmad(block,newblock,'B');
@@ -6382,11 +6392,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            op_free(block);
 #endif
            block = newblock;
-       }
-       else
-           block->op_attached = 1;
-       CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
     }
+    else block->op_attached = 1;
+    CvROOT(cv) = CvLVALUE(cv)
+                  ? newUNOP(OP_LEAVESUBLV, 0,
+                            op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+                  : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
     CvROOT(cv)->op_private |= OPpREFCOUNTED;
     OpREFCNT_set(CvROOT(cv), 1);
     CvSTART(cv) = LINKLIST(CvROOT(cv));
@@ -9044,6 +9055,7 @@ Perl_ck_subr(pTHX_ OP *o)
     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
 
+    o->op_private &= ~1;
     o->op_private |= OPpENTERSUB_HASTARG;
     o->op_private |= (PL_hints & HINT_STRICT_REFS);
     if (PERLDB_SUB && PL_curstash != PL_debstash)
@@ -9787,14 +9799,20 @@ Perl_rpeep(pTHX_ register OP *o)
        case OP_RV2SV:
        case OP_RV2AV:
        case OP_RV2HV:
-           if (oldop
-                && (  oldop->op_type == OP_AELEM
+           if (oldop &&
+               (
+                (
+                   (  oldop->op_type == OP_AELEM
                    || oldop->op_type == OP_PADSV
                    || oldop->op_type == OP_RV2SV
                    || oldop->op_type == OP_RV2GV
                    || oldop->op_type == OP_HELEM
                    )
                 && (oldop->op_private & OPpDEREF)
+                )
+                || (   oldop->op_type == OP_ENTERSUB
+                    && oldop->op_private & OPpENTERSUB_DEREF )
+               )
            ) {
                o->op_private |= OPpDEREFed;
            }