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