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