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