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