/* 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));
static I32 dopoptoloop _((I32 startingblock));
static I32 dopoptosub _((I32 startingblock));
static void save_lines _((AV *array, SV *sv));
-static int sortcmp _((const void *, const void *));
static int sortcv _((const void *, const void *));
+static int sortcmp _((const void *, const void *));
+static int sortcmp_locale _((const void *, const void *));
static I32 sortcxix;
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)
tmpstr = POPs;
t = SvPV(tmpstr, len);
- if (pm->op_pmregexp) {
- regfree(pm->op_pmregexp);
- pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
- }
+ /* JMR: Check against the last compiled regexp */
+ if ( ! pm->op_pmregexp || ! pm->op_pmregexp->precomp
+ || strnNE(pm->op_pmregexp->precomp, t, len)
+ || pm->op_pmregexp->precomp[len]) {
+ if (pm->op_pmregexp) {
+ pregfree(pm->op_pmregexp);
+ pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
+ }
- pm->op_pmregexp = regcomp(t, t + len, pm);
+ pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
+ pm->op_pmregexp = pregcomp(t, t + len, pm);
+ }
if (!pm->op_pmregexp->prelen && curpm)
pm = curpm;
pm->op_pmflags |= PMf_WHITE;
if (pm->op_pmflags & PMf_KEEP) {
-#ifdef NOTDEF
- if (!(pm->op_pmflags & PMf_FOLD))
- scan_prefix(pm, pm->op_pmregexp->precomp,
- pm->op_pmregexp->prelen);
-#endif
pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */
hoistmust(pm);
cLOGOP->op_first->op_next = op->op_next;
- /* XXX delete push code? */
}
RETURN;
}
register char *s = cx->sb_s;
register char *m = cx->sb_m;
char *orig = cx->sb_orig;
- register REGEXP *rx = pm->op_pmregexp;
+ register REGEXP *rx = cx->sb_rx;
if (cx->sb_iters++) {
if (cx->sb_iters > cx->sb_maxiters)
DIE("Substitution loop");
+ 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 || !regexec(rx, s, cx->sb_strend, orig,
+ if (cx->sb_once || !pregexec(rx, s, cx->sb_strend, orig,
s == m, Nullsv, cx->sb_safebase))
{
SV *targ = cx->sb_targ;
sv_catpvn(dstr, s, cx->sb_strend - s);
- sv_replace(targ, dstr);
+
+ TAINT_IF(cx->sb_rxtainted || rx->exec_tainted);
+
+ (void)SvOOK_off(targ);
+ Safefree(SvPVX(targ));
+ SvPVX(targ) = SvPVX(dstr);
+ SvCUR_set(targ, SvCUR(dstr));
+ SvLEN_set(targ, SvLEN(dstr));
+ SvPVX(dstr) = 0;
+ sv_free(dstr);
+
(void)SvPOK_only(targ);
SvSETMAGIC(targ);
+ SvTAINT(targ);
PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
+ LEAVE_SCOPE(cx->sb_oldsave);
POPSUBST(cx);
RETURNOP(pm->op_next);
}
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);
bool chopspace = (strchr(chopset, ' ') != Nullch);
char *chophere;
char *linemark;
- char *formmark;
- SV **markmark;
double value;
bool gotsome;
STRLEN len;
- if (!SvCOMPILED(form)) {
+ if (!SvMAGICAL(form) || !SvCOMPILED(form)) {
SvREADONLY_off(form);
doparseform(form);
}
case FF_END: name = "END"; break;
}
if (arg >= 0)
- fprintf(stderr, "%-16s%ld\n", name, (long) arg);
+ PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
else
- fprintf(stderr, "%-16s\n", name);
+ PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
} )
switch (*fpc++) {
case FF_LINEMARK:
linemark = t;
- formmark = f;
- markmark = MARK;
lines++;
gotsome = FALSE;
break;
}
gotsome = TRUE;
value = SvNV(sv);
+ /* Formats aren't yet marked for locales, so assume "yes". */
+ SET_NUMERIC_LOCAL();
if (arg & 256) {
sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
} else {
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 {
if (!(cv && CvROOT(cv))) {
if (gv) {
SV *tmpstr = sv_newmortal();
- gv_efullname(tmpstr, gv);
+ gv_efullname3(tmpstr, gv, Nullch);
if (cv && CvXSUB(cv))
DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
DIE("Undefined sort subroutine \"%s\" called",
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);
- oldstack = stack;
+ oldstack = curstack;
if (!sortstack) {
sortstack = newAV();
AvREAL_off(sortstack);
av_extend(sortstack, 32);
}
- SWITCHSTACK(stack, sortstack);
+ CATCH_SET(TRUE);
+ SWITCHSTACK(curstack, sortstack);
if (sortstash != stash) {
firstgv = gv_fetchpv("a", TRUE, SVt_PV);
secondgv = gv_fetchpv("b", 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;
}
else {
if (max > 1) {
MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
- qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp);
+ qsort((char*)(ORIGMARK+1), max, sizeof(SV*),
+ (op->op_private & OPpLOCALE) ? sortcmp_locale : sortcmp);
}
}
stack_sp = ORIGMARK + max;
register SV *sv;
I32 max;
- if (SvNIOK(left) || !SvPOK(left) ||
- (looks_like_number(left) && *SvPVX(left) != '0') ) {
+ if (SvNIOKp(left) || !SvPOKp(left) ||
+ (looks_like_number(left) && *SvPVX(left) != '0') )
+ {
i = SvIV(left);
max = SvIV(right);
- if (max > i)
+ if (max >= i) {
+ EXTEND_MORTAL(max - i + 1);
EXTEND(SP, max - i + 1);
+ }
while (i <= max) {
- sv = sv_mortalcopy(&sv_no);
- sv_setiv(sv,i++);
+ sv = sv_2mortal(newSViv(i++));
PUSHs(sv);
}
}
char *tmps = SvPV(final, len);
sv = sv_mortalcopy(left);
- while (!SvNIOK(sv) && SvCUR(sv) <= len &&
+ while (!SvNIOKp(sv) && SvCUR(sv) <= len &&
strNE(SvPVX(sv),tmps) ) {
XPUSHs(sv);
sv = sv_2mortal(newSVsv(sv));
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;
}
}
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;
+
+ 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
dopoptosub(startingblock)
I32 startingblock;
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;
}
}
switch (cx->cx_type) {
case CXt_SUBST:
if (dowarn)
- warn("Exiting substitition via %s", op_name[op->op_type]);
+ warn("Exiting substitution via %s", op_name[op->op_type]);
break;
case CXt_SUB:
if (dowarn)
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;
}
}
while (cxstack_ix > cxix) {
cx = &cxstack[cxstack_ix--];
- DEBUG_l(fprintf(stderr, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
+ DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
block_type[cx->cx_type]));
/* Note: we don't need to restore the base context info till the end. */
switch (cx->cx_type) {
case CXt_LOOP:
POPLOOP(cx);
break;
+ case CXt_NULL:
case CXt_SUBST:
break;
}
}
}
-#ifdef STANDARD_C
-OP *
-die(char* pat, ...)
-#else
-/*VARARGS0*/
-OP *
-die(pat, va_alist)
- char *pat;
- va_dcl
-#endif
-{
- va_list args;
- char *message;
- int oldrunlevel = runlevel;
- int was_in_eval = in_eval;
-
-#ifdef I_STDARG
- va_start(args, pat);
-#else
- va_start(args);
-#endif
- message = mess(pat, &args);
- va_end(args);
- restartop = die_where(message);
- if ((!restartop && was_in_eval) || oldrunlevel > 1)
- longjmp(top_env, 3);
- return restartop;
-}
-
OP *
die_where(message)
char *message;
I32 gimme;
SV **newsp;
- sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),message);
+ if (in_eval & 4) {
+ SV **svp;
+ STRLEN klen = strlen(message);
+
+ svp = hv_fetch(GvHV(errgv), message, klen, TRUE);
+ if (svp) {
+ if (!SvIOK(*svp)) {
+ static char prefix[] = "\t(in cleanup) ";
+ sv_upgrade(*svp, SVt_IV);
+ (void)SvIOK_only(*svp);
+ SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen);
+ sv_catpvn(GvSV(errgv), prefix, sizeof(prefix)-1);
+ sv_catpvn(GvSV(errgv), message, klen);
+ }
+ sv_inc(*svp);
+ }
+ }
+ else
+ sv_setpv(GvSV(errgv), message);
+
cxix = dopoptoeval(cxstack_ix);
if (cxix >= 0) {
I32 optype;
POPBLOCK(cx,curpm);
if (cx->cx_type != CXt_EVAL) {
- fprintf(stderr, "panic: die %s", message);
+ PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
my_exit(1);
}
POPEVAL(cx);
stack_sp = newsp;
LEAVE;
+
if (optype == OP_REQUIRE)
- DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na));
+ DIE("%s", SvPVx(GvSV(errgv), na));
return pop_return();
}
}
- fputs(message, stderr);
- (void)fflush(stderr);
- if (e_fp)
- (void)UNLINK(e_tmpname);
- statusvalue >>= 8;
- my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
+ PerlIO_printf(PerlIO_stderr(), "%s",message);
+ PerlIO_flush(PerlIO_stderr());
+ my_failure_exit();
+ /* NOTREACHED */
return 0;
}
register I32 cxix = dopoptosub(cxstack_ix);
register CONTEXT *cx;
I32 dbcxix;
+ I32 gimme;
SV *sv;
I32 count = 0;
cxix = dopoptosub(cxix - 1);
}
cx = &cxstack[cxix];
+ if (cxstack[cxix].cx_type == CXt_SUB) {
+ dbcxix = dopoptosub(cxix - 1);
+ /* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the
+ field below is defined for any cx. */
+ if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
+ cx = &cxstack[dbcxix];
+ }
+
if (GIMME != G_ARRAY) {
dTARGET;
PUSHs(TARG);
RETURN;
}
- dbcxix = dopoptosub(cxix - 1);
- if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
- cx = &cxstack[dbcxix];
PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0)));
PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
if (!MAXARG)
RETURN;
- if (cx->cx_type == CXt_SUB) {
+ if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
sv = NEWSV(49, 0);
- gv_efullname(sv, CvGV(cxstack[cxix].blk_sub.cv));
+ gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
PUSHs(sv_2mortal(sv));
PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
}
PUSHs(sv_2mortal(newSVpv("(eval)",0)));
PUSHs(sv_2mortal(newSViv(0)));
}
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme)));
- if (cx->blk_sub.hasargs && curcop->cop_stash == debstash) {
+ 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);
+ PUSHs(&sv_no);
+ }
+ else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
+ /* Require, put the name. */
+ PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
+ PUSHs(&sv_yes);
+ }
+ }
+ else if (cx->cx_type == CXt_SUB &&
+ cx->blk_sub.hasargs &&
+ curcop->cop_stash == debstash)
+ {
AV *ary = cx->blk_sub.argarray;
int off = AvARRAY(ary) - AvALLOC(ary);
GV* tmpgv;
dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
SVt_PVAV)));
- SvMULTI_on(tmpgv);
+ GvMULTI_on(tmpgv);
AvREAL_off(dbargs); /* XXX Should be REIFY */
}
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;
GvSV(firstgv) = *str1;
GvSV(secondgv) = *str2;
stack_sp = stack_base;
op = sortcop;
- run();
+ runops();
if (stack_sp != stack_base + 1)
croak("Sort subroutine didn't return single value");
- if (!SvNIOK(*stack_sp))
+ if (!SvNIOKp(*stack_sp))
croak("Sort subroutine didn't return a numeric value");
result = SvIV(*stack_sp);
while (scopestack_ix > oldscopeix) {
LEAVE;
}
+ leave_scope(oldsaveix);
return result;
}
const void *a;
const void *b;
{
- register SV *str1 = *(SV **) a;
- register SV *str2 = *(SV **) b;
- I32 retval;
+ return sv_cmp(*(SV * const *)a, *(SV * const *)b);
+}
- if (SvCUR(str1) < SvCUR(str2)) {
- /*SUPPRESS 560*/
- if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1)))
- return retval;
- else
- return -1;
- }
- /*SUPPRESS 560*/
- else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2)))
- return retval;
- else if (SvCUR(str1) == SvCUR(str2))
- return 0;
- else
- return 1;
+static int
+sortcmp_locale(a, b)
+const void *a;
+const void *b;
+{
+ return sv_cmp_locale(*(SV * const *)a, *(SV * const *)b);
}
PP(pp_reset)
SV **sp;
register CV *cv;
register CONTEXT *cx;
- I32 gimme = GIMME;
+ I32 gimme = G_ARRAY;
I32 hasargs;
GV *gv;
+ gv = DBgv;
+ cv = GvCV(gv);
+ if (!cv)
+ DIE("No DB::DB routine defined");
+
+ if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */
+ return NORMAL;
+
ENTER;
SAVETMPS;
SAVEI32(debug);
+ SAVESTACK_POS();
debug = 0;
hasargs = 0;
- gv = DBgv;
- cv = GvCV(gv);
sp = stack_sp;
- *++sp = Nullsv;
-
- if (!cv)
- DIE("No DB::DB routine defined");
- if (CvDEPTH(cv) >= 1) /* don't do recursive DB::DB call */
- return NORMAL;
push_return(op->op_next);
- PUSHBLOCK(cx, CXt_SUB, sp - 1);
+ PUSHBLOCK(cx, CXt_SUB, sp);
PUSHSUB(cx);
CvDEPTH(cv)++;
(void)SvREFCNT_inc(cv);
{
dSP; dMARK;
register CONTEXT *cx;
- I32 gimme = GIMME;
+ I32 gimme = GIMME_V;
SV **svp;
+ ENTER;
+ SAVETMPS;
+
if (op->op_targ)
svp = &curpad[op->op_targ]; /* "my" variable */
else
svp = &GvSV((GV*)POPs); /* symbol table variable */
- ENTER;
- SAVETMPS;
+ SAVESPTR(*svp);
+
ENTER;
PUSHBLOCK(cx, CXt_LOOP, SP);
PUSHLOOP(cx, svp, MARK);
- cx->blk_loop.iterary = stack;
- cx->blk_loop.iterix = MARK - stack_base;
+ if (op->op_flags & OPf_STACKED)
+ cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
+ else {
+ cx->blk_loop.iterary = curstack;
+ AvFILL(curstack) = sp - stack_base;
+ cx->blk_loop.iterix = MARK - stack_base;
+ }
RETURN;
}
{
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;
I32 optype = 0;
- if (stack == sortstack) {
+ if (curstack == sortstack) {
if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) {
- AvARRAY(stack)[1] = *SP;
+ if (cxstack_ix > sortcxix)
+ dounwind(sortcxix);
+ AvARRAY(curstack)[1] = *SP;
stack_sp = stack_base + 1;
return 0;
}
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;
- if (optype == OP_REQUIRE && !SvTRUE(*newsp))
- DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na));
}
- else {
- if (optype == OP_REQUIRE && MARK == SP)
- DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na));
- 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;
SV **newsp;
PMOP *newpm;
SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
- /* XXX The sp is probably not right yet... */
if (op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
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)
I32 items = 0;
I32 oldsave;
+ if (!CvROOT(cv) && !CvXSUB(cv)) {
+ if (CvGV(cv)) {
+ SV *tmpstr = sv_newmortal();
+ gv_efullname3(tmpstr, CvGV(cv), Nullch);
+ DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
+ }
+ DIE("Goto undefined subroutine");
+ }
+
/* First do some returnish stuff. */
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
AV* av = cx->blk_sub.argarray;
items = AvFILL(av) + 1;
- Copy(AvARRAY(av), ++stack_sp, items, SV*);
+ stack_sp++;
+ EXTEND(stack_sp, items); /* @_ could have been extended. */
+ Copy(AvARRAY(av), stack_sp, items, SV*);
stack_sp += items;
+ SvREFCNT_dec(GvAV(defgv));
GvAV(defgv) = cx->blk_sub.savearray;
- av_clear(av);
AvREAL_off(av);
+ av_clear(av);
}
if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
SvREFCNT_dec(cx->blk_sub.cv);
SAVETMPS;
if (CvXSUB(cv)) {
if (CvOLDSTYLE(cv)) {
+ I32 (*fp3)_((int,int,int));
while (sp > mark) {
sp[1] = sp[0];
sp--;
}
- items = (*(I32(*)_((int,int,int)))CvXSUB(cv))(
- CvXSUBANY(cv).any_i32,
- mark - stack_base + 1,
- items);
+ fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
+ items = (*fp3)(CvXSUBANY(cv).any_i32,
+ mark - stack_base + 1,
+ items);
sp = stack_base + items;
}
else {
+ stack_sp--; /* There is no cv arg. */
(void)(*CvXSUB(cv))(cv);
}
LEAVE;
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
if (CvDEPTH(cv) == 100 && dowarn)
- warn("Deep recursion on subroutine \"%s\"",
- GvENAME(CvGV(cv)));
+ sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILL(padlist)) {
AV *newpad = newAV();
+ SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
I32 ix = AvFILL((AV*)svp[1]);
svp = AvARRAY(svp[0]);
- while (ix > 0) {
+ for ( ;ix > 0; ix--) {
if (svp[ix] != &sv_undef) {
- char *name = SvPVX(svp[ix]); /* XXX */
- if (*name == '@')
- av_store(newpad, ix--, sv = (SV*)newAV());
- else if (*name == '%')
- av_store(newpad, ix--, sv = (SV*)newHV());
- else
- av_store(newpad, ix--, sv = NEWSV(0,0));
- SvPADMY_on(sv);
+ char *name = SvPVX(svp[ix]);
+ if ((SvFLAGS(svp[ix]) & SVf_FAKE)
+ || *name == '&')
+ {
+ /* outer lexical or anon code */
+ av_store(newpad, ix,
+ SvREFCNT_inc(oldpad[ix]) );
+ }
+ else { /* our own lexical */
+ if (*name == '@')
+ av_store(newpad, ix, sv = (SV*)newAV());
+ else if (*name == '%')
+ av_store(newpad, ix, sv = (SV*)newHV());
+ else
+ av_store(newpad, ix, sv = NEWSV(0,0));
+ SvPADMY_on(sv);
+ }
}
else {
- av_store(newpad, ix--, sv = NEWSV(0,0));
+ av_store(newpad, ix, sv = NEWSV(0,0));
SvPADTMP_on(sv);
}
}
cx->blk_sub.savearray = GvAV(defgv);
cx->blk_sub.argarray = av;
- GvAV(defgv) = cx->blk_sub.argarray;
+ GvAV(defgv) = (AV*)SvREFCNT_inc(av);
++mark;
if (items >= AvMAX(av) + 1) {
mark++;
}
}
+ if (perldb && curstash != debstash) {
+ /*
+ * We do not care about using sv to call CV;
+ * it's for informational purposes only.
+ */
+ SV *sv = GvSV(DBsub);
+ save_item(sv);
+ gv_efullname3(sv, CvGV(cv), Nullch);
+ }
RETURNOP(CvSTART(cv));
}
}
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);
/* push wanted frames */
- if (*enterops) {
+ if (*enterops && enterops[1]) {
OP *oldop = op;
- for (ix = 0 + (gotoprobe == main_root); enterops[ix]; ix++) {
+ for (ix = 1; enterops[ix]; ix++) {
op = enterops[ix];
(*op->op_ppaddr)();
}
}
if (do_dump) {
+#ifdef VMS
+ if (!retop) retop = main_start;
+#endif
restartop = retop;
do_undump = TRUE;
do_undump = FALSE;
}
+ if (curstack == signalstack) {
+ restartop = retop;
+ 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;
+ int oldrunlevel = runlevel;
+ OP *oldop = op;
+ dJMPENV;
+
+ op = o;
+#ifdef DEBUGGING
+ assert(CATCH_GET == TRUE);
+ DEBUG_l(deb("(Setting up local jumplevel, runlevel = %d)\n", runlevel+1));
+#endif
+ switch ((ret = JMPENV_PUSH)) {
+ 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;
{
dSP;
OP *saveop = op;
HV *newstash;
+ CV *caller;
+ AV* comppadlist;
in_eval = 1;
+ PUSHMARK(SP);
+
/* set up a scratch pad */
- SAVEINT(padix);
+ SAVEI32(padix);
SAVESPTR(curpad);
SAVESPTR(comppad);
SAVESPTR(comppad_name);
- SAVEINT(comppad_name_fill);
- SAVEINT(min_intro_pending);
- SAVEINT(max_intro_pending);
+ SAVEI32(comppad_name_fill);
+ SAVEI32(min_intro_pending);
+ SAVEI32(max_intro_pending);
+
+ caller = compcv;
+ SAVESPTR(compcv);
+ compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)compcv, SVt_PVCV);
+ CvUNIQUE_on(compcv);
+
comppad = newAV();
comppad_name = newAV();
comppad_name_fill = 0;
curpad = AvARRAY(comppad);
padix = 0;
+ comppadlist = newAV();
+ AvREAL_off(comppadlist);
+ av_store(comppadlist, 0, (SV*)comppad_name);
+ av_store(comppadlist, 1, (SV*)comppad);
+ CvPADLIST(compcv) = comppadlist;
+
+ if (saveop->op_type != OP_REQUIRE)
+ CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
+
+ SAVEFREESV(compcv);
+
/* make sure we compile in the right package */
newstash = curcop->cop_stash;
error_count = 0;
curcop = &compiling;
curcop->cop_arybase = 0;
- rs = "\n";
- rslen = 1;
- rschar = '\n';
- rspara = 0;
- sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
+ SvREFCNT_dec(rs);
+ rs = newSVpv("\n", 1);
+ if (saveop->op_flags & OPf_SPECIAL)
+ in_eval |= 4;
+ else
+ sv_setpv(GvSV(errgv),"");
if (yyparse() || error_count || !eval_root) {
SV **newsp;
I32 gimme;
op_free(eval_root);
eval_root = Nullop;
}
+ SP = stack_base + POPMARK; /* pop original mark */
POPBLOCK(cx,curpm);
POPEVAL(cx);
pop_return();
lex_end();
LEAVE;
if (optype == OP_REQUIRE)
- DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na));
- rs = nrs;
- rslen = nrslen;
- rschar = nrschar;
- rspara = (nrslen == 2);
+ DIE("%s", SvPVx(GvSV(errgv), na));
+ SvREFCNT_dec(rs);
+ rs = SvREFCNT_inc(nrs);
RETPUSHUNDEF;
}
- rs = nrs;
- rslen = nrslen;
- rschar = nrschar;
- rspara = (nrslen == 2);
+ SvREFCNT_dec(rs);
+ rs = SvREFCNT_inc(nrs);
compiling.cop_line = 0;
- SAVEFREESV(comppad);
- SAVEFREESV(comppad_name);
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);
+ XPUSHs((SV*)compiling.cop_filegv);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
+ }
+
/* compiled okay, so do it */
+ CvDEPTH(compcv) = 1;
+
+ SP = stack_base + POPMARK; /* pop original mark */
RETURNOP(eval_start);
}
char *tmpname;
SV** svp;
I32 gimme = G_SCALAR;
- FILE *tryrsfp = 0;
+ PerlIO *tryrsfp = 0;
sv = POPs;
- if (SvNIOK(sv) && !SvPOKp(sv)) {
- if (atof(patchlevel) + 0.000999 < SvNV(sv))
- DIE("Perl %3.3f required--this is only version %s, stopped",
- SvNV(sv),patchlevel);
+ if (SvNIOKp(sv) && !SvPOKp(sv)) {
+ SET_NUMERIC_STANDARD();
+ if (atof(patchlevel) + 0.00000999 < SvNV(sv))
+ DIE("Perl %s required--this is only version %s, stopped",
+ SvPV(sv,na),patchlevel);
RETPUSHYES;
}
name = SvPV(sv, na);
if (!*name)
DIE("Null filename used");
+ TAINT_PROPER("require");
if (op->op_type == OP_REQUIRE &&
(svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) &&
*svp != &sv_undef)
if (*tmpname == '/' ||
(*tmpname == '.' &&
(tmpname[1] == '/' ||
- (tmpname[1] == '.' && tmpname[2] == '/'))))
+ (tmpname[1] == '.' && tmpname[2] == '/')))
+#ifdef DOSISH
+ || (tmpname[0] && tmpname[1] == ':')
+#endif
+#ifdef VMS
+ || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') &&
+ (isALNUM(tmpname[1]) || strchr("$-_]>",tmpname[1]))))
+#endif
+ )
{
- tryrsfp = fopen(tmpname,"r");
+ tryrsfp = PerlIO_open(tmpname,"r");
}
else {
AV *ar = GvAVn(incgv);
I32 i;
-
+#ifdef VMS
+ char unixified[256];
+ if (tounixspec_ts(tmpname,unixified) != NULL)
+ for (i = 0; i <= AvFILL(ar); i++) {
+ if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL)
+ continue;
+ strcat(buf,unixified);
+#else
for (i = 0; i <= AvFILL(ar); i++) {
(void)sprintf(buf, "%s/%s",
SvPVx(*av_fetch(ar, i, TRUE), na), name);
- tryrsfp = fopen(buf, "r");
+#endif
+ tryrsfp = PerlIO_open(buf, "r");
if (tryrsfp) {
char *s = buf;
ENTER;
SAVETMPS;
lex_start(sv_2mortal(newSVpv("",0)));
+ if (rsfp_filters){
+ save_aptr(&rsfp_filters);
+ rsfp_filters = NULL;
+ }
+
rsfp = tryrsfp;
name = savepv(name);
SAVEFREEPV(name);
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;
- char tmpbuf[32];
+ I32 gimme = GIMME_V, was = sub_generation;
+ char tmpbuf[32], *safestr;
STRLEN len;
+ OP *ret;
if (!SvPV(sv,len) || !len)
RETPUSHUNDEF;
+ TAINT_PROPER("eval");
ENTER;
- SAVETMPS;
lex_start(sv);
+ SAVETMPS;
/* switch to eval mode */
- sprintf(tmpbuf, "_<(eval %d)", ++evalseq);
+ SAVESPTR(compiling.cop_filegv);
+ sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
compiling.cop_line = 1;
- SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf));
+ /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
+ deleting the eval's FILEGV from the stash before gv_check() runs
+ (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(defstash, safestr, strlen(safestr));
SAVEI32(hints);
hints = op->op_targ;
if (perldb && curstash != debstash)
save_lines(GvAV(compiling.cop_filegv), linestr);
PUTBACK;
- return doeval(gimme);
+ ret = doeval(gimme);
+ if (perldb && was != sub_generation) { /* Some subs defined here. */
+ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
+ }
+ return DOCATCH(ret);
}
PP(pp_leaveeval)
I32 gimme;
register CONTEXT *cx;
OP *retop;
+ U8 save_flags = op -> op_flags;
I32 optype;
POPBLOCK(cx,newpm);
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++)
- if (!(SvFLAGS(TOPs) & SVs_TEMP))
+ if (!(SvFLAGS(*mark) & SVs_TEMP))
*mark = sv_mortalcopy(*mark);
/* in case LEAVE wipes old return values */
}
curpm = newpm; /* Don't pop $1 et al till now */
- if (optype != OP_ENTEREVAL) {
- char *name = cx->blk_eval.old_name;
-
- if (!(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
- /* Unassume the success we assumed earlier. */
- (void)hv_delete(GvHVn(incgv), name, strlen(name));
+#ifdef DEBUGGING
+ assert(CvDEPTH(compcv) == 1);
+#endif
+ CvDEPTH(compcv) = 0;
- if (optype == OP_REQUIRE)
- retop = die("%s did not return a true value", name);
- }
+ 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;
- sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
- RETURNOP(retop);
-}
+ if (!(save_flags & OPf_SPECIAL))
+ sv_setpv(GvSV(errgv),"");
-#ifdef NOTYET
-PP(pp_evalonce)
-{
- dSP;
- SP = do_eval(st[1], OP_EVAL, curcop->cop_stash, TRUE,
- GIMME, arglast);
- if (eval_root) {
- SvREFCNT_dec(cSVOP->op_sv);
- op[1].arg_ptr.arg_cmd = eval_root;
- op[1].op_type = (A_CMD|A_DONT);
- op[0].op_type = OP_TRY;
- }
- RETURN;
+ RETURNOP(retop);
}
-#endif
PP(pp_entertry)
{
dSP;
register CONTEXT *cx;
- I32 gimme = GIMME;
+ I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
eval_root = op; /* Only needed so that goto works right. */
in_eval = 1;
- sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
- RETURN;
+ sv_setpv(GvSV(errgv),"");
+ 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;
}
else {
for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)))
+ if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
*mark = sv_mortalcopy(*mark);
/* in case LEAVE wipes old return values */
}
curpm = newpm; /* Don't pop $1 et al till now */
LEAVE;
- sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
+ sv_setpv(GvSV(errgv),"");
RETURN;
}
register I32 arg;
bool ischop;
- New(804, fops, (send - s)*3+2, U16); /* Almost certainly too long... */
+ if (len == 0)
+ croak("Null picture in formline");
+
+ New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
fpc = fops;
if (s < send) {
skipspaces++;
arg -= skipspaces;
if (arg) {
- if (postspace) {
+ if (postspace)
*fpc++ = FF_SPACE;
- postspace = FALSE;
- }
*fpc++ = FF_LITERAL;
*fpc++ = arg;
}
+ postspace = FALSE;
if (s <= send)
skipspaces--;
if (skipspaces) {
}
Copy(fops, s, arg, U16);
Safefree(fops);
+ sv_magic(sv, Nullsv, 'f', Nullch, 0);
SvCOMPILED_on(sv);
}
-
projects / p5sagit/p5-mst-13.2.git / blobdiff