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