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