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