X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/149c1637f9ccfb0115aa2ef613b82cf441e6dd11..238d24b47319609016b1ceeca1f7146f7484b9a0:/pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index f817720..ed64242 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -60,11 +60,6 @@ PP(pp_wantarray)
     }
 }
 
-PP(pp_regcmaybe)
-{
-    return NORMAL;
-}
-
 PP(pp_regcreset)
 {
     /* XXXX Should store the old value to allow for tie/overload - and
@@ -122,7 +117,7 @@ PP(pp_regcomp)
 	    mg = mg_find(sv, PERL_MAGIC_qr);
     }
     if (mg) {
-	regexp *re = (regexp *)mg->mg_obj;
+	regexp * const re = (regexp *)mg->mg_obj;
 	ReREFCNT_dec(PM_GETRE(pm));
 	PM_SETRE(pm, ReREFCNT_inc(re));
     }
@@ -222,7 +217,7 @@ PP(pp_substcont)
 				      ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 				      : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 	{
-	    SV *targ = cx->sb_targ;
+	    SV * const targ = cx->sb_targ;
 
 	    assert(cx->sb_strend >= s);
 	    if(cx->sb_strend > s) {
@@ -280,7 +275,7 @@ PP(pp_substcont)
     }
     cx->sb_s = rx->endp[0] + orig;
     { /* Update the pos() information. */
-	SV *sv = cx->sb_targ;
+	SV * const sv = cx->sb_targ;
 	MAGIC *mg;
 	I32 i;
 	if (SvTYPE(sv) < SVt_PVMG)
@@ -368,7 +363,7 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 void
 Perl_rxres_free(pTHX_ void **rsp)
 {
-    UV *p = (UV*)*rsp;
+    UV * const p = (UV*)*rsp;
 
     if (p) {
 #ifdef PERL_POISON
@@ -392,7 +387,7 @@ Perl_rxres_free(pTHX_ void **rsp)
 PP(pp_formline)
 {
     dSP; dMARK; dORIGMARK;
-    register SV *tmpForm = *++MARK;
+    register SV * const tmpForm = *++MARK;
     register U32 *fpc;
     register char *t;
     const char *f;
@@ -408,7 +403,7 @@ PP(pp_formline)
     NV value;
     bool gotsome = FALSE;
     STRLEN len;
-    STRLEN fudge = SvPOK(tmpForm)
+    const STRLEN fudge = SvPOK(tmpForm)
 			? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
     bool item_is_utf8 = FALSE;
     bool targ_is_utf8 = FALSE;
@@ -940,11 +935,6 @@ PP(pp_grepstart)
     return ((LOGOP*)PL_op->op_next)->op_other;
 }
 
-PP(pp_mapstart)
-{
-    DIE(aTHX_ "panic: mapstart");	/* uses grepstart */
-}
-
 PP(pp_mapwhile)
 {
     dVAR; dSP;
@@ -1075,7 +1065,7 @@ PP(pp_flip)
     }
     else {
 	dTOPss;
-	SV *targ = PAD_SV(PL_op->op_targ);
+	SV * const targ = PAD_SV(PL_op->op_targ);
 	int flip = 0;
 
 	if (PL_op->op_private & OPpFLIP_LINENUM) {
@@ -1083,8 +1073,9 @@ PP(pp_flip)
 		flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
 	    }
 	    else {
-		GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
-		if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
+		GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
+		if (gv && GvSV(gv))
+		    flip = SvIV(sv) == SvIV(GvSV(gv));
 	    }
 	} else {
 	    flip = SvTRUE(sv);
@@ -1150,9 +1141,9 @@ PP(pp_flop)
 	    }
 	}
 	else {
-	    SV *final = sv_mortalcopy(right);
+	    SV * const final = sv_mortalcopy(right);
 	    STRLEN len;
-	    const char *tmps = SvPV_const(final, len);
+	    const char * const tmps = SvPV_const(final, len);
 
 	    SV *sv = sv_mortalcopy(left);
 	    SvPV_force_nolen(sv);
@@ -1470,7 +1461,7 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen)
 	    PL_curcop = cx->blk_oldcop;
 
 	    if (optype == OP_REQUIRE) {
-                const char* msg = SvPVx_nolen_const(ERRSV);
+                const char* const msg = SvPVx_nolen_const(ERRSV);
 		SV * const nsv = cx->blk_eval.old_namesv;
                 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
                                &PL_sv_undef, 0);
@@ -1499,56 +1490,6 @@ PP(pp_xor)
 	RETSETNO;
 }
 
-PP(pp_andassign)
-{
-    dSP;
-    if (!SvTRUE(TOPs))
-	RETURN;
-    else
-	RETURNOP(cLOGOP->op_other);
-}
-
-PP(pp_orassign)
-{
-    dSP;
-    if (SvTRUE(TOPs))
-	RETURN;
-    else
-	RETURNOP(cLOGOP->op_other);
-}
-
-PP(pp_dorassign)
-{
-    dSP;
-    register SV* sv;
-
-    sv = TOPs;
-    if (!sv || !SvANY(sv)) {
-	RETURNOP(cLOGOP->op_other);
-    }
-
-    switch (SvTYPE(sv)) {
-    case SVt_PVAV:
-	if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
-	    RETURN;
-	break;
-    case SVt_PVHV:
-	if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
-	    RETURN;
-	break;
-    case SVt_PVCV:
-	if (CvROOT(sv) || CvXSUB(sv))
-	    RETURN;
-	break;
-    default:
-	SvGETMAGIC(sv);
-	if (SvOK(sv))
-	    RETURN;
-    }
-
-    RETURNOP(cLOGOP->op_other);
-}
-
 PP(pp_caller)
 {
     dSP;
@@ -1728,11 +1669,6 @@ PP(pp_reset)
     RETURN;
 }
 
-PP(pp_lineseq)
-{
-    return NORMAL;
-}
-
 /* like pp_nextstate, but used instead when the debugger is active */
 
 PP(pp_dbstate)
@@ -1794,11 +1730,6 @@ PP(pp_dbstate)
 	return NORMAL;
 }
 
-PP(pp_scope)
-{
-    return NORMAL;
-}
-
 PP(pp_enteriter)
 {
     dVAR; dSP; dMARK;
@@ -1962,24 +1893,33 @@ PP(pp_return)
     SV *sv;
     OP *retop;
 
-    if (PL_curstackinfo->si_type == PERLSI_SORT) {
-	if (cxstack_ix == PL_sortcxix
-	    || dopoptosub(cxstack_ix) <= PL_sortcxix)
-	{
-	    if (cxstack_ix > PL_sortcxix)
-		dounwind(PL_sortcxix);
-	    AvARRAY(PL_curstack)[1] = *SP;
+    cxix = dopoptosub(cxstack_ix);
+    if (cxix < 0) {
+	if (CxMULTICALL(cxstack)) { /* In this case we must be in a
+				     * sort block, which is a CXt_NULL
+				     * not a CXt_SUB */
+	    dounwind(0);
+	    PL_stack_base[1] = *PL_stack_sp;
 	    PL_stack_sp = PL_stack_base + 1;
 	    return 0;
 	}
+	else
+	    DIE(aTHX_ "Can't return outside a subroutine");
     }
-
-    cxix = dopoptosub(cxstack_ix);
-    if (cxix < 0)
-	DIE(aTHX_ "Can't return outside a subroutine");
     if (cxix < cxstack_ix)
 	dounwind(cxix);
 
+    if (CxMULTICALL(&cxstack[cxix])) {
+	gimme = cxstack[cxix].blk_gimme;
+	if (gimme == G_VOID)
+	    PL_stack_sp = PL_stack_base;
+	else if (gimme == G_SCALAR) {
+	    PL_stack_base[1] = *PL_stack_sp;
+	    PL_stack_sp = PL_stack_base + 1;
+	}
+	return 0;
+    }
+
     POPBLOCK(cx,newpm);
     switch (CxTYPE(cx)) {
     case CXt_SUB:
@@ -2268,12 +2208,6 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
     return 0;
 }
 
-PP(pp_dump)
-{
-    return pp_goto();
-    /*NOTREACHED*/
-}
-
 PP(pp_goto)
 {
     dVAR; dSP;
@@ -2336,6 +2270,8 @@ PP(pp_goto)
 		else
 		    DIE(aTHX_ "Can't goto subroutine from an eval-block");
 	    }
+	    else if (CxMULTICALL(cx))
+		DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
 	    if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
 		/* put @_ back onto stack */
 		AV* av = cx->blk_sub.argarray;
@@ -2548,7 +2484,7 @@ PP(pp_goto)
 		    gotoprobe = PL_main_root;
 		break;
 	    case CXt_SUB:
-		if (CvDEPTH(cx->blk_sub.cv)) {
+		if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
 		    gotoprobe = CvROOT(cx->blk_sub.cv);
 		    break;
 		}
@@ -2780,6 +2716,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
 /* startop op_free() this to undo. */
 /* code Short string id of the caller. */
 {
+    /* FIXME - how much of this code is common with pp_entereval?  */
     dVAR; dSP;				/* Make POPBLOCK work. */
     PERL_CONTEXT *cx;
     SV **newsp;
@@ -2792,6 +2729,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
     char *safestr;
     int runtime;
     CV* runcv = Nullcv;	/* initialise to avoid compiler warnings */
+    STRLEN len;
 
     ENTER;
     lex_start(sv);
@@ -2820,8 +2758,9 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
        (i.e. before run-time proper). To work around the coredump that
        ensues, we always turn GvMULTI_on for any globals that were
        introduced within evals. See force_ident(). GSAR 96-10-12 */
-    safestr = savepv(tmpbuf);
-    SAVEDELETE(PL_defstash, safestr, strlen(safestr));
+    len = strlen(tmpbuf);
+    safestr = savepvn(tmpbuf, len);
+    SAVEDELETE(PL_defstash, safestr, len);
     SAVEHINTS();
 #ifdef OP_IN_REGISTER
     PL_opsave = op;
@@ -3093,7 +3032,6 @@ PP(pp_require)
     STRLEN len;
     const char *tryname = Nullch;
     SV *namesv = Nullsv;
-    SV** svp;
     const I32 gimme = GIMME_V;
     PerlIO *tryrsfp = 0;
     int filter_has_file = 0;
@@ -3130,12 +3068,14 @@ PP(pp_require)
     if (!(name && len > 0 && *name))
 	DIE(aTHX_ "Null filename used");
     TAINT_PROPER("require");
-    if (PL_op->op_type == OP_REQUIRE &&
-       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
-       if (*svp != &PL_sv_undef)
-           RETPUSHYES;
-       else
-           DIE(aTHX_ "Compilation failed in require");
+    if (PL_op->op_type == OP_REQUIRE) {
+	SV ** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+	if ( svp ) {
+	    if (*svp != &PL_sv_undef)
+		RETPUSHYES;
+	    else
+		DIE(aTHX_ "Compilation failed in require");
+	}
     }
 
     /* prepare to compile file */
@@ -3156,7 +3096,7 @@ PP(pp_require)
     }
 #endif
     if (!tryrsfp) {
-	AV *ar = GvAVn(PL_incgv);
+	AV * const ar = GvAVn(PL_incgv);
 	I32 i;
 #ifdef VMS
 	char *unixname;
@@ -3302,7 +3242,7 @@ PP(pp_require)
 		    sv_setpv(namesv, unixdir);
 		    sv_catpv(namesv, unixname);
 #  else
-#    ifdef SYMBIAN
+#    ifdef __SYMBIAN32__
 		    if (PL_origfilename[0] &&
 			PL_origfilename[1] == ':' &&
 			!(dir[0] && dir[1] == ':'))
@@ -3338,25 +3278,32 @@ PP(pp_require)
     if (!tryrsfp) {
 	if (PL_op->op_type == OP_REQUIRE) {
 	    const char *msgstr = name;
-	    if (namesv) {			/* did we lookup @INC? */
-		SV *msg = sv_2mortal(newSVpv(msgstr,0));
-		SV *dirmsgsv = NEWSV(0, 0);
-		AV *ar = GvAVn(PL_incgv);
-		I32 i;
-		sv_catpvn(msg, " in @INC", 8);
-		if (instr(SvPVX_const(msg), ".h "))
-		    sv_catpv(msg, " (change .h to .ph maybe?)");
-		if (instr(SvPVX_const(msg), ".ph "))
-		    sv_catpv(msg, " (did you run h2ph?)");
-		sv_catpv(msg, " (@INC contains:");
-		for (i = 0; i <= AvFILL(ar); i++) {
-		    const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
-		    Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
-		    sv_catsv(msg, dirmsgsv);
-		}
-		sv_catpvn(msg, ")", 1);
-		SvREFCNT_dec(dirmsgsv);
+	    if(errno == EMFILE) {
+		SV * const msg = sv_2mortal(newSVpv(msgstr,0));
+		sv_catpv(msg, ":  "); 
+		sv_catpv(msg, Strerror(errno));
 		msgstr = SvPV_nolen_const(msg);
+	    } else {
+	        if (namesv) {			/* did we lookup @INC? */
+		    SV * const msg = sv_2mortal(newSVpv(msgstr,0));
+		    SV * const dirmsgsv = NEWSV(0, 0);
+		    AV * const ar = GvAVn(PL_incgv);
+		    I32 i;
+		    sv_catpvn(msg, " in @INC", 8);
+		    if (instr(SvPVX_const(msg), ".h "))
+		        sv_catpv(msg, " (change .h to .ph maybe?)");
+		    if (instr(SvPVX_const(msg), ".ph "))
+		        sv_catpv(msg, " (did you run h2ph?)");
+		    sv_catpv(msg, " (@INC contains:");
+		    for (i = 0; i <= AvFILL(ar); i++) {
+		        const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
+		        Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
+		        sv_catsv(msg, dirmsgsv);
+		    }
+		    sv_catpvn(msg, ")", 1);
+		    SvREFCNT_dec(dirmsgsv);
+		    msgstr = SvPV_nolen_const(msg);
+		}    
 	    }
 	    DIE(aTHX_ "Can't locate %s", msgstr);
 	}
@@ -3367,13 +3314,14 @@ PP(pp_require)
 	SETERRNO(0, SS_NORMAL);
 
     /* Assume success here to prevent recursive requirement. */
-    len = strlen(name);
+    /* name is never assigned to again, so len is still strlen(name)  */
     /* Check whether a hook in @INC has already filled %INC */
-    if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
-	(void)hv_store(GvHVn(PL_incgv), name, len,
-		       (hook_sv ? SvREFCNT_inc(hook_sv)
-				: newSVpv(CopFILE(&PL_compiling), 0)),
-		       0 );
+    if (!hook_sv) {
+	(void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
+    } else {
+	SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+	if (!svp)
+	    (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
     }
 
     ENTER;
@@ -3427,11 +3375,6 @@ PP(pp_require)
     return op;
 }
 
-PP(pp_dofile)
-{
-    return pp_require();
-}
-
 PP(pp_entereval)
 {
     dVAR; dSP;
@@ -3447,7 +3390,7 @@ PP(pp_entereval)
     CV* runcv;
     U32 seq;
 
-    if (!SvPV_const(sv,len))
+    if (!SvPV_nolen_const(sv))
 	RETPUSHUNDEF;
     TAINT_PROPER("eval");
 
@@ -3475,8 +3418,9 @@ PP(pp_entereval)
        (i.e. before run-time proper). To work around the coredump that
        ensues, we always turn GvMULTI_on for any globals that were
        introduced within evals. See force_ident(). GSAR 96-10-12 */
-    safestr = savepv(tmpbuf);
-    SAVEDELETE(PL_defstash, safestr, strlen(safestr));
+    len = strlen(tmpbuf);
+    safestr = savepvn(tmpbuf, len);
+    SAVEDELETE(PL_defstash, safestr, len);
     SAVEHINTS();
     PL_hints = PL_op->op_targ;
     SAVESPTR(PL_compiling.cop_warnings);