Fix breakages that prevended -DPERL_POISON from compiling.

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

diff --git a/op.c b/op.c
index 19eb99c..a3dee91 100644 (file)
--- a/op.c
+++ b/op.c
@@ -211,11 +211,13 @@ Perl_allocmy(pTHX_ char *name)
     PADOFFSET off;
 
     /* complain about "my $<special_var>" etc etc */
-    if (!(PL_in_my == KEY_our ||
+    if (*name &&
+       !(PL_in_my == KEY_our ||
          isALPHA(name[1]) ||
          (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
-         (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
+         (name[1] == '_' && (*name == '$' || name[2]))))
     {
+       /* name[2] is true if strlen(name) > 2  */
        if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
            /* 1999-02-27 mjd@plover.com */
            char *p;
@@ -1515,15 +1517,6 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
 
 }
 
-/* ref() is now a macro using Perl_doref;
- * this version provided for binary compatibility only.
- */
-OP *
-Perl_ref(pTHX_ OP *o, I32 type)
-{
-    return doref(o, type, TRUE);
-}
-
 STATIC OP *
 S_dup_attrlist(pTHX_ OP *o)
 {
@@ -1864,8 +1857,15 @@ Perl_scope(pTHX_ OP *o)
            o->op_type = OP_SCOPE;
            o->op_ppaddr = PL_ppaddr[OP_SCOPE];
            kid = ((LISTOP*)o)->op_first;
-           if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+           if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
                op_null(kid);
+
+               /* The following deals with things like 'do {1 for 1}' */
+               kid = kid->op_sibling;
+               if (kid &&
+                   (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
+                   op_null(kid);
+           }
        }
        else
            o = newLISTOP(OP_SCOPE, 0, o, Nullop);
@@ -1873,13 +1873,6 @@ Perl_scope(pTHX_ OP *o)
     return o;
 }
 
-/* XXX kept for BINCOMPAT only */
-void
-Perl_save_hints(pTHX)
-{
-    Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
-}
-
 int
 Perl_block_start(pTHX_ int full)
 {
@@ -4354,9 +4347,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                SAVEFREESV(PL_compcv);
                goto done;
            }
-           /* ahem, death to those who redefine active sort subs */
-           if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
-               Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
            if (block) {
                if (ckWARN(WARN_REDEFINE)
                    || (CvCONST(cv)
@@ -4516,9 +4506,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        const char *tname = (name ? name : aname);
 
        if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
-           SV *sv = NEWSV(0,0);
-           SV *tmpstr = sv_newmortal();
-           GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
+           SV * const sv = NEWSV(0,0);
+           SV * const tmpstr = sv_newmortal();
+           GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
            HV *hv;
 
            Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
@@ -4548,8 +4538,10 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            goto done;
 
        if (strEQ(s, "BEGIN") && !PL_error_count) {
+           dSP;
            const I32 oldscope = PL_scopestack_ix;
            ENTER;
+           PUSHSTACKi(PERLSI_REQUIRE);
            SAVECOPFILE(&PL_compiling);
            SAVECOPLINE(&PL_compiling);
 
@@ -4562,6 +4554,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 
            PL_curcop = &PL_compiling;
            PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+           POPSTACK;
            LEAVE;
        }
        else if (strEQ(s, "END") && !PL_error_count) {
@@ -4928,15 +4921,6 @@ Perl_newHVREF(pTHX_ OP *o)
 }
 
 OP *
-Perl_oopsCV(pTHX_ OP *o)
-{
-    Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
-    /* STUB */
-    PERL_UNUSED_ARG(o);
-    NORETURN_FUNCTION_END;
-}
-
-OP *
 Perl_newCVREF(pTHX_ I32 flags, OP *o)
 {
     return newUNOP(OP_RV2CV, flags, scalar(o));
@@ -5961,8 +5945,9 @@ Perl_ck_require(pTHX_ OP *o)
 
            for (s = SvPVX(sv); *s; s++) {
                if (*s == ':' && s[1] == ':') {
+                   const STRLEN len = strlen(s+2)+1;
                    *s = '/';
-                   Move(s+2, s+1, strlen(s+2)+1, char);
+                   Move(s+2, s+1, len, char);
                    SvCUR_set(sv, SvCUR(sv) - 1);
                }
            }
@@ -6005,16 +5990,6 @@ Perl_ck_return(pTHX_ OP *o)
     return o;
 }
 
-#if 0
-OP *
-Perl_ck_retarget(pTHX_ OP *o)
-{
-    Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
-    /* STUB */
-    return o;
-}
-#endif
-
 OP *
 Perl_ck_select(pTHX_ OP *o)
 {