X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=0b006855b7c587280536ff4443507cd18adf80f8;hb=92a3e63c3aba23d356cf70f5886c704d07f8067d;hp=b6393de5a124a6786c66903c246f949283b07f10;hpb=dd2155a49b710f23bc6d72169e5b1d71d8b3aa03;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index b6393de..0b00685 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,6 +1,6 @@ /* pp_ctl.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (c) 1991-2003, 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. @@ -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 @@ -156,9 +156,10 @@ PP(pp_substcont) register char *m = cx->sb_m; char *orig = cx->sb_orig; register REGEXP *rx = cx->sb_rx; + SV *nsv = Nullsv; 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; @@ -178,11 +179,22 @@ PP(pp_substcont) { SV *targ = cx->sb_targ; - sv_catpvn(dstr, s, cx->sb_strend - s); + if (DO_UTF8(dstr) && !SvUTF8(targ)) + sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); + else + 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)); @@ -192,7 +204,7 @@ PP(pp_substcont) sv_free(dstr); TAINT_IF(cx->sb_rxtainted & 1); - PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); + PUSHs(sv_2mortal(newSViv(saviters - 1))); (void)SvPOK_only_UTF8(targ); TAINT_IF(cx->sb_rxtainted); @@ -213,8 +225,12 @@ PP(pp_substcont) cx->sb_strend = s + (cx->sb_strend - m); } cx->sb_m = m = rx->startp[0] + orig; - if (m > s) - sv_catpvn(dstr, s, m-s); + if (m > s) { + if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) + sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); + else + sv_catpvn(dstr, s, m-s); + } cx->sb_s = rx->endp[0] + orig; { /* Update the pos() information. */ SV *sv = cx->sb_targ; @@ -243,7 +259,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 +274,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 +295,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 +323,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*); } @@ -319,7 +355,9 @@ PP(pp_formline) bool gotsome = FALSE; STRLEN len; STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1; - bool item_is_utf = FALSE; + bool item_is_utf8 = FALSE; + bool targ_is_utf8 = FALSE; + SV * nsv = Nullsv; if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { if (SvREADONLY(tmpForm)) { @@ -330,8 +368,9 @@ PP(pp_formline) else doparseform(tmpForm); } - SvPV_force(PL_formtarget, len); + if (DO_UTF8(PL_formtarget)) + targ_is_utf8 = TRUE; t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ t += len; f = SvPV(tmpForm, len); @@ -378,6 +417,21 @@ PP(pp_formline) case FF_LITERAL: arg = *fpc++; + if (targ_is_utf8 && !SvUTF8(tmpForm)) { + SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + *t = '\0'; + sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv); + t = SvEND(PL_formtarget); + break; + } + if (!targ_is_utf8 && DO_UTF8(tmpForm)) { + SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + *t = '\0'; + sv_utf8_upgrade(PL_formtarget); + SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + t = SvEND(PL_formtarget); + targ_is_utf8 = TRUE; + } while (arg--) *t++ = *f++; break; @@ -422,13 +476,13 @@ PP(pp_formline) break; s++; } - item_is_utf = TRUE; + item_is_utf8 = TRUE; itemsize = s - item; sv_pos_b2u(sv, &itemsize); break; } } - item_is_utf = FALSE; + item_is_utf8 = FALSE; if (itemsize > fieldsize) itemsize = fieldsize; send = chophere = s + itemsize; @@ -483,11 +537,11 @@ PP(pp_formline) itemsize = chophere - item; sv_pos_b2u(sv, &itemsize); } - item_is_utf = TRUE; + item_is_utf8 = TRUE; break; } } - item_is_utf = FALSE; + item_is_utf8 = FALSE; if (itemsize <= fieldsize) { send = chophere = s + itemsize; while (s < send) { @@ -543,7 +597,15 @@ PP(pp_formline) case FF_ITEM: arg = itemsize; s = item; - if (item_is_utf) { + if (item_is_utf8) { + if (!targ_is_utf8) { + SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + *t = '\0'; + sv_utf8_upgrade(PL_formtarget); + SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + t = SvEND(PL_formtarget); + targ_is_utf8 = TRUE; + } while (arg--) { if (UTF8_IS_CONTINUED(*s)) { STRLEN skip = UTF8SKIP(s); @@ -569,6 +631,21 @@ PP(pp_formline) } break; } + if (targ_is_utf8 && !item_is_utf8) { + SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + *t = '\0'; + sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv); + for (; t < SvEND(PL_formtarget); t++) { +#ifdef EBCDIC + int ch = *t++ = *s++; + if (iscntrl(ch)) +#else + if (!(*t & ~31)) +#endif + *t = ' '; + } + break; + } while (arg--) { #ifdef EBCDIC int ch = *t++ = *s++; @@ -592,22 +669,32 @@ PP(pp_formline) case FF_LINEGLOB: item = s = SvPV(sv, len); itemsize = len; - item_is_utf = FALSE; /* XXX is this correct? */ + if ((item_is_utf8 = DO_UTF8(sv))) + itemsize = sv_len_utf8(sv); if (itemsize) { + bool chopped = FALSE; gotsome = TRUE; - send = s + itemsize; + send = s + len; while (s < send) { if (*s++ == '\n') { - if (s == send) + if (s == send) { itemsize--; + chopped = TRUE; + } else lines++; } } SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); - sv_catpvn(PL_formtarget, item, itemsize); + if (targ_is_utf8) + SvUTF8_on(PL_formtarget); + sv_catsv(PL_formtarget, sv); + if (chopped) + SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1); SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); + if (item_is_utf8) + targ_is_utf8 = TRUE; } break; @@ -703,6 +790,8 @@ PP(pp_formline) if (strnEQ(linemark, linemark - arg, arg)) DIE(aTHX_ "Runaway format"); } + if (targ_is_utf8) + SvUTF8_on(PL_formtarget); FmLINES(PL_formtarget) = lines; SP = ORIGMARK; RETURNOP(cLISTOP->op_first); @@ -742,6 +831,8 @@ PP(pp_formline) case FF_END: *t = '\0'; SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + if (targ_is_utf8) + SvUTF8_on(PL_formtarget); FmLINES(PL_formtarget) += lines; SP = ORIGMARK; RETPUSHYES; @@ -836,7 +927,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 +1034,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 +1106,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 +1126,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 +1247,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; @@ -1558,8 +1635,18 @@ PP(pp_caller) (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) mask = newSVpvn(WARN_NONEstring, WARNsize) ; else if (old_warnings == pWARN_ALL || - (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) - mask = newSVpvn(WARN_ALLstring, WARNsize) ; + (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { + /* Get the bit mask for $warnings::Bits{all}, because + * it could have been extended by warnings::register */ + SV **bits_all; + HV *bits = get_hv("warnings::Bits", FALSE); + if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) { + mask = newSVsv(*bits_all); + } + else { + mask = newSVpvn(WARN_ALLstring, WARNsize) ; + } + } else mask = newSVsv(old_warnings); PUSHs(sv_2mortal(mask)); @@ -1596,7 +1683,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; @@ -1625,7 +1713,7 @@ 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); PAD_SET_CUR(CvPADLIST(cv),1); @@ -1654,14 +1742,6 @@ 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 = &PAD_SVl(PL_op->op_targ); /* "my" variable */ @@ -1694,11 +1774,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) @@ -1824,7 +1904,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: @@ -1869,6 +1949,7 @@ PP(pp_return) } PL_stack_sp = newsp; + LEAVE; /* Stack values are safe: */ if (popsub2) { POPSUB(cx,sv); /* release CV and @_ ... */ @@ -1877,7 +1958,6 @@ PP(pp_return) sv = Nullsv; PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; LEAVESUB(sv); if (clear_errsv) sv_setpv(ERRSV,""); @@ -1953,6 +2033,7 @@ PP(pp_last) SP = newsp; PUTBACK; + LEAVE; /* Stack values are safe: */ switch (pop2) { case CXt_LOOP: @@ -1965,7 +2046,6 @@ PP(pp_last) } PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; LEAVESUB(sv); return nextop; } @@ -2035,6 +2115,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; @@ -2052,11 +2133,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; } @@ -2112,12 +2197,14 @@ 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. */ + SvREFCNT_inc(cv); /* avoid premature free during unwind */ + FREETMPS; cxix = dopoptosub(cxstack_ix); if (cxix < 0) DIE(aTHX_ "Can't goto subroutine outside a subroutine"); @@ -2136,10 +2223,8 @@ 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 */ @@ -2151,11 +2236,7 @@ PP(pp_goto) } else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ AV* av; -#ifdef USE_5005THREADS - av = (AV*)PAD_SVl(0); -#else av = GvAV(PL_defgv); -#endif items = AvFILLp(av) + 1; PL_stack_sp++; EXTEND(PL_stack_sp, items); /* @_ could have been extended. */ @@ -2170,6 +2251,7 @@ PP(pp_goto) /* Now do some callish stuff. */ SAVETMPS; + SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvXSUB(cv)) { #ifdef PERL_XSUB_OLDSTYLE if (CvOLDSTYLE(cv)) { @@ -2220,32 +2302,14 @@ PP(pp_goto) sub_crush_depth(cv); pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs); } -#ifdef USE_5005THREADS - if (!cx->blk_sub.hasargs) { - AV* av = (AV*)PAD_SVl(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 ; - } - } -#endif /* USE_5005THREADS */ PAD_SET_CUR(padlist, CvDEPTH(cv)); -#ifndef USE_5005THREADS if (cx->blk_sub.hasargs) -#endif /* USE_5005THREADS */ { 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_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; ++mark; @@ -2312,6 +2376,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 */ @@ -2337,9 +2402,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: @@ -2396,7 +2462,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. */ @@ -2585,7 +2652,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. */ @@ -2600,6 +2667,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); @@ -2638,19 +2707,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); @@ -2660,14 +2739,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; - I32 i; PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) @@ -2675,17 +2800,6 @@ S_doeval(pTHX_ int gimme, OP** startop) PUSHMARK(SP); - 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); @@ -2693,21 +2807,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 */ + CvOUTSIDE_SEQ(PL_compcv) = seq; + CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside); /* set up a scratch pad */ CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); - if (!saveop || - (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE)) - { - CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller); - } SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ @@ -2765,22 +2871,26 @@ 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) + if (gimme & G_VOID && ! PL_in_eval & EVAL_INREQUIRE) + /* + * EVAL_INREQUIRE (the code is being required) is special-cased : + * in this case we want scalar context to be forced, instead + * of void context, so a proper return value is returned from + * C via this leaveeval op. + */ scalarvoid(PL_eval_root); else if (gimme & G_ARRAY) list(PL_eval_root); @@ -2807,12 +2917,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); } @@ -3202,20 +3306,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; @@ -3239,6 +3335,8 @@ PP(pp_entereval) char *safestr; STRLEN len; OP *ret; + CV* runcv; + U32 seq; if (!SvPV(sv,len)) RETPUSHUNDEF; @@ -3286,6 +3384,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); @@ -3296,15 +3400,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. */ @@ -3368,7 +3464,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 {