X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=c78187092ee169b6ca2540e6dc8fe643c710779c;hb=e262e9be635eb2f99e78e37e3729f3b9494cef78;hp=a4135c64c9d048e3b15eeee9b37237b923c23f42;hpb=49d8d3a1123fb996c090905424ed66f675b3df17;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index a4135c6..c781870 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -25,6 +25,10 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) +#ifdef PERL_OBJECT +#define CALLOP this->*op +#else +#define CALLOP *op static OP *docatch _((OP *o)); static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit)); static void doparseform _((SV *sv)); @@ -32,12 +36,12 @@ static I32 dopoptoeval _((I32 startingblock)); static I32 dopoptolabel _((char *label)); static I32 dopoptoloop _((I32 startingblock)); static I32 dopoptosub _((I32 startingblock)); +static I32 dopoptosub_at _((PERL_CONTEXT *cxstk, I32 startingblock)); static void save_lines _((AV *array, SV *sv)); static I32 sortcv _((SV *a, SV *b)); static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b))); static OP *doeval _((int gimme, OP** startop)); - -static I32 sortcxix; +#endif PP(pp_wantarray) { @@ -64,7 +68,16 @@ PP(pp_regcmaybe) return NORMAL; } -PP(pp_regcomp) { +PP(pp_regcreset) +{ + /* XXXX Should store the old value to allow for tie/overload - and + restore in regcomp, where marked with XXXX. */ + reginterp_cnt = 0; + return NORMAL; +} + +PP(pp_regcomp) +{ djSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; register char *t; @@ -73,12 +86,12 @@ PP(pp_regcomp) { MAGIC *mg = Null(MAGIC*); tmpstr = POPs; - if(SvROK(tmpstr)) { + if (SvROK(tmpstr)) { SV *sv = SvRV(tmpstr); if(SvMAGICAL(sv)) mg = mg_find(sv, 'r'); } - if(mg) { + if (mg) { regexp *re = (regexp *)mg->mg_obj; ReREFCNT_dec(pm->op_pmregexp); pm->op_pmregexp = ReREFCNT_inc(re); @@ -86,22 +99,34 @@ PP(pp_regcomp) { else { t = SvPV(tmpstr, len); - /* JMR: Check against the last compiled regexp - To know for sure, we'd need the length of precomp. - But we don't have it, so we must ... take a guess. */ + /* Check against the last compiled regexp. */ if (!pm->op_pmregexp || !pm->op_pmregexp->precomp || - memNE(pm->op_pmregexp->precomp, t, len + 1)) + pm->op_pmregexp->prelen != len || + memNE(pm->op_pmregexp->precomp, t, len)) { if (pm->op_pmregexp) { ReREFCNT_dec(pm->op_pmregexp); pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ } + if (op->op_flags & OPf_SPECIAL) + reginterp_cnt = I32_MAX; /* Mark as safe. */ pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ - pm->op_pmregexp = pregcomp(t, t + len, pm); + pm->op_pmregexp = CALLREGCOMP(t, t + len, pm); + reginterp_cnt = 0; /* XXXX Be extra paranoid - needed + inside tie/overload accessors. */ } } +#ifndef INCOMPLETE_TAINTS + if (tainting) { + if (tainted) + pm->op_pmdynflags |= PMdf_TAINTED; + else + pm->op_pmdynflags &= ~PMdf_TAINTED; + } +#endif + if (!pm->op_pmregexp->prelen && curpm) pm = curpm; else if (strEQ("\\s+", pm->op_pmregexp->precomp)) @@ -131,19 +156,19 @@ PP(pp_substcont) if (cx->sb_iters > cx->sb_maxiters) DIE("Substitution loop"); - if (!cx->sb_rxtainted) - cx->sb_rxtainted = SvTAINTED(TOPs); + if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) + cx->sb_rxtainted |= 2; sv_catsv(dstr, POPs); /* Are we done */ - if (cx->sb_once || !regexec_flags(rx, s, cx->sb_strend, orig, + if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig, s == m, Nullsv, NULL, cx->sb_safebase ? 0 : REXEC_COPY_STR)) { SV *targ = cx->sb_targ; sv_catpvn(dstr, s, cx->sb_strend - s); - TAINT_IF(cx->sb_rxtainted || RX_MATCH_TAINTED(rx)); + cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); (void)SvOOK_off(targ); Safefree(SvPVX(targ)); @@ -152,11 +177,15 @@ PP(pp_substcont) SvLEN_set(targ, SvLEN(dstr)); SvPVX(dstr) = 0; sv_free(dstr); + + TAINT_IF(cx->sb_rxtainted & 1); + PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); + (void)SvPOK_only(targ); + TAINT_IF(cx->sb_rxtainted); SvSETMAGIC(targ); SvTAINT(targ); - PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); RETURNOP(pm->op_next); @@ -240,7 +269,7 @@ rxres_free(void **rsp) PP(pp_formline) { djSP; dMARK; dORIGMARK; - register SV *form = *++MARK; + register SV *tmpForm = *++MARK; register U16 *fpc; register char *t; register char *f; @@ -259,17 +288,17 @@ PP(pp_formline) bool gotsome; STRLEN len; - if (!SvMAGICAL(form) || !SvCOMPILED(form)) { - SvREADONLY_off(form); - doparseform(form); + if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { + SvREADONLY_off(tmpForm); + doparseform(tmpForm); } SvPV_force(formtarget, len); - t = SvGROW(formtarget, len + SvCUR(form) + 1); /* XXX SvCUR bad */ + t = SvGROW(formtarget, len + SvCUR(tmpForm) + 1); /* XXX SvCUR bad */ t += len; - f = SvPV(form, len); + f = SvPV(tmpForm, len); /* need to jump to the next word */ - s = f + len + WORD_ALIGN - SvCUR(form) % WORD_ALIGN; + s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN; fpc = (U16*)s; @@ -444,7 +473,7 @@ PP(pp_formline) } SvCUR_set(formtarget, t - SvPVX(formtarget)); sv_catpvn(formtarget, item, itemsize); - SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1); + SvGROW(formtarget, SvCUR(formtarget) + SvCUR(tmpForm) + 1); t = SvPVX(formtarget) + SvCUR(formtarget); } break; @@ -535,7 +564,7 @@ PP(pp_grepstart) djSP; SV *src; - if (stack_base + *markstack_ptr == sp) { + if (stack_base + *markstack_ptr == SP) { (void)POPMARK; if (GIMME_V == G_SCALAR) XPUSHs(&sv_no); @@ -574,7 +603,7 @@ PP(pp_mapstart) PP(pp_mapwhile) { djSP; - I32 diff = (sp - stack_base) - *markstack_ptr; + I32 diff = (SP - stack_base) - *markstack_ptr; I32 count; I32 shift; SV** src; @@ -584,11 +613,11 @@ PP(pp_mapwhile) if (diff) { if (diff > markstack_ptr[-1] - markstack_ptr[-2]) { shift = diff - (markstack_ptr[-1] - markstack_ptr[-2]); - count = (sp - stack_base) - markstack_ptr[-1] + 2; + count = (SP - stack_base) - markstack_ptr[-1] + 2; - EXTEND(sp,shift); - src = sp; - dst = (sp += shift); + EXTEND(SP,shift); + src = SP; + dst = (SP += shift); markstack_ptr[-1] += shift; *markstack_ptr += shift; while (--count) @@ -634,7 +663,6 @@ PP(pp_mapwhile) } } - PP(pp_sort) { djSP; dMARK; dORIGMARK; @@ -652,8 +680,9 @@ PP(pp_sort) RETPUSHUNDEF; } + ENTER; + SAVEPPTR(sortcop); if (op->op_flags & OPf_STACKED) { - ENTER; if (op->op_flags & OPf_SPECIAL) { OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */ kid = kUNOP->op_first; /* pass rv2gv */ @@ -705,7 +734,6 @@ PP(pp_sort) max = --up - myorigmark; if (sortcop) { if (max > 1) { - AV *oldstack; PERL_CONTEXT *cx; SV** newsp; bool oldcatch = CATCH_GET; @@ -713,14 +741,8 @@ PP(pp_sort) SAVETMPS; SAVEOP(); - oldstack = curstack; - if (!sortstack) { - sortstack = newAV(); - AvREAL_off(sortstack); - av_extend(sortstack, 32); - } CATCH_SET(TRUE); - SWITCHSTACK(curstack, sortstack); + PUSHSTACKi(PERLSI_SORT); if (sortstash != stash) { firstgv = gv_fetchpv("a", TRUE, SVt_PV); secondgv = gv_fetchpv("b", TRUE, SVt_PV); @@ -740,22 +762,23 @@ PP(pp_sort) (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */ } sortcxix = cxstack_ix; - - qsortsv(myorigmark+1, max, sortcv); + qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv)); POPBLOCK(cx,curpm); - SWITCHSTACK(sortstack, oldstack); + POPSTACK; CATCH_SET(oldcatch); } - LEAVE; } else { if (max > 1) { MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ qsortsv(ORIGMARK+1, max, - (op->op_private & OPpLOCALE) ? sv_cmp_locale : sv_cmp); + (op->op_private & OPpLOCALE) + ? FUNC_NAME_TO_PTR(sv_cmp_locale) + : FUNC_NAME_TO_PTR(sv_cmp)); } } + LEAVE; stack_sp = ORIGMARK + max; return nextop; } @@ -781,7 +804,7 @@ PP(pp_flip) SV *targ = PAD_SV(op->op_targ); if ((op->op_private & OPpFLIP_LINENUM) - ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv)) + ? (last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(last_in_gv))) : SvTRUE(sv) ) { sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); if (op->op_flags & OPf_SPECIAL) { @@ -791,7 +814,7 @@ PP(pp_flip) } else { sv_setiv(targ, 0); - sp--; + SP--; RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); } } @@ -814,6 +837,8 @@ PP(pp_flop) if (SvNIOKp(left) || !SvPOKp(left) || (looks_like_number(left) && *SvPVX(left) != '0') ) { + if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX) + croak("Range iterator outside integer range"); i = SvIV(left); max = SvIV(right); if (max >= i) { @@ -831,14 +856,13 @@ PP(pp_flop) char *tmps = SvPV(final, len); sv = sv_mortalcopy(left); - while (!SvNIOKp(sv) && SvCUR(sv) <= len && - strNE(SvPVX(sv),tmps) ) { + while (!SvNIOKp(sv) && SvCUR(sv) <= len) { XPUSHs(sv); + if (strEQ(SvPVX(sv),tmps)) + break; sv = sv_2mortal(newSVsv(sv)); sv_inc(sv); } - if (strEQ(SvPVX(sv),tmps)) - XPUSHs(sv); } } else { @@ -846,7 +870,7 @@ PP(pp_flop) SV *targ = PAD_SV(cUNOP->op_first->op_targ); sv_inc(targ); if ((op->op_private & OPpFLIP_LINENUM) - ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv)) + ? (last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(last_in_gv))) : SvTRUE(sv) ) { sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); sv_catpv(targ, "E0"); @@ -859,7 +883,7 @@ PP(pp_flop) /* Control. */ -static I32 +STATIC I32 dopoptolabel(char *label) { dTHR; @@ -917,25 +941,34 @@ block_gimme(void) 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; + /* NOTREACHED */ + return 0; } } -static I32 +STATIC I32 dopoptosub(I32 startingblock) { dTHR; + return dopoptosub_at(cxstack, startingblock); +} + +STATIC I32 +dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock) +{ + dTHR; I32 i; register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { - cx = &cxstack[i]; + cx = &cxstk[i]; switch (cx->cx_type) { default: continue; @@ -948,7 +981,7 @@ dopoptosub(I32 startingblock) return i; } -static I32 +STATIC I32 dopoptoeval(I32 startingblock) { dTHR; @@ -967,7 +1000,7 @@ dopoptoeval(I32 startingblock) return i; } -static I32 +STATIC I32 dopoptoloop(I32 startingblock) { dTHR; @@ -1011,7 +1044,7 @@ dounwind(I32 cxix) 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])); + (long) cxstack_ix, 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: @@ -1036,37 +1069,45 @@ dounwind(I32 cxix) OP * die_where(char *message) { - dTHR; + dSP; if (in_eval) { I32 cxix; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; - if (in_eval & 4) { - SV **svp; - STRLEN klen = strlen(message); - - svp = hv_fetch(ERRHV, message, klen, TRUE); - if (svp) { - if (!SvIOK(*svp)) { - static char prefix[] = "\t(in cleanup) "; - SV *err = ERRSV; - sv_upgrade(*svp, SVt_IV); - (void)SvIOK_only(*svp); - if (!SvPOK(err)) - sv_setpv(err,""); - SvGROW(err, SvCUR(err)+sizeof(prefix)+klen); - sv_catpvn(err, prefix, sizeof(prefix)-1); - sv_catpvn(err, message, klen); + if (message) { + if (in_eval & 4) { + SV **svp; + STRLEN klen = strlen(message); + + svp = hv_fetch(ERRHV, message, klen, TRUE); + if (svp) { + if (!SvIOK(*svp)) { + static char prefix[] = "\t(in cleanup) "; + SV *err = ERRSV; + sv_upgrade(*svp, SVt_IV); + (void)SvIOK_only(*svp); + if (!SvPOK(err)) + sv_setpv(err,""); + SvGROW(err, SvCUR(err)+sizeof(prefix)+klen); + sv_catpvn(err, prefix, sizeof(prefix)-1); + sv_catpvn(err, message, klen); + } + sv_inc(*svp); } - sv_inc(*svp); } + else + sv_setpv(ERRSV, message); } else - sv_setpv(ERRSV, message); - - cxix = dopoptoeval(cxstack_ix); + message = SvPVx(ERRSV, na); + + while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) { + dounwind(-1); + POPSTACK; + } + if (cxix >= 0) { I32 optype; @@ -1132,6 +1173,8 @@ PP(pp_caller) djSP; register I32 cxix = dopoptosub(cxstack_ix); register PERL_CONTEXT *cx; + register PERL_CONTEXT *ccstack = cxstack; + PERL_SI *top_si = curstackinfo; I32 dbcxix; I32 gimme; HV *hv; @@ -1142,25 +1185,32 @@ PP(pp_caller) count = POPi; EXTEND(SP, 6); for (;;) { + /* we may be in a higher stacklevel, so dig down deeper */ + while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { + top_si = top_si->si_prev; + ccstack = top_si->si_cxstack; + cxix = dopoptosub_at(ccstack, top_si->si_cxix); + } if (cxix < 0) { if (GIMME != G_ARRAY) RETPUSHUNDEF; RETURN; } if (DBsub && cxix >= 0 && - cxstack[cxix].blk_sub.cv == GvCV(DBsub)) + ccstack[cxix].blk_sub.cv == GvCV(DBsub)) count++; if (!count--) break; - cxix = dopoptosub(cxix - 1); + cxix = dopoptosub_at(ccstack, 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 + + cx = &ccstack[cxix]; + if (ccstack[cxix].cx_type == CXt_SUB) { + dbcxix = dopoptosub_at(ccstack, cxix - 1); + /* We expect that ccstack[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 (DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(DBsub)) + cx = &ccstack[dbcxix]; } if (GIMME != G_ARRAY) { @@ -1184,9 +1234,9 @@ PP(pp_caller) PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line))); if (!MAXARG) RETURN; - if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */ + if (cx->cx_type == CXt_SUB) { /* So is ccstack[dbcxix]. */ sv = NEWSV(49, 0); - gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch); + gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch); PUSHs(sv_2mortal(sv)); PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); } @@ -1233,7 +1283,7 @@ PP(pp_caller) RETURN; } -static I32 +STATIC I32 sortcv(SV *a, SV *b) { dTHR; @@ -1244,7 +1294,7 @@ sortcv(SV *a, SV *b) GvSV(secondgv) = b; stack_sp = stack_base; op = sortcop; - runops(); + CALLRUNOPS(); if (stack_sp != stack_base + 1) croak("Sort subroutine didn't return single value"); if (!SvNIOKp(*stack_sp)) @@ -1285,7 +1335,7 @@ PP(pp_dbstate) if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace)) { - SV **sp; + djSP; register CV *cv; register PERL_CONTEXT *cx; I32 gimme = G_ARRAY; @@ -1307,10 +1357,10 @@ PP(pp_dbstate) SAVESTACK_POS(); debug = 0; hasargs = 0; - sp = stack_sp; + SPAGAIN; push_return(op->op_next); - PUSHBLOCK(cx, CXt_SUB, sp); + PUSHBLOCK(cx, CXt_SUB, SP); PUSHSUB(cx); CvDEPTH(cv)++; (void)SvREFCNT_inc(cv); @@ -1347,19 +1397,34 @@ PP(pp_enteriter) SAVESPTR(*svp); } else { - svp = &GvSV((GV*)POPs); /* symbol table variable */ - SAVESPTR(*svp); + GV *gv = (GV*)POPs; + (void)save_scalar(gv); + svp = &GvSV(gv); /* symbol table variable */ } ENTER; PUSHBLOCK(cx, CXt_LOOP, SP); PUSHLOOP(cx, svp, MARK); - if (op->op_flags & OPf_STACKED) + if (op->op_flags & OPf_STACKED) { cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); + if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { + dPOPss; + if (SvNIOKp(sv) || !SvPOKp(sv) || + (looks_like_number(sv) && *SvPVX(sv) != '0')) { + if (SvNV(sv) < IV_MIN || + SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX) + croak("Range iterator outside integer range"); + cx->blk_loop.iterix = SvIV(sv); + cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary); + } + else + cx->blk_loop.iterlval = newSVsv(sv); + } + } else { cx->blk_loop.iterary = curstack; - AvFILLp(curstack) = sp - stack_base; + AvFILLp(curstack) = SP - stack_base; cx->blk_loop.iterix = MARK - stack_base; } @@ -1435,7 +1500,7 @@ PP(pp_return) PMOP *newpm; I32 optype = 0; - if (curstack == sortstack) { + if (curstackinfo->si_type == PERLSI_SORT) { if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) { if (cxstack_ix > sortcxix) dounwind(sortcxix); @@ -1474,10 +1539,22 @@ PP(pp_return) TAINT_NOT; if (gimme == G_SCALAR) { - if (MARK < SP) - *++newsp = (popsub2 && SvTEMP(*SP)) - ? *SP : sv_mortalcopy(*SP); - else + if (MARK < SP) { + if (popsub2) { + if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) { + if (SvTEMP(TOPs)) { + *++newsp = SvREFCNT_inc(*SP); + FREETMPS; + sv_2mortal(*newsp); + } else { + FREETMPS; + *++newsp = sv_mortalcopy(*SP); + } + } else + *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); + } else + *++newsp = sv_mortalcopy(*SP); + } else *++newsp = &sv_undef; } else if (gimme == G_ARRAY) { @@ -1631,9 +1708,7 @@ PP(pp_redo) return cx->blk_loop.redo_op; } -static OP* lastgotoprobe; - -static OP * +STATIC OP * dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit) { OP *kid; @@ -1653,6 +1728,7 @@ dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit) } *ops = 0; if (o->op_flags & OPf_KIDS) { + dTHR; /* First try all the kids at this level, since that's likeliest. */ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && @@ -1721,8 +1797,11 @@ PP(pp_goto) if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); + if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) + DIE("Can't goto subroutine from an eval-string"); mark = stack_sp; - if (cx->blk_sub.hasargs) { /* put @_ back onto stack */ + if (cx->cx_type == CXt_SUB && + cx->blk_sub.hasargs) { /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; items = AvFILLp(av) + 1; @@ -1737,7 +1816,22 @@ PP(pp_goto) AvREAL_off(av); av_clear(av); } - if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) + else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ + AV* av; + int i; +#ifdef USE_THREADS + av = (AV*)curpad[0]; +#else + av = GvAV(defgv); +#endif + items = AvFILLp(av) + 1; + stack_sp++; + EXTEND(stack_sp, items); /* @_ could have been extended. */ + Copy(AvARRAY(av), stack_sp, items, SV*); + stack_sp += items; + } + if (cx->cx_type == CXt_SUB && + !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) SvREFCNT_dec(cx->blk_sub.cv); oldsave = scopestack[scopestack_ix - 1]; LEAVE_SCOPE(oldsave); @@ -1747,19 +1841,27 @@ PP(pp_goto) if (CvXSUB(cv)) { if (CvOLDSTYLE(cv)) { I32 (*fp3)_((int,int,int)); - while (sp > mark) { - sp[1] = sp[0]; - sp--; + while (SP > mark) { + SP[1] = SP[0]; + SP--; } fp3 = (I32(*)_((int,int,int)))CvXSUB(cv); items = (*fp3)(CvXSUBANY(cv).any_i32, mark - stack_base + 1, items); - sp = stack_base + items; + SP = stack_base + items; } else { + SV **newsp; + I32 gimme; + stack_sp--; /* There is no cv arg. */ - (void)(*CvXSUB(cv))(cv); + /* Push a mark for the start of arglist */ + PUSHMARK(mark); + (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS); + /* Pop the current context like a decent sub should */ + POPBLOCK(cx, curpm); + /* Do _not_ use PUTBACK, keep the XSUB's return stack! */ } LEAVE; return pop_return(); @@ -1767,6 +1869,12 @@ PP(pp_goto) else { AV* padlist = CvPADLIST(cv); SV** svp = AvARRAY(padlist); + if (cx->cx_type == CXt_EVAL) { + in_eval = cx->blk_eval.old_in_eval; + eval_root = cx->blk_eval.old_eval_root; + cx->cx_type = CXt_SUB; + cx->blk_sub.hasargs = 0; + } cx->blk_sub.cv = cv; cx->blk_sub.olddepth = CvDEPTH(cv); CvDEPTH(cv)++; @@ -1823,9 +1931,9 @@ PP(pp_goto) items = AvFILLp(av) + 1; if (items) { /* Mark is at the end of the stack. */ - EXTEND(sp, items); - Copy(AvARRAY(av), sp + 1, items, SV*); - sp += items; + EXTEND(SP, items); + Copy(AvARRAY(av), SP + 1, items, SV*); + SP += items; PUTBACK ; } } @@ -1868,14 +1976,26 @@ PP(pp_goto) mark++; } } - if (PERLDB_SUB && curstash != debstash) { + if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ /* * 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); + CV *gotocv; + + if (PERLDB_SUB_NN) { + SvIVX(sv) = (IV)cv; /* Already upgraded, saved */ + } else { + save_item(sv); + gv_efullname3(sv, CvGV(cv), Nullch); + } + if ( PERLDB_GOTO + && (gotocv = perl_get_cv("DB::goto", FALSE)) ) { + PUSHMARK( stack_sp ); + perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); + stack_sp--; + } } RETURNOP(CvSTART(cv)); } @@ -1961,7 +2081,7 @@ PP(pp_goto) if (op->op_type == OP_ENTERITER) DIE("Can't \"goto\" into the middle of a foreach loop", label); - (*op->op_ppaddr)(ARGS); + (CALLOP->op_ppaddr)(ARGS); } op = oldop; } @@ -1980,7 +2100,7 @@ PP(pp_goto) do_undump = FALSE; } - if (curstack == signalstack) { + if (top_env->je_prev) { restartop = retop; JMPENV_JUMP(3); } @@ -2049,7 +2169,7 @@ PP(pp_cswitch) /* Eval. */ -static void +STATIC void save_lines(AV *array, SV *sv) { register char *s = SvPVX(sv); @@ -2073,7 +2193,7 @@ save_lines(AV *array, SV *sv) } } -static OP * +STATIC OP * docatch(OP *o) { dTHR; @@ -2102,7 +2222,7 @@ docatch(OP *o) restartop = 0; /* FALL THROUGH */ case 0: - runops(); + CALLRUNOPS(); break; } JMPENV_POP; @@ -2143,8 +2263,12 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) introduced within evals. See force_ident(). GSAR 96-10-12 */ safestr = savepv(tmpbuf); SAVEDELETE(defstash, safestr, strlen(safestr)); - SAVEI32(hints); + SAVEHINTS(); +#ifdef OP_IN_REGISTER + opsave = op; +#else SAVEPPTR(op); +#endif hints = 0; op = &dummy; @@ -2161,11 +2285,14 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) lex_end(); *avp = (AV*)SvREFCNT_inc(comppad); LEAVE; +#ifdef OP_IN_REGISTER + op = opsave; +#endif return rop; } /* With USE_THREADS, eval_owner must be held on entry to doeval */ -static OP * +STATIC OP * doeval(int gimme, OP** startop) { dSP; @@ -2319,7 +2446,7 @@ doeval(int gimme, OP** startop) CV *cv = perl_get_cv("DB::postponed", FALSE); if (cv) { dSP; - PUSHMARK(sp); + PUSHMARK(SP); XPUSHs((SV*)compiling.cop_filegv); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); @@ -2347,6 +2474,7 @@ PP(pp_require) register PERL_CONTEXT *cx; SV *sv; char *name; + STRLEN len; char *tryname; SV *namesv = Nullsv; SV** svp; @@ -2361,12 +2489,12 @@ PP(pp_require) SvPV(sv,na),patchlevel); RETPUSHYES; } - name = SvPV(sv, na); - if (!*name) + name = SvPV(sv, len); + if (!(name && len > 0 && *name)) DIE("Null filename used"); TAINT_PROPER("require"); if (op->op_type == OP_REQUIRE && - (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) && + (svp = hv_fetch(GvHVn(incgv), name, len, 0)) && *svp != &sv_undef) RETPUSHYES; @@ -2463,7 +2591,7 @@ PP(pp_require) rsfp = tryrsfp; name = savepv(name); SAVEFREEPV(name); - SAVEI32(hints); + SAVEHINTS(); hints = 0; /* switch to eval mode */ @@ -2523,7 +2651,7 @@ PP(pp_entereval) introduced within evals. See force_ident(). GSAR 96-10-12 */ safestr = savepv(tmpbuf); SAVEDELETE(defstash, safestr, strlen(safestr)); - SAVEI32(hints); + SAVEHINTS(); hints = op->op_targ; push_return(op->op_next); @@ -2628,21 +2756,22 @@ PP(pp_leaveeval) assert(CvDEPTH(compcv) == 1); #endif CvDEPTH(compcv) = 0; + lex_end(); if (optype == OP_REQUIRE && - !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) + !(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); + /* die_where() did LEAVE, or we won't be here */ + } + else { + LEAVE; + if (!(save_flags & OPf_SPECIAL)) + sv_setpv(ERRSV,""); } - - lex_end(); - LEAVE; - - if (!(save_flags & OPf_SPECIAL)) - sv_setpv(ERRSV,""); RETURNOP(retop); } @@ -2714,7 +2843,7 @@ PP(pp_leavetry) RETURN; } -static void +STATIC void doparseform(SV *sv) { STRLEN len; @@ -2998,8 +3127,13 @@ struct partition_stack_entry { /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2 */ +#ifdef PERL_OBJECT +#define qsort_cmp(elt1, elt2) \ + ((this->*compare)(array[elt1], array[elt2])) +#else #define qsort_cmp(elt1, elt2) \ ((*compare)(array[elt1], array[elt2])) +#endif #ifdef QSORT_ORDER_GUESS #define QSORT_NOTICE_SWAP swapped++; @@ -3079,11 +3213,15 @@ doqsort_all_asserts( /* ****************************************************************** qsort */ -void +STATIC void +#ifdef PERL_OBJECT +qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare) +#else qsortsv( SV ** array, size_t num_elts, I32 (*compare)(SV *a, SV *b)) +#endif { register SV * temp; @@ -3546,9 +3684,10 @@ qsortsv( if (j != i) { /* Looks like we really need to move some things */ + int k; temp = array[i]; - for (--i; i >= j; --i) - array[i + 1] = array[i]; + for (k = i - 1; k >= j; --k) + array[k + 1] = array[k]; array[j] = temp; } }