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