X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=371e037ae525e6b28365f5128e99faaa72dae8af;hb=10a676f83f541430b63a3192b246bf6f86d3b189;hp=a2dc38ee77a60f5b1bb1340491c1cba4c688b0d0;hpb=16d20bd98cd29be76029ebf04027a7edd34d817b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index a2dc38e..371e037 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,6 +1,6 @@ /* 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. @@ -23,6 +23,9 @@ #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)); @@ -31,8 +34,9 @@ static I32 dopoptolabel _((char *label)); 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; @@ -46,10 +50,14 @@ PP(pp_wantarray) 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) @@ -67,12 +75,18 @@ PP(pp_regcomp) { 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; @@ -96,34 +110,38 @@ PP(pp_substcont) 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); + 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); } @@ -138,9 +156,7 @@ PP(pp_substcont) cx->sb_m = m = rx->startp[0]; sv_catpvn(dstr, s, m-s); cx->sb_s = rx->endp[0]; - cx->sb_subbase = rx->subbase; - - rx->subbase = Nullch; /* so recursion works */ + cx->sb_rxtainted |= rx->exec_tainted; RETURNOP(pm->op_pmreplstart); } @@ -166,7 +182,7 @@ PP(pp_formline) bool gotsome; STRLEN len; - if (!SvCOMPILED(form)) { + if (!SvMAGICAL(form) || !SvCOMPILED(form)) { SvREADONLY_off(form); doparseform(form); } @@ -204,9 +220,9 @@ PP(pp_formline) 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: @@ -368,6 +384,8 @@ PP(pp_formline) } 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 { @@ -442,7 +460,7 @@ PP(pp_grepstart) 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); } @@ -505,6 +523,7 @@ PP(pp_mapwhile) /* All done yet? */ if (markstack_ptr[-1] > *markstack_ptr) { I32 items; + I32 gimme = GIMME_V; (void)POPMARK; /* pop top */ LEAVE; /* exit outer scope */ @@ -512,12 +531,12 @@ PP(pp_mapwhile) 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 { @@ -566,7 +585,7 @@ PP(pp_sort) 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", @@ -596,10 +615,9 @@ PP(pp_sort) 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++; } } @@ -609,17 +627,19 @@ PP(pp_sort) 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); @@ -628,20 +648,22 @@ PP(pp_sort) 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; @@ -698,15 +720,17 @@ PP(pp_flop) 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); } } @@ -716,7 +740,7 @@ PP(pp_flop) 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)); @@ -766,20 +790,52 @@ char *label; 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; @@ -793,7 +849,7 @@ 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; } } @@ -812,7 +868,7 @@ I32 startingblock; default: continue; case CXt_EVAL: - DEBUG_l( deb("(Found eval #%d)\n", i)); + DEBUG_l( deb("(Found eval #%ld)\n", (long)i)); return i; } } @@ -830,7 +886,7 @@ I32 startingblock; 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) @@ -840,8 +896,12 @@ I32 startingblock; 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; } } @@ -858,7 +918,7 @@ I32 cxix; 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) { @@ -871,53 +931,13 @@ I32 cxix; case CXt_LOOP: POPLOOP(cx); break; + case CXt_NULL: case CXt_SUBST: break; } } } -#ifdef I_STDARG -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; - HV *stash; - GV *gv; - CV *cv; - -#ifdef I_STDARG - va_start(args, pat); -#else - va_start(args); -#endif - message = mess(pat, &args); - va_end(args); - if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) { - dSP; - - PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); - PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); - } - restartop = die_where(message); - if ((!restartop && was_in_eval) || oldrunlevel > 1) - longjmp(top_env, 3); - return restartop; -} - OP * die_where(message) char *message; @@ -927,12 +947,27 @@ char *message; register CONTEXT *cx; I32 gimme; SV **newsp; - SV *errsv; - - errsv = GvSV(gv_fetchpv("@",TRUE, SVt_PV)); - /* As destructors may produce errors we set $@ at the last moment */ - sv_setpv(errsv, ""); /* clear $@ before destroying */ + 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; @@ -942,7 +977,7 @@ char *message; 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); @@ -953,22 +988,17 @@ char *message; LEAVE; - sv_insert(errsv, 0, 0, message, strlen(message)); - if (optype == OP_REQUIRE) - DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na)); + if (optype == OP_REQUIRE) { + char* msg = SvPVx(GvSV(errgv), na); + DIE("%s", *msg ? msg : "Compilation failed in require"); + } return pop_return(); } } - fputs(message, stderr); - (void)fflush(stderr); - if (e_fp) - (void)UNLINK(e_tmpname); - 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 + PerlIO_printf(PerlIO_stderr(), "%s",message); + PerlIO_flush(PerlIO_stderr()); + my_failure_exit(); + /* NOTREACHED */ return 0; } @@ -1020,6 +1050,7 @@ PP(pp_caller) register I32 cxix = dopoptosub(cxstack_ix); register CONTEXT *cx; I32 dbcxix; + I32 gimme; SV *sv; I32 count = 0; @@ -1040,6 +1071,14 @@ PP(pp_caller) 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; @@ -1047,18 +1086,15 @@ PP(pp_caller) 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))); } @@ -1066,11 +1102,26 @@ PP(pp_caller) PUSHs(sv_2mortal(newSVpv("(eval)",0))); PUSHs(sv_2mortal(newSViv(0))); } - PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme))); - if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) - PUSHs(cx->blk_eval.cur_text); - - 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); @@ -1078,7 +1129,7 @@ PP(pp_caller) 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 */ } @@ -1095,8 +1146,8 @@ sortcv(a, b) 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; @@ -1104,7 +1155,7 @@ const void *b; 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 (!SvNIOKp(*stack_sp)) @@ -1122,24 +1173,15 @@ sortcmp(a, b) 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) @@ -1177,19 +1219,19 @@ PP(pp_dbstate) I32 hasargs; GV *gv; - ENTER; - SAVETMPS; - gv = DBgv; cv = GvCV(gv); if (!cv) DIE("No DB::DB routine defined"); - if (CvDEPTH(cv) >= 1) /* don't do recursive DB::DB call */ + if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */ return NORMAL; + ENTER; + SAVETMPS; + SAVEI32(debug); - SAVESPTR(stack_sp); + SAVESTACK_POS(); debug = 0; hasargs = 0; sp = stack_sp; @@ -1216,22 +1258,30 @@ PP(pp_enteriter) { 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; } @@ -1240,7 +1290,7 @@ PP(pp_enterloop) { dSP; register CONTEXT *cx; - I32 gimme = GIMME; + I32 gimme = GIMME_V; ENTER; SAVETMPS; @@ -1256,6 +1306,7 @@ PP(pp_leaveloop) { dSP; register CONTEXT *cx; + struct block_loop cxloop; I32 gimme; SV **newsp; PMOP *newpm; @@ -1263,27 +1314,30 @@ PP(pp_leaveloop) 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) @@ -1291,16 +1345,18 @@ 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) { if (cxstack_ix > sortcxix) dounwind(sortcxix); - AvARRAY(stack)[1] = *SP; + AvARRAY(curstack)[1] = *SP; stack_sp = stack_base + 1; return 0; } @@ -1315,13 +1371,15 @@ PP(pp_return) 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); @@ -1329,22 +1387,28 @@ PP(pp_return) 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(); } @@ -1354,6 +1418,9 @@ PP(pp_last) dSP; I32 cxix; register CONTEXT *cx; + struct block_loop cxloop; + struct block_sub cxsub; + I32 pop2 = 0; I32 gimme; I32 optype; OP *nextop; @@ -1377,38 +1444,52 @@ PP(pp_last) 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) @@ -1533,6 +1614,15 @@ PP(pp_goto) 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) @@ -1545,11 +1635,14 @@ PP(pp_goto) 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); @@ -1572,6 +1665,7 @@ PP(pp_goto) sp = stack_base + items; } else { + stack_sp--; /* There is no cv arg. */ (void)(*CvXSUB(cv))(cv); } LEAVE; @@ -1587,20 +1681,21 @@ PP(pp_goto) (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(); - AV *oldpad = (AV*)AvARRAY(svp[CvDEPTH(cv)-1]); + SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); I32 ix = AvFILL((AV*)svp[1]); svp = AvARRAY(svp[0]); for ( ;ix > 0; ix--) { if (svp[ix] != &sv_undef) { char *name = SvPVX(svp[ix]); - if (SvFLAGS(svp[ix]) & SVf_FAKE) { - /* outer lexical? */ + if ((SvFLAGS(svp[ix]) & SVf_FAKE) + || *name == '&') + { + /* outer lexical or anon code */ av_store(newpad, ix, - SvREFCNT_inc(AvARRAY(oldpad)[ix]) ); + SvREFCNT_inc(oldpad[ix]) ); } else { /* our own lexical */ if (*name == '@') @@ -1636,7 +1731,7 @@ PP(pp_goto) 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) { @@ -1661,6 +1756,15 @@ PP(pp_goto) 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)); } } @@ -1701,11 +1805,12 @@ PP(pp_goto) 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); @@ -1742,6 +1847,9 @@ PP(pp_goto) } if (do_dump) { +#ifdef VMS + if (!retop) retop = main_start; +#endif restartop = retop; do_undump = TRUE; @@ -1751,9 +1859,9 @@ PP(pp_goto) do_undump = FALSE; } - if (stack == signalstack) { + if (curstack == signalstack) { restartop = retop; - longjmp(top_env, 3); + JMPENV_JUMP(3); } RETURNOP(retop); @@ -1766,8 +1874,13 @@ PP(pp_exit) 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; @@ -1842,29 +1955,74 @@ SV *sv; } 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; { 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(); @@ -1876,10 +2034,15 @@ int gimme; comppadlist = newAV(); AvREAL_off(comppadlist); - av_store(comppadlist, 0, SvREFCNT_inc((SV*)comppad_name)); - av_store(comppadlist, 1, SvREFCNT_inc((SV*)comppad)); + 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; @@ -1897,11 +2060,12 @@ int gimme; 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; @@ -1913,35 +2077,50 @@ int 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); + 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 = nrs; - rslen = nrslen; - rschar = nrschar; - rspara = (nrslen == 2); + SvREFCNT_dec(rs); + rs = SvREFCNT_inc(nrs); compiling.cop_line = 0; - SAVEFREESV(compcv); 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); } @@ -1954,18 +2133,20 @@ PP(pp_require) 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) @@ -1978,29 +2159,33 @@ PP(pp_require) (*tmpname == '.' && (tmpname[1] == '/' || (tmpname[1] == '.' && tmpname[2] == '/'))) +#ifdef DOSISH + || (tmpname[0] && tmpname[1] == ':') +#endif #ifdef VMS - || ((*tmpname == '[' || *tmpname == '<') && - (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>')) + || (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; - - for (i = 0; i <= AvFILL(ar); 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) - croak("Error converting file specification %s", - SvPVx(*av_fetch(ar, i, TRUE), na)); - strcat(buf,name); + 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); #endif - tryrsfp = fopen(buf, "r"); + tryrsfp = PerlIO_open(buf, "r"); if (tryrsfp) { char *s = buf; @@ -2036,6 +2221,11 @@ PP(pp_require) 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); @@ -2051,7 +2241,7 @@ PP(pp_require) compiling.cop_line = 0; PUTBACK; - return doeval(G_SCALAR); + return DOCATCH(doeval(G_SCALAR)); } PP(pp_dofile) @@ -2064,9 +2254,10 @@ PP(pp_entereval) 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; @@ -2079,10 +2270,16 @@ PP(pp_entereval) /* 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; - SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf)); + /* XXX For Cs 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; @@ -2095,7 +2292,11 @@ PP(pp_entereval) 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) @@ -2107,53 +2308,55 @@ 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), G_DISCARD); +#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)),""); + + if (!(save_flags & OPf_SPECIAL)) + sv_setpv(GvSV(errgv),""); RETURNOP(retop); } @@ -2162,7 +2365,7 @@ PP(pp_entertry) { dSP; register CONTEXT *cx; - I32 gimme = GIMME; + I32 gimme = GIMME_V; ENTER; SAVETMPS; @@ -2173,8 +2376,9 @@ PP(pp_entertry) 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) @@ -2191,34 +2395,32 @@ 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; } @@ -2240,7 +2442,10 @@ SV *sv; 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) { @@ -2273,13 +2478,12 @@ SV *sv; 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) { @@ -2395,6 +2599,6 @@ SV *sv; } Copy(fops, s, arg, U16); Safefree(fops); + sv_magic(sv, Nullsv, 'f', Nullch, 0); SvCOMPILED_on(sv); } -