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