/* pp_ctl.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * Copyright (c) 1991-1997, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#define WORD_ALIGN sizeof(U16)
#endif
+#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
+
+static OP *docatch _((OP *o));
static OP *doeval _((int gimme));
static OP *dofindlabel _((OP *op, char *label, OP **opstack));
static void doparseform _((SV *sv));
if (cxix < 0)
RETPUSHUNDEF;
- if (cxstack[cxix].blk_gimme == G_ARRAY)
+ switch (cxstack[cxix].blk_gimme) {
+ case G_ARRAY:
RETPUSHYES;
- else
+ case G_SCALAR:
RETPUSHNO;
+ default:
+ RETPUSHUNDEF;
+ }
}
PP(pp_regcmaybe)
if (!cx->sb_rxtainted)
cx->sb_rxtainted = SvTAINTED(TOPs);
sv_catsv(dstr, POPs);
- if (rx->subbase)
- Safefree(rx->subbase);
- rx->subbase = cx->sb_subbase;
/* Are we done */
if (cx->sb_once || !pregexec(rx, s, cx->sb_strend, orig,
SV *targ = cx->sb_targ;
sv_catpvn(dstr, s, cx->sb_strend - s);
+ TAINT_IF(cx->sb_rxtainted || rx->exec_tainted);
+
(void)SvOOK_off(targ);
Safefree(SvPVX(targ));
SvPVX(targ) = SvPVX(dstr);
SvLEN_set(targ, SvLEN(dstr));
SvPVX(dstr) = 0;
sv_free(dstr);
-
(void)SvPOK_only(targ);
SvSETMAGIC(targ);
- if (cx->sb_rxtainted)
- SvTAINTED_on(targ);
+ SvTAINT(targ);
+
PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
LEAVE_SCOPE(cx->sb_oldsave);
POPSUBST(cx);
cx->sb_m = m = rx->startp[0];
sv_catpvn(dstr, s, m-s);
cx->sb_s = rx->endp[0];
- cx->sb_subbase = rx->subbase;
cx->sb_rxtainted |= rx->exec_tainted;
-
- rx->subbase = Nullch; /* so recursion works */
RETURNOP(pm->op_pmreplstart);
}
if (stack_base + *markstack_ptr == sp) {
(void)POPMARK;
- if (GIMME != G_ARRAY)
+ if (GIMME_V == G_SCALAR)
XPUSHs(&sv_no);
RETURNOP(op->op_next->op_next);
}
/* All done yet? */
if (markstack_ptr[-1] > *markstack_ptr) {
I32 items;
+ I32 gimme = GIMME_V;
(void)POPMARK; /* pop top */
LEAVE; /* exit outer scope */
items = --*markstack_ptr - markstack_ptr[-1];
(void)POPMARK; /* pop dst */
SP = stack_base + POPMARK; /* pop original mark */
- if (GIMME != G_ARRAY) {
+ if (gimme == G_SCALAR) {
dTARGET;
XPUSHi(items);
- RETURN;
}
- SP += items;
+ else if (gimme == G_ARRAY)
+ SP += items;
RETURN;
}
else {
while (MARK < SP) { /* This may or may not shift down one here. */
/*SUPPRESS 560*/
if (*up = *++MARK) { /* Weed out nulls. */
- if (!SvPOK(*up))
+ SvTEMP_off(*up);
+ if (!sortcop && !SvPOK(*up))
(void)sv_2pv(*up, &na);
- else
- SvTEMP_off(*up);
up++;
}
}
AV *oldstack;
CONTEXT *cx;
SV** newsp;
+ bool oldcatch = CATCH_GET;
SAVETMPS;
SAVESPTR(op);
AvREAL_off(sortstack);
av_extend(sortstack, 32);
}
+ CATCH_SET(TRUE);
SWITCHSTACK(curstack, sortstack);
if (sortstash != stash) {
firstgv = gv_fetchpv("a", TRUE, SVt_PV);
SAVESPTR(GvSV(firstgv));
SAVESPTR(GvSV(secondgv));
- PUSHBLOCK(cx, CXt_LOOP, stack_base);
+ PUSHBLOCK(cx, CXt_NULL, stack_base);
sortcxix = cxstack_ix;
qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv);
POPBLOCK(cx,curpm);
SWITCHSTACK(sortstack, oldstack);
+ CATCH_SET(oldcatch);
}
LEAVE;
}
if (dowarn)
warn("Exiting eval via %s", op_name[op->op_type]);
break;
+ case CXt_NULL:
+ if (dowarn)
+ warn("Exiting pseudo-block via %s", op_name[op->op_type]);
+ return -1;
case CXt_LOOP:
if (!cx->blk_loop.label ||
strNE(label, cx->blk_loop.label) ) {
- DEBUG_l(deb("(Skipping label #%d %s)\n",
- i, cx->blk_loop.label));
+ DEBUG_l(deb("(Skipping label #%ld %s)\n",
+ (long)i, cx->blk_loop.label));
continue;
}
- DEBUG_l( deb("(Found label #%d %s)\n", i, label));
+ DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
return i;
}
}
I32
dowantarray()
{
+ I32 gimme = block_gimme();
+ return (gimme == G_VOID) ? G_SCALAR : gimme;
+}
+
+I32
+block_gimme()
+{
I32 cxix;
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
return G_SCALAR;
- if (cxstack[cxix].blk_gimme == G_ARRAY)
- return G_ARRAY;
- else
+ switch (cxstack[cxix].blk_gimme) {
+ case G_VOID:
+ return G_VOID;
+ case G_SCALAR:
return G_SCALAR;
+ case G_ARRAY:
+ return G_ARRAY;
+ default:
+ croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
+ }
}
static I32
continue;
case CXt_EVAL:
case CXt_SUB:
- DEBUG_l( deb("(Found sub #%d)\n", i));
+ DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
return i;
}
}
default:
continue;
case CXt_EVAL:
- DEBUG_l( deb("(Found eval #%d)\n", i));
+ DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
return i;
}
}
if (dowarn)
warn("Exiting eval via %s", op_name[op->op_type]);
break;
+ case CXt_NULL:
+ if (dowarn)
+ warn("Exiting pseudo-block via %s", op_name[op->op_type]);
+ return -1;
case CXt_LOOP:
- DEBUG_l( deb("(Found loop #%d)\n", i));
+ DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
return i;
}
}
case CXt_LOOP:
POPLOOP(cx);
break;
+ case CXt_NULL:
case CXt_SUBST:
break;
}
LEAVE;
- if (optype == OP_REQUIRE)
- DIE("%s", SvPVx(GvSV(errgv), na));
+ if (optype == OP_REQUIRE) {
+ char* msg = SvPVx(GvSV(errgv), na);
+ DIE("%s", *msg ? msg : "Compilation failed in require");
+ }
return pop_return();
}
}
PerlIO_printf(PerlIO_stderr(), "%s",message);
PerlIO_flush(PerlIO_stderr());
- if (e_tmpname) {
- if (e_fp) {
- PerlIO_close(e_fp);
- e_fp = Nullfp;
- }
- (void)UNLINK(e_tmpname);
- Safefree(e_tmpname);
- e_tmpname = Nullch;
- }
- statusvalue = SHIFTSTATUS(statusvalue);
-#ifdef VMS
- my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
-#else
- my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
-#endif
+ my_failure_exit();
+ /* NOTREACHED */
return 0;
}
register I32 cxix = dopoptosub(cxstack_ix);
register CONTEXT *cx;
I32 dbcxix;
+ I32 gimme;
SV *sv;
I32 count = 0;
PUSHs(sv_2mortal(newSVpv("(eval)",0)));
PUSHs(sv_2mortal(newSViv(0)));
}
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme)));
+ gimme = (I32)cx->blk_gimme;
+ if (gimme == G_VOID)
+ PUSHs(&sv_undef);
+ else
+ PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
if (cx->cx_type == CXt_EVAL) {
if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
PUSHs(cx->blk_eval.cur_text);
const void *a;
const void *b;
{
- SV **str1 = (SV **) a;
- SV **str2 = (SV **) b;
+ SV * const *str1 = (SV * const *)a;
+ SV * const *str2 = (SV * const *)b;
I32 oldsaveix = savestack_ix;
I32 oldscopeix = scopestack_ix;
I32 result;
const void *a;
const void *b;
{
- return sv_cmp(*(SV **)a, *(SV **)b);
+ return sv_cmp(*(SV * const *)a, *(SV * const *)b);
}
static int
const void *a;
const void *b;
{
- return sv_cmp_locale(*(SV **)a, *(SV **)b);
+ return sv_cmp_locale(*(SV * const *)a, *(SV * const *)b);
}
PP(pp_reset)
{
dSP; dMARK;
register CONTEXT *cx;
- I32 gimme = GIMME;
+ I32 gimme = GIMME_V;
SV **svp;
ENTER;
{
dSP;
register CONTEXT *cx;
- I32 gimme = GIMME;
+ I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
{
dSP;
register CONTEXT *cx;
+ struct block_loop cxloop;
I32 gimme;
SV **newsp;
PMOP *newpm;
POPBLOCK(cx,newpm);
mark = newsp;
- POPLOOP(cx);
- if (gimme == G_SCALAR) {
- if (op->op_private & OPpLEAVE_VOID)
- ;
- else {
- if (mark < SP)
- *++newsp = sv_mortalcopy(*SP);
- else
- *++newsp = &sv_undef;
- }
+ POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
+
+ if (gimme == G_VOID)
+ ; /* do nothing */
+ else if (gimme == G_SCALAR) {
+ if (mark < SP)
+ *++newsp = sv_mortalcopy(*SP);
+ else
+ *++newsp = &sv_undef;
}
else {
while (mark < SP)
*++newsp = sv_mortalcopy(*++mark);
}
- curpm = newpm; /* Don't pop $1 et al till now */
- sp = newsp;
+ SP = newsp;
+ PUTBACK;
+
+ POPLOOP2(); /* Stack values are safe: release loop vars ... */
+ curpm = newpm; /* ... and pop $1 et al */
+
LEAVE;
LEAVE;
- RETURN;
+ return NORMAL;
}
PP(pp_return)
dSP; dMARK;
I32 cxix;
register CONTEXT *cx;
+ struct block_sub cxsub;
+ bool popsub2 = FALSE;
I32 gimme;
SV **newsp;
PMOP *newpm;
POPBLOCK(cx,newpm);
switch (cx->cx_type) {
case CXt_SUB:
- POPSUB(cx);
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+ popsub2 = TRUE;
break;
case CXt_EVAL:
POPEVAL(cx);
if (optype == OP_REQUIRE &&
(MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
{
+ /* Unassume the success we assumed earlier. */
char *name = cx->blk_eval.old_name;
(void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
DIE("%s did not return a true value", name);
break;
default:
DIE("panic: return");
- break;
}
if (gimme == G_SCALAR) {
if (MARK < SP)
- *++newsp = sv_mortalcopy(*SP);
+ *++newsp = (popsub2 && SvTEMP(*SP))
+ ? *SP : sv_mortalcopy(*SP);
else
*++newsp = &sv_undef;
}
- else {
- while (MARK < SP)
- *++newsp = sv_mortalcopy(*++MARK);
+ else if (gimme == G_ARRAY) {
+ while (++MARK <= SP)
+ *++newsp = (popsub2 && SvTEMP(*MARK))
+ ? *MARK : sv_mortalcopy(*MARK);
}
- curpm = newpm; /* Don't pop $1 et al till now */
stack_sp = newsp;
+ /* Stack values are safe: */
+ if (popsub2) {
+ POPSUB2(); /* release CV and @_ ... */
+ }
+ curpm = newpm; /* ... and pop $1 et al */
+
LEAVE;
return pop_return();
}
dSP;
I32 cxix;
register CONTEXT *cx;
+ struct block_loop cxloop;
+ struct block_sub cxsub;
+ I32 pop2 = 0;
I32 gimme;
I32 optype;
OP *nextop;
POPBLOCK(cx,newpm);
switch (cx->cx_type) {
case CXt_LOOP:
- POPLOOP(cx);
- nextop = cx->blk_loop.last_op->op_next;
- LEAVE;
+ POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
+ pop2 = CXt_LOOP;
+ nextop = cxloop.last_op->op_next;
break;
- case CXt_EVAL:
- POPEVAL(cx);
+ case CXt_SUB:
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+ pop2 = CXt_SUB;
nextop = pop_return();
break;
- case CXt_SUB:
- POPSUB(cx);
+ case CXt_EVAL:
+ POPEVAL(cx);
nextop = pop_return();
break;
default:
DIE("panic: last");
- break;
}
if (gimme == G_SCALAR) {
- if (mark < SP)
- *++newsp = sv_mortalcopy(*SP);
+ if (MARK < SP)
+ *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
+ ? *SP : sv_mortalcopy(*SP);
else
*++newsp = &sv_undef;
}
- else {
- while (mark < SP)
- *++newsp = sv_mortalcopy(*++mark);
+ else if (gimme == G_ARRAY) {
+ while (++MARK <= SP)
+ *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
+ ? *MARK : sv_mortalcopy(*MARK);
}
- curpm = newpm; /* Don't pop $1 et al till now */
- sp = newsp;
+ SP = newsp;
+ PUTBACK;
+
+ /* Stack values are safe: */
+ switch (pop2) {
+ case CXt_LOOP:
+ POPLOOP2(); /* release loop vars ... */
+ LEAVE;
+ break;
+ case CXt_SUB:
+ POPSUB2(); /* release CV and @_ ... */
+ break;
+ }
+ curpm = newpm; /* ... and pop $1 et al */
LEAVE;
- RETURNOP(nextop);
+ return nextop;
}
PP(pp_next)
else
gotoprobe = main_root;
break;
+ case CXt_NULL:
+ DIE("Can't \"goto\" outside a block");
default:
if (ix)
DIE("panic: goto");
- else
- gotoprobe = main_root;
+ gotoprobe = main_root;
break;
}
retop = dofindlabel(gotoprobe, label, enterops);
if (curstack == signalstack) {
restartop = retop;
- Siglongjmp(top_env, 3);
+ JMPENV_JUMP(3);
}
RETURNOP(retop);
if (MAXARG < 1)
anum = 0;
- else
+ else {
anum = SvIVx(POPs);
+#ifdef VMSISH_EXIT
+ if (anum == 1 && VMSISH_EXIT)
+ anum = 0;
+#endif
+ }
my_exit(anum);
PUSHs(&sv_undef);
RETURN;
}
static OP *
+docatch(o)
+OP *o;
+{
+ int ret;
+ I32 oldrunlevel = runlevel;
+ OP *oldop = op;
+ dJMPENV;
+
+ op = o;
+#ifdef DEBUGGING
+ assert(CATCH_GET == TRUE);
+ DEBUG_l(deb("(Setting up local jumplevel, runlevel = %ld)\n", (long)runlevel+1));
+#endif
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ default: /* topmost level handles it */
+ JMPENV_POP;
+ runlevel = oldrunlevel;
+ op = oldop;
+ JMPENV_JUMP(ret);
+ /* NOTREACHED */
+ case 3:
+ if (!restartop) {
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ break;
+ }
+ op = restartop;
+ restartop = 0;
+ /* FALL THROUGH */
+ case 0:
+ runops();
+ break;
+ }
+ JMPENV_POP;
+ runlevel = oldrunlevel;
+ op = oldop;
+ return Nullop;
+}
+
+static OP *
doeval(gimme)
int gimme;
{
pop_return();
lex_end();
LEAVE;
- if (optype == OP_REQUIRE)
- DIE("%s", SvPVx(GvSV(errgv), na));
+ if (optype == OP_REQUIRE) {
+ char* msg = SvPVx(GvSV(errgv), na);
+ DIE("%s", *msg ? msg : "Compilation failed in require");
+ }
SvREFCNT_dec(rs);
rs = SvREFCNT_inc(nrs);
RETPUSHUNDEF;
rs = SvREFCNT_inc(nrs);
compiling.cop_line = 0;
SAVEFREEOP(eval_root);
- if (gimme & G_ARRAY)
+ if (gimme & G_VOID)
+ scalarvoid(eval_root);
+ else if (gimme & G_ARRAY)
list(eval_root);
else
scalar(eval_root);
DEBUG_x(dump_eval());
/* Register with debugger: */
-
if (perldb && saveop->op_type == OP_REQUIRE) {
CV *cv = perl_get_cv("DB::postponed", FALSE);
-
if (cv) {
dSP;
PUSHMARK(sp);
/* compiled okay, so do it */
+ CvDEPTH(compcv) = 1;
+
SP = stack_base + POPMARK; /* pop original mark */
RETURNOP(eval_start);
}
compiling.cop_line = 0;
PUTBACK;
- return doeval(G_SCALAR);
+ return DOCATCH(doeval(G_SCALAR));
}
PP(pp_dofile)
dSP;
register CONTEXT *cx;
dPOPss;
- I32 gimme = GIMME, was = sub_generation;
+ I32 gimme = GIMME_V, was = sub_generation;
char tmpbuf[32], *safestr;
STRLEN len;
OP *ret;
/* switch to eval mode */
SAVESPTR(compiling.cop_filegv);
- sprintf(tmpbuf, "_<(eval %d)", ++evalseq);
+ sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
compiling.cop_line = 1;
/* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
if (perldb && was != sub_generation) { /* Some subs defined here. */
strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
}
- return ret;
+ return DOCATCH(ret);
}
PP(pp_leaveeval)
POPEVAL(cx);
retop = pop_return();
- if (gimme == G_SCALAR) {
- if (op->op_private & OPpLEAVE_VOID)
- MARK = newsp;
+ if (gimme == G_VOID)
+ MARK = newsp;
+ else if (gimme == G_SCALAR) {
+ MARK = newsp + 1;
+ if (MARK <= SP) {
+ if (SvFLAGS(TOPs) & SVs_TEMP)
+ *MARK = TOPs;
+ else
+ *MARK = sv_mortalcopy(TOPs);
+ }
else {
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & SVs_TEMP)
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &sv_undef;
- }
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
}
- SP = MARK;
}
else {
for (mark = newsp + 1; mark <= SP; mark++)
}
curpm = newpm; /* Don't pop $1 et al till now */
- if (optype == OP_REQUIRE &&
- !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
- char *name = cx->blk_eval.old_name;
+#ifdef DEBUGGING
+ assert(CvDEPTH(compcv) == 1);
+#endif
+ CvDEPTH(compcv) = 0;
+ if (optype == OP_REQUIRE &&
+ !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp))
+ {
/* Unassume the success we assumed earlier. */
+ char *name = cx->blk_eval.old_name;
(void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
retop = die("%s did not return a true value", name);
}
lex_end();
LEAVE;
+
if (!(save_flags & OPf_SPECIAL))
sv_setpv(GvSV(errgv),"");
{
dSP;
register CONTEXT *cx;
- I32 gimme = GIMME;
+ I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
in_eval = 1;
sv_setpv(GvSV(errgv),"");
- RETURN;
+ PUTBACK;
+ return DOCATCH(op->op_next);
}
PP(pp_leavetry)
POPEVAL(cx);
pop_return();
- if (gimme == G_SCALAR) {
- if (op->op_private & OPpLEAVE_VOID)
- MARK = newsp;
+ if (gimme == G_VOID)
+ SP = newsp;
+ else if (gimme == G_SCALAR) {
+ MARK = newsp + 1;
+ if (MARK <= SP) {
+ if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
+ *MARK = TOPs;
+ else
+ *MARK = sv_mortalcopy(TOPs);
+ }
else {
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &sv_undef;
- }
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
}
SP = MARK;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff