This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[rt.cpan.org #56740] Format Perl versions >= 5.6.0 as X.Y.Z
[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);
bb4c52e0
GG
1667 PL_restartop = cx->blk_eval.retop;
1668 JMPENV_JUMP(3);
1669 /* NOTREACHED */
a0d0e21e
LW
1670 }
1671 }
87582a92 1672
7d0994e0 1673 write_to_stderr( msv ? msv : ERRSV );
f86702cc
PP
1674 my_failure_exit();
1675 /* NOTREACHED */
a0d0e21e
LW
1676}
1677
1678PP(pp_xor)
1679{
97aff369 1680 dVAR; dSP; dPOPTOPssrl;
a0d0e21e
LW
1681 if (SvTRUE(left) != SvTRUE(right))
1682 RETSETYES;
1683 else
1684 RETSETNO;
1685}
1686
a0d0e21e
LW
1687PP(pp_caller)
1688{
97aff369 1689 dVAR;
39644a26 1690 dSP;
a0d0e21e 1691 register I32 cxix = dopoptosub(cxstack_ix);
901017d6
AL
1692 register const PERL_CONTEXT *cx;
1693 register const PERL_CONTEXT *ccstack = cxstack;
1694 const PERL_SI *top_si = PL_curstackinfo;
54310121 1695 I32 gimme;
06b5626a 1696 const char *stashname;
a0d0e21e
LW
1697 I32 count = 0;
1698
1699 if (MAXARG)
1700 count = POPi;
27d41816 1701
a0d0e21e 1702 for (;;) {
2c375eb9
GS
1703 /* we may be in a higher stacklevel, so dig down deeper */
1704 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1705 top_si = top_si->si_prev;
1706 ccstack = top_si->si_cxstack;
1707 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1708 }
a0d0e21e 1709 if (cxix < 0) {
27d41816
DM
1710 if (GIMME != G_ARRAY) {
1711 EXTEND(SP, 1);
a0d0e21e 1712 RETPUSHUNDEF;
27d41816 1713 }
a0d0e21e
LW
1714 RETURN;
1715 }
f2a7f298 1716 /* caller() should not report the automatic calls to &DB::sub */
1717 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
3280af22 1718 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW
1719 count++;
1720 if (!count--)
1721 break;
2c375eb9 1722 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1723 }
2c375eb9
GS
1724
1725 cx = &ccstack[cxix];
7766f137 1726 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
f54cb97a 1727 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2c375eb9 1728 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1729 field below is defined for any cx. */
f2a7f298 1730 /* caller() should not report the automatic calls to &DB::sub */
1731 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1732 cx = &ccstack[dbcxix];
06a5b730
PP
1733 }
1734
ed094faf 1735 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1736 if (GIMME != G_ARRAY) {
27d41816 1737 EXTEND(SP, 1);
ed094faf 1738 if (!stashname)
3280af22 1739 PUSHs(&PL_sv_undef);
49d8d3a1
MB
1740 else {
1741 dTARGET;
ed094faf 1742 sv_setpv(TARG, stashname);
49d8d3a1
MB
1743 PUSHs(TARG);
1744 }
a0d0e21e
LW
1745 RETURN;
1746 }
a0d0e21e 1747
b3ca2e83 1748 EXTEND(SP, 11);
27d41816 1749
ed094faf 1750 if (!stashname)
3280af22 1751 PUSHs(&PL_sv_undef);
49d8d3a1 1752 else
6e449a3a
MHM
1753 mPUSHs(newSVpv(stashname, 0));
1754 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1755 mPUSHi((I32)CopLINE(cx->blk_oldcop));
a0d0e21e
LW
1756 if (!MAXARG)
1757 RETURN;
7766f137 1758 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
0bd48802 1759 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
7766f137 1760 /* So is ccstack[dbcxix]. */
07b8c804 1761 if (isGV(cvgv)) {
561b68a9 1762 SV * const sv = newSV(0);
c445ea15 1763 gv_efullname3(sv, cvgv, NULL);
6e449a3a 1764 mPUSHs(sv);
bf38a478 1765 PUSHs(boolSV(CxHASARGS(cx)));
07b8c804
RGS
1766 }
1767 else {
84bafc02 1768 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
bf38a478 1769 PUSHs(boolSV(CxHASARGS(cx)));
07b8c804 1770 }
a0d0e21e
LW
1771 }
1772 else {
84bafc02 1773 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
6e449a3a 1774 mPUSHi(0);
a0d0e21e 1775 }
54310121
PP
1776 gimme = (I32)cx->blk_gimme;
1777 if (gimme == G_VOID)
3280af22 1778 PUSHs(&PL_sv_undef);
54310121 1779 else
98625aca 1780 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
6b35e009 1781 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1782 /* eval STRING */
85a64632 1783 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
4633a7c4 1784 PUSHs(cx->blk_eval.cur_text);
3280af22 1785 PUSHs(&PL_sv_no);
0f79a09d 1786 }
811a4de9 1787 /* require */
0f79a09d 1788 else if (cx->blk_eval.old_namesv) {
6e449a3a 1789 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
3280af22 1790 PUSHs(&PL_sv_yes);
06a5b730 1791 }
811a4de9
GS
1792 /* eval BLOCK (try blocks have old_namesv == 0) */
1793 else {
1794 PUSHs(&PL_sv_undef);
1795 PUSHs(&PL_sv_undef);
1796 }
4633a7c4 1797 }
a682de96
GS
1798 else {
1799 PUSHs(&PL_sv_undef);
1800 PUSHs(&PL_sv_undef);
1801 }
bafb2adc 1802 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
ed094faf 1803 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1804 {
66a1b24b
AL
1805 AV * const ary = cx->blk_sub.argarray;
1806 const int off = AvARRAY(ary) - AvALLOC(ary);
a0d0e21e 1807
3280af22 1808 if (!PL_dbargs) {
af3885a0
NC
1809 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1810 SVt_PVAV)));
3ddcf04c 1811 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
a0d0e21e
LW
1812 }
1813
3280af22
NIS
1814 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1815 av_extend(PL_dbargs, AvFILLp(ary) + off);
1816 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1817 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1818 }
f3aa04c2
GS
1819 /* XXX only hints propagated via op_private are currently
1820 * visible (others are not easily accessible, since they
1821 * use the global PL_hints) */
6e449a3a 1822 mPUSHi(CopHINTS_get(cx->blk_oldcop));
e476b1b5
GS
1823 {
1824 SV * mask ;
72dc9ed5 1825 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba 1826
ac27b0f5 1827 if (old_warnings == pWARN_NONE ||
114bafba 1828 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1829 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
ac27b0f5 1830 else if (old_warnings == pWARN_ALL ||
75b6c4ca
RGS
1831 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1832 /* Get the bit mask for $warnings::Bits{all}, because
1833 * it could have been extended by warnings::register */
1834 SV **bits_all;
6673a63c 1835 HV * const bits = get_hv("warnings::Bits", 0);
017a3ce5 1836 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
75b6c4ca
RGS
1837 mask = newSVsv(*bits_all);
1838 }
1839 else {
1840 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1841 }
1842 }
e476b1b5 1843 else
72dc9ed5 1844 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
6e449a3a 1845 mPUSHs(mask);
e476b1b5 1846 }
b3ca2e83 1847
c28fe1ec 1848 PUSHs(cx->blk_oldcop->cop_hints_hash ?
b3ca2e83 1849 sv_2mortal(newRV_noinc(
ad64d0ec
NC
1850 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1851 cx->blk_oldcop->cop_hints_hash))))
b3ca2e83 1852 : &PL_sv_undef);
a0d0e21e
LW
1853 RETURN;
1854}
1855
a0d0e21e
LW
1856PP(pp_reset)
1857{
97aff369 1858 dVAR;
39644a26 1859 dSP;
10edeb5d 1860 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
11faa288 1861 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1862 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1863 RETURN;
1864}
1865
dd2155a4
DM
1866/* like pp_nextstate, but used instead when the debugger is active */
1867
a0d0e21e
LW
1868PP(pp_dbstate)
1869{
27da23d5 1870 dVAR;
533c011a 1871 PL_curcop = (COP*)PL_op;
a0d0e21e 1872 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1873 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW
1874 FREETMPS;
1875
f410a211
NC
1876 PERL_ASYNC_CHECK();
1877
5df8de69
DM
1878 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1879 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1880 {
39644a26 1881 dSP;
c09156bb 1882 register PERL_CONTEXT *cx;
f54cb97a 1883 const I32 gimme = G_ARRAY;
eb160463 1884 U8 hasargs;
0bd48802
AL
1885 GV * const gv = PL_DBgv;
1886 register CV * const cv = GvCV(gv);
a0d0e21e 1887
a0d0e21e 1888 if (!cv)
cea2e8a9 1889 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1890
aea4f609
DM
1891 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1892 /* don't do recursive DB::DB call */
a0d0e21e 1893 return NORMAL;
748a9306 1894
a57c6685 1895 ENTER;
4633a7c4
LW
1896 SAVETMPS;
1897
3280af22 1898 SAVEI32(PL_debug);
55497cff 1899 SAVESTACK_POS();
3280af22 1900 PL_debug = 0;
748a9306 1901 hasargs = 0;
924508f0 1902 SPAGAIN;
748a9306 1903
aed2304a 1904 if (CvISXSUB(cv)) {
c127bd3a
SF
1905 CvDEPTH(cv)++;
1906 PUSHMARK(SP);
1907 (void)(*CvXSUB(cv))(aTHX_ cv);
1908 CvDEPTH(cv)--;
1909 FREETMPS;
a57c6685 1910 LEAVE;
c127bd3a
SF
1911 return NORMAL;
1912 }
1913 else {
1914 PUSHBLOCK(cx, CXt_SUB, SP);
1915 PUSHSUB_DB(cx);
1916 cx->blk_sub.retop = PL_op->op_next;
1917 CvDEPTH(cv)++;
1918 SAVECOMPPAD();
1919 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1920 RETURNOP(CvSTART(cv));
1921 }
a0d0e21e
LW
1922 }
1923 else
1924 return NORMAL;
1925}
1926
a0d0e21e
LW
1927PP(pp_enteriter)
1928{
27da23d5 1929 dVAR; dSP; dMARK;
c09156bb 1930 register PERL_CONTEXT *cx;
f54cb97a 1931 const I32 gimme = GIMME_V;
a0d0e21e 1932 SV **svp;
840fe433 1933 U8 cxtype = CXt_LOOP_FOR;
7766f137 1934#ifdef USE_ITHREADS
e846cb92 1935 PAD *iterdata;
7766f137 1936#endif
a0d0e21e 1937
d343c3ef 1938 ENTER_with_name("loop1");
4633a7c4
LW
1939 SAVETMPS;
1940
533c011a 1941 if (PL_op->op_targ) {
14f338dc
DM
1942 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1943 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1944 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1945 SVs_PADSTALE, SVs_PADSTALE);
1946 }
09edbca0 1947 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
c3564e5c 1948#ifndef USE_ITHREADS
dd2155a4 1949 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
c3564e5c 1950#else
e846cb92 1951 iterdata = NULL;
7766f137 1952#endif
54b9620d
MB
1953 }
1954 else {
159b6efe 1955 GV * const gv = MUTABLE_GV(POPs);
7766f137 1956 svp = &GvSV(gv); /* symbol table variable */
0214ae40 1957 SAVEGENERICSV(*svp);
561b68a9 1958 *svp = newSV(0);
7766f137 1959#ifdef USE_ITHREADS
e846cb92 1960 iterdata = (PAD*)gv;
7766f137 1961#endif
54b9620d 1962 }
4633a7c4 1963
0d863452
RH
1964 if (PL_op->op_private & OPpITER_DEF)
1965 cxtype |= CXp_FOR_DEF;
1966
d343c3ef 1967 ENTER_with_name("loop2");
a0d0e21e 1968
7766f137
GS
1969 PUSHBLOCK(cx, cxtype, SP);
1970#ifdef USE_ITHREADS
e846cb92 1971 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
7766f137 1972#else
52d1f6fb 1973 PUSHLOOP_FOR(cx, svp, MARK, 0);
7766f137 1974#endif
533c011a 1975 if (PL_op->op_flags & OPf_STACKED) {
d01136d6
BS
1976 SV *maybe_ary = POPs;
1977 if (SvTYPE(maybe_ary) != SVt_PVAV) {
89ea2908 1978 dPOPss;
d01136d6 1979 SV * const right = maybe_ary;
984a4bea
RD
1980 SvGETMAGIC(sv);
1981 SvGETMAGIC(right);
4fe3f0fa 1982 if (RANGE_IS_NUMERIC(sv,right)) {
d01136d6 1983 cx->cx_type &= ~CXTYPEMASK;
c6fdafd0
NC
1984 cx->cx_type |= CXt_LOOP_LAZYIV;
1985 /* Make sure that no-one re-orders cop.h and breaks our
1986 assumptions */
1987 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
a2309040
JH
1988#ifdef NV_PRESERVES_UV
1989 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1990 (SvNV(sv) > (NV)IV_MAX)))
1991 ||
1992 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1993 (SvNV(right) < (NV)IV_MIN))))
1994#else
1995 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1996 ||
1997 ((SvNV(sv) > 0) &&
1998 ((SvUV(sv) > (UV)IV_MAX) ||
1999 (SvNV(sv) > (NV)UV_MAX)))))
2000 ||
2001 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2002 ||
2003 ((SvNV(right) > 0) &&
2004 ((SvUV(right) > (UV)IV_MAX) ||
2005 (SvNV(right) > (NV)UV_MAX))))))
2006#endif
076d9a11 2007 DIE(aTHX_ "Range iterator outside integer range");
d01136d6
BS
2008 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2009 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
d4665a05
DM
2010#ifdef DEBUGGING
2011 /* for correct -Dstv display */
2012 cx->blk_oldsp = sp - PL_stack_base;
2013#endif
89ea2908 2014 }
3f63a782 2015 else {
d01136d6
BS
2016 cx->cx_type &= ~CXTYPEMASK;
2017 cx->cx_type |= CXt_LOOP_LAZYSV;
2018 /* Make sure that no-one re-orders cop.h and breaks our
2019 assumptions */
2020 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2021 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2022 cx->blk_loop.state_u.lazysv.end = right;
2023 SvREFCNT_inc(right);
2024 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
267cc4a8
NC
2025 /* This will do the upgrade to SVt_PV, and warn if the value
2026 is uninitialised. */
10516c54 2027 (void) SvPV_nolen_const(right);
267cc4a8
NC
2028 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2029 to replace !SvOK() with a pointer to "". */
2030 if (!SvOK(right)) {
2031 SvREFCNT_dec(right);
d01136d6 2032 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
267cc4a8 2033 }
3f63a782 2034 }
89ea2908 2035 }
d01136d6 2036 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
502c6561 2037 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
d01136d6
BS
2038 SvREFCNT_inc(maybe_ary);
2039 cx->blk_loop.state_u.ary.ix =
2040 (PL_op->op_private & OPpITER_REVERSED) ?
2041 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2042 -1;
ef3e5ea9 2043 }
89ea2908 2044 }
d01136d6
BS
2045 else { /* iterating over items on the stack */
2046 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
ef3e5ea9 2047 if (PL_op->op_private & OPpITER_REVERSED) {
d01136d6 2048 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
ef3e5ea9
NC
2049 }
2050 else {
d01136d6 2051 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
ef3e5ea9 2052 }
4633a7c4 2053 }
a0d0e21e
LW
2054
2055 RETURN;
2056}
2057
2058PP(pp_enterloop)
2059{
27da23d5 2060 dVAR; dSP;
c09156bb 2061 register PERL_CONTEXT *cx;
f54cb97a 2062 const I32 gimme = GIMME_V;
a0d0e21e 2063
d343c3ef 2064 ENTER_with_name("loop1");
a0d0e21e 2065 SAVETMPS;
d343c3ef 2066 ENTER_with_name("loop2");
a0d0e21e 2067
3b719c58
NC
2068 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2069 PUSHLOOP_PLAIN(cx, SP);
a0d0e21e
LW
2070
2071 RETURN;
2072}
2073
2074PP(pp_leaveloop)
2075{
27da23d5 2076 dVAR; dSP;
c09156bb 2077 register PERL_CONTEXT *cx;
a0d0e21e
LW
2078 I32 gimme;
2079 SV **newsp;
2080 PMOP *newpm;
2081 SV **mark;
2082
2083 POPBLOCK(cx,newpm);
3b719c58 2084 assert(CxTYPE_is_LOOP(cx));
4fdae800 2085 mark = newsp;
a8bba7fa 2086 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 2087
a1f49e72 2088 TAINT_NOT;
54310121 2089 if (gimme == G_VOID)
6f207bd3 2090 NOOP;
54310121
PP
2091 else if (gimme == G_SCALAR) {
2092 if (mark < SP)
2093 *++newsp = sv_mortalcopy(*SP);
2094 else
3280af22 2095 *++newsp = &PL_sv_undef;
a0d0e21e
LW
2096 }
2097 else {
a1f49e72 2098 while (mark < SP) {
a0d0e21e 2099 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS
2100 TAINT_NOT; /* Each item is independent */
2101 }
a0d0e21e 2102 }
f86702cc
PP
2103 SP = newsp;
2104 PUTBACK;
2105
a8bba7fa 2106 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 2107 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2108
d343c3ef
GG
2109 LEAVE_with_name("loop2");
2110 LEAVE_with_name("loop1");
a0d0e21e 2111
f86702cc 2112 return NORMAL;
a0d0e21e
LW
2113}
2114
2115PP(pp_return)
2116{
27da23d5 2117 dVAR; dSP; dMARK;
c09156bb 2118 register PERL_CONTEXT *cx;
f86702cc 2119 bool popsub2 = FALSE;
b45de488 2120 bool clear_errsv = FALSE;
a0d0e21e
LW
2121 I32 gimme;
2122 SV **newsp;
2123 PMOP *newpm;
2124 I32 optype = 0;
b0d9ce38 2125 SV *sv;
b263a1ad 2126 OP *retop = NULL;
a0d0e21e 2127
0bd48802
AL
2128 const I32 cxix = dopoptosub(cxstack_ix);
2129
9850bf21
RH
2130 if (cxix < 0) {
2131 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2132 * sort block, which is a CXt_NULL
2133 * not a CXt_SUB */
2134 dounwind(0);
d7507f74
RH
2135 PL_stack_base[1] = *PL_stack_sp;
2136 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW
2137 return 0;
2138 }
9850bf21
RH
2139 else
2140 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e 2141 }
a0d0e21e
LW
2142 if (cxix < cxstack_ix)
2143 dounwind(cxix);
2144
d7507f74
RH
2145 if (CxMULTICALL(&cxstack[cxix])) {
2146 gimme = cxstack[cxix].blk_gimme;
2147 if (gimme == G_VOID)
2148 PL_stack_sp = PL_stack_base;
2149 else if (gimme == G_SCALAR) {
2150 PL_stack_base[1] = *PL_stack_sp;
2151 PL_stack_sp = PL_stack_base + 1;
2152 }
9850bf21 2153 return 0;
d7507f74 2154 }
9850bf21 2155
a0d0e21e 2156 POPBLOCK(cx,newpm);
6b35e009 2157 switch (CxTYPE(cx)) {
a0d0e21e 2158 case CXt_SUB:
f86702cc 2159 popsub2 = TRUE;
f39bc417 2160 retop = cx->blk_sub.retop;
5dd42e15 2161 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW
2162 break;
2163 case CXt_EVAL:
b45de488
GS
2164 if (!(PL_in_eval & EVAL_KEEPERR))
2165 clear_errsv = TRUE;
a0d0e21e 2166 POPEVAL(cx);
f39bc417 2167 retop = cx->blk_eval.retop;
1d76a5c3
GS
2168 if (CxTRYBLOCK(cx))
2169 break;
067f92a0 2170 lex_end();
748a9306
LW
2171 if (optype == OP_REQUIRE &&
2172 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2173 {
54310121 2174 /* Unassume the success we assumed earlier. */
901017d6 2175 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 2176 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
be2597df 2177 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
748a9306 2178 }
a0d0e21e 2179 break;
7766f137
GS
2180 case CXt_FORMAT:
2181 POPFORMAT(cx);
f39bc417 2182 retop = cx->blk_sub.retop;
7766f137 2183 break;
a0d0e21e 2184 default:
cea2e8a9 2185 DIE(aTHX_ "panic: return");
a0d0e21e
LW
2186 }
2187
a1f49e72 2188 TAINT_NOT;
a0d0e21e 2189 if (gimme == G_SCALAR) {
a29cdaf0
IZ
2190 if (MARK < SP) {
2191 if (popsub2) {
a8bba7fa 2192 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
2193 if (SvTEMP(TOPs)) {
2194 *++newsp = SvREFCNT_inc(*SP);
2195 FREETMPS;
2196 sv_2mortal(*newsp);
959e3673
GS
2197 }
2198 else {
2199 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 2200 FREETMPS;
959e3673
GS
2201 *++newsp = sv_mortalcopy(sv);
2202 SvREFCNT_dec(sv);
a29cdaf0 2203 }
959e3673
GS
2204 }
2205 else
a29cdaf0 2206 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS
2207 }
2208 else
a29cdaf0 2209 *++newsp = sv_mortalcopy(*SP);
959e3673
GS
2210 }
2211 else
3280af22 2212 *++newsp = &PL_sv_undef;
a0d0e21e 2213 }
54310121 2214 else if (gimme == G_ARRAY) {
a1f49e72 2215 while (++MARK <= SP) {
f86702cc
PP
2216 *++newsp = (popsub2 && SvTEMP(*MARK))
2217 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
2218 TAINT_NOT; /* Each item is independent */
2219 }
a0d0e21e 2220 }
3280af22 2221 PL_stack_sp = newsp;
a0d0e21e 2222
5dd42e15 2223 LEAVE;
f86702cc
PP
2224 /* Stack values are safe: */
2225 if (popsub2) {
5dd42e15 2226 cxstack_ix--;
b0d9ce38 2227 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2228 }
b0d9ce38 2229 else
c445ea15 2230 sv = NULL;
3280af22 2231 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2232
b0d9ce38 2233 LEAVESUB(sv);
8433848b 2234 if (clear_errsv) {
ab69dbc2 2235 CLEAR_ERRSV();
8433848b 2236 }
f39bc417 2237 return retop;
a0d0e21e
LW
2238}
2239
2240PP(pp_last)
2241{
27da23d5 2242 dVAR; dSP;
a0d0e21e 2243 I32 cxix;
c09156bb 2244 register PERL_CONTEXT *cx;
f86702cc 2245 I32 pop2 = 0;
a0d0e21e 2246 I32 gimme;
8772537c 2247 I32 optype;
b263a1ad 2248 OP *nextop = NULL;
a0d0e21e
LW
2249 SV **newsp;
2250 PMOP *newpm;
a8bba7fa 2251 SV **mark;
c445ea15 2252 SV *sv = NULL;
9d4ba2ae 2253
a0d0e21e 2254
533c011a 2255 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2256 cxix = dopoptoloop(cxstack_ix);
2257 if (cxix < 0)
a651a37d 2258 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW
2259 }
2260 else {
2261 cxix = dopoptolabel(cPVOP->op_pv);
2262 if (cxix < 0)
cea2e8a9 2263 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW
2264 }
2265 if (cxix < cxstack_ix)
2266 dounwind(cxix);
2267
2268 POPBLOCK(cx,newpm);
5dd42e15 2269 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2270 mark = newsp;
6b35e009 2271 switch (CxTYPE(cx)) {
c6fdafd0 2272 case CXt_LOOP_LAZYIV:
d01136d6 2273 case CXt_LOOP_LAZYSV:
3b719c58
NC
2274 case CXt_LOOP_FOR:
2275 case CXt_LOOP_PLAIN:
2276 pop2 = CxTYPE(cx);
a8bba7fa 2277 newsp = PL_stack_base + cx->blk_loop.resetsp;
022eaa24 2278 nextop = cx->blk_loop.my_op->op_lastop->op_next;
a0d0e21e 2279 break;
f86702cc 2280 case CXt_SUB:
f86702cc 2281 pop2 = CXt_SUB;
f39bc417 2282 nextop = cx->blk_sub.retop;
a0d0e21e 2283 break;
f86702cc
PP
2284 case CXt_EVAL:
2285 POPEVAL(cx);
f39bc417 2286 nextop = cx->blk_eval.retop;
a0d0e21e 2287 break;
7766f137
GS
2288 case CXt_FORMAT:
2289 POPFORMAT(cx);
f39bc417 2290 nextop = cx->blk_sub.retop;
7766f137 2291 break;
a0d0e21e 2292 default:
cea2e8a9 2293 DIE(aTHX_ "panic: last");
a0d0e21e
LW
2294 }
2295
a1f49e72 2296 TAINT_NOT;
a0d0e21e 2297 if (gimme == G_SCALAR) {
f86702cc
PP
2298 if (MARK < SP)
2299 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2300 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2301 else
3280af22 2302 *++newsp = &PL_sv_undef;
a0d0e21e 2303 }
54310121 2304 else if (gimme == G_ARRAY) {
a1f49e72 2305 while (++MARK <= SP) {
f86702cc
PP
2306 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2307 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
2308 TAINT_NOT; /* Each item is independent */
2309 }
f86702cc
PP
2310 }
2311 SP = newsp;
2312 PUTBACK;
2313
5dd42e15
DM
2314 LEAVE;
2315 cxstack_ix--;
f86702cc
PP
2316 /* Stack values are safe: */
2317 switch (pop2) {
c6fdafd0 2318 case CXt_LOOP_LAZYIV:
3b719c58 2319 case CXt_LOOP_PLAIN:
d01136d6 2320 case CXt_LOOP_LAZYSV:
3b719c58 2321 case CXt_LOOP_FOR:
a8bba7fa 2322 POPLOOP(cx); /* release loop vars ... */
4fdae800 2323 LEAVE;
f86702cc
PP
2324 break;
2325 case CXt_SUB:
b0d9ce38 2326 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2327 break;
a0d0e21e 2328 }
3280af22 2329 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2330
b0d9ce38 2331 LEAVESUB(sv);
9d4ba2ae
AL
2332 PERL_UNUSED_VAR(optype);
2333 PERL_UNUSED_VAR(gimme);
f86702cc 2334 return nextop;
a0d0e21e
LW
2335}
2336
2337PP(pp_next)
2338{
27da23d5 2339 dVAR;
a0d0e21e 2340 I32 cxix;
c09156bb 2341 register PERL_CONTEXT *cx;
85538317 2342 I32 inner;
a0d0e21e 2343
533c011a 2344 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2345 cxix = dopoptoloop(cxstack_ix);
2346 if (cxix < 0)
a651a37d 2347 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW
2348 }
2349 else {
2350 cxix = dopoptolabel(cPVOP->op_pv);
2351 if (cxix < 0)
cea2e8a9 2352 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW
2353 }
2354 if (cxix < cxstack_ix)
2355 dounwind(cxix);
2356
85538317
GS
2357 /* clear off anything above the scope we're re-entering, but
2358 * save the rest until after a possible continue block */
2359 inner = PL_scopestack_ix;
1ba6ee2b 2360 TOPBLOCK(cx);
85538317
GS
2361 if (PL_scopestack_ix < inner)
2362 leave_scope(PL_scopestack[PL_scopestack_ix]);
3a1b2b9e 2363 PL_curcop = cx->blk_oldcop;
022eaa24 2364 return CX_LOOP_NEXTOP_GET(cx);
a0d0e21e
LW
2365}
2366
2367PP(pp_redo)
2368{
27da23d5 2369 dVAR;
a0d0e21e 2370 I32 cxix;
c09156bb 2371 register PERL_CONTEXT *cx;
a0d0e21e 2372 I32 oldsave;
a034e688 2373 OP* redo_op;
a0d0e21e 2374
533c011a 2375 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2376 cxix = dopoptoloop(cxstack_ix);
2377 if (cxix < 0)
a651a37d 2378 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW
2379 }
2380 else {
2381 cxix = dopoptolabel(cPVOP->op_pv);
2382 if (cxix < 0)
cea2e8a9 2383 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW
2384 }
2385 if (cxix < cxstack_ix)
2386 dounwind(cxix);
2387
022eaa24 2388 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
a034e688
DM
2389 if (redo_op->op_type == OP_ENTER) {
2390 /* pop one less context to avoid $x being freed in while (my $x..) */
2391 cxstack_ix++;
2392 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2393 redo_op = redo_op->op_next;
2394 }
2395
a0d0e21e 2396 TOPBLOCK(cx);
3280af22 2397 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2398 LEAVE_SCOPE(oldsave);
936c78b5 2399 FREETMPS;
3a1b2b9e 2400 PL_curcop = cx->blk_oldcop;
a034e688 2401 return redo_op;
a0d0e21e
LW
2402}
2403
0824fdcb 2404STATIC OP *
bfed75c6 2405S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2406{
97aff369 2407 dVAR;
a0d0e21e 2408 OP **ops = opstack;
bfed75c6 2409 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2410
7918f24d
NC
2411 PERL_ARGS_ASSERT_DOFINDLABEL;
2412
fc36a67e 2413 if (ops >= oplimit)
cea2e8a9 2414 Perl_croak(aTHX_ too_deep);
11343788
MB
2415 if (o->op_type == OP_LEAVE ||
2416 o->op_type == OP_SCOPE ||
2417 o->op_type == OP_LEAVELOOP ||
33d34e4c 2418 o->op_type == OP_LEAVESUB ||
11343788 2419 o->op_type == OP_LEAVETRY)
fc36a67e 2420 {
5dc0d613 2421 *ops++ = cUNOPo->op_first;
fc36a67e 2422 if (ops >= oplimit)
cea2e8a9 2423 Perl_croak(aTHX_ too_deep);
fc36a67e 2424 }
c4aa4e48 2425 *ops = 0;
11343788 2426 if (o->op_flags & OPf_KIDS) {
aec46f14 2427 OP *kid;
a0d0e21e 2428 /* First try all the kids at this level, since that's likeliest. */
11343788 2429 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
7e8f1eac
AD
2430 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2431 const char *kid_label = CopLABEL(kCOP);
2432 if (kid_label && strEQ(kid_label, label))
2433 return kid;
2434 }
a0d0e21e 2435 }
11343788 2436 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2437 if (kid == PL_lastgotoprobe)
a0d0e21e 2438 continue;
ed8d0fe2
SM
2439 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2440 if (ops == opstack)
2441 *ops++ = kid;
2442 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2443 ops[-1]->op_type == OP_DBSTATE)
2444 ops[-1] = kid;
2445 else
2446 *ops++ = kid;
2447 }
155aba94 2448 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2449 return o;
a0d0e21e
LW
2450 }
2451 }
c4aa4e48 2452 *ops = 0;
a0d0e21e
LW
2453 return 0;
2454}
2455
a0d0e21e
LW
2456PP(pp_goto)
2457{
27da23d5 2458 dVAR; dSP;
cbbf8932 2459 OP *retop = NULL;
a0d0e21e 2460 I32 ix;
c09156bb 2461 register PERL_CONTEXT *cx;
fc36a67e
PP
2462#define GOTO_DEPTH 64
2463 OP *enterops[GOTO_DEPTH];
cbbf8932 2464 const char *label = NULL;
bfed75c6
AL
2465 const bool do_dump = (PL_op->op_type == OP_DUMP);
2466 static const char must_have_label[] = "goto must have label";
a0d0e21e 2467
533c011a 2468 if (PL_op->op_flags & OPf_STACKED) {
9d4ba2ae 2469 SV * const sv = POPs;
a0d0e21e
LW
2470
2471 /* This egregious kludge implements goto &subroutine */
2472 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2473 I32 cxix;
c09156bb 2474 register PERL_CONTEXT *cx;
ea726b52 2475 CV *cv = MUTABLE_CV(SvRV(sv));
a0d0e21e
LW
2476 SV** mark;
2477 I32 items = 0;
2478 I32 oldsave;
b1464ded 2479 bool reified = 0;
a0d0e21e 2480
e8f7dd13 2481 retry:
4aa0a1f7 2482 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2483 const GV * const gv = CvGV(cv);
e8f7dd13 2484 if (gv) {
7fc63493 2485 GV *autogv;
e8f7dd13
GS
2486 SV *tmpstr;
2487 /* autoloaded stub? */
2488 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2489 goto retry;
2490 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2491 GvNAMELEN(gv), FALSE);
2492 if (autogv && (cv = GvCV(autogv)))
2493 goto retry;
2494 tmpstr = sv_newmortal();
c445ea15 2495 gv_efullname3(tmpstr, gv, NULL);
be2597df 2496 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
4aa0a1f7 2497 }
cea2e8a9 2498 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD
2499 }
2500
a0d0e21e 2501 /* First do some returnish stuff. */
b37c2d43 2502 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
71fc2216 2503 FREETMPS;
a0d0e21e
LW
2504 cxix = dopoptosub(cxstack_ix);
2505 if (cxix < 0)
cea2e8a9 2506 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW
2507 if (cxix < cxstack_ix)
2508 dounwind(cxix);
2509 TOPBLOCK(cx);
2d43a17f 2510 SPAGAIN;
564abe23 2511 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2d43a17f 2512 if (CxTYPE(cx) == CXt_EVAL) {
c74ace89
DM
2513 if (CxREALEVAL(cx))
2514 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2515 else
2516 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2d43a17f 2517 }
9850bf21
RH
2518 else if (CxMULTICALL(cx))
2519 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
bafb2adc 2520 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
d8b46c1b 2521 /* put @_ back onto stack */
a0d0e21e 2522 AV* av = cx->blk_sub.argarray;
bfed75c6 2523
93965878 2524 items = AvFILLp(av) + 1;
a45cdc79
DM
2525 EXTEND(SP, items+1); /* @_ could have been extended. */
2526 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS
2527 SvREFCNT_dec(GvAV(PL_defgv));
2528 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2529 CLEAR_ARGARRAY(av);
d8b46c1b 2530 /* abandon @_ if it got reified */
62b1ebc2 2531 if (AvREAL(av)) {
b1464ded
DM
2532 reified = 1;
2533 SvREFCNT_dec(av);
d8b46c1b
GS
2534 av = newAV();
2535 av_extend(av, items-1);
11ca45c0 2536 AvREIFY_only(av);
ad64d0ec 2537 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
62b1ebc2 2538 }
a0d0e21e 2539 }
aed2304a 2540 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
890ce7af 2541 AV* const av = GvAV(PL_defgv);
1fa4e549 2542 items = AvFILLp(av) + 1;
a45cdc79
DM
2543 EXTEND(SP, items+1); /* @_ could have been extended. */
2544 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2545 }
a45cdc79
DM
2546 mark = SP;
2547 SP += items;
6b35e009 2548 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2549 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2550 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2551 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
2552 LEAVE_SCOPE(oldsave);
2553
2554 /* Now do some callish stuff. */
2555 SAVETMPS;
5023d17a 2556 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
aed2304a 2557 if (CvISXSUB(cv)) {
b37c2d43 2558 OP* const retop = cx->blk_sub.retop;
f73ef291
NC
2559 SV **newsp;
2560 I32 gimme;
b1464ded
DM
2561 if (reified) {
2562 I32 index;
2563 for (index=0; index<items; index++)
2564 sv_2mortal(SP[-index]);
2565 }
1fa4e549 2566
b37c2d43
AL
2567 /* XS subs don't have a CxSUB, so pop it */
2568 POPBLOCK(cx, PL_curpm);
2569 /* Push a mark for the start of arglist */
2570 PUSHMARK(mark);
2571 PUTBACK;
2572 (void)(*CvXSUB(cv))(aTHX_ cv);
a57c6685 2573 LEAVE;
5eff7df7 2574 return retop;
a0d0e21e
LW
2575 }
2576 else {
b37c2d43 2577 AV* const padlist = CvPADLIST(cv);
6b35e009 2578 if (CxTYPE(cx) == CXt_EVAL) {
85a64632 2579 PL_in_eval = CxOLD_IN_EVAL(cx);
3280af22 2580 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22 2581 cx->cx_type = CXt_SUB;
b150fb22 2582 }
a0d0e21e 2583 cx->blk_sub.cv = cv;
1a5b3db4 2584 cx->blk_sub.olddepth = CvDEPTH(cv);
dd2155a4 2585
a0d0e21e
LW
2586 CvDEPTH(cv)++;
2587 if (CvDEPTH(cv) < 2)
74c765eb 2588 SvREFCNT_inc_simple_void_NN(cv);
dd2155a4 2589 else {
2b9dff67 2590 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
44a8e56a 2591 sub_crush_depth(cv);
26019298 2592 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2593 }
fd617465
DM
2594 SAVECOMPPAD();
2595 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
bafb2adc 2596 if (CxHASARGS(cx))
6d4ff0d2 2597 {
502c6561 2598 AV *const av = MUTABLE_AV(PAD_SVl(0));
a0d0e21e 2599
3280af22 2600 cx->blk_sub.savearray = GvAV(PL_defgv);
502c6561 2601 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
dd2155a4 2602 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2603 cx->blk_sub.argarray = av;
a0d0e21e
LW
2604
2605 if (items >= AvMAX(av) + 1) {
b37c2d43 2606 SV **ary = AvALLOC(av);
a0d0e21e
LW
2607 if (AvARRAY(av) != ary) {
2608 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 2609 AvARRAY(av) = ary;
a0d0e21e
LW
2610 }
2611 if (items >= AvMAX(av) + 1) {
2612 AvMAX(av) = items - 1;
2613 Renew(ary,items+1,SV*);
2614 AvALLOC(av) = ary;
9c6bc640 2615 AvARRAY(av) = ary;
a0d0e21e
LW
2616 }
2617 }
a45cdc79 2618 ++mark;
a0d0e21e 2619 Copy(mark,AvARRAY(av),items,SV*);
93965878 2620 AvFILLp(av) = items - 1;
d8b46c1b 2621 assert(!AvREAL(av));
b1464ded
DM
2622 if (reified) {
2623 /* transfer 'ownership' of refcnts to new @_ */
2624 AvREAL_on(av);
2625 AvREIFY_off(av);
2626 }
a0d0e21e
LW
2627 while (items--) {
2628 if (*mark)
2629 SvTEMP_off(*mark);
2630 mark++;
2631 }
2632 }
491527d0 2633 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
005a8a35 2634 Perl_get_db_sub(aTHX_ NULL, cv);
b37c2d43 2635 if (PERLDB_GOTO) {
b96d8cd9 2636 CV * const gotocv = get_cvs("DB::goto", 0);
b37c2d43
AL
2637 if (gotocv) {
2638 PUSHMARK( PL_stack_sp );
ad64d0ec 2639 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
b37c2d43
AL
2640 PL_stack_sp--;
2641 }
491527d0 2642 }
1ce6579f 2643 }
a0d0e21e
LW
2644 RETURNOP(CvSTART(cv));
2645 }
2646 }
1614b0e3 2647 else {
0510663f 2648 label = SvPV_nolen_const(sv);
1614b0e3 2649 if (!(do_dump || *label))
cea2e8a9 2650 DIE(aTHX_ must_have_label);
1614b0e3 2651 }
a0d0e21e 2652 }
533c011a 2653 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2654 if (! do_dump)
cea2e8a9 2655 DIE(aTHX_ must_have_label);
a0d0e21e
LW
2656 }
2657 else
2658 label = cPVOP->op_pv;
2659
f410a211
NC
2660 PERL_ASYNC_CHECK();
2661
a0d0e21e 2662 if (label && *label) {
cbbf8932 2663 OP *gotoprobe = NULL;
3b2447bc 2664 bool leaving_eval = FALSE;
33d34e4c 2665 bool in_block = FALSE;
cbbf8932 2666 PERL_CONTEXT *last_eval_cx = NULL;
a0d0e21e
LW
2667
2668 /* find label */
2669
d4c19fe8 2670 PL_lastgotoprobe = NULL;
a0d0e21e
LW
2671 *enterops = 0;
2672 for (ix = cxstack_ix; ix >= 0; ix--) {
2673 cx = &cxstack[ix];
6b35e009 2674 switch (CxTYPE(cx)) {
a0d0e21e 2675 case CXt_EVAL:
3b2447bc 2676 leaving_eval = TRUE;
971ecbe6 2677 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH
2678 gotoprobe = (last_eval_cx ?
2679 last_eval_cx->blk_eval.old_eval_root :
2680 PL_eval_root);
2681 last_eval_cx = cx;
9c5794fe
RH
2682 break;
2683 }
2684 /* else fall through */
c6fdafd0 2685 case CXt_LOOP_LAZYIV:
d01136d6 2686 case CXt_LOOP_LAZYSV:
3b719c58
NC
2687 case CXt_LOOP_FOR:
2688 case CXt_LOOP_PLAIN:
bb5aedc1
VP
2689 case CXt_GIVEN:
2690 case CXt_WHEN:
a0d0e21e
LW
2691 gotoprobe = cx->blk_oldcop->op_sibling;
2692 break;
2693 case CXt_SUBST:
2694 continue;
2695 case CXt_BLOCK:
33d34e4c 2696 if (ix) {
a0d0e21e 2697 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE
2698 in_block = TRUE;
2699 } else
3280af22 2700 gotoprobe = PL_main_root;
a0d0e21e 2701 break;
b3933176 2702 case CXt_SUB:
9850bf21 2703 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
b3933176
CS
2704 gotoprobe = CvROOT(cx->blk_sub.cv);
2705 break;
2706 }
2707 /* FALL THROUGH */
7766f137 2708 case CXt_FORMAT:
0a753a76 2709 case CXt_NULL:
a651a37d 2710 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW
2711 default:
2712 if (ix)
cea2e8a9 2713 DIE(aTHX_ "panic: goto");
3280af22 2714 gotoprobe = PL_main_root;
a0d0e21e
LW
2715 break;
2716 }
2b597662
GS
2717 if (gotoprobe) {
2718 retop = dofindlabel(gotoprobe, label,
2719 enterops, enterops + GOTO_DEPTH);
2720 if (retop)
2721 break;
2722 }
3280af22 2723 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW
2724 }
2725 if (!retop)
cea2e8a9 2726 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2727
3b2447bc
RH
2728 /* if we're leaving an eval, check before we pop any frames
2729 that we're not going to punt, otherwise the error
2730 won't be caught */
2731
2732 if (leaving_eval && *enterops && enterops[1]) {
2733 I32 i;
2734 for (i = 1; enterops[i]; i++)
2735 if (enterops[i]->op_type == OP_ENTERITER)
2736 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2737 }
2738
b500e03b
GG
2739 if (*enterops && enterops[1]) {
2740 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2741 if (enterops[i])
2742 deprecate("\"goto\" to jump into a construct");
2743 }
2744
a0d0e21e
LW
2745 /* pop unwanted frames */
2746
2747 if (ix < cxstack_ix) {
2748 I32 oldsave;
2749
2750 if (ix < 0)
2751 ix = 0;
2752 dounwind(ix);
2753 TOPBLOCK(cx);
3280af22 2754 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW
2755 LEAVE_SCOPE(oldsave);
2756 }
2757
2758 /* push wanted frames */
2759
748a9306 2760 if (*enterops && enterops[1]) {
0bd48802 2761 OP * const oldop = PL_op;
33d34e4c
AE
2762 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2763 for (; enterops[ix]; ix++) {
533c011a 2764 PL_op = enterops[ix];
84902520
TB
2765 /* Eventually we may want to stack the needed arguments
2766 * for each op. For now, we punt on the hard ones. */
533c011a 2767 if (PL_op->op_type == OP_ENTERITER)
894356b3 2768 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2769 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2770 }
533c011a 2771 PL_op = oldop;
a0d0e21e
LW
2772 }
2773 }
2774
2775 if (do_dump) {
a5f75d66 2776#ifdef VMS
6b88bc9c 2777 if (!retop) retop = PL_main_start;
a5f75d66 2778#endif
3280af22
NIS
2779 PL_restartop = retop;
2780 PL_do_undump = TRUE;
a0d0e21e
LW
2781
2782 my_unexec();
2783
3280af22
NIS
2784 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2785 PL_do_undump = FALSE;
a0d0e21e
LW
2786 }
2787
2788 RETURNOP(retop);
2789}
2790
2791PP(pp_exit)
2792{
97aff369 2793 dVAR;
39644a26 2794 dSP;
a0d0e21e
LW
2795 I32 anum;
2796
2797 if (MAXARG < 1)
2798 anum = 0;
ff0cee69 2799 else {
a0d0e21e 2800 anum = SvIVx(POPs);
d98f61e7
GS
2801#ifdef VMS
2802 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2803 anum = 0;
96e176bf 2804 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69
PP
2805#endif
2806 }
cc3604b1 2807 PL_exit_flags |= PERL_EXIT_EXPECTED;
81d86705
NC
2808#ifdef PERL_MAD
2809 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2810 if (anum || !(PL_minus_c && PL_madskills))
2811 my_exit(anum);
2812#else
a0d0e21e 2813 my_exit(anum);
81d86705 2814#endif
3280af22 2815 PUSHs(&PL_sv_undef);
a0d0e21e
LW
2816 RETURN;
2817}
2818
a0d0e21e
LW
2819/* Eval. */
2820
0824fdcb 2821STATIC void
cea2e8a9 2822S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2823{
504618e9 2824 const char *s = SvPVX_const(sv);
890ce7af 2825 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 2826 I32 line = 1;
a0d0e21e 2827
7918f24d
NC
2828 PERL_ARGS_ASSERT_SAVE_LINES;
2829
a0d0e21e 2830 while (s && s < send) {
f54cb97a 2831 const char *t;
b9f83d2f 2832 SV * const tmpstr = newSV_type(SVt_PVMG);
a0d0e21e 2833
1d963ff3 2834 t = (const char *)memchr(s, '\n', send - s);
a0d0e21e
LW
2835 if (t)
2836 t++;
2837 else
2838 t = send;
2839
2840 sv_setpvn(tmpstr, s, t - s);
2841 av_store(array, line++, tmpstr);
2842 s = t;
2843 }
2844}
2845
22f16304
RU
2846/*
2847=for apidoc docatch
2848
2849Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2850
28510 is used as continue inside eval,
2852
28533 is used for a die caught by an inner eval - continue inner loop
2854
2855See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2856establish a local jmpenv to handle exception traps.
2857
2858=cut
2859*/
0824fdcb 2860STATIC OP *
cea2e8a9 2861S_docatch(pTHX_ OP *o)
1e422769 2862{
97aff369 2863 dVAR;
6224f72b 2864 int ret;
06b5626a 2865 OP * const oldop = PL_op;
db36c5a1 2866 dJMPENV;
1e422769 2867
1e422769 2868#ifdef DEBUGGING
54310121 2869 assert(CATCH_GET == TRUE);
1e422769 2870#endif
312caa8e 2871 PL_op = o;
8bffa5f8 2872
14dd3ad8 2873 JMPENV_PUSH(ret);
6224f72b 2874 switch (ret) {
312caa8e 2875 case 0:
abd70938
DM
2876 assert(cxstack_ix >= 0);
2877 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2878 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8 2879 redo_body:
85aaa934 2880 CALLRUNOPS(aTHX);
312caa8e
CS
2881 break;
2882 case 3:
8bffa5f8 2883 /* die caught by an inner eval - continue inner loop */
abd70938
DM
2884
2885 /* NB XXX we rely on the old popped CxEVAL still being at the top
2886 * of the stack; the way die_where() currently works, this
2887 * assumption is valid. In theory The cur_top_env value should be
2888 * returned in another global, the way retop (aka PL_restartop)
2889 * is. */
2890 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2891
2892 if (PL_restartop
2893 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2894 {
312caa8e
CS
2895 PL_op = PL_restartop;
2896 PL_restartop = 0;
2897 goto redo_body;
2898 }
2899 /* FALL THROUGH */
2900 default:
14dd3ad8 2901 JMPENV_POP;
533c011a 2902 PL_op = oldop;
6224f72b 2903 JMPENV_JUMP(ret);
1e422769 2904 /* NOTREACHED */
1e422769 2905 }
14dd3ad8 2906 JMPENV_POP;
533c011a 2907 PL_op = oldop;
5f66b61c 2908 return NULL;
1e422769
PP
2909}
2910
ee23ad3b
NC
2911/* James Bond: Do you expect me to talk?
2912 Auric Goldfinger: No, Mr. Bond. I expect you to die.
2913
2914 This code is an ugly hack, doesn't work with lexicals in subroutines that are
2915 called more than once, and is only used by regcomp.c, for (?{}) blocks.
2916
2917 Currently it is not used outside the core code. Best if it stays that way.
2918*/
c277df42 2919OP *
bfed75c6 2920Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ
2921/* sv Text to convert to OP tree. */
2922/* startop op_free() this to undo. */
2923/* code Short string id of the caller. */
2924{
27da23d5 2925 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ
2926 PERL_CONTEXT *cx;
2927 SV **newsp;
b094c71d 2928 I32 gimme = G_VOID;
c277df42
IZ
2929 I32 optype;
2930 OP dummy;
83ee9e09
GS
2931 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2932 char *tmpbuf = tbuf;
c277df42 2933 char *safestr;
a3985cdc 2934 int runtime;
601f1833 2935 CV* runcv = NULL; /* initialise to avoid compiler warnings */
f7997f86 2936 STRLEN len;
c277df42 2937
7918f24d
NC
2938 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2939
d343c3ef 2940 ENTER_with_name("eval");
5486870f 2941 lex_start(sv, NULL, FALSE);
c277df42
IZ
2942 SAVETMPS;
2943 /* switch to eval mode */
2944
923e4eb5 2945 if (IN_PERL_COMPILETIME) {
f4dd75d9 2946 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2947 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2948 }
83ee9e09 2949 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
9d4ba2ae 2950 SV * const sv = sv_newmortal();
83ee9e09
GS
2951 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2952 code, (unsigned long)++PL_evalseq,
2953 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2954 tmpbuf = SvPVX(sv);
fc009855 2955 len = SvCUR(sv);
83ee9e09
GS
2956 }
2957 else
d9fad198
JH
2958 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2959 (unsigned long)++PL_evalseq);
f4dd75d9 2960 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2961 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2962 SAVECOPLINE(&PL_compiling);
57843af0 2963 CopLINE_set(&PL_compiling, 1);
c277df42
IZ
2964 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2965 deleting the eval's FILEGV from the stash before gv_check() runs
2966 (i.e. before run-time proper). To work around the coredump that
2967 ensues, we always turn GvMULTI_on for any globals that were
2968 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC
2969 safestr = savepvn(tmpbuf, len);
2970 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 2971 SAVEHINTS();
d1ca3daa 2972#ifdef OP_IN_REGISTER
6b88bc9c 2973 PL_opsave = op;
d1ca3daa 2974#else
7766f137 2975 SAVEVPTR(PL_op);
d1ca3daa 2976#endif
c277df42 2977
a3985cdc 2978 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2979 runtime = IN_PERL_RUNTIME;
a3985cdc 2980 if (runtime)
d819b83a 2981 runcv = find_runcv(NULL);
a3985cdc 2982
533c011a 2983 PL_op = &dummy;
13b51b79 2984 PL_op->op_type = OP_ENTEREVAL;
533c011a 2985 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2986 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
6b75f042 2987 PUSHEVAL(cx, 0);
a3985cdc
DM
2988
2989 if (runtime)
410be5db 2990 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
a3985cdc 2991 else
410be5db 2992 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2993 POPBLOCK(cx,PL_curpm);
e84b9f1f 2994 POPEVAL(cx);
c277df42
IZ
2995
2996 (*startop)->op_type = OP_NULL;
22c35a8c 2997 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2998 lex_end();
f3548bdc 2999 /* XXX DAPM do this properly one year */
502c6561 3000 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
d343c3ef 3001 LEAVE_with_name("eval");
923e4eb5 3002 if (IN_PERL_COMPILETIME)
623e6609 3003 CopHINTS_set(&PL_compiling, PL_hints);
d1ca3daa 3004#ifdef OP_IN_REGISTER
6b88bc9c 3005 op = PL_opsave;
d1ca3daa 3006#endif
9d4ba2ae
AL
3007 PERL_UNUSED_VAR(newsp);
3008 PERL_UNUSED_VAR(optype);
3009
410be5db 3010 return PL_eval_start;
c277df42
IZ
3011}
3012
a3985cdc
DM
3013
3014/*
3015=for apidoc find_runcv
3016
3017Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM
3018If db_seqp is non_null, skip CVs that are in the DB package and populate
3019*db_seqp with the cop sequence number at the point that the DB:: code was
3020entered. (allows debuggers to eval in the scope of the breakpoint rather
cf525c36 3021than in the scope of the debugger itself).
a3985cdc
DM
3022
3023=cut
3024*/
3025
3026CV*
d819b83a 3027Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 3028{
97aff369 3029 dVAR;
a3985cdc 3030 PERL_SI *si;
a3985cdc 3031
d819b83a
DM
3032 if (db_seqp)
3033 *db_seqp = PL_curcop->cop_seq;
a3985cdc 3034 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 3035 I32 ix;
a3985cdc 3036 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 3037 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a 3038 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1b6737cc 3039 CV * const cv = cx->blk_sub.cv;
d819b83a
DM
3040 /* skip DB:: code */
3041 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3042 *db_seqp = cx->blk_oldcop->cop_seq;
3043 continue;
3044 }
3045 return cv;
3046 }
a3985cdc
DM
3047 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3048 return PL_compcv;
3049 }
3050 }
3051 return PL_main_cv;
3052}
3053
3054
27e90453
DM
3055/* Run yyparse() in a setjmp wrapper. Returns:
3056 * 0: yyparse() successful
3057 * 1: yyparse() failed
3058 * 3: yyparse() died
3059 */
3060STATIC int
3061S_try_yyparse(pTHX)
3062{
3063 int ret;
3064 dJMPENV;
3065
3066 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3067 JMPENV_PUSH(ret);
3068 switch (ret) {
3069 case 0:
3070 ret = yyparse() ? 1 : 0;
3071 break;
3072 case 3:
3073 break;
3074 default:
3075 JMPENV_POP;
3076 JMPENV_JUMP(ret);
3077 /* NOTREACHED */
3078 }
3079 JMPENV_POP;
3080 return ret;
3081}
3082
3083
a3985cdc
DM
3084/* Compile a require/do, an eval '', or a /(?{...})/.
3085 * In the last case, startop is non-null, and contains the address of
3086 * a pointer that should be set to the just-compiled code.
3087 * outside is the lexically enclosing CV (if any) that invoked us.
410be5db
DM
3088 * Returns a bool indicating whether the compile was successful; if so,
3089 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3090 * pushes undef (also croaks if startop != NULL).
a3985cdc
DM
3091 */
3092
410be5db 3093STATIC bool
a3985cdc 3094S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 3095{
27da23d5 3096 dVAR; dSP;
46c461b5 3097 OP * const saveop = PL_op;
27e90453
DM
3098 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3099 int yystatus;
a0d0e21e 3100
27e90453 3101 PL_in_eval = (in_require
6dc8a9e4
IZ
3102 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3103 : EVAL_INEVAL);
a0d0e21e 3104
1ce6579f
PP
3105 PUSHMARK(SP);
3106
3280af22 3107 SAVESPTR(PL_compcv);
ea726b52 3108 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
1aff0e91 3109 CvEVAL_on(PL_compcv);
2090ab20
JH
3110 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3111 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3112
a3985cdc 3113 CvOUTSIDE_SEQ(PL_compcv) = seq;
ea726b52 3114 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
a3985cdc 3115
dd2155a4 3116 /* set up a scratch pad */
a0d0e21e 3117
dd2155a4 3118 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
cecbe010 3119 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2c05e328 3120
07055b4c 3121
81d86705
NC
3122 if (!PL_madskills)
3123 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 3124
a0d0e21e
LW
3125 /* make sure we compile in the right package */
3126
ed094faf 3127 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 3128 SAVESPTR(PL_curstash);
ed094faf 3129 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 3130 }
3c10abe3 3131 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3280af22
NIS
3132 SAVESPTR(PL_beginav);
3133 PL_beginav = newAV();
3134 SAVEFREESV(PL_beginav);
3c10abe3
AG
3135 SAVESPTR(PL_unitcheckav);
3136 PL_unitcheckav = newAV();
3137 SAVEFREESV(PL_unitcheckav);
a0d0e21e 3138
81d86705 3139#ifdef PERL_MAD
9da243ce 3140 SAVEBOOL(PL_madskills);
81d86705
NC
3141 PL_madskills = 0;
3142#endif
3143
a0d0e21e
LW
3144 /* try to compile it */
3145
5f66b61c 3146 PL_eval_root = NULL;
3280af22 3147 PL_curcop = &PL_compiling;
fc15ae8f 3148 CopARYBASE_set(PL_curcop, 0);
5f66b61c 3149 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
faef0170 3150 PL_in_eval |= EVAL_KEEPERR;
ab69dbc2
RGS
3151 else
3152 CLEAR_ERRSV();
27e90453
DM
3153
3154 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3155 * so honour CATCH_GET and trap it here if necessary */
3156
3157 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
3158
3159 if (yystatus || PL_parser->error_count || !PL_eval_root) {
0c58d367 3160 SV **newsp; /* Used by POPBLOCK. */
9d4ba2ae 3161 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
27e90453 3162 I32 optype; /* Used by POPEVAL. */
9d4ba2ae 3163 const char *msg;
bfed75c6 3164
27e90453
DM
3165 PERL_UNUSED_VAR(newsp);
3166 PERL_UNUSED_VAR(optype);
3167
533c011a 3168 PL_op = saveop;
3280af22
NIS
3169 if (PL_eval_root) {
3170 op_free(PL_eval_root);
5f66b61c 3171 PL_eval_root = NULL;
a0d0e21e 3172 }
27e90453
DM
3173 if (yystatus != 3) {
3174 SP = PL_stack_base + POPMARK; /* pop original mark */
3175 if (!startop) {
3176 POPBLOCK(cx,PL_curpm);
3177 POPEVAL(cx);
3178 }
c277df42 3179 }
a0d0e21e 3180 lex_end();
27e90453
DM
3181 if (yystatus != 3)
3182 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
9d4ba2ae
AL
3183
3184 msg = SvPVx_nolen_const(ERRSV);
27e90453 3185 if (in_require) {
b464bac0 3186 const SV * const nsv = cx->blk_eval.old_namesv;
504618e9 3187 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 3188 &PL_sv_undef, 0);
58d3fd3b
SH
3189 Perl_croak(aTHX_ "%sCompilation failed in require",
3190 *msg ? msg : "Unknown error\n");
5a844595
GS
3191 }
3192 else if (startop) {
27e90453
DM
3193 if (yystatus != 3) {
3194 POPBLOCK(cx,PL_curpm);
3195 POPEVAL(cx);
3196 }
5a844595
GS
3197 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3198 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 3199 }
9d7f88dd 3200 else {
9d7f88dd 3201 if (!*msg) {
6502358f 3202 sv_setpvs(ERRSV, "Compilation error");
9d7f88dd
SR
3203 }
3204 }
410be5db
DM
3205 PUSHs(&PL_sv_undef);
3206 PUTBACK;
3207 return FALSE;
a0d0e21e 3208 }
57843af0 3209 CopLINE_set(&PL_compiling, 0);
c277df42 3210 if (startop) {
3280af22 3211 *startop = PL_eval_root;
c277df42 3212 } else
3280af22 3213 SAVEFREEOP(PL_eval_root);
0c58d367
RGS
3214
3215 /* Set the context for this new optree.
021f53de
GG
3216 * Propagate the context from the eval(). */
3217 if ((gimme & G_WANT) == G_VOID)
3280af22 3218 scalarvoid(PL_eval_root);
7df0357e 3219 else if ((gimme & G_WANT) == G_ARRAY)
3280af22 3220 list(PL_eval_root);
a0d0e21e 3221 else
3280af22 3222 scalar(PL_eval_root);
a0d0e21e
LW
3223
3224 DEBUG_x(dump_eval());
3225
55497cff 3226 /* Register with debugger: */
6482a30d 3227 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
b96d8cd9 3228 CV * const cv = get_cvs("DB::postponed", 0);
55497cff
PP
3229 if (cv) {
3230 dSP;
924508f0 3231 PUSHMARK(SP);
ad64d0ec 3232 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
55497cff 3233 PUTBACK;
ad64d0ec 3234 call_sv(MUTABLE_SV(cv), G_DISCARD);
55497cff
PP
3235 }
3236 }
3237
3c10abe3
AG
3238 if (PL_unitcheckav)
3239 call_list(PL_scopestack_ix, PL_unitcheckav);
3240
a0d0e21e
LW
3241 /* compiled okay, so do it */
3242
3280af22
NIS
3243 CvDEPTH(PL_compcv) = 1;
3244 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 3245 PL_op = saveop; /* The caller may need it. */
bc177e6b 3246 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 3247
410be5db
DM
3248 PUTBACK;
3249 return TRUE;
a0d0e21e
LW
3250}
3251
a6c40364 3252STATIC PerlIO *
0786552a 3253S_check_type_and_open(pTHX_ const char *name)
ce8abf5f
SP
3254{
3255 Stat_t st;
c445ea15 3256 const int st_rc = PerlLIO_stat(name, &st);
df528165 3257
7918f24d
NC
3258 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3259
6b845e56 3260 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
4608196e 3261 return NULL;
ce8abf5f
SP
3262 }
3263
0786552a 3264 return PerlIO_open(name, PERL_SCRIPT_MODE);
ce8abf5f
SP
3265}
3266
75c20bac 3267#ifndef PERL_DISABLE_PMC
ce8abf5f 3268STATIC PerlIO *
0786552a 3269S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
b295d113 3270{
b295d113
TH
3271 PerlIO *fp;
3272
7918f24d
NC
3273 PERL_ARGS_ASSERT_DOOPEN_PM;
3274
ce9440c8 3275 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
50b8ed39
NC
3276 SV *const pmcsv = newSV(namelen + 2);
3277 char *const pmc = SvPVX(pmcsv);
a6c40364 3278 Stat_t pmcstat;
50b8ed39
NC
3279
3280 memcpy(pmc, name, namelen);
3281 pmc[namelen] = 'c';
3282 pmc[namelen + 1] = '\0';
3283
a6c40364 3284 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
0786552a 3285 fp = check_type_and_open(name);
a6c40364
GS
3286 }
3287 else {
0786552a 3288 fp = check_type_and_open(pmc);
b295d113 3289 }
a6c40364
GS
3290 SvREFCNT_dec(pmcsv);
3291 }
3292 else {
0786552a 3293 fp = check_type_and_open(name);
b295d113 3294 }
b295d113 3295 return fp;
75c20bac 3296}
7925835c 3297#else
75c20bac 3298# define doopen_pm(name, namelen) check_type_and_open(name)
7925835c 3299#endif /* !PERL_DISABLE_PMC */
b295d113 3300
a0d0e21e
LW
3301PP(pp_require)
3302{
27da23d5 3303 dVAR; dSP;
c09156bb 3304 register PERL_CONTEXT *cx;
a0d0e21e 3305 SV *sv;
5c144d81 3306 const char *name;
6132ea6c 3307 STRLEN len;
4492be7a
JM
3308 char * unixname;
3309 STRLEN unixlen;
62f5ad7a 3310#ifdef VMS
4492be7a 3311 int vms_unixname = 0;
62f5ad7a 3312#endif
c445ea15
AL
3313 const char *tryname = NULL;
3314 SV *namesv = NULL;
f54cb97a 3315 const I32 gimme = GIMME_V;
bbed91b5 3316 int filter_has_file = 0;
c445ea15 3317 PerlIO *tryrsfp = NULL;
34113e50 3318 SV *filter_cache = NULL;
c445ea15
AL
3319 SV *filter_state = NULL;
3320 SV *filter_sub = NULL;
3321 SV *hook_sv = NULL;
6ec9efec
JH
3322 SV *encoding;
3323 OP *op;
a0d0e21e
LW
3324
3325 sv = POPs;
d7aa5382 3326 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
d7aa5382
JP
3327 sv = new_version(sv);
3328 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 3329 upg_version(PL_patchlevel, TRUE);
149c1637 3330 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3cacfbb9 3331 if ( vcmp(sv,PL_patchlevel) <= 0 )
468aa647 3332 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
be2597df 3333 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
468aa647
RGS
3334 }
3335 else {
d1029faa
JP
3336 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3337 I32 first = 0;
3338 AV *lav;
3339 SV * const req = SvRV(sv);
85fbaab2 3340 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
d1029faa
JP
3341
3342 /* get the left hand term */
502c6561 3343 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
d1029faa
JP
3344
3345 first = SvIV(*av_fetch(lav,0,0));
3346 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
85fbaab2 3347 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
d1029faa
JP
3348 || av_len(lav) > 1 /* FP with > 3 digits */
3349 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3350 ) {
3351 DIE(aTHX_ "Perl %"SVf" required--this is only "
3352 "%"SVf", stopped", SVfARG(vnormal(req)),
3353 SVfARG(vnormal(PL_patchlevel)));
3354 }
3355 else { /* probably 'use 5.10' or 'use 5.8' */
af61dbfd 3356 SV *hintsv;
d1029faa
JP
3357 I32 second = 0;
3358
3359 if (av_len(lav)>=1)
3360 second = SvIV(*av_fetch(lav,1,0));
3361
3362 second /= second >= 600 ? 100 : 10;
af61dbfd
NC
3363 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3364 (int)first, (int)second);
d1029faa
JP
3365 upg_version(hintsv, TRUE);
3366
3367 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3368 "--this is only %"SVf", stopped",
3369 SVfARG(vnormal(req)),
af61dbfd 3370 SVfARG(vnormal(sv_2mortal(hintsv))),
d1029faa
JP
3371 SVfARG(vnormal(PL_patchlevel)));
3372 }
3373 }
468aa647 3374 }
d7aa5382 3375
fbc891ce
RB
3376 /* We do this only with use, not require. */
3377 if (PL_compcv &&
fbc891ce
RB
3378 /* If we request a version >= 5.9.5, load feature.pm with the
3379 * feature bundle that corresponds to the required version. */
2e8342de 3380 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
7dfde25d
RGS
3381 SV *const importsv = vnormal(sv);
3382 *SvPVX_mutable(importsv) = ':';
d343c3ef 3383 ENTER_with_name("load_feature");
7dfde25d 3384 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
d343c3ef 3385 LEAVE_with_name("load_feature");