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