X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=de3487998fee0b78748993f1816249eb149bc973;hb=8ead3603a48f891846d351cca41dd2b5647ab9b9;hp=921363fe978412a889e7ebfd38e9e4231ea86c0e;hpb=d343c3ef4538135207ab69cd65d1bb1ef5403ccc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 921363f..de34879 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -149,6 +149,27 @@ PP(pp_regcomp) re = (REGEXP*) tmpstr; if (re) { + /* The match's LHS's get-magic might need to access this op's reg- + exp (as is sometimes the case with $'; see bug 70764). So we + must call get-magic now before we replace the regexp. Hopeful- + ly this hack can be replaced with the approach described at + http://www.nntp.perl.org/group/perl.perl5.porters/2007/03 + /msg122415.html some day. */ + if(pm->op_type == OP_MATCH) { + SV *lhs; + const bool was_tainted = PL_tainted; + if (pm->op_flags & OPf_STACKED) + lhs = TOPs; + else if (pm->op_private & OPpTARGET_MY) + lhs = PAD_SV(pm->op_targ); + else lhs = DEFSV; + SvGETMAGIC(lhs); + /* Restore the previous value of PL_tainted (which may have been + modified by get-magic), to avoid incorrectly setting the + RXf_TAINTED flag further down. */ + PL_tainted = was_tainted; + } + re = reg_temp_copy(NULL, re); ReREFCNT_dec(PM_GETRE(pm)); PM_SETRE(pm, re); @@ -1313,13 +1334,16 @@ S_dopoptolabel(pTHX_ const char *label) case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: - if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) { + { + const char *cx_label = CxLABEL(cx); + if (!cx_label || strNE(label, cx_label) ) { DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", - (long)i, CxLABEL(cx))); + (long)i, cx_label)); continue; } DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label)); return i; + } } } return i; @@ -1858,7 +1882,7 @@ PP(pp_dbstate) /* don't do recursive DB::DB call */ return NORMAL; - ENTER_with_name("sub"); + ENTER; SAVETMPS; SAVEI32(PL_debug); @@ -1873,7 +1897,7 @@ PP(pp_dbstate) (void)(*CvXSUB(cv))(aTHX_ cv); CvDEPTH(cv)--; FREETMPS; - LEAVE_with_name("sub"); + LEAVE; return NORMAL; } else { @@ -2089,7 +2113,7 @@ PP(pp_return) PMOP *newpm; I32 optype = 0; SV *sv; - OP *retop; + OP *retop = NULL; const I32 cxix = dopoptosub(cxstack_ix); @@ -2211,7 +2235,7 @@ PP(pp_last) I32 pop2 = 0; I32 gimme; I32 optype; - OP *nextop; + OP *nextop = NULL; SV **newsp; PMOP *newpm; SV **mark; @@ -2393,9 +2417,11 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) OP *kid; /* 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) && - CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label)) - return kid; + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { + const char *kid_label = CopLABEL(kCOP); + if (kid_label && strEQ(kid_label, label)) + return kid; + } } for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid == PL_lastgotoprobe) @@ -2534,7 +2560,7 @@ PP(pp_goto) PUSHMARK(mark); PUTBACK; (void)(*CvXSUB(cv))(aTHX_ cv); - LEAVE_with_name("sub"); + LEAVE; return retop; } else { @@ -2698,6 +2724,12 @@ PP(pp_goto) DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); } + if (*enterops && enterops[1]) { + I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; + if (enterops[i]) + deprecate("\"goto\" to jump into a construct"); + } + /* pop unwanted frames */ if (ix < cxstack_ix) { @@ -2799,6 +2831,20 @@ S_save_lines(pTHX_ AV *array, SV *sv) } } +/* +=for apidoc docatch + +Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context. + +0 is used as continue inside eval, + +3 is used for a die caught by an inner eval - continue inner loop + +See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must +establish a local jmpenv to handle exception traps. + +=cut +*/ STATIC OP * S_docatch(pTHX_ OP *o) { @@ -2850,13 +2896,20 @@ S_docatch(pTHX_ OP *o) return NULL; } +/* James Bond: Do you expect me to talk? + Auric Goldfinger: No, Mr. Bond. I expect you to die. + + This code is an ugly hack, doesn't work with lexicals in subroutines that are + called more than once, and is only used by regcomp.c, for (?{}) blocks. + + Currently it is not used outside the core code. Best if it stays that way. +*/ OP * Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) /* sv Text to convert to OP tree. */ /* startop op_free() this to undo. */ /* code Short string id of the caller. */ { - /* FIXME - how much of this code is common with pp_entereval? */ dVAR; dSP; /* Make POPBLOCK work. */ PERL_CONTEXT *cx; SV **newsp; @@ -3104,14 +3157,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) SAVEFREEOP(PL_eval_root); /* Set the context for this new optree. - * If the last op is an OP_REQUIRE, force scalar context. - * Otherwise, propagate the context from the eval(). */ - if (PL_eval_root->op_type == OP_LEAVEEVAL - && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ - && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type - == OP_REQUIRE) - scalar(PL_eval_root); - else if ((gimme & G_WANT) == G_VOID) + * Propagate the context from the eval(). */ + if ((gimme & G_WANT) == G_VOID) scalarvoid(PL_eval_root); else if ((gimme & G_WANT) == G_ARRAY) list(PL_eval_root); @@ -3250,21 +3297,21 @@ PP(pp_require) SVfARG(vnormal(PL_patchlevel))); } else { /* probably 'use 5.10' or 'use 5.8' */ - SV * hintsv = newSV(0); + SV *hintsv; I32 second = 0; if (av_len(lav)>=1) second = SvIV(*av_fetch(lav,1,0)); second /= second >= 600 ? 100 : 10; - hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d", - (int)first, (int)second,0); + hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0", + (int)first, (int)second); upg_version(hintsv, TRUE); DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" "--this is only %"SVf", stopped", SVfARG(vnormal(req)), - SVfARG(vnormal(hintsv)), + SVfARG(vnormal(sv_2mortal(hintsv))), SVfARG(vnormal(PL_patchlevel))); } } @@ -4313,7 +4360,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) (void) sv_2mortal(MUTABLE_SV(seen_this)); } if (NULL == seen_other) { - seen_this = newHV(); + seen_other = newHV(); (void) sv_2mortal(MUTABLE_SV(seen_other)); } for(i = 0; i <= other_len; ++i) { @@ -4321,7 +4368,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) SV * const * const other_elem = av_fetch(other_av, i, FALSE); if (!this_elem || !other_elem) { - if (this_elem || other_elem) + if ((this_elem && SvOK(*this_elem)) + || (other_elem && SvOK(*other_elem))) RETPUSHNO; } else if (hv_exists_ent(seen_this, @@ -4849,8 +4897,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) int status = 0; SV *upstream; STRLEN got_len; - const char *got_p = NULL; - const char *prune_from = NULL; + char *got_p = NULL; + char *prune_from = NULL; bool read_from_cache = FALSE; STRLEN umaxlen; @@ -4953,8 +5001,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) prune_from = got_p + umaxlen; } } else { - const char *const first_nl = - (const char *)memchr(got_p, '\n', got_len); + char *const first_nl = (char *)memchr(got_p, '\n', got_len); if (first_nl && first_nl + 1 < got_p + got_len) { /* There's a second line here... */ prune_from = first_nl + 1; @@ -4980,6 +5027,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) SvUTF8_on(cache); } SvCUR_set(upstream, got_len - cached_len); + *prune_from = 0; /* Can't yet be EOF */ if (status == 0) status = 1;