This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_ctl.c:pp_goto: Don’t repeat yourself
[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)
eade7155
BF
1427 : (len == cx_label_len && ((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)
eade7155
BF
2809 : ( len == kid_label_len && ((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 }
a0d0e21e 3048 }
2fc690dc 3049 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
5db1eb8d
BF
3050 label = cPVOP->op_pv;
3051 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3052 label_len = strlen(label);
3053 }
2fc690dc 3054 if (!(do_dump || label_len)) DIE(aTHX_ must_have_label);
a0d0e21e 3055
f410a211
NC
3056 PERL_ASYNC_CHECK();
3057
3532f34a 3058 if (label_len) {
cbbf8932 3059 OP *gotoprobe = NULL;
3b2447bc 3060 bool leaving_eval = FALSE;
33d34e4c 3061 bool in_block = FALSE;
cbbf8932 3062 PERL_CONTEXT *last_eval_cx = NULL;
a0d0e21e
LW
3063
3064 /* find label */
3065
d4c19fe8 3066 PL_lastgotoprobe = NULL;
a0d0e21e
LW
3067 *enterops = 0;
3068 for (ix = cxstack_ix; ix >= 0; ix--) {
3069 cx = &cxstack[ix];
6b35e009 3070 switch (CxTYPE(cx)) {
a0d0e21e 3071 case CXt_EVAL:
3b2447bc 3072 leaving_eval = TRUE;
971ecbe6 3073 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH
3074 gotoprobe = (last_eval_cx ?
3075 last_eval_cx->blk_eval.old_eval_root :
3076 PL_eval_root);
3077 last_eval_cx = cx;
9c5794fe
RH
3078 break;
3079 }
3080 /* else fall through */
c6fdafd0 3081 case CXt_LOOP_LAZYIV:
d01136d6 3082 case CXt_LOOP_LAZYSV:
3b719c58
NC
3083 case CXt_LOOP_FOR:
3084 case CXt_LOOP_PLAIN:
bb5aedc1
VP
3085 case CXt_GIVEN:
3086 case CXt_WHEN:
a0d0e21e
LW
3087 gotoprobe = cx->blk_oldcop->op_sibling;
3088 break;
3089 case CXt_SUBST:
3090 continue;
3091 case CXt_BLOCK:
33d34e4c 3092 if (ix) {
a0d0e21e 3093 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE
3094 in_block = TRUE;
3095 } else
3280af22 3096 gotoprobe = PL_main_root;
a0d0e21e 3097 break;
b3933176 3098 case CXt_SUB:
9850bf21 3099 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
b3933176
CS
3100 gotoprobe = CvROOT(cx->blk_sub.cv);
3101 break;
3102 }
3103 /* FALL THROUGH */
7766f137 3104 case CXt_FORMAT:
0a753a76 3105 case CXt_NULL:
a651a37d 3106 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW
3107 default:
3108 if (ix)
5637ef5b
NC
3109 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3110 CxTYPE(cx), (long) ix);
3280af22 3111 gotoprobe = PL_main_root;
a0d0e21e
LW
3112 break;
3113 }
2b597662 3114 if (gotoprobe) {
5db1eb8d 3115 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
2b597662
GS
3116 enterops, enterops + GOTO_DEPTH);
3117 if (retop)
3118 break;
eae48c89
Z
3119 if (gotoprobe->op_sibling &&
3120 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3121 gotoprobe->op_sibling->op_sibling) {
3122 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
5db1eb8d
BF
3123 label, label_len, label_flags, enterops,
3124 enterops + GOTO_DEPTH);
eae48c89
Z
3125 if (retop)
3126 break;
3127 }
2b597662 3128 }
3280af22 3129 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW
3130 }
3131 if (!retop)
5db1eb8d
BF
3132 DIE(aTHX_ "Can't find label %"SVf,
3133 SVfARG(newSVpvn_flags(label, label_len,
3134 SVs_TEMP | label_flags)));
a0d0e21e 3135
3b2447bc
RH
3136 /* if we're leaving an eval, check before we pop any frames
3137 that we're not going to punt, otherwise the error
3138 won't be caught */
3139
3140 if (leaving_eval && *enterops && enterops[1]) {
3141 I32 i;
3142 for (i = 1; enterops[i]; i++)
3143 if (enterops[i]->op_type == OP_ENTERITER)
3144 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3145 }
3146
b500e03b
GG
3147 if (*enterops && enterops[1]) {
3148 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3149 if (enterops[i])
3150 deprecate("\"goto\" to jump into a construct");
3151 }
3152
a0d0e21e
LW
3153 /* pop unwanted frames */
3154
3155 if (ix < cxstack_ix) {
3156 I32 oldsave;
3157
3158 if (ix < 0)
3159 ix = 0;
3160 dounwind(ix);
3161 TOPBLOCK(cx);
3280af22 3162 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW
3163 LEAVE_SCOPE(oldsave);
3164 }
3165
3166 /* push wanted frames */
3167
748a9306 3168 if (*enterops && enterops[1]) {
0bd48802 3169 OP * const oldop = PL_op;
33d34e4c
AE
3170 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3171 for (; enterops[ix]; ix++) {
533c011a 3172 PL_op = enterops[ix];
84902520
TB
3173 /* Eventually we may want to stack the needed arguments
3174 * for each op. For now, we punt on the hard ones. */
533c011a 3175 if (PL_op->op_type == OP_ENTERITER)
894356b3 3176 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
16c91539 3177 PL_op->op_ppaddr(aTHX);
a0d0e21e 3178 }
533c011a 3179 PL_op = oldop;
a0d0e21e
LW
3180 }
3181 }
3182
3183 if (do_dump) {
a5f75d66 3184#ifdef VMS
6b88bc9c 3185 if (!retop) retop = PL_main_start;
a5f75d66 3186#endif
3280af22
NIS
3187 PL_restartop = retop;
3188 PL_do_undump = TRUE;
a0d0e21e
LW
3189
3190 my_unexec();
3191
3280af22
NIS
3192 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3193 PL_do_undump = FALSE;
a0d0e21e
LW
3194 }
3195
3196 RETURNOP(retop);
3197}
3198
3199PP(pp_exit)
3200{
97aff369 3201 dVAR;
39644a26 3202 dSP;
a0d0e21e
LW
3203 I32 anum;
3204
3205 if (MAXARG < 1)
3206 anum = 0;
9d3c658e
FC
3207 else if (!TOPs) {
3208 anum = 0; (void)POPs;
3209 }
ff0cee69 3210 else {
a0d0e21e 3211 anum = SvIVx(POPs);
d98f61e7
GS
3212#ifdef VMS
3213 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 3214 anum = 0;
96e176bf 3215 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69
PP
3216#endif
3217 }
cc3604b1 3218 PL_exit_flags |= PERL_EXIT_EXPECTED;
81d86705
NC
3219#ifdef PERL_MAD
3220 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3221 if (anum || !(PL_minus_c && PL_madskills))
3222 my_exit(anum);
3223#else
a0d0e21e 3224 my_exit(anum);
81d86705 3225#endif
3280af22 3226 PUSHs(&PL_sv_undef);
a0d0e21e
LW
3227 RETURN;
3228}
3229
a0d0e21e
LW
3230/* Eval. */
3231
0824fdcb 3232STATIC void
cea2e8a9 3233S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 3234{
504618e9 3235 const char *s = SvPVX_const(sv);
890ce7af 3236 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 3237 I32 line = 1;
a0d0e21e 3238
7918f24d
NC
3239 PERL_ARGS_ASSERT_SAVE_LINES;
3240
a0d0e21e 3241 while (s && s < send) {
f54cb97a 3242 const char *t;
b9f83d2f 3243 SV * const tmpstr = newSV_type(SVt_PVMG);
a0d0e21e 3244
1d963ff3 3245 t = (const char *)memchr(s, '\n', send - s);
a0d0e21e
LW
3246 if (t)
3247 t++;
3248 else
3249 t = send;
3250
3251 sv_setpvn(tmpstr, s, t - s);
3252 av_store(array, line++, tmpstr);
3253 s = t;
3254 }
3255}
3256
22f16304
RU
3257/*
3258=for apidoc docatch
3259
3260Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3261
32620 is used as continue inside eval,
3263
32643 is used for a die caught by an inner eval - continue inner loop
3265
3266See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3267establish a local jmpenv to handle exception traps.
3268
3269=cut
3270*/
0824fdcb 3271STATIC OP *
cea2e8a9 3272S_docatch(pTHX_ OP *o)
1e422769 3273{
97aff369 3274 dVAR;
6224f72b 3275 int ret;
06b5626a 3276 OP * const oldop = PL_op;
db36c5a1 3277 dJMPENV;
1e422769 3278
1e422769 3279#ifdef DEBUGGING
54310121 3280 assert(CATCH_GET == TRUE);
1e422769 3281#endif
312caa8e 3282 PL_op = o;
8bffa5f8 3283
14dd3ad8 3284 JMPENV_PUSH(ret);
6224f72b 3285 switch (ret) {
312caa8e 3286 case 0:
abd70938
DM
3287 assert(cxstack_ix >= 0);
3288 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3289 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8 3290 redo_body:
85aaa934 3291 CALLRUNOPS(aTHX);
312caa8e
CS
3292 break;
3293 case 3:
8bffa5f8 3294 /* die caught by an inner eval - continue inner loop */
febb3a6d
Z
3295 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3296 PL_restartjmpenv = NULL;
312caa8e
CS
3297 PL_op = PL_restartop;
3298 PL_restartop = 0;
3299 goto redo_body;
3300 }
3301 /* FALL THROUGH */
3302 default:
14dd3ad8 3303 JMPENV_POP;
533c011a 3304 PL_op = oldop;
6224f72b 3305 JMPENV_JUMP(ret);
1e422769 3306 /* NOTREACHED */
1e422769 3307 }
14dd3ad8 3308 JMPENV_POP;
533c011a 3309 PL_op = oldop;
5f66b61c 3310 return NULL;
1e422769
PP
3311}
3312
ee23ad3b
NC
3313/* James Bond: Do you expect me to talk?
3314 Auric Goldfinger: No, Mr. Bond. I expect you to die.
3315
3316 This code is an ugly hack, doesn't work with lexicals in subroutines that are
3317 called more than once, and is only used by regcomp.c, for (?{}) blocks.
3318
3319 Currently it is not used outside the core code. Best if it stays that way.
d59a8b3e
NC
3320
3321 Hence it's now deprecated, and will be removed.
ee23ad3b 3322*/
c277df42 3323OP *
bfed75c6 3324Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ
3325/* sv Text to convert to OP tree. */
3326/* startop op_free() this to undo. */
3327/* code Short string id of the caller. */
3328{
d59a8b3e
NC
3329 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3330 return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3331}
3332
3333/* Don't use this. It will go away without warning once the regexp engine is
3334 refactored not to use it. */
3335OP *
3336Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3337 PAD **padp)
3338{
27da23d5 3339 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ
3340 PERL_CONTEXT *cx;
3341 SV **newsp;
b094c71d 3342 I32 gimme = G_VOID;
c277df42
IZ
3343 I32 optype;
3344 OP dummy;
83ee9e09
GS
3345 char tbuf[TYPE_DIGITS(long) + 12 + 10];
3346 char *tmpbuf = tbuf;
c277df42 3347 char *safestr;
a3985cdc 3348 int runtime;
601f1833 3349 CV* runcv = NULL; /* initialise to avoid compiler warnings */
f7997f86 3350 STRLEN len;
634d6919 3351 bool need_catch;
c277df42 3352
d59a8b3e 3353 PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
7918f24d 3354
d343c3ef 3355 ENTER_with_name("eval");
27fcb6ee 3356 lex_start(sv, NULL, LEX_START_SAME_FILTER);
c277df42
IZ
3357 SAVETMPS;
3358 /* switch to eval mode */
3359
923e4eb5 3360 if (IN_PERL_COMPILETIME) {
f4dd75d9 3361 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 3362 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 3363 }
83ee9e09 3364 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
9d4ba2ae 3365 SV * const sv = sv_newmortal();
83ee9e09
GS
3366 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3367 code, (unsigned long)++PL_evalseq,
3368 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3369 tmpbuf = SvPVX(sv);
fc009855 3370 len = SvCUR(sv);
83ee9e09
GS
3371 }
3372 else
d9fad198
JH
3373 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3374 (unsigned long)++PL_evalseq);
f4dd75d9 3375 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3376 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3377 SAVECOPLINE(&PL_compiling);
57843af0 3378 CopLINE_set(&PL_compiling, 1);
c277df42
IZ
3379 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3380 deleting the eval's FILEGV from the stash before gv_check() runs
3381 (i.e. before run-time proper). To work around the coredump that
3382 ensues, we always turn GvMULTI_on for any globals that were
3383 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC
3384 safestr = savepvn(tmpbuf, len);
3385 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 3386 SAVEHINTS();
d1ca3daa 3387#ifdef OP_IN_REGISTER
6b88bc9c 3388 PL_opsave = op;
d1ca3daa 3389#else
7766f137 3390 SAVEVPTR(PL_op);
d1ca3daa 3391#endif
c277df42 3392
a3985cdc 3393 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 3394 runtime = IN_PERL_RUNTIME;
a3985cdc 3395 if (runtime)
558b4424 3396 {
d819b83a 3397 runcv = find_runcv(NULL);
a3985cdc 3398
558b4424
FC
3399 /* At run time, we have to fetch the hints from PL_curcop. */
3400 PL_hints = PL_curcop->cop_hints;
3401 if (PL_hints & HINT_LOCALIZE_HH) {
3402 /* SAVEHINTS created a new HV in PL_hintgv, which we
3403 need to GC */
3404 SvREFCNT_dec(GvHV(PL_hintgv));
3405 GvHV(PL_hintgv) =
3406 refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3407 hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3408 }
3409 SAVECOMPILEWARNINGS();
3410 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3411 cophh_free(CopHINTHASH_get(&PL_compiling));
3412 /* XXX Does this need to avoid copying a label? */
3413 PL_compiling.cop_hints_hash
3414 = cophh_copy(PL_curcop->cop_hints_hash);
3415 }
3416
533c011a 3417 PL_op = &dummy;
13b51b79 3418 PL_op->op_type = OP_ENTEREVAL;
533c011a 3419 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 3420 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
6b75f042 3421 PUSHEVAL(cx, 0);
634d6919
GG
3422 need_catch = CATCH_GET;
3423 CATCH_SET(TRUE);
a3985cdc
DM
3424
3425 if (runtime)
f45b078d 3426 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
a3985cdc 3427 else
f45b078d 3428 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
634d6919 3429 CATCH_SET(need_catch);
13b51b79 3430 POPBLOCK(cx,PL_curpm);
e84b9f1f 3431 POPEVAL(cx);
c277df42
IZ
3432
3433 (*startop)->op_type = OP_NULL;
22c35a8c 3434 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
f3548bdc 3435 /* XXX DAPM do this properly one year */
502c6561 3436 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
d343c3ef 3437 LEAVE_with_name("eval");
923e4eb5 3438 if (IN_PERL_COMPILETIME)
623e6609 3439 CopHINTS_set(&PL_compiling, PL_hints);