Upgrade to podlators-2.1.0

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

diff --git a/op.c b/op.c
index db2a67b..c314caf 100644 (file)
--- a/op.c
+++ b/op.c
@@ -495,8 +495,6 @@ Perl_op_free(pTHX_ OP *o)
            op_free(kid);
        }
     }
-    if (type == OP_NULL)
-       type = (OPCODE)o->op_targ;
 
 #ifdef PERL_DEBUG_READONLY_OPS
     Slab_to_rw(o);
@@ -504,10 +502,16 @@ Perl_op_free(pTHX_ OP *o)
 
     /* COP* is not cleared by op_clear() so that we may track line
      * numbers etc even after null() */
-    if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
+    if (type == OP_NEXTSTATE || type == OP_DBSTATE
+           || (type == OP_NULL /* the COP might have been null'ed */
+               && ((OPCODE)o->op_targ == OP_NEXTSTATE
+                   || (OPCODE)o->op_targ == OP_DBSTATE))) {
        cop_free((COP*)o);
     }
 
+    if (type == OP_NULL)
+       type = (OPCODE)o->op_targ;
+
     op_clear(o);
     if (o->op_latefree) {
        o->op_latefreed = 1;
@@ -548,7 +552,7 @@ Perl_op_clear(pTHX_ OP *o)
     switch (o->op_type) {
     case OP_NULL:      /* Was holding old type, if any. */
        if (PL_madskills && o->op_targ != OP_NULL) {
-           o->op_type = (optype)o->op_targ;
+           o->op_type = (Optype)o->op_targ;
            o->op_targ = 0;
            goto retry;
        }
@@ -672,7 +676,6 @@ S_cop_free(pTHX_ COP* cop)
 {
     PERL_ARGS_ASSERT_COP_FREE;
 
-    CopLABEL_free(cop);
     CopFILE_free(cop);
     CopSTASH_free(cop);
     if (! specialWARN(cop->cop_warnings))
@@ -4369,10 +4372,6 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
     cop->op_next = (OP*)cop;
 
-    if (label) {
-       CopLABEL_set(cop, label);
-       PL_hints |= HINT_BLOCK_SCOPE;
-    }
     cop->cop_seq = seq;
     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
@@ -4384,6 +4383,16 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
        cop->cop_hints_hash->refcounted_he_refcnt++;
        HINTS_REFCNT_UNLOCK;
     }
+    if (label) {
+       cop->cop_hints_hash
+           = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
+                                                    
+       PL_hints |= HINT_BLOCK_SCOPE;
+       /* It seems that we need to defer freeing this pointer, as other parts
+          of the grammar end up wanting to copy it after this op has been
+          created. */
+       SAVEFREEPV(label);
+    }
 
     if (PL_parser && PL_parser->copline == NOLINE)
         CopLINE_set(cop, CopLINE(PL_curcop));
@@ -4410,6 +4419,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
        }
     }
 
+    if (flags & OPf_SPECIAL)
+       op_null((OP*)cop);
     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
 }
 
@@ -5052,7 +5063,7 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
     PERL_ARGS_ASSERT_NEWGIVWHENOP;
 
     NewOp(1101, enterop, 1, LOGOP);
-    enterop->op_type = (optype)enter_opcode;
+    enterop->op_type = (Optype)enter_opcode;
     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
     enterop->op_flags =  (U8) OPf_KIDS;
     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
@@ -6545,7 +6556,7 @@ Perl_ck_exists(pTHX_ OP *o)
        else if (kid->op_type == OP_AELEM)
            o->op_flags |= OPf_SPECIAL;
        else if (kid->op_type != OP_HELEM)
-           Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
+           Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
                        OP_DESC(o));
        op_null(kid);
     }
@@ -7404,7 +7415,9 @@ Perl_ck_open(pTHX_ OP *o)
     if (table) {
        SV **svp = hv_fetchs(table, "open_IN", FALSE);
        if (svp && *svp) {
-           const I32 mode = mode_from_discipline(*svp);
+           STRLEN len = 0;
+           const char *d = SvPV_const(*svp, len);
+           const I32 mode = mode_from_discipline(d, len);
            if (mode & O_BINARY)
                o->op_private |= OPpOPEN_IN_RAW;
            else if (mode & O_TEXT)
@@ -7413,7 +7426,9 @@ Perl_ck_open(pTHX_ OP *o)
 
        svp = hv_fetchs(table, "open_OUT", FALSE);
        if (svp && *svp) {
-           const I32 mode = mode_from_discipline(*svp);
+           STRLEN len = 0;
+           const char *d = SvPV_const(*svp, len);
+           const I32 mode = mode_from_discipline(d, len);
            if (mode & O_BINARY)
                o->op_private |= OPpOPEN_OUT_RAW;
            else if (mode & O_TEXT)