X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/fd7c759890fb35d6828190e9cc86c897c789a73d..c803703701b66ee8fee828b4344c92c4d0124184:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 8e16629..9a807a5 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -73,7 +73,7 @@ PP(pp_regcomp) tmpstr = POPs; /* prevent recompiling under /o and ithreads. */ -#if defined(USE_ITHREADS) || defined(USE_5005THREADS) +#if defined(USE_ITHREADS) if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) RETURN; #endif @@ -138,7 +138,7 @@ PP(pp_regcomp) /* XXX runtime compiled output needs to move to the pad */ if (pm->op_pmflags & PMf_KEEP) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ -#if !defined(USE_ITHREADS) && !defined(USE_5005THREADS) +#if !defined(USE_ITHREADS) /* XXX can't change the optree at runtime either */ cLOGOP->op_first->op_next = PL_op->op_next; #endif @@ -158,7 +158,7 @@ PP(pp_substcont) register REGEXP *rx = cx->sb_rx; rxres_restore(&cx->sb_rxres, rx); - PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0; + RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ)); if (cx->sb_iters++) { I32 saviters = cx->sb_iters; @@ -181,8 +181,16 @@ PP(pp_substcont) sv_catpvn(dstr, s, cx->sb_strend - s); cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); - (void)SvOOK_off(targ); - Safefree(SvPVX(targ)); +#ifdef PERL_COPY_ON_WRITE + if (SvIsCOW(targ)) { + sv_force_normal_flags(targ, SV_COW_DROP_PV); + } else +#endif + { + (void)SvOOK_off(targ); + if (SvLEN(targ)) + Safefree(SvPVX(targ)); + } SvPVX(targ) = SvPVX(dstr); SvCUR_set(targ, SvCUR(dstr)); SvLEN_set(targ, SvLEN(dstr)); @@ -243,7 +251,11 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) U32 i; if (!p || p[1] < rx->nparens) { +#ifdef PERL_COPY_ON_WRITE + i = 7 + rx->nparens * 2; +#else i = 6 + rx->nparens * 2; +#endif if (!p) New(501, p, i, UV); else @@ -254,6 +266,11 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); RX_MATCH_COPIED_off(rx); +#ifdef PERL_COPY_ON_WRITE + *p++ = PTR2UV(rx->saved_copy); + rx->saved_copy = Nullsv; +#endif + *p++ = rx->nparens; *p++ = PTR2UV(rx->subbeg); @@ -270,11 +287,17 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) UV *p = (UV*)*rsp; U32 i; - if (RX_MATCH_COPIED(rx)) - Safefree(rx->subbeg); + RX_MATCH_COPY_FREE(rx); RX_MATCH_COPIED_set(rx, *p); *p++ = 0; +#ifdef PERL_COPY_ON_WRITE + if (rx->saved_copy) + SvREFCNT_dec (rx->saved_copy); + rx->saved_copy = INT2PTR(SV*,*p); + *p++ = 0; +#endif + rx->nparens = *p++; rx->subbeg = INT2PTR(char*,*p++); @@ -292,6 +315,11 @@ Perl_rxres_free(pTHX_ void **rsp) if (p) { Safefree(INT2PTR(char*,*p)); +#ifdef PERL_COPY_ON_WRITE + if (p[1]) { + SvREFCNT_dec (INT2PTR(SV*,p[1])); + } +#endif Safefree(p); *rsp = Null(void*); } @@ -836,7 +864,7 @@ PP(pp_mapwhile) } /* copy the new items down to the destination list */ dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; - while (items--) + while (items-- > 0) *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); } LEAVE; /* exit inner scope */ @@ -943,10 +971,14 @@ PP(pp_flop) if (SvGMAGICAL(right)) mg_get(right); + /* This code tries to decide if "$left .. $right" should use the + magical string increment, or if the range is numeric (we make + an exception for .."0" [#18165]). AMS 20021031. */ + if (SvNIOKp(left) || !SvPOKp(left) || SvNIOKp(right) || !SvPOKp(right) || (looks_like_number(left) && *SvPVX(left) != '0' && - looks_like_number(right) && *SvPVX(right) != '0')) + looks_like_number(right))) { if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX) DIE(aTHX_ "Range iterator outside integer range"); @@ -1011,6 +1043,16 @@ PP(pp_flop) /* Control. */ +static char *context_name[] = { + "pseudo-block", + "subroutine", + "eval", + "loop", + "substitution", + "block", + "format" +}; + STATIC I32 S_dopoptolabel(pTHX_ char *label) { @@ -1021,30 +1063,16 @@ S_dopoptolabel(pTHX_ char *label) cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s", - OP_NAME(PL_op)); - break; case CXt_SUB: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s", - OP_NAME(PL_op)); - break; case CXt_FORMAT: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s", - OP_NAME(PL_op)); - break; case CXt_EVAL: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s", - OP_NAME(PL_op)); - break; case CXt_NULL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s", - OP_NAME(PL_op)); - return -1; + Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); + if (CxTYPE(cx) == CXt_NULL) + return -1; + break; case CXt_LOOP: if (!cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) { @@ -1156,30 +1184,16 @@ S_dopoptoloop(pTHX_ I32 startingblock) cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s", - OP_NAME(PL_op)); - break; case CXt_SUB: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s", - OP_NAME(PL_op)); - break; case CXt_FORMAT: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s", - OP_NAME(PL_op)); - break; case CXt_EVAL: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s", - OP_NAME(PL_op)); - break; case CXt_NULL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s", - OP_NAME(PL_op)); - return -1; + Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); + if ((CxTYPE(cx)) == CXt_NULL) + return -1; + break; case CXt_LOOP: DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); return i; @@ -1378,7 +1392,40 @@ PP(pp_orassign) else RETURNOP(cLOGOP->op_other); } - + +PP(pp_dorassign) +{ + dSP; + register SV* sv; + + sv = TOPs; + if (!sv || !SvANY(sv)) { + RETURNOP(cLOGOP->op_other); + } + + switch (SvTYPE(sv)) { + case SVt_PVAV: + if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) + RETURN; + break; + case SVt_PVHV: + if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) + RETURN; + break; + case SVt_PVCV: + if (CvROOT(sv) || CvXSUB(sv)) + RETURN; + break; + default: + if (SvGMAGICAL(sv)) + mg_get(sv); + if (SvOK(sv)) + RETURN; + } + + RETURNOP(cLOGOP->op_other); +} + PP(pp_caller) { dSP; @@ -1450,11 +1497,18 @@ PP(pp_caller) if (!MAXARG) RETURN; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { + GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv); /* So is ccstack[dbcxix]. */ - sv = NEWSV(49, 0); - gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch); - PUSHs(sv_2mortal(sv)); - PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); + if (isGV(cvgv)) { + sv = NEWSV(49, 0); + gv_efullname3(sv, cvgv, Nullch); + PUSHs(sv_2mortal(sv)); + PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); + } + else { + PUSHs(sv_2mortal(newSVpvn("(unknown)",9))); + PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); + } } else { PUSHs(sv_2mortal(newSVpvn("(eval)",6))); @@ -1547,6 +1601,8 @@ PP(pp_lineseq) return NORMAL; } +/* like pp_nextstate, but used instead when the debugger is active */ + PP(pp_dbstate) { PL_curcop = (COP*)PL_op; @@ -1554,7 +1610,8 @@ PP(pp_dbstate) PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; - if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) + if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ + || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { dSP; register CV *cv; @@ -1583,11 +1640,10 @@ PP(pp_dbstate) push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_SUB, SP); - PUSHSUB(cx); + PUSHSUB_DB(cx); CvDEPTH(cv)++; (void)SvREFCNT_inc(cv); - SAVEVPTR(PL_curpad); - PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE)); + PAD_SET_CUR(CvPADLIST(cv),1); RETURNOP(CvSTART(cv)); } else @@ -1613,17 +1669,9 @@ PP(pp_enteriter) ENTER; SAVETMPS; -#ifdef USE_5005THREADS - if (PL_op->op_flags & OPf_SPECIAL) { - svp = &THREADSV(PL_op->op_targ); /* per-thread variable */ - SAVEGENERICSV(*svp); - *svp = NEWSV(0,0); - } - else -#endif /* USE_5005THREADS */ if (PL_op->op_targ) { #ifndef USE_ITHREADS - svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */ + svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */ SAVESPTR(*svp); #else SAVEPADSV(PL_op->op_targ); @@ -1653,11 +1701,11 @@ PP(pp_enteriter) cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { dPOPss; + /* See comment in pp_flop() */ if (SvNIOKp(sv) || !SvPOKp(sv) || SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) || (looks_like_number(sv) && *SvPVX(sv) != '0' && - looks_like_number((SV*)cx->blk_loop.iterary) && - *SvPVX(cx->blk_loop.iterary) != '0')) + looks_like_number((SV*)cx->blk_loop.iterary))) { if (SvNV(sv) < IV_MIN || SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX) @@ -1783,7 +1831,7 @@ PP(pp_return) /* Unassume the success we assumed earlier. */ SV *nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD); - DIE(aTHX_ "%s did not return a true value", SvPVX(nsv)); + DIE(aTHX_ "%"SVf" did not return a true value", nsv); } break; case CXt_FORMAT: @@ -1994,6 +2042,7 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) if (o->op_type == OP_LEAVE || o->op_type == OP_SCOPE || o->op_type == OP_LEAVELOOP || + o->op_type == OP_LEAVESUB || o->op_type == OP_LEAVETRY) { *ops++ = cUNOPo->op_first; @@ -2011,11 +2060,15 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid == PL_lastgotoprobe) continue; - 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 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { + if (ops == opstack) + *ops++ = kid; + else if (ops[-1]->op_type == OP_NEXTSTATE || + ops[-1]->op_type == OP_DBSTATE) + ops[-1] = kid; + else + *ops++ = kid; + } if ((o = dofindlabel(kid, label, ops, oplimit))) return o; } @@ -2071,12 +2124,13 @@ PP(pp_goto) goto retry; tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, Nullch); - DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr)); + DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr); } DIE(aTHX_ "Goto undefined subroutine"); } /* First do some returnish stuff. */ + FREETMPS; cxix = dopoptosub(cxstack_ix); if (cxix < 0) DIE(aTHX_ "Can't goto subroutine outside a subroutine"); @@ -2095,26 +2149,20 @@ PP(pp_goto) EXTEND(PL_stack_sp, items); /* @_ could have been extended. */ Copy(AvARRAY(av), PL_stack_sp, items, SV*); PL_stack_sp += items; -#ifndef USE_5005THREADS SvREFCNT_dec(GvAV(PL_defgv)); GvAV(PL_defgv) = cx->blk_sub.savearray; -#endif /* USE_5005THREADS */ /* abandon @_ if it got reified */ if (AvREAL(av)) { (void)sv_2mortal((SV*)av); /* delay until return */ av = newAV(); av_extend(av, items-1); AvFLAGS(av) = AVf_REIFY; - PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av); + PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av); } } else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ AV* av; -#ifdef USE_5005THREADS - av = (AV*)PL_curpad[0]; -#else av = GvAV(PL_defgv); -#endif items = AvFILLp(av) + 1; PL_stack_sp++; EXTEND(PL_stack_sp, items); /* @_ could have been extended. */ @@ -2162,7 +2210,6 @@ PP(pp_goto) } else { AV* padlist = CvPADLIST(cv); - SV** svp = AvARRAY(padlist); if (CxTYPE(cx) == CXt_EVAL) { PL_in_eval = cx->blk_eval.old_in_eval; PL_eval_root = cx->blk_eval.old_eval_root; @@ -2171,85 +2218,24 @@ PP(pp_goto) } cx->blk_sub.cv = cv; cx->blk_sub.olddepth = (U16)CvDEPTH(cv); + CvDEPTH(cv)++; if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); - else { /* save temporaries on recursion? */ + else { if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); - if (CvDEPTH(cv) > AvFILLp(padlist)) { - AV *newpad = newAV(); - SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); - I32 ix = AvFILLp((AV*)svp[1]); - I32 names_fill = AvFILLp((AV*)svp[0]); - svp = AvARRAY(svp[0]); - for ( ;ix > 0; ix--) { - if (names_fill >= ix && svp[ix] != &PL_sv_undef) { - 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 if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { - av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix])); - } - else { - av_store(newpad, ix, sv = NEWSV(0,0)); - SvPADTMP_on(sv); - } - } - if (cx->blk_sub.hasargs) { - AV* av = newAV(); - av_extend(av, 0); - av_store(newpad, 0, (SV*)av); - AvFLAGS(av) = AVf_REIFY; - } - av_store(padlist, CvDEPTH(cv), (SV*)newpad); - AvFILLp(padlist) = CvDEPTH(cv); - svp = AvARRAY(padlist); - } - } -#ifdef USE_5005THREADS - if (!cx->blk_sub.hasargs) { - AV* av = (AV*)PL_curpad[0]; - - 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; - PUTBACK ; - } + pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs); } -#endif /* USE_5005THREADS */ - SAVEVPTR(PL_curpad); - PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); -#ifndef USE_5005THREADS + PAD_SET_CUR(padlist, CvDEPTH(cv)); if (cx->blk_sub.hasargs) -#endif /* USE_5005THREADS */ { - AV* av = (AV*)PL_curpad[0]; + AV* av = (AV*)PAD_SVl(0); SV** ary; -#ifndef USE_5005THREADS cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); -#endif /* USE_5005THREADS */ - cx->blk_sub.oldcurpad = PL_curpad; + CX_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; ++mark; @@ -2315,6 +2301,7 @@ PP(pp_goto) if (label && *label) { OP *gotoprobe = 0; bool leaving_eval = FALSE; + bool in_block = FALSE; PERL_CONTEXT *last_eval_cx = 0; /* find label */ @@ -2340,9 +2327,10 @@ PP(pp_goto) case CXt_SUBST: continue; case CXt_BLOCK: - if (ix) + if (ix) { gotoprobe = cx->blk_oldcop->op_sibling; - else + in_block = TRUE; + } else gotoprobe = PL_main_root; break; case CXt_SUB: @@ -2399,7 +2387,8 @@ PP(pp_goto) if (*enterops && enterops[1]) { OP *oldop = PL_op; - for (ix = 1; enterops[ix]; ix++) { + ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; + for (; enterops[ix]; ix++) { PL_op = enterops[ix]; /* Eventually we may want to stack the needed arguments * for each op. For now, we punt on the hard ones. */ @@ -2588,7 +2577,7 @@ S_docatch(pTHX_ OP *o) } OP * -Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) +Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) /* sv Text to convert to OP tree. */ /* startop op_free() this to undo. */ /* code Short string id of the caller. */ @@ -2603,6 +2592,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) char tbuf[TYPE_DIGITS(long) + 12 + 10]; char *tmpbuf = tbuf; char *safestr; + int runtime; + CV* runcv = Nullcv; /* initialise to avoid compiler warnings */ ENTER; lex_start(sv); @@ -2641,19 +2632,29 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) #endif PL_hints &= HINT_UTF8; + /* we get here either during compilation, or via pp_regcomp at runtime */ + runtime = PL_op && (PL_op->op_type == OP_REGCOMP); + if (runtime) + runcv = find_runcv(NULL); + PL_op = &dummy; PL_op->op_type = OP_ENTEREVAL; PL_op->op_flags = 0; /* Avoid uninit warning. */ PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP); PUSHEVAL(cx, 0, Nullgv); - rop = doeval(G_SCALAR, startop); + + if (runtime) + rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); + else + rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); POPBLOCK(cx,PL_curpm); POPEVAL(cx); (*startop)->op_type = OP_NULL; (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; lex_end(); - *avp = (AV*)SvREFCNT_inc(PL_comppad); + /* XXX DAPM do this properly one year */ + *padp = (AV*)SvREFCNT_inc(PL_comppad); LEAVE; if (PL_curcop == &PL_compiling) PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); @@ -2663,15 +2664,60 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) return rop; } + +/* +=for apidoc find_runcv + +Locate the CV corresponding to the currently executing sub or eval. +If db_seqp is non_null, skip CVs that are in the DB package and populate +*db_seqp with the cop sequence number at the point that the DB:: code was +entered. (allows debuggers to eval in the scope of the breakpoint rather +than in in the scope of the debuger itself). + +=cut +*/ + +CV* +Perl_find_runcv(pTHX_ U32 *db_seqp) +{ + I32 ix; + PERL_SI *si; + PERL_CONTEXT *cx; + + if (db_seqp) + *db_seqp = PL_curcop->cop_seq; + for (si = PL_curstackinfo; si; si = si->si_prev) { + for (ix = si->si_cxix; ix >= 0; ix--) { + cx = &(si->si_cxstack[ix]); + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { + CV *cv = cx->blk_sub.cv; + /* skip DB:: code */ + if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { + *db_seqp = cx->blk_oldcop->cop_seq; + continue; + } + return cv; + } + else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) + return PL_compcv; + } + } + return PL_main_cv; +} + + +/* Compile a require/do, an eval '', or a /(?{...})/. + * In the last case, startop is non-null, and contains the address of + * a pointer that should be set to the just-compiled code. + * outside is the lexically enclosing CV (if any) that invoked us. + */ + /* With USE_5005THREADS, eval_owner must be held on entry to doeval */ STATIC OP * -S_doeval(pTHX_ int gimme, OP** startop) +S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { dSP; OP *saveop = PL_op; - CV *caller; - AV* comppadlist; - I32 i; PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) @@ -2679,27 +2725,6 @@ S_doeval(pTHX_ int gimme, OP** startop) PUSHMARK(SP); - /* set up a scratch pad */ - - SAVEI32(PL_padix); - SAVEVPTR(PL_curpad); - SAVESPTR(PL_comppad); - SAVESPTR(PL_comppad_name); - SAVEI32(PL_comppad_name_fill); - SAVEI32(PL_min_intro_pending); - SAVEI32(PL_max_intro_pending); - - caller = PL_compcv; - for (i = cxstack_ix - 1; i >= 0; i--) { - PERL_CONTEXT *cx = &cxstack[i]; - if (CxTYPE(cx) == CXt_EVAL) - break; - else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { - caller = cx->blk_sub.cv; - break; - } - } - SAVESPTR(PL_compcv); PL_compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)PL_compcv, SVt_PVCV); @@ -2707,36 +2732,13 @@ S_doeval(pTHX_ int gimme, OP** startop) assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); cxstack[cxstack_ix].blk_eval.cv = PL_compcv; -#ifdef USE_5005THREADS - CvOWNER(PL_compcv) = 0; - New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(PL_compcv)); -#endif /* USE_5005THREADS */ - - PL_comppad = newAV(); - av_push(PL_comppad, Nullsv); - PL_curpad = AvARRAY(PL_comppad); - PL_comppad_name = newAV(); - PL_comppad_name_fill = 0; - PL_min_intro_pending = 0; - PL_padix = 0; -#ifdef USE_5005THREADS - av_store(PL_comppad_name, 0, newSVpvn("@_", 2)); - PL_curpad[0] = (SV*)newAV(); - SvPADMY_on(PL_curpad[0]); /* XXX Needed? */ -#endif /* USE_5005THREADS */ - - comppadlist = newAV(); - AvREAL_off(comppadlist); - av_store(comppadlist, 0, (SV*)PL_comppad_name); - av_store(comppadlist, 1, (SV*)PL_comppad); - CvPADLIST(PL_compcv) = comppadlist; - - if (!saveop || - (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE)) - { - CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller); - } + CvOUTSIDE_SEQ(PL_compcv) = seq; + CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside); + + /* set up a scratch pad */ + + CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); + SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ @@ -2794,19 +2796,17 @@ S_doeval(pTHX_ int gimme, OP** startop) Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n")); } -#ifdef USE_5005THREADS - MUTEX_LOCK(&PL_eval_mutex); - PL_eval_owner = 0; - COND_SIGNAL(&PL_eval_cond); - MUTEX_UNLOCK(&PL_eval_mutex); -#endif /* USE_5005THREADS */ + else { + char* msg = SvPVx(ERRSV, n_a); + if (!*msg) { + sv_setpv(ERRSV, "Compilation error"); + } + } RETPUSHUNDEF; } CopLINE_set(&PL_compiling, 0); if (startop) { *startop = PL_eval_root; - SvREFCNT_dec(CvOUTSIDE(PL_compcv)); - CvOUTSIDE(PL_compcv) = Nullcv; } else SAVEFREEOP(PL_eval_root); if (gimme & G_VOID) @@ -2836,12 +2836,6 @@ S_doeval(pTHX_ int gimme, OP** startop) SP = PL_stack_base + POPMARK; /* pop original mark */ PL_op = saveop; /* The caller may need it. */ PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */ -#ifdef USE_5005THREADS - MUTEX_LOCK(&PL_eval_mutex); - PL_eval_owner = 0; - COND_SIGNAL(&PL_eval_cond); - MUTEX_UNLOCK(&PL_eval_mutex); -#endif /* USE_5005THREADS */ RETURNOP(PL_eval_start); } @@ -2948,8 +2942,8 @@ PP(pp_require) DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required" " (did you mean v%"UVuf".%03"UVuf"?)--" "this is only v%d.%d.%d, stopped", - rev, ver, sver, PERL_REVISION, PERL_VERSION, - PERL_SUBVERSION, rev, ver/100); + rev, ver, sver, rev, ver/100, + PERL_REVISION, PERL_VERSION, PERL_SUBVERSION); } else { DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--" @@ -2976,6 +2970,17 @@ PP(pp_require) tryname = name; tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); } +#ifdef MACOS_TRADITIONAL + if (!tryrsfp) { + char newname[256]; + + MacPerl_CanonDir(name, newname, 1); + if (path_is_absolute(newname)) { + tryname = newname; + tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE); + } + } +#endif if (!tryrsfp) { AV *ar = GvAVn(PL_incgv); I32 i; @@ -3109,8 +3114,11 @@ PP(pp_require) ) { char *dir = SvPVx(dirsv, n_a); #ifdef MACOS_TRADITIONAL - char buf[256]; - Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':')); + char buf1[256]; + char buf2[256]; + + MacPerl_CanonDir(name, buf2, 1); + Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':')); #else #ifdef VMS char *unixdir; @@ -3124,14 +3132,6 @@ PP(pp_require) #endif TAINT_PROPER("require"); tryname = SvPVX(namesv); -#ifdef MACOS_TRADITIONAL - { - /* Convert slashes in the name part, but not the directory part, to colons */ - char * colon; - for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); ) - *colon++ = ':'; - } -#endif tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') @@ -3175,7 +3175,7 @@ PP(pp_require) RETPUSHUNDEF; } else - SETERRNO(0, SS$_NORMAL); + SETERRNO(0, SS_NORMAL); /* Assume success here to prevent recursive requirement. */ len = strlen(name); @@ -3225,20 +3225,12 @@ PP(pp_require) CopLINE_set(&PL_compiling, 0); PUTBACK; -#ifdef USE_5005THREADS - MUTEX_LOCK(&PL_eval_mutex); - if (PL_eval_owner && PL_eval_owner != thr) - while (PL_eval_owner) - COND_WAIT(&PL_eval_cond, &PL_eval_mutex); - PL_eval_owner = thr; - MUTEX_UNLOCK(&PL_eval_mutex); -#endif /* USE_5005THREADS */ /* Store and reset encoding. */ encoding = PL_encoding; PL_encoding = Nullsv; - op = DOCATCH(doeval(gimme, NULL)); + op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq)); /* Restore encoding. */ PL_encoding = encoding; @@ -3262,8 +3254,10 @@ PP(pp_entereval) char *safestr; STRLEN len; OP *ret; + CV* runcv; + U32 seq; - if (!SvPV(sv,len) || !len) + if (!SvPV(sv,len)) RETPUSHUNDEF; TAINT_PROPER("eval"); @@ -3309,6 +3303,12 @@ PP(pp_entereval) PL_compiling.cop_io = newSVsv(PL_curcop->cop_io); SAVEFREESV(PL_compiling.cop_io); } + /* special case: an eval '' executed within the DB package gets lexically + * placed in the first non-DB CV rather than the current CV - this + * allows the debugger to execute code, find lexicals etc, in the + * scope of the code being debugged. Passing &seq gets find_runcv + * to do the dirty work for us */ + runcv = find_runcv(&seq); push_return(PL_op->op_next); PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); @@ -3319,15 +3319,7 @@ PP(pp_entereval) if (PERLDB_LINE && PL_curstash != PL_debstash) save_lines(CopFILEAV(&PL_compiling), PL_linestr); PUTBACK; -#ifdef USE_5005THREADS - MUTEX_LOCK(&PL_eval_mutex); - if (PL_eval_owner && PL_eval_owner != thr) - while (PL_eval_owner) - COND_WAIT(&PL_eval_cond, &PL_eval_mutex); - PL_eval_owner = thr; - MUTEX_UNLOCK(&PL_eval_mutex); -#endif /* USE_5005THREADS */ - ret = doeval(gimme, NULL); + ret = doeval(gimme, NULL, runcv, seq); if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */ && ret != PL_op->op_next) { /* Successive compilation. */ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ @@ -3391,7 +3383,7 @@ PP(pp_leaveeval) /* Unassume the success we assumed earlier. */ SV *nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD); - retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv)); + retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv); /* die_where() did LEAVE, or we won't be here */ } else { @@ -3743,7 +3735,7 @@ S_path_is_absolute(pTHX_ char *name) { if (PERL_FILE_IS_ABSOLUTE(name) #ifdef MACOS_TRADITIONAL - || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))) + || (*name == ':')) #else || (*name == '.' && (name[1] == '/' || (name[1] == '.' && name[2] == '/'))))