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