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