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