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