This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
add a missing colon to a code snippet in perlfunc
[perl5.git] / pp_ctl.c
<
CommitLineData
a0d0e21e
LW		 1/* pp_ctl.c
2 *
1129b882
NC		 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
a0d0e21e
LW		 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
4ac71550
TC		 12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
18 *
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
a0d0e21e
LW		 20 */
21
166f8a29
DM		 22/* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
27 *
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
30 */
31
32
a0d0e21e 33#include "EXTERN.h"
864dbfa3 34#define PERL_IN_PP_CTL_C
a0d0e21e
LW		 35#include "perl.h"
36
54310121 37#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
1e422769 38
94fcd414
NC		 39#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
40
a0d0e21e
LW		 41PP(pp_wantarray)
42{
97aff369 43 dVAR;
39644a26 44 dSP;
a0d0e21e 45 I32 cxix;
93f0bc49 46 const PERL_CONTEXT *cx;
a0d0e21e
LW		 47 EXTEND(SP, 1);
48
93f0bc49
FC		 49 if (PL_op->op_private & OPpOFFBYONE) {
50 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
51 }
52 else {
53 cxix = dopoptosub(cxstack_ix);
54 if (cxix < 0)
a0d0e21e 55 RETPUSHUNDEF;
93f0bc49
FC		 56 cx = &cxstack[cxix];
57 }
a0d0e21e 58
93f0bc49 59 switch (cx->blk_gimme) {
54310121 60 case G_ARRAY:
a0d0e21e 61 RETPUSHYES;
54310121 62 case G_SCALAR:
a0d0e21e 63 RETPUSHNO;
54310121
PP		 64 default:
65 RETPUSHUNDEF;
66 }
a0d0e21e
LW		 67}
68
2cd61cdb
IZ		 69PP(pp_regcreset)
70{
97aff369 71 dVAR;
2cd61cdb
IZ		 72 /* XXXX Should store the old value to allow for tie/overload - and
73 restore in regcomp, where marked with XXXX. */
3280af22 74 PL_reginterp_cnt = 0;
0b4182de 75 TAINT_NOT;
2cd61cdb
IZ		 76 return NORMAL;
77}
78
b3eb6a9b
GS		 79PP(pp_regcomp)
80{
97aff369 81 dVAR;
39644a26 82 dSP;
a0d0e21e 83 register PMOP *pm = (PMOP*)cLOGOP->op_other;
a0d0e21e 84 SV *tmpstr;
84679df5 85 REGEXP *re = NULL;
bfed75c6 86
4b5a0d1c 87 /* prevent recompiling under /o and ithreads. */
3db8f154 88#if defined(USE_ITHREADS)
131b3ad0
DM		 89 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
90 if (PL_op->op_flags & OPf_STACKED) {
91 dMARK;
92 SP = MARK;
93 }
94 else
95 (void)POPs;
96 RETURN;
97 }
513629ba 98#endif
d4b87e75
BM		 99
100#define tryAMAGICregexp(rx) \
101 STMT_START { \
6f1401dc 102 SvGETMAGIC(rx); \
d4b87e75 103 if (SvROK(rx) && SvAMAGIC(rx)) { \
31d632c3 104 SV *sv = AMG_CALLunary(rx, regexp_amg); \
d4b87e75
BM		 105 if (sv) { \
106 if (SvROK(sv)) \
107 sv = SvRV(sv); \
108 if (SvTYPE(sv) != SVt_REGEXP) \
109 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
110 rx = sv; \
111 } \
112 } \
113 } STMT_END
114
115
131b3ad0 116 if (PL_op->op_flags & OPf_STACKED) {
486ec47a 117 /* multiple args; concatenate them */
131b3ad0
DM		 118 dMARK; dORIGMARK;
119 tmpstr = PAD_SV(ARGTARG);
76f68e9b 120 sv_setpvs(tmpstr, "");
131b3ad0 121 while (++MARK <= SP) {
d4b87e75 122 SV *msv = *MARK;
79a8d529 123 SV *sv;
d4b87e75 124
79a8d529 125 tryAMAGICregexp(msv);
d4b87e75 126
79a8d529
DM		 127 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
128 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
129 {
130 sv_setsv(tmpstr, sv);
131 continue;
131b3ad0 132 }
37c07a4b
FC		 133
134 if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP) {
135 msv = SvRV(msv);
136 PL_reginterp_cnt +=
137 RX_SEEN_EVALS((REGEXP *)MUTABLE_PTR(msv));
138 }
139
a9984b10 140 sv_catsv_nomg(tmpstr, msv);
131b3ad0
DM		 141 }
142 SvSETMAGIC(tmpstr);
143 SP = ORIGMARK;
144 }
d4b87e75 145 else {
131b3ad0 146 tmpstr = POPs;
d4b87e75
BM		 147 tryAMAGICregexp(tmpstr);
148 }
149
150#undef tryAMAGICregexp
513629ba 151
b3eb6a9b 152 if (SvROK(tmpstr)) {
d8f6592e 153 SV * const sv = SvRV(tmpstr);
5c35adbb 154 if (SvTYPE(sv) == SVt_REGEXP)
d2f13c59 155 re = (REGEXP*) sv;
c277df42 156 }
d4b87e75
BM		 157 else if (SvTYPE(tmpstr) == SVt_REGEXP)
158 re = (REGEXP*) tmpstr;
159
5c35adbb 160 if (re) {
69dc4b30
FC		 161 /* The match's LHS's get-magic might need to access this op's reg-
162 exp (as is sometimes the case with $'; see bug 70764). So we
163 must call get-magic now before we replace the regexp. Hopeful-
164 ly this hack can be replaced with the approach described at
165 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
166 /msg122415.html some day. */
455d9033
FC		 167 if(pm->op_type == OP_MATCH) {
168 SV *lhs;
169 const bool was_tainted = PL_tainted;
170 if (pm->op_flags & OPf_STACKED)
69dc4b30 171 lhs = TOPs;
455d9033
FC		 172 else if (pm->op_private & OPpTARGET_MY)
173 lhs = PAD_SV(pm->op_targ);
174 else lhs = DEFSV;
175 SvGETMAGIC(lhs);
176 /* Restore the previous value of PL_tainted (which may have been
177 modified by get-magic), to avoid incorrectly setting the
178 RXf_TAINTED flag further down. */
179 PL_tainted = was_tainted;
180 }
69dc4b30 181
f0826785 182 re = reg_temp_copy(NULL, re);
aaa362c4 183 ReREFCNT_dec(PM_GETRE(pm));
28d8d7f4 184 PM_SETRE(pm, re);
c277df42
IZ		 185 }
186 else {
f3ec07c7
DM		 187 STRLEN len = 0;
188 const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
189
c737faaf 190 re = PM_GETRE(pm);
14a49a24 191 assert (re != (REGEXP*) &PL_sv_undef);
c277df42 192
20408e3c 193 /* Check against the last compiled regexp. */
a11c8683 194 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
220fc49f 195 memNE(RX_PRECOMP(re), t, len))
85aff577 196 {
07bc277f 197 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
73134a2e 198 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
d8f6592e
AL		 199 if (re) {
200 ReREFCNT_dec(re);
14a49a24
NC		 201#ifdef USE_ITHREADS
202 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
203#else
4608196e 204 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
14a49a24 205#endif
1e2e3d02 206 } else if (PL_curcop->cop_hints_hash) {
20439bc7 207 SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
1e2e3d02
YO		 208 if (ptr && SvIOK(ptr) && SvIV(ptr))
209 eng = INT2PTR(regexp_engine*,SvIV(ptr));
c277df42 210 }
664e119d 211
533c011a 212 if (PL_op->op_flags & OPf_SPECIAL)
3280af22 213 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
a0d0e21e 214
15d9c083 215 if (!DO_UTF8(tmpstr) && SvUTF8(tmpstr)) {
b9ad30b4
NC		 216 /* Not doing UTF-8, despite what the SV says. Is this only if
217 we're trapped in use 'bytes'? */
218 /* Make a copy of the octet sequence, but without the flag on,
219 as the compiler now honours the SvUTF8 flag on tmpstr. */
220 STRLEN len;
221 const char *const p = SvPV(tmpstr, len);
222 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
223 }
3e102237 224 else if (SvAMAGIC(tmpstr) || SvGMAGICAL(tmpstr)) {
f3ec07c7 225 /* make a copy to avoid extra stringifies */
0479a84a 226 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
f3ec07c7 227 }
c737faaf 228
5a8697a7 229 if (eng)
3ab4a224 230 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
5a8697a7 231 else
3ab4a224 232 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
c737faaf 233
f86aaa29 234 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
2cd61cdb 235 inside tie/overload accessors. */
c277df42 236 }
4633a7c4 237 }
c737faaf
YO		 238
239 re = PM_GETRE(pm);
a0d0e21e 240
72311751 241#ifndef INCOMPLETE_TAINTS
3280af22 242 if (PL_tainting) {
9274aefd
DM		 243 if (PL_tainted) {
244 SvTAINTED_on((SV*)re);
07bc277f 245 RX_EXTFLAGS(re) |= RXf_TAINTED;
9274aefd 246 }
72311751
GS		 247 }
248#endif
249
220fc49f 250 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
3280af22 251 pm = PL_curpm;
a0d0e21e 252
c737faaf
YO		 253
254#if !defined(USE_ITHREADS)
255 /* can't change the optree at runtime either */
256 /* PMf_KEEP is handled differently under threads to avoid these problems */
a0d0e21e 257 if (pm->op_pmflags & PMf_KEEP) {
c90c0ff4 258 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
533c011a 259 cLOGOP->op_first->op_next = PL_op->op_next;
a0d0e21e 260 }
c737faaf 261#endif
a0d0e21e
LW		 262 RETURN;
263}
264
265PP(pp_substcont)
266{
97aff369 267 dVAR;
39644a26 268 dSP;
c09156bb 269 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
901017d6
AL		 270 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
271 register SV * const dstr = cx->sb_dstr;
a0d0e21e
LW		 272 register char *s = cx->sb_s;
273 register char *m = cx->sb_m;
274 char *orig = cx->sb_orig;
901017d6 275 register REGEXP * const rx = cx->sb_rx;
c445ea15 276 SV *nsv = NULL;
988e6e7e 277 REGEXP *old = PM_GETRE(pm);
f410a211
NC		 278
279 PERL_ASYNC_CHECK();
280
988e6e7e 281 if(old != rx) {
bfed75c6 282 if(old)
988e6e7e 283 ReREFCNT_dec(old);
d6106309 284 PM_SETRE(pm,ReREFCNT_inc(rx));
d8f2cf8a
AB		 285 }
286
d9f97599 287 rxres_restore(&cx->sb_rxres, rx);
01b35787 288 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
c90c0ff4 289
a0d0e21e 290 if (cx->sb_iters++) {
a3b680e6 291 const I32 saviters = cx->sb_iters;
a0d0e21e 292 if (cx->sb_iters > cx->sb_maxiters)
cea2e8a9 293 DIE(aTHX_ "Substitution loop");
a0d0e21e 294
447ee134
DM		 295 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
296
ef07e810 297 /* See "how taint works" above pp_subst() */
20be6587
DM		 298 if (SvTAINTED(TOPs))
299 cx->sb_rxtainted |= SUBST_TAINT_REPL;
447ee134 300 sv_catsv_nomg(dstr, POPs);
2c296965
YO		 301 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
302 s -= RX_GOFS(rx);
a0d0e21e
LW		 303
304 /* Are we done */
134b8cd8
NC		 305 /* I believe that we can't set REXEC_SCREAM here if
306 SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always
307 equal to s. [See the comment before Perl_re_intuit_start(), which is
308 called from Perl_regexec_flags(), which says that it should be when
309 SvSCREAM() is true.] s, cx->sb_strend and orig will be consistent
310 with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ
311 during the match. */
2c296965
YO		 312 if (CxONCE(cx) || s < orig ||
313 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
314 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
315 ((cx->sb_rflags & REXEC_COPY_STR)
316 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
317 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
a0d0e21e 318 {
8ca8a454 319 SV *targ = cx->sb_targ;
748a9306 320
078c425b
JH		 321 assert(cx->sb_strend >= s);
322 if(cx->sb_strend > s) {
323 if (DO_UTF8(dstr) && !SvUTF8(targ))
324 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
325 else
326 sv_catpvn(dstr, s, cx->sb_strend - s);
327 }
20be6587
DM		 328 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
329 cx->sb_rxtainted |= SUBST_TAINT_PAT;
9212bbba 330
8ca8a454
NC		 331 if (pm->op_pmflags & PMf_NONDESTRUCT) {
332 PUSHs(dstr);
333 /* From here on down we're using the copy, and leaving the
334 original untouched. */
335 targ = dstr;
336 }
337 else {
8ca8a454
NC		 338 if (SvIsCOW(targ)) {
339 sv_force_normal_flags(targ, SV_COW_DROP_PV);
340 } else
8ca8a454
NC		 341 {
342 SvPV_free(targ);
343 }
344 SvPV_set(targ, SvPVX(dstr));
345 SvCUR_set(targ, SvCUR(dstr));
346 SvLEN_set(targ, SvLEN(dstr));
347 if (DO_UTF8(dstr))
348 SvUTF8_on(targ);
349 SvPV_set(dstr, NULL);
350
4f4d7508 351 mPUSHi(saviters - 1);
48c036b1 352
8ca8a454
NC		 353 (void)SvPOK_only_UTF8(targ);
354 }
5cd24f17 355
20be6587 356 /* update the taint state of various various variables in
ef07e810
DM		 357 * preparation for final exit.
358 * See "how taint works" above pp_subst() */
20be6587
DM		 359 if (PL_tainting) {
360 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
361 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
362 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
363 )
364 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
365
366 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
367 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
368 )
369 SvTAINTED_on(TOPs); /* taint return value */
370 /* needed for mg_set below */
371 PL_tainted = cBOOL(cx->sb_rxtainted &
372 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
373 SvTAINT(TARG);
374 }
375 /* PL_tainted must be correctly set for this mg_set */
376 SvSETMAGIC(TARG);
377 TAINT_NOT;
4633a7c4 378 LEAVE_SCOPE(cx->sb_oldsave);
a0d0e21e
LW		 379 POPSUBST(cx);
380 RETURNOP(pm->op_next);
20be6587 381 /* NOTREACHED */
a0d0e21e 382 }
8e5e9ebe 383 cx->sb_iters = saviters;
a0d0e21e 384 }
07bc277f 385 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
a0d0e21e
LW		 386 m = s;
387 s = orig;
07bc277f 388 cx->sb_orig = orig = RX_SUBBEG(rx);
a0d0e21e
LW		 389 s = orig + (m - s);
390 cx->sb_strend = s + (cx->sb_strend - m);
391 }
07bc277f 392 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
db79b45b 393 if (m > s) {
bfed75c6 394 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
db79b45b
JH		 395 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
396 else
397 sv_catpvn(dstr, s, m-s);
398 }
07bc277f 399 cx->sb_s = RX_OFFS(rx)[0].end + orig;
084916e3 400 { /* Update the pos() information. */
8ca8a454
NC		 401 SV * const sv
402 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
084916e3 403 MAGIC *mg;
7a7f3e45 404 SvUPGRADE(sv, SVt_PVMG);
14befaf4 405 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
d83f0a82 406#ifdef PERL_OLD_COPY_ON_WRITE
51a9ea20 407 if (SvIsCOW(sv))
d83f0a82
NC		 408 sv_force_normal_flags(sv, 0);
409#endif
410 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
411 NULL, 0);
084916e3 412 }
ce474962 413 mg->mg_len = m - orig;
084916e3 414 }
988e6e7e 415 if (old != rx)
d6106309 416 (void)ReREFCNT_inc(rx);
20be6587 417 /* update the taint state of various various variables in preparation
ef07e810
DM		 418 * for calling the code block.
419 * See "how taint works" above pp_subst() */
20be6587
DM		 420 if (PL_tainting) {
421 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
422 cx->sb_rxtainted |= SUBST_TAINT_PAT;
423
424 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
425 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
426 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
427 )
428 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
429
430 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
431 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
8ca8a454
NC		 432 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
433 ? cx->sb_dstr : cx->sb_targ);
20be6587
DM		 434 TAINT_NOT;
435 }
d9f97599 436 rxres_save(&cx->sb_rxres, rx);
af9838cc 437 PL_curpm = pm;
29f2e912 438 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
a0d0e21e
LW		 439}
440
c90c0ff4 441void
864dbfa3 442Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4
PP		 443{
444 UV *p = (UV*)*rsp;
445 U32 i;
7918f24d
NC		 446
447 PERL_ARGS_ASSERT_RXRES_SAVE;
96a5add6 448 PERL_UNUSED_CONTEXT;
c90c0ff4 449
07bc277f 450 if (!p || p[1] < RX_NPARENS(rx)) {
f8c7b90f 451#ifdef PERL_OLD_COPY_ON_WRITE
07bc277f 452 i = 7 + RX_NPARENS(rx) * 2;
ed252734 453#else
07bc277f 454 i = 6 + RX_NPARENS(rx) * 2;
ed252734 455#endif
c90c0ff4 456 if (!p)
a02a5408 457 Newx(p, i, UV);
c90c0ff4
PP		 458 else
459 Renew(p, i, UV);
460 *rsp = (void*)p;
461 }
462
07bc277f 463 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
cf93c79d 464 RX_MATCH_COPIED_off(rx);
c90c0ff4 465
f8c7b90f 466#ifdef PERL_OLD_COPY_ON_WRITE
bdd9a1b1
NC		 467 *p++ = PTR2UV(RX_SAVED_COPY(rx));
468 RX_SAVED_COPY(rx) = NULL;
ed252734
NC		 469#endif
470
07bc277f 471 *p++ = RX_NPARENS(rx);
c90c0ff4 472
07bc277f
NC		 473 *p++ = PTR2UV(RX_SUBBEG(rx));
474 *p++ = (UV)RX_SUBLEN(rx);
475 for (i = 0; i <= RX_NPARENS(rx); ++i) {
476 *p++ = (UV)RX_OFFS(rx)[i].start;
477 *p++ = (UV)RX_OFFS(rx)[i].end;
c90c0ff4
PP		 478 }
479}
480
9c105995
NC		 481static void
482S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4
PP		 483{
484 UV *p = (UV*)*rsp;
485 U32 i;
7918f24d
NC		 486
487 PERL_ARGS_ASSERT_RXRES_RESTORE;
96a5add6 488 PERL_UNUSED_CONTEXT;
c90c0ff4 489
ed252734 490 RX_MATCH_COPY_FREE(rx);
cf93c79d 491 RX_MATCH_COPIED_set(rx, *p);
c90c0ff4
PP		 492 *p++ = 0;
493
f8c7b90f 494#ifdef PERL_OLD_COPY_ON_WRITE
bdd9a1b1
NC		 495 if (RX_SAVED_COPY(rx))
496 SvREFCNT_dec (RX_SAVED_COPY(rx));
497 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
ed252734
NC		 498 *p++ = 0;
499#endif
500
07bc277f 501 RX_NPARENS(rx) = *p++;
c90c0ff4 502
07bc277f
NC		 503 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
504 RX_SUBLEN(rx) = (I32)(*p++);
505 for (i = 0; i <= RX_NPARENS(rx); ++i) {
506 RX_OFFS(rx)[i].start = (I32)(*p++);
507 RX_OFFS(rx)[i].end = (I32)(*p++);
c90c0ff4
PP		 508 }
509}
510
9c105995
NC		 511static void
512S_rxres_free(pTHX_ void **rsp)
c90c0ff4 513{
44f8325f 514 UV * const p = (UV*)*rsp;
7918f24d
NC		 515
516 PERL_ARGS_ASSERT_RXRES_FREE;
96a5add6 517 PERL_UNUSED_CONTEXT;
c90c0ff4
PP		 518
519 if (p) {
94010e71
NC		 520#ifdef PERL_POISON
521 void *tmp = INT2PTR(char*,*p);
522 Safefree(tmp);
523 if (*p)
7e337ee0 524 PoisonFree(*p, 1, sizeof(*p));
94010e71 525#else
56431972 526 Safefree(INT2PTR(char*,*p));
94010e71 527#endif
f8c7b90f 528#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 529 if (p[1]) {
530 SvREFCNT_dec (INT2PTR(SV*,p[1]));
531 }
532#endif
c90c0ff4 533 Safefree(p);
4608196e 534 *rsp = NULL;
c90c0ff4
PP		 535 }
536}
537
a701009a
DM		 538#define FORM_NUM_BLANK (1<<30)
539#define FORM_NUM_POINT (1<<29)
540
a0d0e21e
LW		 541PP(pp_formline)
542{
97aff369 543 dVAR; dSP; dMARK; dORIGMARK;
823a54a3 544 register SV * const tmpForm = *++MARK;
086b26f3
DM		 545 SV *formsv; /* contains text of original format */
546 register U32 *fpc; /* format ops program counter */
547 register char *t; /* current append position in target string */
548 const char *f; /* current position in format string */
a0d0e21e 549 register I32 arg;
086b26f3
DM		 550 register SV *sv = NULL; /* current item */
551 const char *item = NULL;/* string value of current item */
552 I32 itemsize = 0; /* length of current item, possibly truncated */
553 I32 fieldsize = 0; /* width of current field */
554 I32 lines = 0; /* number of lines that have been output */
555 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
556 const char *chophere = NULL; /* where to chop current item */
f5ada144 557 STRLEN linemark = 0; /* pos of start of line in output */
65202027 558 NV value;
086b26f3 559 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
a0d0e21e 560 STRLEN len;
26e935cf 561 STRLEN linemax; /* estimate of output size in bytes */
1bd51a4c
IH		 562 bool item_is_utf8 = FALSE;
563 bool targ_is_utf8 = FALSE;
bfed75c6 564 const char *fmt;
74e0ddf7 565 MAGIC *mg = NULL;
4ff700b9
DM		 566 U8 *source; /* source of bytes to append */
567 STRLEN to_copy; /* how may bytes to append */
ea60cfe8 568 char trans; /* what chars to translate */
74e0ddf7 569
3808a683 570 mg = doparseform(tmpForm);
a0d0e21e 571
74e0ddf7 572 fpc = (U32*)mg->mg_ptr;
3808a683
DM		 573 /* the actual string the format was compiled from.
574 * with overload etc, this may not match tmpForm */
575 formsv = mg->mg_obj;
576
74e0ddf7 577
3280af22 578 SvPV_force(PL_formtarget, len);
3808a683 579 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
125b9982 580 SvTAINTED_on(PL_formtarget);
1bd51a4c
IH		 581 if (DO_UTF8(PL_formtarget))
582 targ_is_utf8 = TRUE;
26e935cf
DM		 583 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
584 t = SvGROW(PL_formtarget, len + linemax + 1);
585 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
a0d0e21e 586 t += len;
3808a683 587 f = SvPV_const(formsv, len);
a0d0e21e
LW		 588
589 for (;;) {
590 DEBUG_f( {
bfed75c6 591 const char *name = "???";
a0d0e21e
LW		 592 arg = -1;
593 switch (*fpc) {
594 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
595 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
596 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
597 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
598 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
599
600 case FF_CHECKNL: name = "CHECKNL"; break;
601 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
602 case FF_SPACE: name = "SPACE"; break;
603 case FF_HALFSPACE: name = "HALFSPACE"; break;
604 case FF_ITEM: name = "ITEM"; break;
605 case FF_CHOP: name = "CHOP"; break;
606 case FF_LINEGLOB: name = "LINEGLOB"; break;
607 case FF_NEWLINE: name = "NEWLINE"; break;
608 case FF_MORE: name = "MORE"; break;
609 case FF_LINEMARK: name = "LINEMARK"; break;
610 case FF_END: name = "END"; break;
bfed75c6 611 case FF_0DECIMAL: name = "0DECIMAL"; break;
a1b95068 612 case FF_LINESNGL: name = "LINESNGL"; break;
a0d0e21e
LW		 613 }
614 if (arg >= 0)
bf49b057 615 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
a0d0e21e 616 else
bf49b057 617 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
5f80b19c 618 } );
a0d0e21e
LW		 619 switch (*fpc++) {
620 case FF_LINEMARK:
f5ada144 621 linemark = t - SvPVX(PL_formtarget);
a0d0e21e
LW		 622 lines++;
623 gotsome = FALSE;
624 break;
625
626 case FF_LITERAL:
ea60cfe8
DM		 627 to_copy = *fpc++;
628 source = (U8 *)f;
629 f += to_copy;
630 trans = '~';
75645721 631 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
ea60cfe8 632 goto append;
a0d0e21e
LW		 633
634 case FF_SKIP:
635 f += *fpc++;
636 break;
637
638 case FF_FETCH:
639 arg = *fpc++;
640 f += arg;
641 fieldsize = arg;
642
643 if (MARK < SP)
644 sv = *++MARK;
645 else {
3280af22 646 sv = &PL_sv_no;
a2a5de95 647 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
a0d0e21e 648 }
125b9982
NT		 649 if (SvTAINTED(sv))
650 SvTAINTED_on(PL_formtarget);
a0d0e21e
LW		 651 break;
652
653 case FF_CHECKNL:
5a34cab7
NC		 654 {
655 const char *send;
656 const char *s = item = SvPV_const(sv, len);
657 itemsize = len;
658 if (DO_UTF8(sv)) {
659 itemsize = sv_len_utf8(sv);
660 if (itemsize != (I32)len) {
661 I32 itembytes;
662 if (itemsize > fieldsize) {
663 itemsize = fieldsize;
664 itembytes = itemsize;
665 sv_pos_u2b(sv, &itembytes, 0);
666 }
667 else
668 itembytes = len;
669 send = chophere = s + itembytes;
670 while (s < send) {
671 if (*s & ~31)
672 gotsome = TRUE;
673 else if (*s == '\n')
674 break;
675 s++;
676 }
677 item_is_utf8 = TRUE;
678 itemsize = s - item;
679 sv_pos_b2u(sv, &itemsize);
680 break;
a0ed51b3 681 }
a0ed51b3 682 }
5a34cab7
NC		 683 item_is_utf8 = FALSE;
684 if (itemsize > fieldsize)
685 itemsize = fieldsize;
686 send = chophere = s + itemsize;
687 while (s < send) {
688 if (*s & ~31)
689 gotsome = TRUE;
690 else if (*s == '\n')
691 break;
692 s++;
693 }
694 itemsize = s - item;
695 break;
a0ed51b3 696 }
a0d0e21e
LW		 697
698 case FF_CHECKCHOP:
5a34cab7
NC		 699 {
700 const char *s = item = SvPV_const(sv, len);
701 itemsize = len;
702 if (DO_UTF8(sv)) {
703 itemsize = sv_len_utf8(sv);
704 if (itemsize != (I32)len) {
705 I32 itembytes;
706 if (itemsize <= fieldsize) {
707 const char *send = chophere = s + itemsize;
708 while (s < send) {
709 if (*s == '\r') {
710 itemsize = s - item;
a0ed51b3 711 chophere = s;
a0ed51b3 712 break;
5a34cab7
NC		 713 }
714 if (*s++ & ~31)
a0ed51b3 715 gotsome = TRUE;
a0ed51b3 716 }
a0ed51b3 717 }
5a34cab7
NC		 718 else {
719 const char *send;
720 itemsize = fieldsize;
721 itembytes = itemsize;
722 sv_pos_u2b(sv, &itembytes, 0);
723 send = chophere = s + itembytes;
724 while (s < send || (s == send && isSPACE(*s))) {
725 if (isSPACE(*s)) {
726 if (chopspace)
727 chophere = s;
728 if (*s == '\r')
729 break;
730 }
731 else {
732 if (*s & ~31)
733 gotsome = TRUE;
734 if (strchr(PL_chopset, *s))
735 chophere = s + 1;
736 }
737 s++;
738 }
739 itemsize = chophere - item;
740 sv_pos_b2u(sv, &itemsize);
741 }
742 item_is_utf8 = TRUE;
a0d0e21e
LW		 743 break;
744 }
a0d0e21e 745 }
5a34cab7
NC		 746 item_is_utf8 = FALSE;
747 if (itemsize <= fieldsize) {
748 const char *const send = chophere = s + itemsize;
749 while (s < send) {
750 if (*s == '\r') {
751 itemsize = s - item;
a0d0e21e 752 chophere = s;
a0d0e21e 753 break;
5a34cab7
NC		 754 }
755 if (*s++ & ~31)
a0d0e21e 756 gotsome = TRUE;
a0d0e21e 757 }
a0d0e21e 758 }
5a34cab7
NC		 759 else {
760 const char *send;
761 itemsize = fieldsize;
762 send = chophere = s + itemsize;
763 while (s < send || (s == send && isSPACE(*s))) {
764 if (isSPACE(*s)) {
765 if (chopspace)
766 chophere = s;
767 if (*s == '\r')
768 break;
769 }
770 else {
771 if (*s & ~31)
772 gotsome = TRUE;
773 if (strchr(PL_chopset, *s))
774 chophere = s + 1;
775 }
776 s++;
777 }
778 itemsize = chophere - item;
779 }
780 break;
a0d0e21e 781 }
a0d0e21e
LW		 782
783 case FF_SPACE:
784 arg = fieldsize - itemsize;
785 if (arg) {
786 fieldsize -= arg;
787 while (arg-- > 0)
788 *t++ = ' ';
789 }
790 break;
791
792 case FF_HALFSPACE:
793 arg = fieldsize - itemsize;
794 if (arg) {
795 arg /= 2;
796 fieldsize -= arg;
797 while (arg-- > 0)
798 *t++ = ' ';
799 }
800 break;
801
802 case FF_ITEM:
8aa7beb6
DM		 803 to_copy = itemsize;
804 source = (U8 *)item;
805 trans = 1;
806 if (item_is_utf8) {
807 /* convert to_copy from chars to bytes */
808 U8 *s = source;
809 while (to_copy--)
810 s += UTF8SKIP(s);
811 to_copy = s - source;
a0d0e21e 812 }
8aa7beb6 813 goto append;
a0d0e21e
LW		 814
815 case FF_CHOP:
5a34cab7
NC		 816 {
817 const char *s = chophere;
818 if (chopspace) {
af68e756 819 while (isSPACE(*s))
5a34cab7
NC		 820 s++;
821 }
822 sv_chop(sv,s);
823 SvSETMAGIC(sv);
824 break;
a0d0e21e 825 }
a0d0e21e 826
a1b95068
LW		 827 case FF_LINESNGL:
828 chopspace = 0;
a0d0e21e 829 case FF_LINEGLOB:
5a34cab7 830 {
e32383e2 831 const bool oneline = fpc[-1] == FF_LINESNGL;
5a34cab7 832 const char *s = item = SvPV_const(sv, len);
7440a75b 833 const char *const send = s + len;
7440a75b 834
f3f2f1a3 835 item_is_utf8 = DO_UTF8(sv);
a1137ee5 836 if (!len)
7440a75b 837 break;
ea60cfe8 838 trans = 0;
0d21cefe 839 gotsome = TRUE;
a1137ee5 840 chophere = s + len;
4ff700b9
DM		 841 source = (U8 *) s;
842 to_copy = len;
0d21cefe
DM		 843 while (s < send) {
844 if (*s++ == '\n') {
845 if (oneline) {
846 to_copy = s - SvPVX_const(sv) - 1;
847 chophere = s;
848 break;
849 } else {
850 if (s == send) {
0d21cefe
DM		 851 to_copy--;
852 } else
853 lines++;
1bd51a4c 854 }
a0d0e21e 855 }
0d21cefe 856 }
a2c0032b
DM		 857 }
858
ea60cfe8
DM		 859 append:
860 /* append to_copy bytes from source to PL_formstring.
861 * item_is_utf8 implies source is utf8.
862 * if trans, translate certain characters during the copy */
a2c0032b
DM		 863 {
864 U8 *tmp = NULL;
26e935cf 865 STRLEN grow = 0;
0325ce87
DM		 866
867 SvCUR_set(PL_formtarget,
868 t - SvPVX_const(PL_formtarget));
869
0d21cefe
DM		 870 if (targ_is_utf8 && !item_is_utf8) {
871 source = tmp = bytes_to_utf8(source, &to_copy);
0d21cefe
DM		 872 } else {
873 if (item_is_utf8 && !targ_is_utf8) {
f5ada144 874 U8 *s;
0d21cefe 875 /* Upgrade targ to UTF8, and then we reduce it to
0325ce87
DM		 876 a problem we have a simple solution for.
877 Don't need get magic. */
0d21cefe 878 sv_utf8_upgrade_nomg(PL_formtarget);
0325ce87 879 targ_is_utf8 = TRUE;
f5ada144
DM		 880 /* re-calculate linemark */
881 s = (U8*)SvPVX(PL_formtarget);
26e935cf
DM		 882 /* the bytes we initially allocated to append the
883 * whole line may have been gobbled up during the
884 * upgrade, so allocate a whole new line's worth
885 * for safety */
886 grow = linemax;
f5ada144
DM		 887 while (linemark--)
888 s += UTF8SKIP(s);
889 linemark = s - (U8*)SvPVX(PL_formtarget);
e8e72d41 890 }
0d21cefe
DM		 891 /* Easy. They agree. */
892 assert (item_is_utf8 == targ_is_utf8);
893 }
26e935cf
DM		 894 if (!trans)
895 /* @* and ^* are the only things that can exceed
896 * the linemax, so grow by the output size, plus
897 * a whole new form's worth in case of any further
898 * output */
899 grow = linemax + to_copy;
900 if (grow)
901 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
0d21cefe
DM		 902 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
903
904 Copy(source, t, to_copy, char);
ea60cfe8 905 if (trans) {
8aa7beb6
DM		 906 /* blank out ~ or control chars, depending on trans.
907 * works on bytes not chars, so relies on not
908 * matching utf8 continuation bytes */
ea60cfe8
DM		 909 U8 *s = (U8*)t;
910 U8 *send = s + to_copy;
911 while (s < send) {
8aa7beb6
DM		 912 const int ch = *s;
913 if (trans == '~' ? (ch == '~') :
914#ifdef EBCDIC
915 iscntrl(ch)
916#else
917 (!(ch & ~31))
918#endif
919 )
ea60cfe8
DM		 920 *s = ' ';
921 s++;
922 }
923 }
924
0d21cefe
DM		 925 t += to_copy;
926 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
a1137ee5 927 if (tmp)
0d21cefe 928 Safefree(tmp);
5a34cab7 929 break;
a0d0e21e 930 }
a0d0e21e 931
a1b95068
LW		 932 case FF_0DECIMAL:
933 arg = *fpc++;
934#if defined(USE_LONG_DOUBLE)
10edeb5d 935 fmt = (const char *)
a701009a 936 ((arg & FORM_NUM_POINT) ?
10edeb5d 937 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
a1b95068 938#else
10edeb5d 939 fmt = (const char *)
a701009a 940 ((arg & FORM_NUM_POINT) ?
10edeb5d 941 "%#0*.*f" : "%0*.*f");
a1b95068
LW		 942#endif
943 goto ff_dec;
a0d0e21e 944 case FF_DECIMAL:
a0d0e21e 945 arg = *fpc++;
65202027 946#if defined(USE_LONG_DOUBLE)
10edeb5d 947 fmt = (const char *)
a701009a 948 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
65202027 949#else
10edeb5d 950 fmt = (const char *)
a701009a 951 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
65202027 952#endif
a1b95068 953 ff_dec:
784707d5
JP		 954 /* If the field is marked with ^ and the value is undefined,
955 blank it out. */
a701009a 956 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
784707d5
JP		 957 arg = fieldsize;
958 while (arg--)
959 *t++ = ' ';
960 break;
961 }
962 gotsome = TRUE;
963 value = SvNV(sv);
a1b95068 964 /* overflow evidence */
bfed75c6 965 if (num_overflow(value, fieldsize, arg)) {
a1b95068
LW		 966 arg = fieldsize;
967 while (arg--)
968 *t++ = '#';
969 break;
970 }
784707d5
JP		 971 /* Formats aren't yet marked for locales, so assume "yes". */
972 {
973 STORE_NUMERIC_STANDARD_SET_LOCAL();
a701009a
DM		 974 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
975 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
784707d5
JP		 976 RESTORE_NUMERIC_STANDARD();
977 }
978 t += fieldsize;
979 break;
a1b95068 980
a0d0e21e
LW		 981 case FF_NEWLINE:
982 f++;
f5ada144 983 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
a0d0e21e
LW		 984 t++;
985 *t++ = '\n';
986 break;
987
988 case FF_BLANK:
989 arg = *fpc++;
990 if (gotsome) {
991 if (arg) { /* repeat until fields exhausted? */
11f9eeaf
DM		 992 fpc--;
993 goto end;
a0d0e21e
LW		 994 }
995 }
996 else {
f5ada144 997 t = SvPVX(PL_formtarget) + linemark;
a0d0e21e
LW		 998 lines--;
999 }
1000 break;
1001
1002 case FF_MORE:
5a34cab7
NC		 1003 {
1004 const char *s = chophere;
1005 const char *send = item + len;
1006 if (chopspace) {
af68e756 1007 while (isSPACE(*s) && (s < send))
5a34cab7 1008 s++;
a0d0e21e 1009 }
5a34cab7
NC		 1010 if (s < send) {
1011 char *s1;
1012 arg = fieldsize - itemsize;
1013 if (arg) {
1014 fieldsize -= arg;
1015 while (arg-- > 0)
1016 *t++ = ' ';
1017 }
1018 s1 = t - 3;
1019 if (strnEQ(s1," ",3)) {
1020 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1021 s1--;
1022 }
1023 *s1++ = '.';
1024 *s1++ = '.';
1025 *s1++ = '.';
a0d0e21e 1026 }
5a34cab7 1027 break;
a0d0e21e 1028 }
a0d0e21e 1029 case FF_END:
11f9eeaf 1030 end:
bf2bec63 1031 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
a0d0e21e 1032 *t = '\0';
b15aece3 1033 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1bd51a4c
IH		 1034 if (targ_is_utf8)
1035 SvUTF8_on(PL_formtarget);
3280af22 1036 FmLINES(PL_formtarget) += lines;
a0d0e21e 1037 SP = ORIGMARK;
11f9eeaf
DM		 1038 if (fpc[-1] == FF_BLANK)
1039 RETURNOP(cLISTOP->op_first);
1040 else
1041 RETPUSHYES;
a0d0e21e
LW		 1042 }
1043 }
1044}
1045
1046PP(pp_grepstart)
1047{
27da23d5 1048 dVAR; dSP;
a0d0e21e
LW		 1049 SV *src;
1050
3280af22 1051 if (PL_stack_base + *PL_markstack_ptr == SP) {
a0d0e21e 1052 (void)POPMARK;
54310121 1053 if (GIMME_V == G_SCALAR)
6e449a3a 1054 mXPUSHi(0);
533c011a 1055 RETURNOP(PL_op->op_next->op_next);
a0d0e21e 1056 }
3280af22 1057 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
897d3989
NC		 1058 Perl_pp_pushmark(aTHX); /* push dst */
1059 Perl_pp_pushmark(aTHX); /* push src */
d343c3ef 1060 ENTER_with_name("grep"); /* enter outer scope */
a0d0e21e
LW		 1061
1062 SAVETMPS;
59f00321
RGS		 1063 if (PL_op->op_private & OPpGREP_LEX)
1064 SAVESPTR(PAD_SVl(PL_op->op_targ));
1065 else
1066 SAVE_DEFSV;
d343c3ef 1067 ENTER_with_name("grep_item"); /* enter inner scope */
7766f137 1068 SAVEVPTR(PL_curpm);
a0d0e21e 1069
3280af22 1070 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 1071 SvTEMP_off(src);
59f00321
RGS		 1072 if (PL_op->op_private & OPpGREP_LEX)
1073 PAD_SVl(PL_op->op_targ) = src;
1074 else
414bf5ae 1075 DEFSV_set(src);
a0d0e21e
LW		 1076
1077 PUTBACK;
533c011a 1078 if (PL_op->op_type == OP_MAPSTART)
897d3989 1079 Perl_pp_pushmark(aTHX); /* push top */
533c011a 1080 return ((LOGOP*)PL_op->op_next)->op_other;
a0d0e21e
LW		 1081}
1082
a0d0e21e
LW		 1083PP(pp_mapwhile)
1084{
27da23d5 1085 dVAR; dSP;
f54cb97a 1086 const I32 gimme = GIMME_V;
544f3153 1087 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
a0d0e21e
LW		 1088 I32 count;
1089 I32 shift;
1090 SV** src;
ac27b0f5 1091 SV** dst;
a0d0e21e 1092
544f3153 1093 /* first, move source pointer to the next item in the source list */
3280af22 1094 ++PL_markstack_ptr[-1];
544f3153
GS		 1095
1096 /* if there are new items, push them into the destination list */
4c90a460 1097 if (items && gimme != G_VOID) {
544f3153
GS		 1098 /* might need to make room back there first */
1099 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1100 /* XXX this implementation is very pessimal because the stack
1101 * is repeatedly extended for every set of items. Is possible
1102 * to do this without any stack extension or copying at all
1103 * by maintaining a separate list over which the map iterates
18ef8bea 1104 * (like foreach does). --gsar */
544f3153
GS		 1105
1106 /* everything in the stack after the destination list moves
1107 * towards the end the stack by the amount of room needed */
1108 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1109
1110 /* items to shift up (accounting for the moved source pointer) */
1111 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
18ef8bea
BT		 1112
1113 /* This optimization is by Ben Tilly and it does
1114 * things differently from what Sarathy (gsar)
1115 * is describing. The downside of this optimization is
1116 * that leaves "holes" (uninitialized and hopefully unused areas)
1117 * to the Perl stack, but on the other hand this
1118 * shouldn't be a problem. If Sarathy's idea gets
1119 * implemented, this optimization should become
1120 * irrelevant. --jhi */
1121 if (shift < count)
1122 shift = count; /* Avoid shifting too often --Ben Tilly */
bfed75c6 1123
924508f0
GS		 1124 EXTEND(SP,shift);
1125 src = SP;
1126 dst = (SP += shift);
3280af22
NIS		 1127 PL_markstack_ptr[-1] += shift;
1128 *PL_markstack_ptr += shift;
544f3153 1129 while (count--)
a0d0e21e
LW		 1130 *dst-- = *src--;
1131 }
544f3153 1132 /* copy the new items down to the destination list */
ac27b0f5 1133 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
22023b26 1134 if (gimme == G_ARRAY) {
b2a2a901
DM		 1135 /* add returned items to the collection (making mortal copies
1136 * if necessary), then clear the current temps stack frame
1137 * *except* for those items. We do this splicing the items
1138 * into the start of the tmps frame (so some items may be on
59d53fd6 1139 * the tmps stack twice), then moving PL_tmps_floor above
b2a2a901
DM		 1140 * them, then freeing the frame. That way, the only tmps that
1141 * accumulate over iterations are the return values for map.
1142 * We have to do to this way so that everything gets correctly
1143 * freed if we die during the map.
1144 */
1145 I32 tmpsbase;
1146 I32 i = items;
1147 /* make space for the slice */
1148 EXTEND_MORTAL(items);
1149 tmpsbase = PL_tmps_floor + 1;
1150 Move(PL_tmps_stack + tmpsbase,
1151 PL_tmps_stack + tmpsbase + items,
1152 PL_tmps_ix - PL_tmps_floor,
1153 SV*);
1154 PL_tmps_ix += items;
1155
1156 while (i-- > 0) {
1157 SV *sv = POPs;
1158 if (!SvTEMP(sv))
1159 sv = sv_mortalcopy(sv);
1160 *dst-- = sv;
1161 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1162 }
1163 /* clear the stack frame except for the items */
1164 PL_tmps_floor += items;
1165 FREETMPS;
1166 /* FREETMPS may have cleared the TEMP flag on some of the items */
1167 i = items;
1168 while (i-- > 0)
1169 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
22023b26 1170 }
bfed75c6 1171 else {
22023b26
TP		 1172 /* scalar context: we don't care about which values map returns
1173 * (we use undef here). And so we certainly don't want to do mortal
1174 * copies of meaningless values. */
1175 while (items-- > 0) {
b988aa42 1176 (void)POPs;
22023b26
TP		 1177 *dst-- = &PL_sv_undef;
1178 }
b2a2a901 1179 FREETMPS;
22023b26 1180 }
a0d0e21e 1181 }
b2a2a901
DM		 1182 else {
1183 FREETMPS;
1184 }
d343c3ef 1185 LEAVE_with_name("grep_item"); /* exit inner scope */
a0d0e21e
LW		 1186
1187 /* All done yet? */
3280af22 1188 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
a0d0e21e
LW		 1189
1190 (void)POPMARK; /* pop top */
d343c3ef 1191 LEAVE_with_name("grep"); /* exit outer scope */
a0d0e21e 1192 (void)POPMARK; /* pop src */
3280af22 1193 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 1194 (void)POPMARK; /* pop dst */
3280af22 1195 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 1196 if (gimme == G_SCALAR) {
7cc47870
RGS		 1197 if (PL_op->op_private & OPpGREP_LEX) {
1198 SV* sv = sv_newmortal();
1199 sv_setiv(sv, items);
1200 PUSHs(sv);
1201 }
1202 else {
1203 dTARGET;
1204 XPUSHi(items);
1205 }
a0d0e21e 1206 }
54310121
PP		 1207 else if (gimme == G_ARRAY)
1208 SP += items;
a0d0e21e
LW		 1209 RETURN;
1210 }
1211 else {
1212 SV *src;
1213
d343c3ef 1214 ENTER_with_name("grep_item"); /* enter inner scope */
7766f137 1215 SAVEVPTR(PL_curpm);
a0d0e21e 1216
544f3153 1217 /* set $_ to the new source item */
3280af22 1218 src = PL_stack_base[PL_markstack_ptr[-1]];
a0d0e21e 1219 SvTEMP_off(src);
59f00321
RGS		 1220 if (PL_op->op_private & OPpGREP_LEX)
1221 PAD_SVl(PL_op->op_targ) = src;
1222 else
414bf5ae 1223 DEFSV_set(src);
a0d0e21e
LW		 1224
1225 RETURNOP(cLOGOP->op_other);
1226 }
1227}
1228
a0d0e21e
LW		 1229/* Range stuff. */
1230
1231PP(pp_range)
1232{
97aff369 1233 dVAR;
a0d0e21e 1234 if (GIMME == G_ARRAY)
1a67a97c 1235 return NORMAL;
538573f7 1236 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1a67a97c 1237 return cLOGOP->op_other;
538573f7 1238 else
1a67a97c 1239 return NORMAL;
a0d0e21e
LW		 1240}
1241
1242PP(pp_flip)
1243{
97aff369 1244 dVAR;
39644a26 1245 dSP;
a0d0e21e
LW		 1246
1247 if (GIMME == G_ARRAY) {
1a67a97c 1248 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 1249 }
1250 else {
1251 dTOPss;
44f8325f 1252 SV * const targ = PAD_SV(PL_op->op_targ);
bfed75c6 1253 int flip = 0;
790090df 1254
bfed75c6 1255 if (PL_op->op_private & OPpFLIP_LINENUM) {
4e3399f9
YST		 1256 if (GvIO(PL_last_in_gv)) {
1257 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1258 }
1259 else {
fafc274c 1260 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
44f8325f
AL		 1261 if (gv && GvSV(gv))
1262 flip = SvIV(sv) == SvIV(GvSV(gv));
4e3399f9 1263 }
bfed75c6
AL		 1264 } else {
1265 flip = SvTRUE(sv);
1266 }
1267 if (flip) {
a0d0e21e 1268 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 1269 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1270 sv_setiv(targ, 1);
3e3baf6d 1271 SETs(targ);
a0d0e21e
LW		 1272 RETURN;
1273 }
1274 else {
1275 sv_setiv(targ, 0);
924508f0 1276 SP--;
1a67a97c 1277 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 1278 }
1279 }
76f68e9b 1280 sv_setpvs(TARG, "");
a0d0e21e
LW		 1281 SETs(targ);
1282 RETURN;
1283 }
1284}
1285
8e9bbdb9
RGS		 1286/* This code tries to decide if "$left .. $right" should use the
1287 magical string increment, or if the range is numeric (we make
1288 an exception for .."0" [#18165]). AMS 20021031. */
1289
1290#define RANGE_IS_NUMERIC(left,right) ( \
b0e74086
RGS		 1291 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1292 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
e0ab1c0e 1293 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
b15aece3 1294 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
e0ab1c0e 1295 && (!SvOK(right) || looks_like_number(right))))
8e9bbdb9 1296
a0d0e21e
LW		 1297PP(pp_flop)
1298{
97aff369 1299 dVAR; dSP;
a0d0e21e
LW		 1300
1301 if (GIMME == G_ARRAY) {
1302 dPOPPOPssrl;
86cb7173 1303
5b295bef
RD		 1304 SvGETMAGIC(left);
1305 SvGETMAGIC(right);
a0d0e21e 1306
8e9bbdb9 1307 if (RANGE_IS_NUMERIC(left,right)) {
901017d6
AL		 1308 register IV i, j;
1309 IV max;
f52e41ad
FC		 1310 if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
1311 (SvOK(right) && SvNV_nomg(right) > IV_MAX))
d470f89e 1312 DIE(aTHX_ "Range iterator outside integer range");
f52e41ad
FC		 1313 i = SvIV_nomg(left);
1314 max = SvIV_nomg(right);
bbce6d69 1315 if (max >= i) {
c1ab3db2
AK		 1316 j = max - i + 1;
1317 EXTEND_MORTAL(j);
1318 EXTEND(SP, j);
bbce6d69 1319 }
c1ab3db2
AK		 1320 else
1321 j = 0;
1322 while (j--) {
901017d6 1323 SV * const sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW		 1324 PUSHs(sv);
1325 }
1326 }
1327 else {
3c323193
FC		 1328 STRLEN len, llen;
1329 const char * const lpv = SvPV_nomg_const(left, llen);
f52e41ad 1330 const char * const tmps = SvPV_nomg_const(right, len);
a0d0e21e 1331
3c323193 1332 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
89ea2908 1333 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1334 XPUSHs(sv);
b15aece3 1335 if (strEQ(SvPVX_const(sv),tmps))
89ea2908 1336 break;
a0d0e21e
LW		 1337 sv = sv_2mortal(newSVsv(sv));
1338 sv_inc(sv);
1339 }
a0d0e21e
LW		 1340 }
1341 }
1342 else {
1343 dTOPss;
901017d6 1344 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
4e3399f9 1345 int flop = 0;
a0d0e21e 1346 sv_inc(targ);
4e3399f9
YST		 1347
1348 if (PL_op->op_private & OPpFLIP_LINENUM) {
1349 if (GvIO(PL_last_in_gv)) {
1350 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1351 }
1352 else {
fafc274c 1353 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
4e3399f9
YST		 1354 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1355 }
1356 }
1357 else {
1358 flop = SvTRUE(sv);
1359 }
1360
1361 if (flop) {
a0d0e21e 1362 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
396482e1 1363 sv_catpvs(targ, "E0");
a0d0e21e
LW		 1364 }
1365 SETs(targ);
1366 }
1367
1368 RETURN;
1369}
1370
1371/* Control. */
1372
27da23d5 1373static const char * const context_name[] = {
515afda2 1374 "pseudo-block",
f31522f3 1375 NULL, /* CXt_WHEN never actually needs "block" */
76753e7f 1376 NULL, /* CXt_BLOCK never actually needs "block" */
f31522f3 1377 NULL, /* CXt_GIVEN never actually needs "block" */
76753e7f
NC		 1378 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1379 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1380 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1381 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
515afda2 1382 "subroutine",
76753e7f 1383 "format",
515afda2 1384 "eval",
515afda2 1385 "substitution",
515afda2
NC		 1386};
1387
76e3520e 1388STATIC I32
5db1eb8d 1389S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
a0d0e21e 1390{
97aff369 1391 dVAR;
a0d0e21e 1392 register I32 i;
a0d0e21e 1393
7918f24d
NC		 1394 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1395
a0d0e21e 1396 for (i = cxstack_ix; i >= 0; i--) {
901017d6 1397 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1398 switch (CxTYPE(cx)) {
a0d0e21e 1399 case CXt_SUBST:
a0d0e21e 1400 case CXt_SUB:
7766f137 1401 case CXt_FORMAT:
a0d0e21e 1402 case CXt_EVAL:
0a753a76 1403 case CXt_NULL:
dcbac5bb 1404 /* diag_listed_as: Exiting subroutine via %s */
a2a5de95
NC		 1405 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1406 context_name[CxTYPE(cx)], OP_NAME(PL_op));
515afda2
NC		 1407 if (CxTYPE(cx) == CXt_NULL)
1408 return -1;
1409 break;
c6fdafd0 1410 case CXt_LOOP_LAZYIV:
d01136d6 1411 case CXt_LOOP_LAZYSV:
3b719c58
NC		 1412 case CXt_LOOP_FOR:
1413 case CXt_LOOP_PLAIN:
7e8f1eac 1414 {
5db1eb8d
BF		 1415 STRLEN cx_label_len = 0;
1416 U32 cx_label_flags = 0;
1417 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1418 if (!cx_label || !(
1419 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1420 (flags & SVf_UTF8)
1421 ? (bytes_cmp_utf8(
1422 (const U8*)cx_label, cx_label_len,
1423 (const U8*)label, len) == 0)
1424 : (bytes_cmp_utf8(
1425 (const U8*)label, len,
1426 (const U8*)cx_label, cx_label_len) == 0)
1427 : ((cx_label == label)
1428 || memEQ(cx_label, label, len))) ) {
1c98cc53 1429 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
7e8f1eac 1430 (long)i, cx_label));
a0d0e21e
LW		 1431 continue;
1432 }
1c98cc53 1433 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
a0d0e21e 1434 return i;
7e8f1eac 1435 }
a0d0e21e
LW		 1436 }
1437 }
1438 return i;
1439}
1440
0d863452
RH		 1441
1442
e50aee73 1443I32
864dbfa3 1444Perl_dowantarray(pTHX)
e50aee73 1445{
97aff369 1446 dVAR;
f54cb97a 1447 const I32 gimme = block_gimme();
54310121
PP		 1448 return (gimme == G_VOID) ? G_SCALAR : gimme;
1449}
1450
1451I32
864dbfa3 1452Perl_block_gimme(pTHX)
54310121 1453{
97aff369 1454 dVAR;
06b5626a 1455 const I32 cxix = dopoptosub(cxstack_ix);
e50aee73 1456 if (cxix < 0)
46fc3d4c 1457 return G_VOID;
e50aee73 1458
54310121 1459 switch (cxstack[cxix].blk_gimme) {
d2719217
GS		 1460 case G_VOID:
1461 return G_VOID;
54310121 1462 case G_SCALAR:
e50aee73 1463 return G_SCALAR;
54310121
PP		 1464 case G_ARRAY:
1465 return G_ARRAY;
1466 default:
cea2e8a9 1467 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS		 1468 /* NOTREACHED */
1469 return 0;
54310121 1470 }
e50aee73
AD		 1471}
1472
78f9721b
SM		 1473I32
1474Perl_is_lvalue_sub(pTHX)
1475{
97aff369 1476 dVAR;
06b5626a 1477 const I32 cxix = dopoptosub(cxstack_ix);
78f9721b
SM		 1478 assert(cxix >= 0); /* We should only be called from inside subs */
1479
bafb2adc
NC		 1480 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1481 return CxLVAL(cxstack + cxix);
78f9721b
SM		 1482 else
1483 return 0;
1484}
1485
777d9014
FC		 1486/* only used by PUSHSUB */
1487I32
1488Perl_was_lvalue_sub(pTHX)
1489{
1490 dVAR;
1491 const I32 cxix = dopoptosub(cxstack_ix-1);
1492 assert(cxix >= 0); /* We should only be called from inside subs */
1493
1494 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1495 return CxLVAL(cxstack + cxix);
1496 else
1497 return 0;
1498}
1499
76e3520e 1500STATIC I32
901017d6 1501S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9 1502{
97aff369 1503 dVAR;
a0d0e21e 1504 I32 i;
7918f24d
NC		 1505
1506 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1507
a0d0e21e 1508 for (i = startingblock; i >= 0; i--) {
901017d6 1509 register const PERL_CONTEXT * const cx = &cxstk[i];
6b35e009 1510 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1511 default:
1512 continue;
1513 case CXt_EVAL:
1514 case CXt_SUB:
7766f137 1515 case CXt_FORMAT:
1c98cc53 1516 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
a0d0e21e
LW		 1517 return i;
1518 }
1519 }
1520 return i;
1521}
1522
76e3520e 1523STATIC I32
cea2e8a9 1524S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e 1525{
97aff369 1526 dVAR;
a0d0e21e 1527 I32 i;
a0d0e21e 1528 for (i = startingblock; i >= 0; i--) {
06b5626a 1529 register const PERL_CONTEXT *cx = &cxstack[i];
6b35e009 1530 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1531 default:
1532 continue;
1533 case CXt_EVAL:
1c98cc53 1534 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
a0d0e21e
LW		 1535 return i;
1536 }
1537 }
1538 return i;
1539}
1540
76e3520e 1541STATIC I32
cea2e8a9 1542S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e 1543{
97aff369 1544 dVAR;
a0d0e21e 1545 I32 i;
a0d0e21e 1546 for (i = startingblock; i >= 0; i--) {
901017d6 1547 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1548 switch (CxTYPE(cx)) {
a0d0e21e 1549 case CXt_SUBST:
a0d0e21e 1550 case CXt_SUB:
7766f137 1551 case CXt_FORMAT:
a0d0e21e 1552 case CXt_EVAL:
0a753a76 1553 case CXt_NULL:
dcbac5bb 1554 /* diag_listed_as: Exiting subroutine via %s */
a2a5de95
NC		 1555 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1556 context_name[CxTYPE(cx)], OP_NAME(PL_op));
515afda2
NC		 1557 if ((CxTYPE(cx)) == CXt_NULL)
1558 return -1;
1559 break;
c6fdafd0 1560 case CXt_LOOP_LAZYIV:
d01136d6 1561 case CXt_LOOP_LAZYSV:
3b719c58
NC		 1562 case CXt_LOOP_FOR:
1563 case CXt_LOOP_PLAIN:
1c98cc53 1564 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
a0d0e21e
LW		 1565 return i;
1566 }
1567 }
1568 return i;
1569}
1570
0d863452
RH		 1571STATIC I32
1572S_dopoptogiven(pTHX_ I32 startingblock)
1573{
97aff369 1574 dVAR;
0d863452
RH		 1575 I32 i;
1576 for (i = startingblock; i >= 0; i--) {
1577 register const PERL_CONTEXT *cx = &cxstack[i];
1578 switch (CxTYPE(cx)) {
1579 default:
1580 continue;
1581 case CXt_GIVEN:
1c98cc53 1582 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
0d863452 1583 return i;
3b719c58
NC		 1584 case CXt_LOOP_PLAIN:
1585 assert(!CxFOREACHDEF(cx));
1586 break;
c6fdafd0 1587 case CXt_LOOP_LAZYIV:
d01136d6 1588 case CXt_LOOP_LAZYSV:
3b719c58 1589 case CXt_LOOP_FOR:
0d863452 1590 if (CxFOREACHDEF(cx)) {
1c98cc53 1591 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
0d863452
RH		 1592 return i;
1593 }
1594 }
1595 }
1596 return i;
1597}
1598
1599STATIC I32
1600S_dopoptowhen(pTHX_ I32 startingblock)
1601{
97aff369 1602 dVAR;
0d863452
RH		 1603 I32 i;
1604 for (i = startingblock; i >= 0; i--) {
1605 register const PERL_CONTEXT *cx = &cxstack[i];
1606 switch (CxTYPE(cx)) {
1607 default:
1608 continue;
1609 case CXt_WHEN:
1c98cc53 1610 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
0d863452
RH		 1611 return i;
1612 }
1613 }
1614 return i;
1615}
1616
a0d0e21e 1617void
864dbfa3 1618Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1619{
97aff369 1620 dVAR;
a0d0e21e
LW		 1621 I32 optype;
1622
f144f1e3
DM		 1623 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1624 return;
1625
a0d0e21e 1626 while (cxstack_ix > cxix) {
b0d9ce38 1627 SV *sv;
06b5626a 1628 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1c98cc53 1629 DEBUG_CX("UNWIND"); \
a0d0e21e 1630 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1631 switch (CxTYPE(cx)) {
c90c0ff4
PP		 1632 case CXt_SUBST:
1633 POPSUBST(cx);
1634 continue; /* not break */
a0d0e21e 1635 case CXt_SUB:
b0d9ce38
GS		 1636 POPSUB(cx,sv);
1637 LEAVESUB(sv);
a0d0e21e
LW		 1638 break;
1639 case CXt_EVAL:
1640 POPEVAL(cx);
1641 break;
c6fdafd0 1642 case CXt_LOOP_LAZYIV:
d01136d6 1643 case CXt_LOOP_LAZYSV:
3b719c58
NC		 1644 case CXt_LOOP_FOR:
1645 case CXt_LOOP_PLAIN:
a0d0e21e
LW		 1646 POPLOOP(cx);
1647 break;
0a753a76 1648 case CXt_NULL:
a0d0e21e 1649 break;
7766f137
GS		 1650 case CXt_FORMAT:
1651 POPFORMAT(cx);
1652 break;
a0d0e21e 1653 }
c90c0ff4 1654 cxstack_ix--;
a0d0e21e 1655 }
1b6737cc 1656 PERL_UNUSED_VAR(optype);
a0d0e21e
LW		 1657}
1658
5a844595
GS		 1659void
1660Perl_qerror(pTHX_ SV *err)
1661{
97aff369 1662 dVAR;
7918f24d
NC		 1663
1664 PERL_ARGS_ASSERT_QERROR;
1665
6b2fb389
DM		 1666 if (PL_in_eval) {
1667 if (PL_in_eval & EVAL_KEEPERR) {
ecad31f0
BF		 1668 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1669 SVfARG(err));
6b2fb389
DM		 1670 }
1671 else
1672 sv_catsv(ERRSV, err);
1673 }
5a844595
GS		 1674 else if (PL_errors)
1675 sv_catsv(PL_errors, err);
1676 else
be2597df 1677 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
13765c85
DM		 1678 if (PL_parser)
1679 ++PL_parser->error_count;
5a844595
GS		 1680}
1681
bb4c52e0 1682void
c5df3096 1683Perl_die_unwind(pTHX_ SV *msv)
a0d0e21e 1684{
27da23d5 1685 dVAR;
c5df3096 1686 SV *exceptsv = sv_mortalcopy(msv);
96d9b9cd 1687 U8 in_eval = PL_in_eval;
c5df3096 1688 PERL_ARGS_ASSERT_DIE_UNWIND;
87582a92 1689
96d9b9cd 1690 if (in_eval) {
a0d0e21e 1691 I32 cxix;
a0d0e21e 1692 I32 gimme;
a0d0e21e 1693
22a30693
Z		 1694 /*
1695 * Historically, perl used to set ERRSV ($@) early in the die
1696 * process and rely on it not getting clobbered during unwinding.
1697 * That sucked, because it was liable to get clobbered, so the
1698 * setting of ERRSV used to emit the exception from eval{} has
1699 * been moved to much later, after unwinding (see just before
1700 * JMPENV_JUMP below). However, some modules were relying on the
1701 * early setting, by examining $@ during unwinding to use it as
1702 * a flag indicating whether the current unwinding was caused by
1703 * an exception. It was never a reliable flag for that purpose,
1704 * being totally open to false positives even without actual
1705 * clobberage, but was useful enough for production code to
1706 * semantically rely on it.
1707 *
1708 * We'd like to have a proper introspective interface that
1709 * explicitly describes the reason for whatever unwinding
1710 * operations are currently in progress, so that those modules
1711 * work reliably and $@ isn't further overloaded. But we don't
1712 * have one yet. In its absence, as a stopgap measure, ERRSV is
1713 * now *additionally* set here, before unwinding, to serve as the
1714 * (unreliable) flag that it used to.
1715 *
1716 * This behaviour is temporary, and should be removed when a
1717 * proper way to detect exceptional unwinding has been developed.
1718 * As of 2010-12, the authors of modules relying on the hack
1719 * are aware of the issue, because the modules failed on
1720 * perls 5.13.{1..7} which had late setting of $@ without this
1721 * early-setting hack.
1722 */
1723 if (!(in_eval & EVAL_KEEPERR)) {
1724 SvTEMP_off(exceptsv);
1725 sv_setsv(ERRSV, exceptsv);
1726 }
1727
5a844595
GS		 1728 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1729 && PL_curstackinfo->si_prev)
1730 {
bac4b2ad 1731 dounwind(-1);
d3acc0f7 1732 POPSTACK;
bac4b2ad 1733 }
e336de0d 1734
a0d0e21e
LW		 1735 if (cxix >= 0) {
1736 I32 optype;
b6494f15 1737 SV *namesv;
35a4481c 1738 register PERL_CONTEXT *cx;
901017d6 1739 SV **newsp;
8f89e5a9
Z		 1740 COP *oldcop;
1741 JMPENV *restartjmpenv;
1742 OP *restartop;
a0d0e21e
LW		 1743
1744 if (cxix < cxstack_ix)
1745 dounwind(cxix);
1746
3280af22 1747 POPBLOCK(cx,PL_curpm);
6b35e009 1748 if (CxTYPE(cx) != CXt_EVAL) {
7d0994e0 1749 STRLEN msglen;
96d9b9cd 1750 const char* message = SvPVx_const(exceptsv, msglen);
10edeb5d 1751 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
bf49b057 1752 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW		 1753 my_exit(1);
1754 }
1755 POPEVAL(cx);
b6494f15 1756 namesv = cx->blk_eval.old_namesv;
8f89e5a9
Z		 1757 oldcop = cx->blk_oldcop;
1758 restartjmpenv = cx->blk_eval.cur_top_env;
1759 restartop = cx->blk_eval.retop;
a0d0e21e
LW		 1760
1761 if (gimme == G_SCALAR)
3280af22
NIS		 1762 *++newsp = &PL_sv_undef;
1763 PL_stack_sp = newsp;
a0d0e21e
LW		 1764
1765 LEAVE;
748a9306 1766
7fb6a879
GS		 1767 /* LEAVE could clobber PL_curcop (see save_re_context())
1768 * XXX it might be better to find a way to avoid messing with
1769 * PL_curcop in save_re_context() instead, but this is a more
1770 * minimal fix --GSAR */
8f89e5a9 1771 PL_curcop = oldcop;
7fb6a879 1772
7a2e2cd6 1773 if (optype == OP_REQUIRE) {
b6494f15 1774 (void)hv_store(GvHVn(PL_incgv),
ecad31f0 1775 SvPVX_const(namesv),
c60dbbc3 1776 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
27bcc0a7 1777 &PL_sv_undef, 0);
27e90453
DM		 1778 /* note that unlike pp_entereval, pp_require isn't
1779 * supposed to trap errors. So now that we've popped the
1780 * EVAL that pp_require pushed, and processed the error
1781 * message, rethrow the error */
ecad31f0
BF		 1782 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1783 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1784 SVs_TEMP)));
7a2e2cd6 1785 }
c5df3096 1786 if (in_eval & EVAL_KEEPERR) {
ecad31f0
BF		 1787 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1788 SVfARG(exceptsv));
96d9b9cd
Z		 1789 }
1790 else {
1791 sv_setsv(ERRSV, exceptsv);
1792 }
8f89e5a9
Z		 1793 PL_restartjmpenv = restartjmpenv;
1794 PL_restartop = restartop;
bb4c52e0
GG		 1795 JMPENV_JUMP(3);
1796 /* NOTREACHED */
a0d0e21e
LW		 1797 }
1798 }
87582a92 1799
96d9b9cd 1800 write_to_stderr(exceptsv);
f86702cc
PP		 1801 my_failure_exit();
1802 /* NOTREACHED */
a0d0e21e
LW		 1803}
1804
1805PP(pp_xor)
1806{
97aff369 1807 dVAR; dSP; dPOPTOPssrl;
a0d0e21e
LW		 1808 if (SvTRUE(left) != SvTRUE(right))
1809 RETSETYES;
1810 else
1811 RETSETNO;
1812}
1813
8dff4fc5
BM		 1814/*
1815=for apidoc caller_cx
1816
1817The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1818returned C<PERL_CONTEXT> structure can be interrogated to find all the
1819information returned to Perl by C<caller>. Note that XSUBs don't get a
1820stack frame, so C<caller_cx(0, NULL)> will return information for the
1821immediately-surrounding Perl code.
1822
1823This function skips over the automatic calls to C<&DB::sub> made on the
1824behalf of the debugger. If the stack frame requested was a sub called by
1825C<DB::sub>, the return value will be the frame for the call to
1826C<DB::sub>, since that has the correct line number/etc. for the call
1827site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1828frame for the sub call itself.
1829
1830=cut
1831*/
1832
1833const PERL_CONTEXT *
1834Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
a0d0e21e 1835{
a0d0e21e 1836 register I32 cxix = dopoptosub(cxstack_ix);
901017d6
AL		 1837 register const PERL_CONTEXT *cx;
1838 register const PERL_CONTEXT *ccstack = cxstack;
1839 const PERL_SI *top_si = PL_curstackinfo;
27d41816 1840
a0d0e21e 1841 for (;;) {
2c375eb9
GS		 1842 /* we may be in a higher stacklevel, so dig down deeper */
1843 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1844 top_si = top_si->si_prev;
1845 ccstack = top_si->si_cxstack;
1846 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1847 }
8dff4fc5
BM		 1848 if (cxix < 0)
1849 return NULL;
f2a7f298 1850 /* caller() should not report the automatic calls to &DB::sub */
1851 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
3280af22 1852 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1853 count++;
1854 if (!count--)
1855 break;
2c375eb9 1856 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1857 }
2c375eb9
GS		 1858
1859 cx = &ccstack[cxix];
8dff4fc5
BM		 1860 if (dbcxp) *dbcxp = cx;
1861
7766f137 1862 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
f54cb97a 1863 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2c375eb9 1864 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1865 field below is defined for any cx. */
f2a7f298 1866 /* caller() should not report the automatic calls to &DB::sub */
1867 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1868 cx = &ccstack[dbcxix];
06a5b730
PP		 1869 }
1870
8dff4fc5
BM		 1871 return cx;
1872}
1873
1874PP(pp_caller)
1875{
1876 dVAR;
1877 dSP;
1878 register const PERL_CONTEXT *cx;
1879 const PERL_CONTEXT *dbcx;
1880 I32 gimme;
d527ce7c 1881 const HEK *stash_hek;
8dff4fc5 1882 I32 count = 0;
ce0b554b 1883 bool has_arg = MAXARG && TOPs;
8dff4fc5 1884
ce0b554b
FC		 1885 if (MAXARG) {
1886 if (has_arg)
8dff4fc5 1887 count = POPi;
ce0b554b
FC		 1888 else (void)POPs;
1889 }
8dff4fc5 1890
ce0b554b 1891 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
8dff4fc5
BM		 1892 if (!cx) {
1893 if (GIMME != G_ARRAY) {
1894 EXTEND(SP, 1);
1895 RETPUSHUNDEF;
1896 }
1897 RETURN;
1898 }
1899
d527ce7c 1900 stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop));
a0d0e21e 1901 if (GIMME != G_ARRAY) {
27d41816 1902 EXTEND(SP, 1);
d527ce7c 1903 if (!stash_hek)
3280af22 1904 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1905 else {
1906 dTARGET;
d527ce7c 1907 sv_sethek(TARG, stash_hek);
49d8d3a1
MB		 1908 PUSHs(TARG);
1909 }
a0d0e21e
LW		 1910 RETURN;
1911 }
a0d0e21e 1912
b3ca2e83 1913 EXTEND(SP, 11);
27d41816 1914
d527ce7c 1915 if (!stash_hek)
3280af22 1916 PUSHs(&PL_sv_undef);
d527ce7c
BF		 1917 else {
1918 dTARGET;
1919 sv_sethek(TARG, stash_hek);
1920 PUSHTARG;
1921 }
6e449a3a
MHM		 1922 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1923 mPUSHi((I32)CopLINE(cx->blk_oldcop));
ce0b554b 1924 if (!has_arg)
a0d0e21e 1925 RETURN;
7766f137 1926 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
8dff4fc5 1927 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
7766f137 1928 /* So is ccstack[dbcxix]. */
07b8c804 1929 if (isGV(cvgv)) {
561b68a9 1930 SV * const sv = newSV(0);
c445ea15 1931 gv_efullname3(sv, cvgv, NULL);
6e449a3a 1932 mPUSHs(sv);
bf38a478 1933 PUSHs(boolSV(CxHASARGS(cx)));
07b8c804
RGS		 1934 }
1935 else {
84bafc02 1936 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
bf38a478 1937 PUSHs(boolSV(CxHASARGS(cx)));
07b8c804 1938 }
a0d0e21e
LW		 1939 }
1940 else {
84bafc02 1941 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
6e449a3a 1942 mPUSHi(0);
a0d0e21e 1943 }
54310121
PP		 1944 gimme = (I32)cx->blk_gimme;
1945 if (gimme == G_VOID)
3280af22 1946 PUSHs(&PL_sv_undef);
54310121 1947 else
98625aca 1948 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
6b35e009 1949 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1950 /* eval STRING */
85a64632 1951 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
4633a7c4 1952 PUSHs(cx->blk_eval.cur_text);
3280af22 1953 PUSHs(&PL_sv_no);
0f79a09d 1954 }
811a4de9 1955 /* require */
0f79a09d 1956 else if (cx->blk_eval.old_namesv) {
6e449a3a 1957 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
3280af22 1958 PUSHs(&PL_sv_yes);
06a5b730 1959 }
811a4de9
GS		 1960 /* eval BLOCK (try blocks have old_namesv == 0) */
1961 else {
1962 PUSHs(&PL_sv_undef);
1963 PUSHs(&PL_sv_undef);
1964 }
4633a7c4 1965 }
a682de96
GS		 1966 else {
1967 PUSHs(&PL_sv_undef);
1968 PUSHs(&PL_sv_undef);
1969 }
bafb2adc 1970 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
ed094faf 1971 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1972 {
66a1b24b
AL		 1973 AV * const ary = cx->blk_sub.argarray;
1974 const int off = AvARRAY(ary) - AvALLOC(ary);
a0d0e21e 1975
e1a80902 1976 Perl_init_dbargs(aTHX);
a0d0e21e 1977
3280af22
NIS		 1978 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1979 av_extend(PL_dbargs, AvFILLp(ary) + off);
1980 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1981 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1982 }
f3aa04c2
GS		 1983 /* XXX only hints propagated via op_private are currently
1984 * visible (others are not easily accessible, since they
1985 * use the global PL_hints) */
6e449a3a 1986 mPUSHi(CopHINTS_get(cx->blk_oldcop));
e476b1b5
GS		 1987 {
1988 SV * mask ;
72dc9ed5 1989 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba 1990
ac27b0f5 1991 if (old_warnings == pWARN_NONE ||
114bafba 1992 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1993 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
ac27b0f5 1994 else if (old_warnings == pWARN_ALL ||
75b6c4ca
RGS		 1995 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1996 /* Get the bit mask for $warnings::Bits{all}, because
1997 * it could have been extended by warnings::register */
1998 SV **bits_all;
6673a63c 1999 HV * const bits = get_hv("warnings::Bits", 0);
017a3ce5 2000 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
75b6c4ca
RGS		 2001 mask = newSVsv(*bits_all);
2002 }
2003 else {
2004 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2005 }
2006 }
e476b1b5 2007 else
72dc9ed5 2008 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
6e449a3a 2009 mPUSHs(mask);
e476b1b5 2010 }
b3ca2e83 2011
c28fe1ec 2012 PUSHs(cx->blk_oldcop->cop_hints_hash ?
20439bc7 2013 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
b3ca2e83 2014 : &PL_sv_undef);
a0d0e21e
LW		 2015 RETURN;
2016}
2017
a0d0e21e
LW		 2018PP(pp_reset)
2019{
97aff369 2020 dVAR;
39644a26 2021 dSP;
f650fa72
FC		 2022 const char * const tmps =
2023 (MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx;
11faa288 2024 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 2025 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2026 RETURN;
2027}
2028
dd2155a4
DM		 2029/* like pp_nextstate, but used instead when the debugger is active */
2030
a0d0e21e
LW		 2031PP(pp_dbstate)
2032{
27da23d5 2033 dVAR;
533c011a 2034 PL_curcop = (COP*)PL_op;
a0d0e21e 2035 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 2036 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 2037 FREETMPS;
2038
f410a211
NC		 2039 PERL_ASYNC_CHECK();
2040
5df8de69
DM		 2041 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2042 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 2043 {
39644a26 2044 dSP;
c09156bb 2045 register PERL_CONTEXT *cx;
f54cb97a 2046 const I32 gimme = G_ARRAY;
eb160463 2047 U8 hasargs;
0bd48802
AL		 2048 GV * const gv = PL_DBgv;
2049 register CV * const cv = GvCV(gv);
a0d0e21e 2050
a0d0e21e 2051 if (!cv)
cea2e8a9 2052 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 2053
aea4f609
DM		 2054 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2055 /* don't do recursive DB::DB call */
a0d0e21e 2056 return NORMAL;
748a9306 2057
a57c6685 2058 ENTER;
4633a7c4
LW		 2059 SAVETMPS;
2060
3280af22 2061 SAVEI32(PL_debug);
55497cff 2062 SAVESTACK_POS();
3280af22 2063 PL_debug = 0;
748a9306 2064 hasargs = 0;
924508f0 2065 SPAGAIN;
748a9306 2066
aed2304a 2067 if (CvISXSUB(cv)) {
c127bd3a
SF		 2068 CvDEPTH(cv)++;
2069 PUSHMARK(SP);
2070 (void)(*CvXSUB(cv))(aTHX_ cv);
2071 CvDEPTH(cv)--;
2072 FREETMPS;
a57c6685 2073 LEAVE;
c127bd3a
SF		 2074 return NORMAL;
2075 }
2076 else {
2077 PUSHBLOCK(cx, CXt_SUB, SP);
2078 PUSHSUB_DB(cx);
2079 cx->blk_sub.retop = PL_op->op_next;
2080 CvDEPTH(cv)++;
2081 SAVECOMPPAD();
2082 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2083 RETURNOP(CvSTART(cv));
2084 }
a0d0e21e
LW		 2085 }
2086 else
2087 return NORMAL;
2088}
2089
b9d76716
VP		 2090STATIC SV **
2091S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2092{
9a214eec 2093 bool padtmp = 0;
b9d76716
VP		 2094 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2095
9a214eec
DM		 2096 if (flags & SVs_PADTMP) {
2097 flags &= ~SVs_PADTMP;
2098 padtmp = 1;
2099 }
b9d76716
VP		 2100 if (gimme == G_SCALAR) {
2101 if (MARK < SP)
9a214eec
DM		 2102 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2103 ? *SP : sv_mortalcopy(*SP);
b9d76716
VP		 2104 else {
2105 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2106 MARK = newsp;
2107 MEXTEND(MARK, 1);
2108 *++MARK = &PL_sv_undef;
2109 return MARK;
2110 }
2111 }
2112 else if (gimme == G_ARRAY) {
2113 /* in case LEAVE wipes old return values */
2114 while (++MARK <= SP) {
9a214eec 2115 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
b9d76716
VP		 2116 *++newsp = *MARK;
2117 else {
2118 *++newsp = sv_mortalcopy(*MARK);
2119 TAINT_NOT; /* Each item is independent */
2120 }
2121 }
2122 /* When this function was called with MARK == newsp, we reach this
2123 * point with SP == newsp. */
2124 }
2125
2126 return newsp;
2127}
2128
2b9a6457
VP		 2129PP(pp_enter)
2130{
2131 dVAR; dSP;
2132 register PERL_CONTEXT *cx;
7c2d9d03 2133 I32 gimme = GIMME_V;
2b9a6457
VP		 2134
2135 ENTER_with_name("block");
2136
2137 SAVETMPS;
2138 PUSHBLOCK(cx, CXt_BLOCK, SP);
2139
2140 RETURN;
2141}
2142
2143PP(pp_leave)
2144{
2145 dVAR; dSP;
2146 register PERL_CONTEXT *cx;
2147 SV **newsp;
2148 PMOP *newpm;
2149 I32 gimme;
2150
2151 if (PL_op->op_flags & OPf_SPECIAL) {
2152 cx = &cxstack[cxstack_ix];
2153 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2154 }
2155
2156 POPBLOCK(cx,newpm);
2157
2158 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2159
2160 TAINT_NOT;
f02ea43c 2161 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2b9a6457
VP		 2162 PL_curpm = newpm; /* Don't pop $1 et al till now */
2163
2164 LEAVE_with_name("block");
2165
2166 RETURN;
2167}
2168
a0d0e21e
LW		 2169PP(pp_enteriter)
2170{
27da23d5 2171 dVAR; dSP; dMARK;
c09156bb 2172 register PERL_CONTEXT *cx;
f54cb97a 2173 const I32 gimme = GIMME_V;
df530c37 2174 void *itervar; /* location of the iteration variable */
840fe433 2175 U8 cxtype = CXt_LOOP_FOR;
a0d0e21e 2176
d343c3ef 2177 ENTER_with_name("loop1");
4633a7c4
LW		 2178 SAVETMPS;
2179
aafca525
DM		 2180 if (PL_op->op_targ) { /* "my" variable */
2181 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
14f338dc
DM		 2182 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2183 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2184 SVs_PADSTALE, SVs_PADSTALE);
2185 }
09edbca0 2186 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
89e00a7c 2187#ifdef USE_ITHREADS
df530c37 2188 itervar = PL_comppad;
89e00a7c 2189#else
aafca525 2190 itervar = &PAD_SVl(PL_op->op_targ);
7766f137 2191#endif
54b9620d 2192 }
aafca525 2193 else { /* symbol table variable */
159b6efe 2194 GV * const gv = MUTABLE_GV(POPs);
f83b46a0
DM		 2195 SV** svp = &GvSV(gv);
2196 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
561b68a9 2197 *svp = newSV(0);
df530c37 2198 itervar = (void *)gv;
54b9620d 2199 }
4633a7c4 2200
0d863452
RH		 2201 if (PL_op->op_private & OPpITER_DEF)
2202 cxtype |= CXp_FOR_DEF;
2203
d343c3ef 2204 ENTER_with_name("loop2");
a0d0e21e 2205
7766f137 2206 PUSHBLOCK(cx, cxtype, SP);
df530c37 2207 PUSHLOOP_FOR(cx, itervar, MARK);
533c011a 2208 if (PL_op->op_flags & OPf_STACKED) {
d01136d6
BS		 2209 SV *maybe_ary = POPs;
2210 if (SvTYPE(maybe_ary) != SVt_PVAV) {
89ea2908 2211 dPOPss;
d01136d6 2212 SV * const right = maybe_ary;
984a4bea
RD		 2213 SvGETMAGIC(sv);
2214 SvGETMAGIC(right);
4fe3f0fa 2215 if (RANGE_IS_NUMERIC(sv,right)) {
d01136d6 2216 cx->cx_type &= ~CXTYPEMASK;
c6fdafd0
NC		 2217 cx->cx_type |= CXt_LOOP_LAZYIV;
2218 /* Make sure that no-one re-orders cop.h and breaks our
2219 assumptions */
2220 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
a2309040 2221#ifdef NV_PRESERVES_UV
f52e41ad
FC		 2222 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2223 (SvNV_nomg(sv) > (NV)IV_MAX)))
a2309040 2224 ||
f52e41ad
FC		 2225 (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2226 (SvNV_nomg(right) < (NV)IV_MIN))))
a2309040 2227#else
f52e41ad 2228 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
a2309040 2229 ||
f52e41ad
FC		 2230 ((SvNV_nomg(sv) > 0) &&
2231 ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2232 (SvNV_nomg(sv) > (NV)UV_MAX)))))
a2309040 2233 ||
f52e41ad 2234 (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
a2309040 2235 ||
f52e41ad
FC		 2236 ((SvNV_nomg(right) > 0) &&
2237 ((SvUV_nomg(right) > (UV)IV_MAX) ||
2238 (SvNV_nomg(right) > (NV)UV_MAX))
2239 ))))
a2309040 2240#endif
076d9a11 2241 DIE(aTHX_ "Range iterator outside integer range");
f52e41ad
FC		 2242 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2243 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
d4665a05
DM		 2244#ifdef DEBUGGING
2245 /* for correct -Dstv display */
2246 cx->blk_oldsp = sp - PL_stack_base;
2247#endif
89ea2908 2248 }
3f63a782 2249 else {
d01136d6
BS		 2250 cx->cx_type &= ~CXTYPEMASK;
2251 cx->cx_type |= CXt_LOOP_LAZYSV;
2252 /* Make sure that no-one re-orders cop.h and breaks our
2253 assumptions */
2254 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2255 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2256 cx->blk_loop.state_u.lazysv.end = right;
2257 SvREFCNT_inc(right);
2258 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
267cc4a8
NC		 2259 /* This will do the upgrade to SVt_PV, and warn if the value
2260 is uninitialised. */
10516c54 2261 (void) SvPV_nolen_const(right);
267cc4a8
NC		 2262 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2263 to replace !SvOK() with a pointer to "". */
2264 if (!SvOK(right)) {
2265 SvREFCNT_dec(right);
d01136d6 2266 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
267cc4a8 2267 }
3f63a782 2268 }
89ea2908 2269 }
d01136d6 2270 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
502c6561 2271 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
d01136d6
BS		 2272 SvREFCNT_inc(maybe_ary);
2273 cx->blk_loop.state_u.ary.ix =
2274 (PL_op->op_private & OPpITER_REVERSED) ?
2275 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2276 -1;
ef3e5ea9 2277 }
89ea2908 2278 }
d01136d6
BS		 2279 else { /* iterating over items on the stack */
2280 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
ef3e5ea9 2281 if (PL_op->op_private & OPpITER_REVERSED) {
d01136d6 2282 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
ef3e5ea9
NC		 2283 }
2284 else {
d01136d6 2285 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
ef3e5ea9 2286 }
4633a7c4 2287 }
a0d0e21e
LW		 2288
2289 RETURN;
2290}
2291
2292PP(pp_enterloop)
2293{
27da23d5 2294 dVAR; dSP;
c09156bb 2295 register PERL_CONTEXT *cx;
f54cb97a 2296 const I32 gimme = GIMME_V;
a0d0e21e 2297
d343c3ef 2298 ENTER_with_name("loop1");
a0d0e21e 2299 SAVETMPS;
d343c3ef 2300 ENTER_with_name("loop2");
a0d0e21e 2301
3b719c58
NC		 2302 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2303 PUSHLOOP_PLAIN(cx, SP);
a0d0e21e
LW		 2304
2305 RETURN;
2306}
2307
2308PP(pp_leaveloop)
2309{
27da23d5 2310 dVAR; dSP;
c09156bb 2311 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2312 I32 gimme;
2313 SV **newsp;
2314 PMOP *newpm;
2315 SV **mark;
2316
2317 POPBLOCK(cx,newpm);
3b719c58 2318 assert(CxTYPE_is_LOOP(cx));
4fdae800 2319 mark = newsp;
a8bba7fa 2320 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 2321
a1f49e72 2322 TAINT_NOT;
b9d76716 2323 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
f86702cc
PP		 2324 PUTBACK;
2325
a8bba7fa 2326 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 2327 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2328
d343c3ef
GG		 2329 LEAVE_with_name("loop2");
2330 LEAVE_with_name("loop1");
a0d0e21e 2331
f86702cc 2332 return NORMAL;
a0d0e21e
LW		 2333}
2334
3bdf583b
FC		 2335STATIC void
2336S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
d25b0d7b 2337 PERL_CONTEXT *cx, PMOP *newpm)
3bdf583b 2338{
80422e24 2339 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
3bdf583b 2340 if (gimme == G_SCALAR) {
d25b0d7b
FC		 2341 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2342 SV *sv;
001de122 2343 const char *what = NULL;
d25b0d7b
FC		 2344 if (MARK < SP) {
2345 assert(MARK+1 == SP);
2346 if ((SvPADTMP(TOPs) ||
2347 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2348 == SVf_READONLY
2349 ) &&
2350 !SvSMAGICAL(TOPs)) {
001de122 2351 what =
d25b0d7b 2352 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
001de122 2353 : "a readonly value" : "a temporary";
d25b0d7b 2354 }
001de122 2355 else goto copy_sv;
d25b0d7b
FC		 2356 }
2357 else {
2358 /* sub:lvalue{} will take us here. */
001de122 2359 what = "undef";
d25b0d7b 2360 }
001de122
FC		 2361 LEAVE;
2362 cxstack_ix--;
2363 POPSUB(cx,sv);
2364 PL_curpm = newpm;
2365 LEAVESUB(sv);
2366 Perl_croak(aTHX_
2367 "Can't return %s from lvalue subroutine", what
2368 );
d25b0d7b 2369 }
93905212 2370 if (MARK < SP) {
a5ad7a5a 2371 copy_sv:
3bdf583b
FC		 2372 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2373 *++newsp = SvREFCNT_inc(*SP);
2374 FREETMPS;
2375 sv_2mortal(*newsp);
2376 }
2377 else
e08be60b 2378 *++newsp =
e08be60b
FC		 2379 !SvTEMP(*SP)
2380 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2381 : *SP;
3bdf583b 2382 }
0d235c77
FC		 2383 else {
2384 EXTEND(newsp,1);
3bdf583b 2385 *++newsp = &PL_sv_undef;
0d235c77 2386 }
0e9700df 2387 if (CxLVAL(cx) & OPpDEREF) {
767eda44
FC		 2388 SvGETMAGIC(TOPs);
2389 if (!SvOK(TOPs)) {
0e9700df 2390 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
767eda44
FC		 2391 }
2392 }
3bdf583b
FC		 2393 }
2394 else if (gimme == G_ARRAY) {
0e9700df 2395 assert (!(CxLVAL(cx) & OPpDEREF));
80422e24 2396 if (ref || !CxLVAL(cx))
e08be60b
FC		 2397 while (++MARK <= SP)
2398 *++newsp =
2399 SvTEMP(*MARK)
2400 ? *MARK
80422e24
FC		 2401 : ref && SvFLAGS(*MARK) & SVs_PADTMP
2402 ? sv_mortalcopy(*MARK)
2403 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
e08be60b 2404 else while (++MARK <= SP) {
d25b0d7b
FC		 2405 if (*MARK != &PL_sv_undef
2406 && (SvPADTMP(*MARK)
2407 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2408 == SVf_READONLY
2409 )
2410 ) {
2411 SV *sv;
2412 /* Might be flattened array after $#array = */
2413 PUTBACK;
2414 LEAVE;
2415 cxstack_ix--;
2416 POPSUB(cx,sv);
2417 PL_curpm = newpm;
2418 LEAVESUB(sv);
ae917476 2419 /* diag_listed_as: Can't return %s from lvalue subroutine */
d25b0d7b
FC		 2420 Perl_croak(aTHX_
2421 "Can't return a %s from lvalue subroutine",
2422 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2423 }
2424 else
4bee03f8
FC		 2425 *++newsp =
2426 SvTEMP(*MARK)
2427 ? *MARK
2428 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
3bdf583b
FC		 2429 }
2430 }
2431 PL_stack_sp = newsp;
2432}
2433
a0d0e21e
LW		 2434PP(pp_return)
2435{
27da23d5 2436 dVAR; dSP; dMARK;
c09156bb 2437 register PERL_CONTEXT *cx;
f86702cc 2438 bool popsub2 = FALSE;
b45de488 2439 bool clear_errsv = FALSE;
fa1e92c4 2440 bool lval = FALSE;
a0d0e21e
LW		 2441 I32 gimme;
2442 SV **newsp;
2443 PMOP *newpm;
2444 I32 optype = 0;
b6494f15 2445 SV *namesv;
b0d9ce38 2446 SV *sv;
b263a1ad 2447 OP *retop = NULL;
a0d0e21e 2448
0bd48802
AL		 2449 const I32 cxix = dopoptosub(cxstack_ix);
2450
9850bf21
RH		 2451 if (cxix < 0) {
2452 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2453 * sort block, which is a CXt_NULL
2454 * not a CXt_SUB */
2455 dounwind(0);
d7507f74
RH		 2456 PL_stack_base[1] = *PL_stack_sp;
2457 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 2458 return 0;
2459 }
9850bf21
RH		 2460 else
2461 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e 2462 }
a0d0e21e
LW		 2463 if (cxix < cxstack_ix)
2464 dounwind(cxix);
2465
d7507f74
RH		 2466 if (CxMULTICALL(&cxstack[cxix])) {
2467 gimme = cxstack[cxix].blk_gimme;
2468 if (gimme == G_VOID)
2469 PL_stack_sp = PL_stack_base;
2470 else if (gimme == G_SCALAR) {
2471 PL_stack_base[1] = *PL_stack_sp;
2472 PL_stack_sp = PL_stack_base + 1;
2473 }
9850bf21 2474 return 0;
d7507f74 2475 }
9850bf21 2476
a0d0e21e 2477 POPBLOCK(cx,newpm);
6b35e009 2478 switch (CxTYPE(cx)) {
a0d0e21e 2479 case CXt_SUB:
f86702cc 2480 popsub2 = TRUE;
fa1e92c4 2481 lval = !!CvLVALUE(cx->blk_sub.cv);
f39bc417 2482 retop = cx->blk_sub.retop;
5dd42e15 2483 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW		 2484 break;
2485 case CXt_EVAL:
b45de488
GS		 2486 if (!(PL_in_eval & EVAL_KEEPERR))
2487 clear_errsv = TRUE;
a0d0e21e 2488 POPEVAL(cx);
b6494f15 2489 namesv = cx->blk_eval.old_namesv;
f39bc417 2490 retop = cx->blk_eval.retop;
1d76a5c3
GS		 2491 if (CxTRYBLOCK(cx))
2492 break;
748a9306
LW		 2493 if (optype == OP_REQUIRE &&
2494 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2495 {
54310121 2496 /* Unassume the success we assumed earlier. */
b6494f15 2497 (void)hv_delete(GvHVn(PL_incgv),
ecad31f0 2498 SvPVX_const(namesv),
c60dbbc3 2499 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
b6494f15
VP		 2500 G_DISCARD);
2501 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
748a9306 2502 }
a0d0e21e 2503 break;
7766f137
GS		 2504 case CXt_FORMAT:
2505 POPFORMAT(cx);
f39bc417 2506 retop = cx->blk_sub.retop;
7766f137 2507 break;
a0d0e21e 2508 default:
5637ef5b 2509 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
a0d0e21e
LW		 2510 }
2511
a1f49e72 2512 TAINT_NOT;
d25b0d7b 2513 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
3bdf583b
FC		 2514 else {
2515 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 2516 if (MARK < SP) {
2517 if (popsub2) {
a8bba7fa 2518 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
6f48390a
FC		 2519 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2520 && !SvMAGICAL(TOPs)) {
a29cdaf0
IZ		 2521 *++newsp = SvREFCNT_inc(*SP);
2522 FREETMPS;
2523 sv_2mortal(*newsp);
959e3673
GS		 2524 }
2525 else {
2526 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 2527 FREETMPS;
959e3673
GS		 2528 *++newsp = sv_mortalcopy(sv);
2529 SvREFCNT_dec(sv);
a29cdaf0 2530 }
959e3673 2531 }
6f48390a
FC		 2532 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2533 && !SvMAGICAL(*SP)) {
767eda44 2534 *++newsp = *SP;
767eda44 2535 }
959e3673 2536 else
767eda44 2537 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 2538 }
2539 else
a29cdaf0 2540 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 2541 }
2542 else
3280af22 2543 *++newsp = &PL_sv_undef;
3bdf583b
FC		 2544 }
2545 else if (gimme == G_ARRAY) {
a1f49e72 2546 while (++MARK <= SP) {
3ed94dc0 2547 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
6f48390a 2548 && !SvGMAGICAL(*MARK)
f86702cc 2549 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2550 TAINT_NOT; /* Each item is independent */
2551 }
3bdf583b
FC		 2552 }
2553 PL_stack_sp = newsp;
a0d0e21e 2554 }
a0d0e21e 2555
5dd42e15 2556 LEAVE;
f86702cc
PP		 2557 /* Stack values are safe: */
2558 if (popsub2) {
5dd42e15 2559 cxstack_ix--;
b0d9ce38 2560 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2561 }
b0d9ce38 2562 else
c445ea15 2563 sv = NULL;
3280af22 2564 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2565
b0d9ce38 2566 LEAVESUB(sv);
8433848b 2567 if (clear_errsv) {
ab69dbc2 2568 CLEAR_ERRSV();
8433848b 2569 }
f39bc417 2570 return retop;
a0d0e21e
LW		 2571}
2572
4f443c3d
FC		 2573/* This duplicates parts of pp_leavesub, so that it can share code with
2574 * pp_return */
2575PP(pp_leavesublv)
2576{
2577 dVAR; dSP;
4f443c3d
FC		 2578 SV **newsp;
2579 PMOP *newpm;
2580 I32 gimme;
2581 register PERL_CONTEXT *cx;
2582 SV *sv;
2583
2584 if (CxMULTICALL(&cxstack[cxstack_ix]))
2585 return 0;
2586
2587 POPBLOCK(cx,newpm);
2588 cxstack_ix++; /* temporarily protect top context */
4f443c3d
FC		 2589
2590 TAINT_NOT;
2591
0d235c77 2592 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
4f443c3d
FC		 2593
2594 LEAVE;
2595 cxstack_ix--;
2596 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2597 PL_curpm = newpm; /* ... and pop $1 et al */
2598
2599 LEAVESUB(sv);
2600 return cx->blk_sub.retop;
2601}
2602
a0d0e21e
LW		 2603PP(pp_last)
2604{
27da23d5 2605 dVAR; dSP;
a0d0e21e 2606 I32 cxix;
c09156bb 2607 register PERL_CONTEXT *cx;
f86702cc 2608 I32 pop2 = 0;
a0d0e21e 2609 I32 gimme;
8772537c 2610 I32 optype;
b263a1ad 2611 OP *nextop = NULL;
a0d0e21e
LW		 2612 SV **newsp;
2613 PMOP *newpm;
a8bba7fa 2614 SV **mark;
c445ea15 2615 SV *sv = NULL;
9d4ba2ae 2616
a0d0e21e 2617
533c011a 2618 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2619 cxix = dopoptoloop(cxstack_ix);
2620 if (cxix < 0)
a651a37d 2621 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 2622 }
2623 else {
5db1eb8d
BF		 2624 cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
2625 (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
a0d0e21e 2626 if (cxix < 0)
5db1eb8d
BF		 2627 DIE(aTHX_ "Label not found for \"last %"SVf"\"",
2628 SVfARG(newSVpvn_flags(cPVOP->op_pv,
2629 strlen(cPVOP->op_pv),
2630 ((cPVOP->op_private & OPpPV_IS_UTF8)
2631 ? SVf_UTF8 : 0) | SVs_TEMP)));
a0d0e21e
LW		 2632 }
2633 if (cxix < cxstack_ix)
2634 dounwind(cxix);
2635
2636 POPBLOCK(cx,newpm);
5dd42e15 2637 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2638 mark = newsp;
6b35e009 2639 switch (CxTYPE(cx)) {
c6fdafd0 2640 case CXt_LOOP_LAZYIV:
d01136d6 2641 case CXt_LOOP_LAZYSV:
3b719c58
NC		 2642 case CXt_LOOP_FOR:
2643 case CXt_LOOP_PLAIN:
2644 pop2 = CxTYPE(cx);
a8bba7fa 2645 newsp = PL_stack_base + cx->blk_loop.resetsp;
022eaa24 2646 nextop = cx->blk_loop.my_op->op_lastop->op_next;
a0d0e21e 2647 break;
f86702cc 2648 case CXt_SUB:
f86702cc 2649 pop2 = CXt_SUB;
f39bc417 2650 nextop = cx->blk_sub.retop;
a0d0e21e 2651 break;
f86702cc
PP		 2652 case CXt_EVAL:
2653 POPEVAL(cx);
f39bc417 2654 nextop = cx->blk_eval.retop;
a0d0e21e 2655 break;
7766f137
GS		 2656 case CXt_FORMAT:
2657 POPFORMAT(cx);
f39bc417 2658 nextop = cx->blk_sub.retop;
7766f137 2659 break;
a0d0e21e 2660 default:
5637ef5b 2661 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
a0d0e21e
LW		 2662 }
2663
a1f49e72 2664 TAINT_NOT;
b9d76716
VP		 2665 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
2666 pop2 == CXt_SUB ? SVs_TEMP : 0);
f86702cc
PP		 2667 PUTBACK;
2668
5dd42e15
DM		 2669 LEAVE;
2670 cxstack_ix--;
f86702cc
PP		 2671 /* Stack values are safe: */
2672 switch (pop2) {
c6fdafd0 2673 case CXt_LOOP_LAZYIV:
3b719c58 2674 case CXt_LOOP_PLAIN:
d01136d6 2675 case CXt_LOOP_LAZYSV:
3b719c58 2676 case CXt_LOOP_FOR:
a8bba7fa 2677 POPLOOP(cx); /* release loop vars ... */
4fdae800 2678 LEAVE;
f86702cc
PP		 2679 break;
2680 case CXt_SUB:
b0d9ce38 2681 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2682 break;
a0d0e21e 2683 }
3280af22 2684 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2685
b0d9ce38 2686 LEAVESUB(sv);
9d4ba2ae
AL		 2687 PERL_UNUSED_VAR(optype);
2688 PERL_UNUSED_VAR(gimme);
f86702cc 2689 return nextop;
a0d0e21e
LW		 2690}
2691
2692PP(pp_next)
2693{
27da23d5 2694 dVAR;
a0d0e21e 2695 I32 cxix;
c09156bb 2696 register PERL_CONTEXT *cx;
85538317 2697 I32 inner;
a0d0e21e 2698
533c011a 2699 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2700 cxix = dopoptoloop(cxstack_ix);
2701 if (cxix < 0)
a651a37d 2702 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 2703 }
2704 else {
5db1eb8d
BF		 2705 cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
2706 (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
2707 if (cxix < 0)
2708 DIE(aTHX_ "Label not found for \"next %"SVf"\"",
2709 SVfARG(newSVpvn_flags(cPVOP->op_pv,
2710 strlen(cPVOP->op_pv),
2711 ((cPVOP->op_private & OPpPV_IS_UTF8)
2712 ? SVf_UTF8 : 0) | SVs_TEMP)));
a0d0e21e
LW		 2713 }
2714 if (cxix < cxstack_ix)
2715 dounwind(cxix);
2716
85538317
GS		 2717 /* clear off anything above the scope we're re-entering, but
2718 * save the rest until after a possible continue block */
2719 inner = PL_scopestack_ix;
1ba6ee2b 2720 TOPBLOCK(cx);
85538317
GS		 2721 if (PL_scopestack_ix < inner)
2722 leave_scope(PL_scopestack[PL_scopestack_ix]);
3a1b2b9e 2723 PL_curcop = cx->blk_oldcop;
d57ce4df 2724 return (cx)->blk_loop.my_op->op_nextop;
a0d0e21e
LW		 2725}
2726
2727PP(pp_redo)
2728{
27da23d5 2729 dVAR;
a0d0e21e 2730 I32 cxix;
c09156bb 2731 register PERL_CONTEXT *cx;
a0d0e21e 2732 I32 oldsave;
a034e688 2733 OP* redo_op;
a0d0e21e 2734
533c011a 2735 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2736 cxix = dopoptoloop(cxstack_ix);
2737 if (cxix < 0)
a651a37d 2738 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 2739 }
2740 else {
5db1eb8d
BF		 2741 cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
2742 (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
2743 if (cxix < 0)
2744 DIE(aTHX_ "Label not found for \"redo %"SVf"\"",
2745 SVfARG(newSVpvn_flags(cPVOP->op_pv,
2746 strlen(cPVOP->op_pv),
2747 ((cPVOP->op_private & OPpPV_IS_UTF8)
2748 ? SVf_UTF8 : 0) | SVs_TEMP)));
a0d0e21e
LW		 2749 }
2750 if (cxix < cxstack_ix)
2751 dounwind(cxix);
2752
022eaa24 2753 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
a034e688
DM		 2754 if (redo_op->op_type == OP_ENTER) {
2755 /* pop one less context to avoid $x being freed in while (my $x..) */
2756 cxstack_ix++;
2757 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2758 redo_op = redo_op->op_next;
2759 }
2760
a0d0e21e 2761 TOPBLOCK(cx);
3280af22 2762 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2763 LEAVE_SCOPE(oldsave);
936c78b5 2764 FREETMPS;
3a1b2b9e 2765 PL_curcop = cx->blk_oldcop;
a034e688 2766 return redo_op;
a0d0e21e
LW		 2767}
2768
0824fdcb 2769STATIC OP *
5db1eb8d 2770S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
a0d0e21e 2771{
97aff369 2772 dVAR;
a0d0e21e 2773 OP **ops = opstack;
bfed75c6 2774 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2775
7918f24d
NC		 2776 PERL_ARGS_ASSERT_DOFINDLABEL;
2777
fc36a67e 2778 if (ops >= oplimit)
cea2e8a9 2779 Perl_croak(aTHX_ too_deep);
11343788
MB		 2780 if (o->op_type == OP_LEAVE ||
2781 o->op_type == OP_SCOPE ||
2782 o->op_type == OP_LEAVELOOP ||
33d34e4c 2783 o->op_type == OP_LEAVESUB ||
11343788 2784 o->op_type == OP_LEAVETRY)
fc36a67e 2785 {
5dc0d613 2786 *ops++ = cUNOPo->op_first;
fc36a67e 2787 if (ops >= oplimit)
cea2e8a9 2788 Perl_croak(aTHX_ too_deep);
fc36a67e 2789 }
c4aa4e48 2790 *ops = 0;
11343788 2791 if (o->op_flags & OPf_KIDS) {
aec46f14 2792 OP *kid;
a0d0e21e 2793 /* First try all the kids at this level, since that's likeliest. */
11343788 2794 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
7e8f1eac 2795 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5db1eb8d
BF		 2796 STRLEN kid_label_len;
2797 U32 kid_label_flags;
2798 const char *kid_label = CopLABEL_len_flags(kCOP,
2799 &kid_label_len, &kid_label_flags);
2800 if (kid_label && (
2801 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2802 (flags & SVf_UTF8)
2803 ? (bytes_cmp_utf8(
2804 (const U8*)kid_label, kid_label_len,
2805 (const U8*)label, len) == 0)
2806 : (bytes_cmp_utf8(
2807 (const U8*)label, len,
2808 (const U8*)kid_label, kid_label_len) == 0)
2809 : ((kid_label == label)
2810 || memEQ(kid_label, label, len))))
7e8f1eac
AD		 2811 return kid;
2812 }
a0d0e21e 2813 }
11343788 2814 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2815 if (kid == PL_lastgotoprobe)
a0d0e21e 2816 continue;
ed8d0fe2
SM		 2817 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2818 if (ops == opstack)
2819 *ops++ = kid;
2820 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2821 ops[-1]->op_type == OP_DBSTATE)
2822 ops[-1] = kid;
2823 else
2824 *ops++ = kid;
2825 }
5db1eb8d 2826 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
11343788 2827 return o;
a0d0e21e
LW		 2828 }
2829 }
c4aa4e48 2830 *ops = 0;
a0d0e21e
LW		 2831 return 0;
2832}
2833
a0d0e21e
LW		 2834PP(pp_goto)
2835{
27da23d5 2836 dVAR; dSP;
cbbf8932 2837 OP *retop = NULL;
a0d0e21e 2838 I32 ix;
c09156bb 2839 register PERL_CONTEXT *cx;
fc36a67e
PP		 2840#define GOTO_DEPTH 64
2841 OP *enterops[GOTO_DEPTH];
cbbf8932 2842 const char *label = NULL;
5db1eb8d
BF		 2843 STRLEN label_len = 0;
2844 U32 label_flags = 0;
bfed75c6
AL		 2845 const bool do_dump = (PL_op->op_type == OP_DUMP);
2846 static const char must_have_label[] = "goto must have label";
a0d0e21e 2847
533c011a 2848 if (PL_op->op_flags & OPf_STACKED) {
9d4ba2ae 2849 SV * const sv = POPs;
a0d0e21e
LW		 2850
2851 /* This egregious kludge implements goto &subroutine */
2852 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2853 I32 cxix;
c09156bb 2854 register PERL_CONTEXT *cx;
ea726b52 2855 CV *cv = MUTABLE_CV(SvRV(sv));
a0d0e21e
LW		 2856 SV** mark;
2857 I32 items = 0;
2858 I32 oldsave;
b1464ded 2859 bool reified = 0;
a0d0e21e 2860
e8f7dd13 2861 retry:
4aa0a1f7 2862 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2863 const GV * const gv = CvGV(cv);
e8f7dd13 2864 if (gv) {
7fc63493 2865 GV *autogv;
e8f7dd13
GS		 2866 SV *tmpstr;
2867 /* autoloaded stub? */
2868 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2869 goto retry;
c271df94
BF		 2870 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2871 GvNAMELEN(gv),
2872 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
e8f7dd13
GS		 2873 if (autogv && (cv = GvCV(autogv)))
2874 goto retry;
2875 tmpstr = sv_newmortal();
c445ea15 2876 gv_efullname3(tmpstr, gv, NULL);
be2597df 2877 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
4aa0a1f7 2878 }
cea2e8a9 2879 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2880 }
2881
a0d0e21e 2882 /* First do some returnish stuff. */
b37c2d43 2883 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
71fc2216 2884 FREETMPS;
a0d0e21e
LW		 2885 cxix = dopoptosub(cxstack_ix);
2886 if (cxix < 0)
cea2e8a9 2887 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2888 if (cxix < cxstack_ix)
2889 dounwind(cxix);
2890 TOPBLOCK(cx);
2d43a17f 2891 SPAGAIN;
564abe23 2892 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2d43a17f 2893 if (CxTYPE(cx) == CXt_EVAL) {
c74ace89 2894 if (CxREALEVAL(cx))
00455a92 2895 /* diag_listed_as: Can't goto subroutine from an eval-%s */
c74ace89
DM		 2896 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2897 else
00455a92 2898 /* diag_listed_as: Can't goto subroutine from an eval-%s */
c74ace89 2899 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2d43a17f 2900 }
9850bf21
RH		 2901 else if (CxMULTICALL(cx))
2902 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
bafb2adc 2903 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
d8b46c1b 2904 /* put @_ back onto stack */
a0d0e21e 2905 AV* av = cx->blk_sub.argarray;
bfed75c6 2906
93965878 2907 items = AvFILLp(av) + 1;
a45cdc79
DM		 2908 EXTEND(SP, items+1); /* @_ could have been extended. */
2909 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS		 2910 SvREFCNT_dec(GvAV(PL_defgv));
2911 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2912 CLEAR_ARGARRAY(av);
d8b46c1b 2913 /* abandon @_ if it got reified */
62b1ebc2 2914 if (AvREAL(av)) {
b1464ded
DM		 2915 reified = 1;
2916 SvREFCNT_dec(av);
d8b46c1b
GS		 2917 av = newAV();
2918 av_extend(av, items-1);
11ca45c0 2919 AvREIFY_only(av);
ad64d0ec 2920 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
62b1ebc2 2921 }
a0d0e21e 2922 }
aed2304a 2923 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
890ce7af 2924 AV* const av = GvAV(PL_defgv);
1fa4e549 2925 items = AvFILLp(av) + 1;
a45cdc79
DM		 2926 EXTEND(SP, items+1); /* @_ could have been extended. */
2927 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2928 }
a45cdc79
DM		 2929 mark = SP;
2930 SP += items;
6b35e009 2931 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2932 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2933 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2934 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2935 LEAVE_SCOPE(oldsave);
2936
1d59c038
FC		 2937 /* A destructor called during LEAVE_SCOPE could have undefined
2938 * our precious cv. See bug #99850. */
2939 if (!CvROOT(cv) && !CvXSUB(cv)) {
2940 const GV * const gv = CvGV(cv);
2941 if (gv) {
2942 SV * const tmpstr = sv_newmortal();
2943 gv_efullname3(tmpstr, gv, NULL);
2944 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2945 SVfARG(tmpstr));
2946 }
2947 DIE(aTHX_ "Goto undefined subroutine");
2948 }
2949
a0d0e21e
LW		 2950 /* Now do some callish stuff. */
2951 SAVETMPS;
5023d17a 2952 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
aed2304a 2953 if (CvISXSUB(cv)) {
b37c2d43 2954 OP* const retop = cx->blk_sub.retop;
9d63fa07
KW		 2955 SV **newsp PERL_UNUSED_DECL;
2956 I32 gimme PERL_UNUSED_DECL;
b1464ded
DM		 2957 if (reified) {
2958 I32 index;
2959 for (index=0; index<items; index++)
2960 sv_2mortal(SP[-index]);
2961 }
1fa4e549 2962
b37c2d43
AL		 2963 /* XS subs don't have a CxSUB, so pop it */
2964 POPBLOCK(cx, PL_curpm);
2965 /* Push a mark for the start of arglist */
2966 PUSHMARK(mark);
2967 PUTBACK;
2968 (void)(*CvXSUB(cv))(aTHX_ cv);
a57c6685 2969 LEAVE;
5eff7df7 2970 return retop;
a0d0e21e
LW		 2971 }
2972 else {
b37c2d43 2973 AV* const padlist = CvPADLIST(cv);
6b35e009 2974 if (CxTYPE(cx) == CXt_EVAL) {
85a64632 2975 PL_in_eval = CxOLD_IN_EVAL(cx);
3280af22 2976 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22 2977 cx->cx_type = CXt_SUB;
b150fb22 2978 }
a0d0e21e 2979 cx->blk_sub.cv = cv;
1a5b3db4 2980 cx->blk_sub.olddepth = CvDEPTH(cv);
dd2155a4 2981
a0d0e21e
LW		 2982 CvDEPTH(cv)++;
2983 if (CvDEPTH(cv) < 2)
74c765eb 2984 SvREFCNT_inc_simple_void_NN(cv);
dd2155a4 2985 else {
2b9dff67 2986 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
44a8e56a 2987 sub_crush_depth(cv);
26019298 2988 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2989 }
426a09cd 2990 PL_curcop = cx->blk_oldcop;
fd617465
DM		 2991 SAVECOMPPAD();
2992 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
bafb2adc 2993 if (CxHASARGS(cx))
6d4ff0d2 2994 {
502c6561 2995 AV *const av = MUTABLE_AV(PAD_SVl(0));
a0d0e21e 2996
3280af22 2997 cx->blk_sub.savearray = GvAV(PL_defgv);
502c6561 2998 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
dd2155a4 2999 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 3000 cx->blk_sub.argarray = av;
a0d0e21e
LW		 3001
3002 if (items >= AvMAX(av) + 1) {
b37c2d43 3003 SV **ary = AvALLOC(av);
a0d0e21e
LW		 3004 if (AvARRAY(av) != ary) {
3005 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 3006 AvARRAY(av) = ary;
a0d0e21e
LW		 3007 }
3008 if (items >= AvMAX(av) + 1) {
3009 AvMAX(av) = items - 1;
3010 Renew(ary,items+1,SV*);
3011 AvALLOC(av) = ary;
9c6bc640 3012 AvARRAY(av) = ary;
a0d0e21e
LW		 3013 }
3014 }
a45cdc79 3015 ++mark;
a0d0e21e 3016 Copy(mark,AvARRAY(av),items,SV*);
93965878 3017 AvFILLp(av) = items - 1;
d8b46c1b 3018 assert(!AvREAL(av));
b1464ded
DM		 3019 if (reified) {
3020 /* transfer 'ownership' of refcnts to new @_ */
3021 AvREAL_on(av);
3022 AvREIFY_off(av);
3023 }
a0d0e21e
LW		 3024 while (items--) {
3025 if (*mark)
3026 SvTEMP_off(*mark);
3027 mark++;
3028 }
3029 }
491527d0 3030 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
005a8a35 3031 Perl_get_db_sub(aTHX_ NULL, cv);
b37c2d43 3032 if (PERLDB_GOTO) {
b96d8cd9 3033 CV * const gotocv = get_cvs("DB::goto", 0);
b37c2d43
AL		 3034 if (gotocv) {
3035 PUSHMARK( PL_stack_sp );
ad64d0ec 3036 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
b37c2d43
AL		 3037 PL_stack_sp--;
3038 }
491527d0 3039 }
1ce6579f 3040 }
a0d0e21e
LW		 3041 RETURNOP(CvSTART(cv));
3042 }
3043 }
1614b0e3 3044 else {
5db1eb8d
BF		 3045 label = SvPV_const(sv, label_len);
3046 label_flags = SvUTF8(sv);
1614b0e3 3047 if (!(do_dump || *label))
cea2e8a9 3048 DIE(aTHX_ must_have_label);
1614b0e3 3049 }
a0d0e21e 3050 }
533c011a 3051 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 3052 if (! do_dump)
cea2e8a9 3053 DIE(aTHX_ must_have_label);
a0d0e21e 3054 }
5db1eb8d
BF		 3055 else {
3056 label = cPVOP->op_pv;
3057 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3058 label_len = strlen(label);
3059 }
a0d0e21e 3060
f410a211
NC		 3061 PERL_ASYNC_CHECK();
3062
a0d0e21e 3063 if (label && *label) {
cbbf8932 3064 OP *gotoprobe = NULL;
3b2447bc 3065 bool leaving_eval = FALSE;
33d34e4c 3066 bool in_block = FALSE;
cbbf8932 3067 PERL_CONTEXT *last_eval_cx = NULL;
a0d0e21e
LW		 3068
3069 /* find label */
3070
d4c19fe8 3071 PL_lastgotoprobe = NULL;
a0d0e21e
LW		 3072 *enterops = 0;
3073 for (ix = cxstack_ix; ix >= 0; ix--) {
3074 cx = &cxstack[ix];
6b35e009 3075 switch (CxTYPE(cx)) {
a0d0e21e 3076 case CXt_EVAL:
3b2447bc 3077 leaving_eval = TRUE;
971ecbe6 3078 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH		 3079 gotoprobe = (last_eval_cx ?
3080 last_eval_cx->blk_eval.old_eval_root :
3081 PL_eval_root);
3082 last_eval_cx = cx;
9c5794fe
RH		 3083 break;
3084 }
3085 /* else fall through */
c6fdafd0 3086 case CXt_LOOP_LAZYIV:
d01136d6 3087 case CXt_LOOP_LAZYSV:
3b719c58
NC		 3088 case CXt_LOOP_FOR:
3089 case CXt_LOOP_PLAIN:
bb5aedc1
VP		 3090 case CXt_GIVEN:
3091 case CXt_WHEN:
a0d0e21e
LW		 3092 gotoprobe = cx->blk_oldcop->op_sibling;
3093 break;
3094 case CXt_SUBST:
3095 continue;
3096 case CXt_BLOCK:
33d34e4c 3097 if (ix) {
a0d0e21e 3098 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE		 3099 in_block = TRUE;
3100 } else
3280af22 3101 gotoprobe = PL_main_root;
a0d0e21e 3102 break;
b3933176 3103 case CXt_SUB:
9850bf21 3104 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
b3933176
CS		 3105 gotoprobe = CvROOT(cx->blk_sub.cv);
3106 break;
3107 }
3108 /* FALL THROUGH */
7766f137 3109 case CXt_FORMAT:
0a753a76 3110 case CXt_NULL:
a651a37d 3111 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 3112 default:
3113 if (ix)
5637ef5b
NC		 3114 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3115 CxTYPE(cx), (long) ix);
3280af22 3116 gotoprobe = PL_main_root;
a0d0e21e
LW		 3117 break;
3118 }
2b597662 3119 if (gotoprobe) {
5db1eb8d 3120 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
2b597662
GS		 3121 enterops, enterops + GOTO_DEPTH);
3122 if (retop)
3123 break;
eae48c89
Z		 3124 if (gotoprobe->op_sibling &&
3125 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3126 gotoprobe->op_sibling->op_sibling) {
3127 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
5db1eb8d
BF		 3128 label, label_len, label_flags, enterops,
3129 enterops + GOTO_DEPTH);
eae48c89
Z		 3130 if (retop)
3131 break;
3132 }
2b597662 3133 }
3280af22 3134 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 3135 }
3136 if (!retop)
5db1eb8d
BF		 3137 DIE(aTHX_ "Can't find label %"SVf,
3138 SVfARG(newSVpvn_flags(label, label_len,
3139 SVs_TEMP | label_flags)));
a0d0e21e 3140
3b2447bc
RH		 3141 /* if we're leaving an eval, check before we pop any frames
3142 that we're not going to punt, otherwise the error
3143 won't be caught */
3144
3145 if (leaving_eval && *enterops && enterops[1]) {
3146 I32 i;
3147 for (i = 1; enterops[i]; i++)
3148 if (enterops[i]->op_type == OP_ENTERITER)
3149 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3150 }
3151
b500e03b
GG		 3152 if (*enterops && enterops[1]) {
3153 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3154 if (enterops[i])
3155 deprecate("\"goto\" to jump into a construct");
3156 }
3157
a0d0e21e
LW		 3158 /* pop unwanted frames */
3159
3160 if (ix < cxstack_ix) {
3161 I32 oldsave;
3162
3163 if (ix < 0)
3164 ix = 0;
3165 dounwind(ix);
3166 TOPBLOCK(cx);
3280af22 3167 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 3168 LEAVE_SCOPE(oldsave);
3169 }
3170
3171 /* push wanted frames */
3172
748a9306 3173 if (*enterops && enterops[1]) {
0bd48802 3174 OP * const oldop = PL_op;
33d34e4c
AE		 3175 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3176 for (; enterops[ix]; ix++) {
533c011a 3177 PL_op = enterops[ix];
84902520
TB		 3178 /* Eventually we may want to stack the needed arguments
3179 * for each op. For now, we punt on the hard ones. */
533c011a 3180 if (PL_op->op_type == OP_ENTERITER)
894356b3 3181 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
16c91539 3182 PL_op->op_ppaddr(aTHX);
a0d0e21e 3183 }
533c011a 3184 PL_op = oldop;
a0d0e21e
LW		 3185 }
3186 }
3187
3188 if (do_dump) {
a5f75d66 3189#ifdef VMS
6b88bc9c 3190 if (!retop) retop = PL_main_start;
a5f75d66 3191#endif
3280af22
NIS		 3192 PL_restartop = retop;
3193 PL_do_undump = TRUE;
a0d0e21e
LW		 3194
3195 my_unexec();
3196
3280af22
NIS		 3197 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3198 PL_do_undump = FALSE;
a0d0e21e
LW		 3199 }
3200
3201 RETURNOP(retop);
3202}
3203
3204PP(pp_exit)
3205{
97aff369 3206 dVAR;
39644a26 3207 dSP;
a0d0e21e
LW		 3208 I32 anum;
3209
3210 if (MAXARG < 1)
3211 anum = 0;
9d3c658e
FC		 3212 else if (!TOPs) {
3213 anum = 0; (void)POPs;
3214 }
ff0cee69 3215 else {
a0d0e21e 3216 anum = SvIVx(POPs);
d98f61e7
GS		 3217#ifdef VMS
3218 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 3219 anum = 0;
96e176bf 3220 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69
PP		 3221#endif
3222 }
cc3604b1 3223 PL_exit_flags |= PERL_EXIT_EXPECTED;
81d86705
NC		 3224#ifdef PERL_MAD
3225 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3226 if (anum || !(PL_minus_c && PL_madskills))
3227 my_exit(anum);
3228#else
a0d0e21e 3229 my_exit(anum);
81d86705 3230#endif
3280af22 3231 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 3232 RETURN;
3233}
3234
a0d0e21e
LW		 3235/* Eval. */
3236
0824fdcb 3237STATIC void
cea2e8a9 3238S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 3239{
504618e9 3240 const char *s = SvPVX_const(sv);
890ce7af 3241 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 3242 I32 line = 1;
a0d0e21e 3243
7918f24d
NC		 3244 PERL_ARGS_ASSERT_SAVE_LINES;
3245
a0d0e21e 3246 while (s && s < send) {
f54cb97a 3247 const char *t;
b9f83d2f 3248 SV * const tmpstr = newSV_type(SVt_PVMG);
a0d0e21e 3249
1d963ff3 3250 t = (const char *)memchr(s, '\n', send - s);
a0d0e21e
LW		 3251 if (t)
3252 t++;
3253 else
3254 t = send;
3255
3256 sv_setpvn(tmpstr, s, t - s);
3257 av_store(array, line++, tmpstr);
3258 s = t;
3259 }
3260}
3261
22f16304
RU		 3262/*
3263=for apidoc docatch
3264
3265Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3266
32670 is used as continue inside eval,
3268
32693 is used for a die caught by an inner eval - continue inner loop
3270
3271See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3272establish a local jmpenv to handle exception traps.
3273
3274=cut
3275*/
0824fdcb 3276STATIC OP *
cea2e8a9 3277S_docatch(pTHX_ OP *o)
1e422769 3278{
97aff369 3279 dVAR;
6224f72b 3280 int ret;
06b5626a 3281 OP * const oldop = PL_op;
db36c5a1 3282 dJMPENV;
1e422769 3283
1e422769 3284#ifdef DEBUGGING
54310121 3285 assert(CATCH_GET == TRUE);
1e422769 3286#endif
312caa8e 3287 PL_op = o;
8bffa5f8 3288
14dd3ad8 3289 JMPENV_PUSH(ret);
6224f72b 3290 switch (ret) {
312caa8e 3291 case 0:
abd70938
DM		 3292 assert(cxstack_ix >= 0);
3293 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3294 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8 3295 redo_body:
85aaa934 3296 CALLRUNOPS(aTHX);
312caa8e
CS		 3297 break;
3298 case 3:
8bffa5f8 3299 /* die caught by an inner eval - continue inner loop */
febb3a6d
Z		 3300 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3301 PL_restartjmpenv = NULL;
312caa8e
CS		 3302 PL_op = PL_restartop;
3303 PL_restartop = 0;
3304 goto redo_body;
3305 }
3306 /* FALL THROUGH */
3307 default:
14dd3ad8 3308 JMPENV_POP;
533c011a 3309 PL_op = oldop;
6224f72b 3310 JMPENV_JUMP(ret);
1e422769 3311 /* NOTREACHED */
1e422769 3312 }
14dd3ad8 3313 JMPENV_POP;
533c011a 3314 PL_op = oldop;
5f66b61c 3315 return NULL;
1e422769
PP		 3316}
3317
ee23ad3b
NC		 3318/* James Bond: Do you expect me to talk?
3319 Auric Goldfinger: No, Mr. Bond. I expect you to die.
3320
3321 This code is an ugly hack, doesn't work with lexicals in subroutines that are
3322 called more than once, and is only used by regcomp.c, for (?{}) blocks.
3323
3324 Currently it is not used outside the core code. Best if it stays that way.
d59a8b3e
NC		 3325
3326 Hence it's now deprecated, and will be removed.
ee23ad3b 3327*/
c277df42 3328OP *
bfed75c6 3329Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ		 3330/* sv Text to convert to OP tree. */
3331/* startop op_free() this to undo. */
3332/* code Short string id of the caller. */
3333{
d59a8b3e
NC		 3334 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3335 return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3336}
3337
3338/* Don't use this. It will go away without warning once the regexp engine is
3339 refactored not to use it. */
3340OP *
3341Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3342 PAD **padp)
3343{
27da23d5 3344 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ		 3345 PERL_CONTEXT *cx;
3346 SV **newsp;
b094c71d 3347 I32 gimme = G_VOID;
c277df42
IZ		 3348 I32 optype;
3349 OP dummy;
83ee9e09
GS		 3350 char tbuf[TYPE_DIGITS(long) + 12 + 10];
3351 char *tmpbuf = tbuf;
c277df42 3352 char *safestr;
a3985cdc 3353 int runtime;
601f1833 3354 CV* runcv = NULL; /* initialise to avoid compiler warnings */
f7997f86 3355 STRLEN len;
634d6919 3356 bool need_catch;
c277df42 3357
d59a8b3e 3358 PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
7918f24d 3359
d343c3ef 3360 ENTER_with_name("eval");
27fcb6ee 3361 lex_start(sv, NULL, LEX_START_SAME_FILTER);
c277df42
IZ		 3362 SAVETMPS;
3363 /* switch to eval mode */
3364
923e4eb5 3365 if (IN_PERL_COMPILETIME) {
f4dd75d9 3366 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 3367 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 3368 }
83ee9e09 3369 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
9d4ba2ae 3370 SV * const sv = sv_newmortal();
83ee9e09
GS		 3371 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3372 code, (unsigned long)++PL_evalseq,
3373 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3374 tmpbuf = SvPVX(sv);
fc009855 3375 len = SvCUR(sv);
83ee9e09
GS		 3376 }
3377 else
d9fad198
JH		 3378 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3379 (unsigned long)++PL_evalseq);
f4dd75d9 3380 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3381 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3382 SAVECOPLINE(&PL_compiling);
57843af0 3383 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 3384 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3385 deleting the eval's FILEGV from the stash before gv_check() runs
3386 (i.e. before run-time proper). To work around the coredump that
3387 ensues, we always turn GvMULTI_on for any globals that were
3388 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC		 3389 safestr = savepvn(tmpbuf, len);
3390 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 3391 SAVEHINTS();
d1ca3daa 3392#ifdef OP_IN_REGISTER
6b88bc9c 3393 PL_opsave = op;
d1ca3daa 3394#else
7766f137 3395 SAVEVPTR(PL_op);
d1ca3daa 3396#endif
c277df42 3397
a3985cdc 3398 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 3399 runtime = IN_PERL_RUNTIME;
a3985cdc 3400 if (runtime)
558b4424 3401 {
d819b83a 3402 runcv = find_runcv(NULL);
a3985cdc 3403
558b4424
FC		 3404 /* At run time, we have to fetch the hints from PL_curcop. */
3405 PL_hints = PL_curcop->cop_hints;
3406 if (PL_hints & HINT_LOCALIZE_HH) {
3407 /* SAVEHINTS created a new HV in PL_hintgv, which we
3408 need to GC */
3409 SvREFCNT_dec(GvHV(PL_hintgv));
3410 GvHV(PL_hintgv) =
3411 refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3412 hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3413 }
3414 SAVECOMPILEWARNINGS();
3415 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3416 cophh_free(CopHINTHASH_get(&PL_compiling));
3417 /* XXX Does this need to avoid copying a label? */
3418 PL_compiling.cop_hints_hash
3419 = cophh_copy(PL_curcop->cop_hints_hash);
3420 }
3421
533c011a 3422 PL_op = &dummy;
13b51b79 3423 PL_op->op_type = OP_ENTEREVAL;
533c011a 3424 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 3425 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
6b75f042 3426 PUSHEVAL(cx, 0);
634d6919
GG		 3427 need_catch = CATCH_GET;
3428 CATCH_SET(TRUE);
a3985cdc
DM		 3429
3430 if (runtime)
f45b078d 3431 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
a3985cdc 3432 else
f45b078d 3433 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
634d6919 3434 CATCH_SET(need_catch);
13b51b79 3435 POPBLOCK(cx,PL_curpm);
e84b9f1f 3436 POPEVAL(cx);
c277df42
IZ		 3437
3438 (*startop)->op_type = OP_NULL;
22c35a8c 3439 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
f3548bdc 3440 /* XXX DAPM do this properly one year */
502c6561 3441 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));