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