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