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