X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=a3dee91b333de62ba8ea791c0f4d5b35f324d7be;hb=06c0cc96ebd866767a6d107ed78967600f7e0395;hp=5d593f8edfc2b15857df71d3ca3be393bcc25b23;hpb=585ec06d680e861557397efeb05210638532c6dc;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/op.c b/op.c
index 5d593f8..a3dee91 100644
--- 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;
@@ -1422,7 +1424,7 @@ Perl_refkids(pTHX_ OP *o, I32 type)
 }
 
 OP *
-Perl_ref(pTHX_ OP *o, I32 type)
+Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
 {
     dVAR;
     OP *kid;
@@ -1444,12 +1446,12 @@ Perl_ref(pTHX_ OP *o, I32 type)
 
     case OP_COND_EXPR:
 	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
-	    ref(kid, type);
+	    doref(kid, type, set_op_ref);
 	break;
     case OP_RV2SV:
 	if (type == OP_DEFINED)
 	    o->op_flags |= OPf_SPECIAL;		/* don't create GV */
-	ref(cUNOPo->op_first, o->op_type);
+	doref(cUNOPo->op_first, o->op_type, set_op_ref);
 	/* FALL THROUGH */
     case OP_PADSV:
 	if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
@@ -1466,28 +1468,30 @@ Perl_ref(pTHX_ OP *o, I32 type)
 
     case OP_RV2AV:
     case OP_RV2HV:
-	o->op_flags |= OPf_REF;
+	if (set_op_ref)
+	    o->op_flags |= OPf_REF;
 	/* FALL THROUGH */
     case OP_RV2GV:
 	if (type == OP_DEFINED)
 	    o->op_flags |= OPf_SPECIAL;		/* don't create GV */
-	ref(cUNOPo->op_first, o->op_type);
+	doref(cUNOPo->op_first, o->op_type, set_op_ref);
 	break;
 
     case OP_PADAV:
     case OP_PADHV:
-	o->op_flags |= OPf_REF;
+	if (set_op_ref)
+	    o->op_flags |= OPf_REF;
 	break;
 
     case OP_SCALAR:
     case OP_NULL:
 	if (!(o->op_flags & OPf_KIDS))
 	    break;
-	ref(cBINOPo->op_first, type);
+	doref(cBINOPo->op_first, type, set_op_ref);
 	break;
     case OP_AELEM:
     case OP_HELEM:
-	ref(cBINOPo->op_first, o->op_type);
+	doref(cBINOPo->op_first, o->op_type, set_op_ref);
 	if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
 	    o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
 			      : type == OP_RV2HV ? OPpDEREF_HV
@@ -1498,11 +1502,13 @@ Perl_ref(pTHX_ OP *o, I32 type)
 
     case OP_SCOPE:
     case OP_LEAVE:
+	set_op_ref = FALSE;
+	/* FALL THROUGH */
     case OP_ENTER:
     case OP_LIST:
 	if (!(o->op_flags & OPf_KIDS))
 	    break;
-	ref(cLISTOPo->op_last, type);
+	doref(cLISTOPo->op_last, type, set_op_ref);
 	break;
     default:
 	break;
@@ -1851,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);
@@ -1860,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)
 {
@@ -4341,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)
@@ -4503,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",
@@ -4535,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);
 
@@ -4549,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) {
@@ -4915,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));
@@ -5948,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);
 		}
 	    }
@@ -5992,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)
 {