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