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