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);
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;
/* don't do recursive DB::DB call */
return NORMAL;
- ENTER_with_name("sub");
+ ENTER;
SAVETMPS;
SAVEI32(PL_debug);
(void)(*CvXSUB(cv))(aTHX_ cv);
CvDEPTH(cv)--;
FREETMPS;
- LEAVE_with_name("sub");
+ LEAVE;
return NORMAL;
}
else {
PMOP *newpm;
I32 optype = 0;
SV *sv;
- OP *retop;
+ OP *retop = NULL;
const I32 cxix = dopoptosub(cxstack_ix);
I32 pop2 = 0;
I32 gimme;
I32 optype;
- OP *nextop;
+ OP *nextop = NULL;
SV **newsp;
PMOP *newpm;
SV **mark;
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)
PUSHMARK(mark);
PUTBACK;
(void)(*CvXSUB(cv))(aTHX_ cv);
- LEAVE_with_name("sub");
+ LEAVE;
return retop;
}
else {
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) {
}
}
+/*
+=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)
{
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;
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);
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)));
}
}
(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) {
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,
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;
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;
SvUTF8_on(cache);
}
SvCUR_set(upstream, got_len - cached_len);
+ *prune_from = 0;
/* Can't yet be EOF */
if (status == 0)
status = 1;
projects / p5sagit/p5-mst-13.2.git / blobdiff