Allow -C on the #! line when it is identical to -C on the command line.

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

diff --git a/op.c b/op.c
index b889319..d7ef32c 100644 (file)
--- a/op.c
+++ b/op.c
@@ -103,6 +103,7 @@ recursive, but it's recursive on basic blocks, not on tree nodes.
 #include "keywords.h"
 
 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
+#define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
 
 #if defined(PL_OP_SLAB_ALLOC)
 
@@ -399,14 +400,6 @@ Perl_allocmy(pTHX_ const char *const name)
     /* check for duplicate declaration */
     pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
 
-    if (PL_parser->in_my_stash && *name != '$') {
-       yyerror(Perl_form(aTHX_
-                   "Can't declare class for non-scalar %s in \"%s\"",
-                    name,
-                    is_our ? "our"
-                           : PL_parser->in_my == KEY_state ? "state" : "my"));
-    }
-
     /* allocate a spare slot and store the name in that slot */
 
     off = pad_add_name(name,
@@ -490,6 +483,11 @@ Perl_op_free(pTHX_ OP *o)
        }
     }
 
+    /* Call the op_free hook if it has been set. Do it now so that it's called
+     * at the right time for refcounted ops, but still before all of the kids
+     * are freed. */
+    CALL_OPFREEHOOK(o);
+
     if (o->op_flags & OPf_KIDS) {
         register OP *kid, *nextkid;
        for (kid = cUNOPo->op_first; kid; kid = nextkid) {
@@ -3347,6 +3345,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
        PAD_SETSV(cPADOPo->op_padix, swash);
        SvPADTMP_on(swash);
+       SvREADONLY_on(swash);
 #else
        cSVOPo->op_sv = swash;
 #endif
@@ -3865,7 +3864,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
            SV *meth;
 
            if (version->op_type != OP_CONST || !SvNIOKp(vesv))
-               Perl_croak(aTHX_ "Version number must be constant number");
+               Perl_croak(aTHX_ "Version number must be a constant number");
 
            /* Make copy of idop so we don't free it twice */
            pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
@@ -4333,7 +4332,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
                      ((LISTOP*)right)->op_last->op_type == OP_CONST)
                    {
                        SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
-                       if (SvIVX(sv) == 0)
+                       if (SvIOK(sv) && SvIVX(sv) == 0)
                            sv_setiv(sv, PL_modcount+1);
                    }
                }
@@ -4355,6 +4354,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
            PL_eval_start = 0;
        else {
            if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
+               deprecate("assignment to $[");
                op_free(o);
                o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
                o->op_private |= OPpCONST_ARYBASE;
@@ -5183,6 +5183,7 @@ S_looks_like_bool(pTHX_ const OP *o)
 
     switch(o->op_type) {
        case OP_OR:
+       case OP_DOR:
            return looks_like_bool(cLOGOPo->op_first);
 
        case OP_AND:
@@ -5198,7 +5199,6 @@ S_looks_like_bool(pTHX_ const OP *o)
        case OP_ENTERSUB:
 
        case OP_NOT:    case OP_XOR:
-       /* Note that OP_DOR is not here */
 
        case OP_EQ:     case OP_NE:     case OP_LT:
        case OP_GT:     case OP_LE:     case OP_GE:
@@ -5223,6 +5223,8 @@ S_looks_like_bool(pTHX_ const OP *o)
        case OP_DEFINED: case OP_EXISTS:
        case OP_MATCH:   case OP_EOF:
 
+       case OP_FLOP:
+
            return TRUE;
        
        case OP_CONST:
@@ -5231,7 +5233,9 @@ S_looks_like_bool(pTHX_ const OP *o)
            ||  cSVOPo->op_sv == &PL_sv_no)
            
                return TRUE;
-               
+           else
+               return FALSE;
+
        /* FALL THROUGH */
        default:
            return FALSE;
@@ -5587,12 +5591,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 
     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
 
-#ifdef GV_UNIQUE_CHECK
-    if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
-        Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
-    }
-#endif
-
     if (!block || !ps || *ps || attrs
        || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
 #ifdef PERL_MAD
@@ -5606,12 +5604,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     if (cv) {
         const bool exists = CvROOT(cv) || CvXSUB(cv);
 
-#ifdef GV_UNIQUE_CHECK
-        if (exists && GvUNIQUE(gv)) {
-            Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
-        }
-#endif
-
         /* if the subroutine doesn't exist and wasn't pre-declared
          * with a prototype, assume it will be AUTOLOADed,
          * skipping the prototype check
@@ -6154,20 +6146,19 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
        ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
        : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
 
-#ifdef GV_UNIQUE_CHECK
-    if (GvUNIQUE(gv)) {
-        Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
-    }
-#endif
     GvMULTI_on(gv);
     if ((cv = GvFORM(gv))) {
        if (ckWARN(WARN_REDEFINE)) {
            const line_t oldline = CopLINE(PL_curcop);
            if (PL_parser && PL_parser->copline != NOLINE)
                CopLINE_set(PL_curcop, PL_parser->copline);
-           Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
-                       o ? "Format %"SVf" redefined"
-                       : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
+           if (o) {
+               Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+                           "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
+           } else {
+               Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+                           "Format STDOUT redefined");
+           }
            CopLINE_set(PL_curcop, oldline);
        }
        SvREFCNT_dec(cv);
@@ -8977,6 +8968,7 @@ const_sv_xsub(pTHX_ CV* cv)
     if (items != 0) {
        NOOP;
 #if 0
+       /* diag_listed_as: SKIPME */
         Perl_croak(aTHX_ "usage: %s::%s()",
                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
 #endif