op.c:ck_rvconst: Allocate GV pad slots like constants

[perl5.git] / op.c

diff --git a/op.c b/op.c
index 7bdfbce..357a524 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3775,7 +3775,7 @@ S_fold_constants(pTHX_ OP *o)
            {
                const char *s = SvPVX_const(sv);
                while (s < SvEND(sv)) {
-                   if (*s == 'p' || *s == 'P') goto nope;
+                   if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
                    s++;
                }
            }
@@ -5297,7 +5297,6 @@ Perl_package(pTHX_ OP *o)
 
     PL_hints |= HINT_BLOCK_SCOPE;
     PL_parser->copline = NOLINE;
-    PL_parser->expect = XSTATE;
 
     op_free(o);
 }
@@ -5436,7 +5435,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
 
     PL_hints |= HINT_BLOCK_SCOPE;
     PL_parser->copline = NOLINE;
-    PL_parser->expect = XSTATE;
     PL_cop_seqmax++; /* Purely for B::*'s benefit */
     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
        PL_cop_seqmax++;
@@ -7669,7 +7667,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
        gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
        has_name = FALSE;
     }
-
     if (!ec)
         move_proto_attr(&proto, &attrs, gv);
 
@@ -7929,8 +7926,12 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            }
        }
 
-       if (name && ! (PL_parser && PL_parser->error_count))
-           process_special_blocks(floor, name, gv, cv);
+        if (name) {
+            if (PL_parser && PL_parser->error_count)
+                clear_special_blocks(name, gv, cv);
+            else
+                process_special_blocks(floor, name, gv, cv);
+        }
     }
 
   done:
@@ -7945,6 +7946,27 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 }
 
 STATIC void
+S_clear_special_blocks(pTHX_ const char *const fullname,
+                       GV *const gv, CV *const cv) {
+    const char *colon;
+    const char *name;
+
+    PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
+
+    colon = strrchr(fullname,':');
+    name = colon ? colon + 1 : fullname;
+
+    if ((*name == 'B' && strEQ(name, "BEGIN"))
+        || (*name == 'E' && strEQ(name, "END"))
+        || (*name == 'U' && strEQ(name, "UNITCHECK"))
+        || (*name == 'C' && strEQ(name, "CHECK"))
+        || (*name == 'I' && strEQ(name, "INIT"))) {
+        GvCV_set(gv, NULL);
+        SvREFCNT_dec_NN(MUTABLE_SV(cv));
+    }
+}
+
+STATIC void
 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
                         GV *const gv,
                         CV *const cv)
@@ -8811,31 +8833,7 @@ Perl_ck_rvconst(pTHX_ OP *o)
        SV * const kidsv = kid->op_sv;
 
        /* Is it a constant from cv_const_sv()? */
-       if (SvROK(kidsv) && SvREADONLY(kidsv)) {
-           SV * const rsv = SvRV(kidsv);
-           const svtype type = SvTYPE(rsv);
-            const char *badtype = NULL;
-
-           switch (o->op_type) {
-           case OP_RV2SV:
-               if (type > SVt_PVMG)
-                   badtype = "a SCALAR";
-               break;
-           case OP_RV2AV:
-               if (type != SVt_PVAV)
-                   badtype = "an ARRAY";
-               break;
-           case OP_RV2HV:
-               if (type != SVt_PVHV)
-                   badtype = "a HASH";
-               break;
-           case OP_RV2CV:
-               if (type != SVt_PVCV)
-                   badtype = "a CODE";
-               break;
-           }
-           if (badtype)
-               Perl_croak(aTHX_ "Constant is not %s reference", badtype);
+       if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
            return o;
        }
        if (SvTYPE(kidsv) == SVt_PVAV) return o;
@@ -8888,7 +8886,7 @@ Perl_ck_rvconst(pTHX_ OP *o)
 #ifdef USE_ITHREADS
            /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
            assert (sizeof(PADOP) <= sizeof(SVOP));
-           kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
+           kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
            SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
            GvIN_PAD_on(gv);
            PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
@@ -9357,7 +9355,6 @@ Perl_ck_defined(pTHX_ OP *o)              /* 19990527 MJD */
        switch (cUNOPo->op_first->op_type) {
        case OP_RV2AV:
        case OP_PADAV:
-       case OP_AASSIGN:                /* Is this a good idea? */
            Perl_croak(aTHX_ "Can't use 'defined(@array)'"
                             " (Maybe you should just omit the defined()?)");
        break;