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