X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/035902c79e208213cb9362b522626b418fd715ad..2dac949e495b95e587bbb698cde49a859cbb8f89:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 4f41374..36baae5 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -27,7 +27,7 @@ static OP *docatch _((OP *o)); static OP *doeval _((int gimme)); -static OP *dofindlabel _((OP *op, char *label, OP **opstack)); +static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit)); static void doparseform _((SV *sv)); static I32 dopoptoeval _((I32 startingblock)); static I32 dopoptolabel _((char *label)); @@ -42,7 +42,7 @@ static I32 sortcxix; PP(pp_wantarray) { - dSP; + djSP; I32 cxix; EXTEND(SP, 1); @@ -66,7 +66,7 @@ PP(pp_regcmaybe) } PP(pp_regcomp) { - dSP; + djSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; register char *t; SV *tmpstr; @@ -94,7 +94,7 @@ PP(pp_regcomp) { pm->op_pmflags |= PMf_WHITE; if (pm->op_pmflags & PMf_KEEP) { - pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */ + pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ hoistmust(pm); cLOGOP->op_first->op_next = op->op_next; } @@ -103,7 +103,7 @@ PP(pp_regcomp) { PP(pp_substcont) { - dSP; + djSP; register PMOP *pm = (PMOP*) cLOGOP->op_other; register CONTEXT *cx = &cxstack[cxstack_ix]; register SV *dstr = cx->sb_dstr; @@ -112,6 +112,8 @@ PP(pp_substcont) char *orig = cx->sb_orig; register REGEXP *rx = cx->sb_rx; + rxres_restore(&cx->sb_rxres, rx); + if (cx->sb_iters++) { if (cx->sb_iters > cx->sb_maxiters) DIE("Substitution loop"); @@ -119,9 +121,6 @@ PP(pp_substcont) 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, @@ -139,10 +138,10 @@ PP(pp_substcont) 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); @@ -159,16 +158,74 @@ 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; cx->sb_rxtainted |= rx->exec_tainted; - - rx->subbase = Nullch; /* so recursion works */ + rxres_save(&cx->sb_rxres, rx); RETURNOP(pm->op_pmreplstart); } +void +rxres_save(void **rsp, REGEXP *rx) +{ + UV *p = (UV*)*rsp; + U32 i; + + if (!p || p[1] < rx->nparens) { + i = 6 + rx->nparens * 2; + if (!p) + New(501, p, i, UV); + else + Renew(p, i, UV); + *rsp = (void*)p; + } + + *p++ = (UV)rx->subbase; + rx->subbase = Nullch; + + *p++ = rx->nparens; + + *p++ = (UV)rx->subbeg; + *p++ = (UV)rx->subend; + for (i = 0; i <= rx->nparens; ++i) { + *p++ = (UV)rx->startp[i]; + *p++ = (UV)rx->endp[i]; + } +} + +void +rxres_restore(void **rsp, REGEXP *rx) +{ + UV *p = (UV*)*rsp; + U32 i; + + Safefree(rx->subbase); + rx->subbase = (char*)(*p); + *p++ = 0; + + rx->nparens = *p++; + + rx->subbeg = (char*)(*p++); + rx->subend = (char*)(*p++); + for (i = 0; i <= rx->nparens; ++i) { + rx->startp[i] = (char*)(*p++); + rx->endp[i] = (char*)(*p++); + } +} + +void +rxres_free(void **rsp) +{ + UV *p = (UV*)*rsp; + + if (p) { + Safefree((char*)(*p)); + Safefree(p); + *rsp = Null(void*); + } +} + PP(pp_formline) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; register SV *form = *++MARK; register U16 *fpc; register char *t; @@ -461,7 +518,7 @@ PP(pp_formline) PP(pp_grepstart) { - dSP; + djSP; SV *src; if (stack_base + *markstack_ptr == sp) { @@ -471,8 +528,8 @@ PP(pp_grepstart) RETURNOP(op->op_next->op_next); } stack_sp = stack_base + *markstack_ptr + 1; - pp_pushmark(); /* push dst */ - pp_pushmark(); /* push src */ + pp_pushmark(ARGS); /* push dst */ + pp_pushmark(ARGS); /* push src */ ENTER; /* enter outer scope */ SAVETMPS; @@ -487,7 +544,7 @@ PP(pp_grepstart) PUTBACK; if (op->op_type == OP_MAPSTART) - pp_pushmark(); /* push top */ + pp_pushmark(ARGS); /* push top */ return ((LOGOP*)op->op_next)->op_other; } @@ -498,7 +555,7 @@ PP(pp_mapstart) PP(pp_mapwhile) { - dSP; + djSP; I32 diff = (sp - stack_base) - *markstack_ptr; I32 count; I32 shift; @@ -562,7 +619,7 @@ PP(pp_mapwhile) PP(pp_sort) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; register SV **up; SV **myorigmark = ORIGMARK; register I32 max; @@ -607,7 +664,7 @@ PP(pp_sort) sortcop = CvSTART(cv); SAVESPTR(CvROOT(cv)->op_ppaddr); CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL]; - + SAVESPTR(curpad); curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); } @@ -636,7 +693,7 @@ PP(pp_sort) bool oldcatch = CATCH_GET; SAVETMPS; - SAVESPTR(op); + SAVEOP(); oldstack = curstack; if (!sortstack) { @@ -654,7 +711,16 @@ PP(pp_sort) SAVESPTR(GvSV(firstgv)); SAVESPTR(GvSV(secondgv)); + PUSHBLOCK(cx, CXt_NULL, stack_base); + if (!(op->op_flags & OPf_SPECIAL)) { + bool hasargs = FALSE; + cx->cx_type = CXt_SUB; + cx->blk_gimme = G_SCALAR; + PUSHSUB(cx); + if (!CvDEPTH(cv)) + (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */ + } sortcxix = cxstack_ix; qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv); @@ -687,7 +753,7 @@ PP(pp_range) PP(pp_flip) { - dSP; + djSP; if (GIMME == G_ARRAY) { RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); @@ -702,6 +768,7 @@ PP(pp_flip) sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); if (op->op_flags & OPf_SPECIAL) { sv_setiv(targ, 1); + SETs(targ); RETURN; } else { @@ -718,7 +785,7 @@ PP(pp_flip) PP(pp_flop) { - dSP; + djSP; if (GIMME == G_ARRAY) { dPOPPOPssrl; @@ -775,9 +842,9 @@ PP(pp_flop) /* Control. */ static I32 -dopoptolabel(label) -char *label; +dopoptolabel(char *label) { + dTHR; register I32 i; register CONTEXT *cx; @@ -815,37 +882,38 @@ char *label; } I32 -dowantarray() +dowantarray(void) { I32 gimme = block_gimme(); return (gimme == G_VOID) ? G_SCALAR : gimme; } I32 -block_gimme() +block_gimme(void) { + dTHR; I32 cxix; cxix = dopoptosub(cxstack_ix); if (cxix < 0) - return G_SCALAR; + return G_VOID; 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); + case G_VOID: + return G_VOID; } } static I32 -dopoptosub(startingblock) -I32 startingblock; +dopoptosub(I32 startingblock) { + dTHR; I32 i; register CONTEXT *cx; for (i = startingblock; i >= 0; i--) { @@ -863,9 +931,9 @@ I32 startingblock; } static I32 -dopoptoeval(startingblock) -I32 startingblock; +dopoptoeval(I32 startingblock) { + dTHR; I32 i; register CONTEXT *cx; for (i = startingblock; i >= 0; i--) { @@ -882,9 +950,9 @@ I32 startingblock; } static I32 -dopoptoloop(startingblock) -I32 startingblock; +dopoptoloop(I32 startingblock) { + dTHR; I32 i; register CONTEXT *cx; for (i = startingblock; i >= 0; i--) { @@ -915,19 +983,22 @@ I32 startingblock; } void -dounwind(cxix) -I32 cxix; +dounwind(I32 cxix) { + dTHR; register CONTEXT *cx; SV **newsp; I32 optype; while (cxstack_ix > cxix) { - cx = &cxstack[cxstack_ix--]; - DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1, - block_type[cx->cx_type])); + cx = &cxstack[cxstack_ix]; + 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_SUBST: + POPSUBST(cx); + continue; /* not break */ case CXt_SUB: POPSUB(cx); break; @@ -938,16 +1009,16 @@ I32 cxix; POPLOOP(cx); break; case CXt_NULL: - case CXt_SUBST: break; } + cxstack_ix--; } } OP * -die_where(message) -char *message; +die_where(char *message) { + dTHR; if (in_eval) { I32 cxix; register CONTEXT *cx; @@ -958,21 +1029,21 @@ char *message; SV **svp; STRLEN klen = strlen(message); - svp = hv_fetch(GvHV(errgv), message, klen, TRUE); + svp = hv_fetch(errhv, 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); + SvGROW(errsv, SvCUR(errsv)+sizeof(prefix)+klen); + sv_catpvn(errsv, prefix, sizeof(prefix)-1); + sv_catpvn(errsv, message, klen); } sv_inc(*svp); } } else - sv_setpv(GvSV(errgv), message); + sv_setpv(errsv, message); cxix = dopoptoeval(cxstack_ix); if (cxix >= 0) { @@ -994,8 +1065,10 @@ char *message; LEAVE; - if (optype == OP_REQUIRE) - DIE("%s", SvPVx(GvSV(errgv), na)); + if (optype == OP_REQUIRE) { + char* msg = SvPV(errsv, na); + DIE("%s", *msg ? msg : "Compilation failed in require"); + } return pop_return(); } } @@ -1008,7 +1081,7 @@ char *message; PP(pp_xor) { - dSP; dPOPTOPssrl; + djSP; dPOPTOPssrl; if (SvTRUE(left) != SvTRUE(right)) RETSETYES; else @@ -1017,7 +1090,7 @@ PP(pp_xor) PP(pp_andassign) { - dSP; + djSP; if (!SvTRUE(TOPs)) RETURN; else @@ -1026,31 +1099,16 @@ PP(pp_andassign) PP(pp_orassign) { - dSP; + djSP; if (SvTRUE(TOPs)) RETURN; else RETURNOP(cLOGOP->op_other); } -#ifdef DEPRECATED -PP(pp_entersubr) -{ - dSP; - SV** mark = (stack_base + *markstack_ptr + 1); - SV* cv = *mark; - while (mark < sp) { /* emulate old interface */ - *mark = mark[1]; - mark++; - } - *sp = cv; - return pp_entersub(); -} -#endif - PP(pp_caller) { - dSP; + djSP; register I32 cxix = dopoptosub(cxstack_ix); register CONTEXT *cx; I32 dbcxix; @@ -1146,10 +1204,9 @@ PP(pp_caller) } static int -sortcv(a, b) -const void *a; -const void *b; +sortcv(const void *a, const void *b) { + dTHR; SV * const *str1 = (SV * const *)a; SV * const *str2 = (SV * const *)b; I32 oldsaveix = savestack_ix; @@ -1173,24 +1230,20 @@ const void *b; } static int -sortcmp(a, b) -const void *a; -const void *b; +sortcmp(const void *a, const void *b) { return sv_cmp(*(SV * const *)a, *(SV * const *)b); } static int -sortcmp_locale(a, b) -const void *a; -const void *b; +sortcmp_locale(const void *a, const void *b) { return sv_cmp_locale(*(SV * const *)a, *(SV * const *)b); } PP(pp_reset) { - dSP; + djSP; char *tmps; if (MAXARG < 1) @@ -1260,7 +1313,7 @@ PP(pp_scope) PP(pp_enteriter) { - dSP; dMARK; + djSP; dMARK; register CONTEXT *cx; I32 gimme = GIMME_V; SV **svp; @@ -1292,7 +1345,7 @@ PP(pp_enteriter) PP(pp_enterloop) { - dSP; + djSP; register CONTEXT *cx; I32 gimme = GIMME_V; @@ -1308,7 +1361,7 @@ PP(pp_enterloop) PP(pp_leaveloop) { - dSP; + djSP; register CONTEXT *cx; struct block_loop cxloop; I32 gimme; @@ -1320,6 +1373,7 @@ PP(pp_leaveloop) mark = newsp; POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */ + TAINT_NOT; if (gimme == G_VOID) ; /* do nothing */ else if (gimme == G_SCALAR) { @@ -1329,8 +1383,10 @@ PP(pp_leaveloop) *++newsp = &sv_undef; } else { - while (mark < SP) + while (mark < SP) { *++newsp = sv_mortalcopy(*++mark); + TAINT_NOT; /* Each item is independent */ + } } SP = newsp; PUTBACK; @@ -1346,7 +1402,7 @@ PP(pp_leaveloop) PP(pp_return) { - dSP; dMARK; + djSP; dMARK; I32 cxix; register CONTEXT *cx; struct block_sub cxsub; @@ -1357,7 +1413,7 @@ PP(pp_return) I32 optype = 0; if (curstack == sortstack) { - if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) { + if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) { if (cxstack_ix > sortcxix) dounwind(sortcxix); AvARRAY(curstack)[1] = *SP; @@ -1393,6 +1449,7 @@ PP(pp_return) DIE("panic: return"); } + TAINT_NOT; if (gimme == G_SCALAR) { if (MARK < SP) *++newsp = (popsub2 && SvTEMP(*SP)) @@ -1401,9 +1458,11 @@ PP(pp_return) *++newsp = &sv_undef; } else if (gimme == G_ARRAY) { - while (++MARK <= SP) + while (++MARK <= SP) { *++newsp = (popsub2 && SvTEMP(*MARK)) ? *MARK : sv_mortalcopy(*MARK); + TAINT_NOT; /* Each item is independent */ + } } stack_sp = newsp; @@ -1419,7 +1478,7 @@ PP(pp_return) PP(pp_last) { - dSP; + djSP; I32 cxix; register CONTEXT *cx; struct block_loop cxloop; @@ -1465,6 +1524,7 @@ PP(pp_last) DIE("panic: last"); } + TAINT_NOT; if (gimme == G_SCALAR) { if (MARK < SP) *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP)) @@ -1473,9 +1533,11 @@ PP(pp_last) *++newsp = &sv_undef; } else if (gimme == G_ARRAY) { - while (++MARK <= SP) + while (++MARK <= SP) { *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK)) ? *MARK : sv_mortalcopy(*MARK); + TAINT_NOT; /* Each item is independent */ + } } SP = newsp; PUTBACK; @@ -1549,40 +1611,41 @@ PP(pp_redo) static OP* lastgotoprobe; static OP * -dofindlabel(op,label,opstack) -OP *op; -char *label; -OP **opstack; +dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit) { OP *kid; OP **ops = opstack; - - if (op->op_type == OP_LEAVE || - op->op_type == OP_SCOPE || - op->op_type == OP_LEAVELOOP || - op->op_type == OP_LEAVETRY) - *ops++ = cUNOP->op_first; + static char too_deep[] = "Target of goto is too deeply nested"; + + if (ops >= oplimit) + croak(too_deep); + if (o->op_type == OP_LEAVE || + o->op_type == OP_SCOPE || + o->op_type == OP_LEAVELOOP || + o->op_type == OP_LEAVETRY) + { + *ops++ = cUNOPo->op_first; + if (ops >= oplimit) + croak(too_deep); + } *ops = 0; - if (op->op_flags & OPf_KIDS) { + if (o->op_flags & OPf_KIDS) { /* First try all the kids at this level, since that's likeliest. */ - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) { + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && kCOP->cop_label && strEQ(kCOP->cop_label, label)) return kid; } - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) { + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid == lastgotoprobe) continue; - if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { - if (ops > opstack && - (ops[-1]->op_type == OP_NEXTSTATE || - ops[-1]->op_type == OP_DBSTATE)) - *ops = kid; - else - *ops++ = kid; - } - if (op = dofindlabel(kid,label,ops)) - return op; + if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && + (ops == opstack || + (ops[-1]->op_type != OP_NEXTSTATE && + ops[-1]->op_type != OP_DBSTATE))) + *ops++ = kid; + if (o = dofindlabel(kid, label, ops, oplimit)) + return o; } } *ops = 0; @@ -1597,11 +1660,12 @@ PP(pp_dump) PP(pp_goto) { - dSP; + djSP; OP *retop = 0; I32 ix; register CONTEXT *cx; - OP *enterops[64]; +#define GOTO_DEPTH 64 + OP *enterops[GOTO_DEPTH]; char *label; int do_dump = (op->op_type == OP_DUMP); @@ -1643,8 +1707,10 @@ PP(pp_goto) EXTEND(stack_sp, items); /* @_ could have been extended. */ Copy(AvARRAY(av), stack_sp, items, SV*); stack_sp += items; +#ifndef USE_THREADS SvREFCNT_dec(GvAV(defgv)); GvAV(defgv) = cx->blk_sub.savearray; +#endif /* USE_THREADS */ AvREAL_off(av); av_clear(av); } @@ -1727,15 +1793,34 @@ PP(pp_goto) svp = AvARRAY(padlist); } } +#ifdef USE_THREADS + if (!cx->blk_sub.hasargs) { + AV* av = (AV*)curpad[0]; + + items = AvFILL(av) + 1; + if (items) { + /* Mark is at the end of the stack. */ + EXTEND(sp, items); + Copy(AvARRAY(av), sp + 1, items, SV*); + sp += items; + PUTBACK ; + } + } +#endif /* USE_THREADS */ SAVESPTR(curpad); curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); - if (cx->blk_sub.hasargs) { +#ifndef USE_THREADS + if (cx->blk_sub.hasargs) +#endif /* USE_THREADS */ + { AV* av = (AV*)curpad[0]; SV** ary; +#ifndef USE_THREADS cx->blk_sub.savearray = GvAV(defgv); - cx->blk_sub.argarray = av; GvAV(defgv) = (AV*)SvREFCNT_inc(av); +#endif /* USE_THREADS */ + cx->blk_sub.argarray = av; ++mark; if (items >= AvMAX(av) + 1) { @@ -1760,7 +1845,7 @@ PP(pp_goto) mark++; } } - if (perldb && curstash != debstash) { + if (PERLDB_SUB && curstash != debstash) { /* * We do not care about using sv to call CV; * it's for informational purposes only. @@ -1792,9 +1877,6 @@ PP(pp_goto) for (ix = cxstack_ix; ix >= 0; ix--) { cx = &cxstack[ix]; switch (cx->cx_type) { - case CXt_SUB: - gotoprobe = CvROOT(cx->blk_sub.cv); - break; case CXt_EVAL: gotoprobe = eval_root; /* XXX not good for nested eval */ break; @@ -1809,6 +1891,12 @@ PP(pp_goto) else gotoprobe = main_root; break; + case CXt_SUB: + if (CvDEPTH(cx->blk_sub.cv)) { + gotoprobe = CvROOT(cx->blk_sub.cv); + break; + } + /* FALL THROUGH */ case CXt_NULL: DIE("Can't \"goto\" outside a block"); default: @@ -1817,7 +1905,8 @@ PP(pp_goto) gotoprobe = main_root; break; } - retop = dofindlabel(gotoprobe, label, enterops); + retop = dofindlabel(gotoprobe, label, + enterops, enterops + GOTO_DEPTH); if (retop) break; lastgotoprobe = gotoprobe; @@ -1844,7 +1933,12 @@ PP(pp_goto) OP *oldop = op; for (ix = 1; enterops[ix]; ix++) { op = enterops[ix]; - (*op->op_ppaddr)(); + /* Eventually we may want to stack the needed arguments + * for each op. For now, we punt on the hard ones. */ + if (op->op_type == OP_ENTERITER) + DIE("Can't \"goto\" into the middle of a foreach loop", + label); + (*op->op_ppaddr)(ARGS); } op = oldop; } @@ -1873,7 +1967,7 @@ PP(pp_goto) PP(pp_exit) { - dSP; + djSP; I32 anum; if (MAXARG < 1) @@ -1893,7 +1987,7 @@ PP(pp_exit) #ifdef NOTYET PP(pp_nswitch) { - dSP; + djSP; double value = SvNVx(GvSV(cCOP->cop_gv)); register I32 match = I_32(value); @@ -1912,7 +2006,7 @@ PP(pp_nswitch) PP(pp_cswitch) { - dSP; + djSP; register I32 match; if (multiline) @@ -1933,9 +2027,7 @@ PP(pp_cswitch) /* Eval. */ static void -save_lines(array, sv) -AV *array; -SV *sv; +save_lines(AV *array, SV *sv) { register char *s = SvPVX(sv); register char *send = SvPVX(sv) + SvCUR(sv); @@ -1959,9 +2051,9 @@ SV *sv; } static OP * -docatch(o) -OP *o; +docatch(OP *o) { + dTHR; int ret; I32 oldrunlevel = runlevel; OP *oldop = op; @@ -1998,9 +2090,9 @@ OP *o; return Nullop; } +/* With USE_THREADS, eval_owner must be held on entry to doeval */ static OP * -doeval(gimme) -int gimme; +doeval(int gimme) { dSP; OP *saveop = op; @@ -2027,14 +2119,24 @@ int gimme; compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)compcv, SVt_PVCV); CvUNIQUE_on(compcv); +#ifdef USE_THREADS + CvOWNER(compcv) = 0; + New(666, CvMUTEXP(compcv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(compcv)); +#endif /* USE_THREADS */ comppad = newAV(); + av_push(comppad, Nullsv); + curpad = AvARRAY(comppad); comppad_name = newAV(); comppad_name_fill = 0; min_intro_pending = 0; - av_push(comppad, Nullsv); - curpad = AvARRAY(comppad); padix = 0; +#ifdef USE_THREADS + av_store(comppad_name, 0, newSVpv("@_", 2)); + curpad[0] = (SV*)newAV(); + SvPADMY_on(curpad[0]); /* XXX Needed? */ +#endif /* USE_THREADS */ comppadlist = newAV(); AvREAL_off(comppadlist); @@ -2069,7 +2171,7 @@ int gimme; if (saveop->op_flags & OPf_SPECIAL) in_eval |= 4; else - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); if (yyparse() || error_count || !eval_root) { SV **newsp; I32 gimme; @@ -2087,10 +2189,18 @@ int gimme; pop_return(); lex_end(); LEAVE; - if (optype == OP_REQUIRE) - DIE("%s", SvPVx(GvSV(errgv), na)); + if (optype == OP_REQUIRE) { + char* msg = SvPV(errsv, na); + DIE("%s", *msg ? msg : "Compilation failed in require"); + } SvREFCNT_dec(rs); rs = SvREFCNT_inc(nrs); +#ifdef USE_THREADS + MUTEX_LOCK(&eval_mutex); + eval_owner = 0; + COND_SIGNAL(&eval_cond); + MUTEX_UNLOCK(&eval_mutex); +#endif /* USE_THREADS */ RETPUSHUNDEF; } SvREFCNT_dec(rs); @@ -2107,7 +2217,7 @@ int gimme; DEBUG_x(dump_eval()); /* Register with debugger: */ - if (perldb && saveop->op_type == OP_REQUIRE) { + if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { CV *cv = perl_get_cv("DB::postponed", FALSE); if (cv) { dSP; @@ -2121,18 +2231,26 @@ int gimme; /* compiled okay, so do it */ CvDEPTH(compcv) = 1; - SP = stack_base + POPMARK; /* pop original mark */ + op = saveop; /* The caller may need it. */ +#ifdef USE_THREADS + MUTEX_LOCK(&eval_mutex); + eval_owner = 0; + COND_SIGNAL(&eval_cond); + MUTEX_UNLOCK(&eval_mutex); +#endif /* USE_THREADS */ + RETURNOP(eval_start); } PP(pp_require) { - dSP; + djSP; register CONTEXT *cx; SV *sv; char *name; - char *tmpname; + char *tryname; + SV *namesv = Nullsv; SV** svp; I32 gimme = G_SCALAR; PerlIO *tryrsfp = 0; @@ -2156,61 +2274,77 @@ PP(pp_require) /* prepare to compile file */ - tmpname = savepv(name); - if (*tmpname == '/' || - (*tmpname == '.' && - (tmpname[1] == '/' || - (tmpname[1] == '.' && tmpname[2] == '/'))) + if (*name == '/' || + (*name == '.' && + (name[1] == '/' || + (name[1] == '.' && name[2] == '/'))) #ifdef DOSISH - || (tmpname[0] && tmpname[1] == ':') + || (name[0] && name[1] == ':') +#endif +#ifdef WIN32 + || (name[0] == '\\' && name[1] == '\\') /* UNC path */ #endif #ifdef VMS - || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') && - (isALNUM(tmpname[1]) || strchr("$-_]>",tmpname[1])))) + || (strchr(name,':') || ((*name == '[' || *name == '<') && + (isALNUM(name[1]) || strchr("$-_]>",name[1])))) #endif ) { - tryrsfp = PerlIO_open(tmpname,"r"); + tryname = name; + tryrsfp = PerlIO_open(name,"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); + char *unixname; + if ((unixname = tounixspec(name, Nullch)) != Nullch) +#endif + { + namesv = NEWSV(806, 0); + for (i = 0; i <= AvFILL(ar); i++) { + char *dir = SvPVx(*av_fetch(ar, i, TRUE), na); +#ifdef VMS + char *unixdir; + if ((unixdir = tounixpath(dir, Nullch)) == Nullch) + continue; + sv_setpv(namesv, unixdir); + sv_catpv(namesv, unixname); #else - for (i = 0; i <= AvFILL(ar); i++) { - (void)sprintf(buf, "%s/%s", - SvPVx(*av_fetch(ar, i, TRUE), na), name); + sv_setpvf(namesv, "%s/%s", dir, name); #endif - tryrsfp = PerlIO_open(buf, "r"); - if (tryrsfp) { - char *s = buf; - - if (*s == '.' && s[1] == '/') - s += 2; - Safefree(tmpname); - tmpname = savepv(s); - break; + tryname = SvPVX(namesv); + tryrsfp = PerlIO_open(tryname, "r"); + if (tryrsfp) { + if (tryname[0] == '.' && tryname[1] == '/') + tryname += 2; + break; + } } } } SAVESPTR(compiling.cop_filegv); - compiling.cop_filegv = gv_fetchfile(tmpname); - Safefree(tmpname); - tmpname = Nullch; + compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name); + SvREFCNT_dec(namesv); if (!tryrsfp) { if (op->op_type == OP_REQUIRE) { - sprintf(tokenbuf,"Can't locate %s in @INC", name); - if (instr(tokenbuf,".h ")) - strcat(tokenbuf," (change .h to .ph maybe?)"); - if (instr(tokenbuf,".ph ")) - strcat(tokenbuf," (did you run h2ph?)"); - DIE("%s",tokenbuf); + SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name)); + SV *dirmsgsv = NEWSV(0, 0); + AV *ar = GvAVn(incgv); + I32 i; + if (instr(SvPVX(msg), ".h ")) + sv_catpv(msg, " (change .h to .ph maybe?)"); + if (instr(SvPVX(msg), ".ph ")) + sv_catpv(msg, " (did you run h2ph?)"); + sv_catpv(msg, " (@INC contains:"); + for (i = 0; i <= AvFILL(ar); i++) { + char *dir = SvPVx(*av_fetch(ar, i, TRUE), na); + sv_setpvf(dirmsgsv, " %s", dir); + sv_catsv(msg, dirmsgsv); + } + sv_catpvn(msg, ")", 1); + SvREFCNT_dec(dirmsgsv); + DIE("%_", msg); } RETPUSHUNDEF; @@ -2243,6 +2377,14 @@ PP(pp_require) compiling.cop_line = 0; PUTBACK; +#ifdef USE_THREADS + MUTEX_LOCK(&eval_mutex); + if (eval_owner && eval_owner != thr) + while (eval_owner) + COND_WAIT(&eval_cond, &eval_mutex); + eval_owner = thr; + MUTEX_UNLOCK(&eval_mutex); +#endif /* USE_THREADS */ return DOCATCH(doeval(G_SCALAR)); } @@ -2253,11 +2395,12 @@ PP(pp_dofile) PP(pp_entereval) { - dSP; + djSP; register CONTEXT *cx; dPOPss; I32 gimme = GIMME_V, was = sub_generation; - char tmpbuf[32], *safestr; + char tmpbuf[TYPE_DIGITS(long) + 12]; + char *safestr; STRLEN len; OP *ret; @@ -2291,11 +2434,20 @@ PP(pp_entereval) /* prepare to compile string */ - if (perldb && curstash != debstash) + if (PERLDB_LINE && curstash != debstash) save_lines(GvAV(compiling.cop_filegv), linestr); PUTBACK; +#ifdef USE_THREADS + MUTEX_LOCK(&eval_mutex); + if (eval_owner && eval_owner != thr) + while (eval_owner) + COND_WAIT(&eval_cond, &eval_mutex); + eval_owner = thr; + MUTEX_UNLOCK(&eval_mutex); +#endif /* USE_THREADS */ ret = doeval(gimme); - if (perldb && was != sub_generation) { /* Some subs defined here. */ + if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */ + && ret != op->op_next) { /* Successive compilation. */ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ } return DOCATCH(ret); @@ -2303,7 +2455,7 @@ PP(pp_entereval) PP(pp_leaveeval) { - dSP; + djSP; register SV **mark; SV **newsp; PMOP *newpm; @@ -2317,6 +2469,7 @@ PP(pp_leaveeval) POPEVAL(cx); retop = pop_return(); + TAINT_NOT; if (gimme == G_VOID) MARK = newsp; else if (gimme == G_SCALAR) { @@ -2333,13 +2486,46 @@ PP(pp_leaveeval) } } else { - for (mark = newsp + 1; mark <= SP; mark++) - if (!(SvFLAGS(*mark) & SVs_TEMP)) + /* in case LEAVE wipes old return values */ + for (mark = newsp + 1; mark <= SP; mark++) { + if (!(SvFLAGS(*mark) & SVs_TEMP)) { *mark = sv_mortalcopy(*mark); - /* in case LEAVE wipes old return values */ + TAINT_NOT; /* Each item is independent */ + } + } } curpm = newpm; /* Don't pop $1 et al till now */ + /* + * Closures mentioned at top level of eval cannot be referenced + * again, and their presence indirectly causes a memory leak. + * (Note that the fact that compcv and friends are still set here + * is, AFAIK, an accident.) --Chip + */ + if (AvFILL(comppad_name) >= 0) { + SV **svp = AvARRAY(comppad_name); + I32 ix; + for (ix = AvFILL(comppad_name); ix >= 0; ix--) { + SV *sv = svp[ix]; + if (sv && sv != &sv_undef && *SvPVX(sv) == '&') { + SvREFCNT_dec(sv); + svp[ix] = &sv_undef; + + sv = curpad[ix]; + if (CvCLONE(sv)) { + SvREFCNT_dec(CvOUTSIDE(sv)); + CvOUTSIDE(sv) = Nullcv; + } + else { + SvREFCNT_dec(sv); + sv = NEWSV(0,0); + SvPADTMP_on(sv); + curpad[ix] = sv; + } + } + } + } + #ifdef DEBUGGING assert(CvDEPTH(compcv) == 1); #endif @@ -2358,14 +2544,14 @@ PP(pp_leaveeval) LEAVE; if (!(save_flags & OPf_SPECIAL)) - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); RETURNOP(retop); } PP(pp_entertry) { - dSP; + djSP; register CONTEXT *cx; I32 gimme = GIMME_V; @@ -2378,14 +2564,14 @@ PP(pp_entertry) eval_root = op; /* Only needed so that goto works right. */ in_eval = 1; - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); PUTBACK; return DOCATCH(op->op_next); } PP(pp_leavetry) { - dSP; + djSP; register SV **mark; SV **newsp; PMOP *newpm; @@ -2397,6 +2583,7 @@ PP(pp_leavetry) POPEVAL(cx); pop_return(); + TAINT_NOT; if (gimme == G_VOID) SP = newsp; else if (gimme == G_SCALAR) { @@ -2414,21 +2601,23 @@ PP(pp_leavetry) SP = MARK; } else { - for (mark = newsp + 1; mark <= SP; mark++) - if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) + /* in case LEAVE wipes old return values */ + for (mark = newsp + 1; mark <= SP; mark++) { + if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { *mark = sv_mortalcopy(*mark); - /* in case LEAVE wipes old return values */ + TAINT_NOT; /* Each item is independent */ + } + } } curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); RETURN; } static void -doparseform(sv) -SV *sv; +doparseform(SV *sv) { STRLEN len; register char *s = SvPV_force(sv, len); @@ -2604,3 +2793,4 @@ SV *sv; sv_magic(sv, Nullsv, 'f', Nullch, 0); SvCOMPILED_on(sv); } +