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