Fix the implementation of list assignment to state().

[perl5.git] / op.c

diff --git a/op.c b/op.c
index c86c184..ad110e1 100644 (file)
--- a/op.c
+++ b/op.c
@@ -89,10 +89,10 @@ recursive, but it's recursive on basic blocks, not on tree nodes.
    To cause actions on %^H to write out the serialisation records, it has
    magic type 'H'. This magic (itself) does nothing, but its presence causes
    the values to gain magic type 'h', which has entries for set and clear.
-   C<Perl_magic_sethint> updates C<PL_compiling.cop_hints> with a store
+   C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
    record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
-   saves the current C<PL_compiling.cop_hints> on the save stack, so that it
-   will be correctly restored when any inner compiling scope is exited.
+   saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
+   it will be correctly restored when any inner compiling scope is exited.
 */
 
 #include "EXTERN.h"
@@ -495,14 +495,7 @@ S_cop_free(pTHX_ COP* cop)
     CopSTASH_free(cop);
     if (! specialWARN(cop->cop_warnings))
        PerlMemShared_free(cop->cop_warnings);
-    if (! specialCopIO(cop->cop_io)) {
-#ifdef USE_ITHREADS
-       NOOP;
-#else
-       SvREFCNT_dec(cop->cop_io);
-#endif
-    }
-    Perl_refcounted_he_free(aTHX_ cop->cop_hints);
+    Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
 }
 
 void
@@ -647,7 +640,7 @@ Perl_scalar(pTHX_ OP *o)
            else
                scalar(kid);
        }
-       WITH_THR(PL_curcop = &PL_compiling);
+       PL_curcop = &PL_compiling;
        break;
     case OP_SCOPE:
     case OP_LINESEQ:
@@ -658,7 +651,7 @@ Perl_scalar(pTHX_ OP *o)
            else
                scalar(kid);
        }
-       WITH_THR(PL_curcop = &PL_compiling);
+       PL_curcop = &PL_compiling;
        break;
     case OP_SORT:
        if (ckWARN(WARN_VOID))
@@ -995,7 +988,7 @@ Perl_list(pTHX_ OP *o)
            else
                list(kid);
        }
-       WITH_THR(PL_curcop = &PL_compiling);
+       PL_curcop = &PL_compiling;
        break;
     case OP_SCOPE:
     case OP_LINESEQ:
@@ -1005,7 +998,7 @@ Perl_list(pTHX_ OP *o)
            else
                list(kid);
        }
-       WITH_THR(PL_curcop = &PL_compiling);
+       PL_curcop = &PL_compiling;
        break;
     case OP_REQUIRE:
        /* all requires must return a boolean value */
@@ -1977,11 +1970,6 @@ Perl_block_start(pTHX_ int full)
     PL_hints &= ~HINT_BLOCK_SCOPE;
     SAVECOMPILEWARNINGS();
     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
-    SAVESPTR(PL_compiling.cop_io);
-    if (! specialCopIO(PL_compiling.cop_io)) {
-        PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
-        SAVEFREESV(PL_compiling.cop_io) ;
-    }
     return retval;
 }
 
@@ -3795,7 +3783,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
         * to store these values, evil chicanery is done with SvCUR().
         */
 
-       if (!(left->op_private & OPpLVAL_INTRO)) {
+       {
            OP *lastop = o;
            PL_generation++;
            for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
@@ -3850,6 +3838,34 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
            if (curop != o)
                o->op_private |= OPpASSIGN_COMMON;
        }
+
+       if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
+               && (left->op_type == OP_LIST
+                   || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
+       {
+           OP* lop = ((LISTOP*)left)->op_first;
+           while (lop) {
+               if (lop->op_type == OP_PADSV ||
+                   lop->op_type == OP_PADAV ||
+                   lop->op_type == OP_PADHV ||
+                   lop->op_type == OP_PADANY)
+               {
+                   if (lop->op_private & OPpPAD_STATE) {
+                       if (left->op_private & OPpLVAL_INTRO) {
+                           o->op_private |= OPpASSIGN_STATE;
+                           /* hijacking PADSTALE for uninitialized state variables */
+                           SvPADSTALE_on(PAD_SVl(lop->op_targ));
+                       }
+                       else { /* we already checked for WARN_MISC before */
+                           Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
+                                   PAD_COMPNAME_PV(lop->op_targ));
+                       }
+                   }
+               }
+               lop = lop->op_sibling;
+           }
+       }
+
        if (right && right->op_type == OP_SPLIT) {
            OP* tmpop = ((LISTOP*)right)->op_first;
            if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
@@ -3947,16 +3963,13 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
     }
     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, so no need to copy it.  */
+       CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
+    */
     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
-    if (specialCopIO(PL_curcop->cop_io))
-        cop->cop_io = PL_curcop->cop_io;
-    else
-        cop->cop_io = newSVsv(PL_curcop->cop_io) ;
-    cop->cop_hints = PL_curcop->cop_hints;
-    if (cop->cop_hints) {
+    cop->cop_hints_hash = PL_curcop->cop_hints_hash;
+    if (cop->cop_hints_hash) {
        HINTS_REFCNT_LOCK;
-       cop->cop_hints->refcounted_he_refcnt++;
+       cop->cop_hints_hash->refcounted_he_refcnt++;
        HINTS_REFCNT_UNLOCK;
     }
 
@@ -5831,7 +5844,7 @@ Perl_ck_bitop(pTHX_ OP *o)
         (op) == OP_EQ   || (op) == OP_I_EQ || \
         (op) == OP_NE   || (op) == OP_I_NE || \
         (op) == OP_NCMP || (op) == OP_I_NCMP)
-    o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+    o->op_private = (U8)(PL_hints & HINT_INTEGER);
     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
            && (o->op_type == OP_BIT_OR
             || o->op_type == OP_BIT_AND
@@ -6086,24 +6099,24 @@ Perl_ck_rvconst(pTHX_ register OP *o)
        /* Is it a constant from cv_const_sv()? */
        if (SvROK(kidsv) && SvREADONLY(kidsv)) {
            SV * const rsv = SvRV(kidsv);
-           const int svtype = SvTYPE(rsv);
+           const svtype type = SvTYPE(rsv);
             const char *badtype = NULL;
 
            switch (o->op_type) {
            case OP_RV2SV:
-               if (svtype > SVt_PVMG)
+               if (type > SVt_PVMG)
                    badtype = "a SCALAR";
                break;
            case OP_RV2AV:
-               if (svtype != SVt_PVAV)
+               if (type != SVt_PVAV)
                    badtype = "an ARRAY";
                break;
            case OP_RV2HV:
-               if (svtype != SVt_PVHV)
+               if (type != SVt_PVHV)
                    badtype = "a HASH";
                break;
            case OP_RV2CV:
-               if (svtype != SVt_PVCV)
+               if (type != SVt_PVCV)
                    badtype = "a CODE";
                break;
            }