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
Correctly preserve the stack on an implicit break.
[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
54310121 37#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
1e422769 38
94fcd414
NC		 39#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
40
a0d0e21e
LW		 41PP(pp_wantarray)
42{
97aff369 43 dVAR;
39644a26 44 dSP;
a0d0e21e
LW		 45 I32 cxix;
46 EXTEND(SP, 1);
47
48 cxix = dopoptosub(cxstack_ix);
49 if (cxix < 0)
50 RETPUSHUNDEF;
51
54310121 52 switch (cxstack[cxix].blk_gimme) {
53 case G_ARRAY:
a0d0e21e 54 RETPUSHYES;
54310121 55 case G_SCALAR:
a0d0e21e 56 RETPUSHNO;
54310121 57 default:
58 RETPUSHUNDEF;
59 }
a0d0e21e
LW		 60}
61
2cd61cdb
IZ		 62PP(pp_regcreset)
63{
97aff369 64 dVAR;
2cd61cdb
IZ		 65 /* XXXX Should store the old value to allow for tie/overload - and
66 restore in regcomp, where marked with XXXX. */
3280af22 67 PL_reginterp_cnt = 0;
0b4182de 68 TAINT_NOT;
2cd61cdb
IZ		 69 return NORMAL;
70}
71
b3eb6a9b
GS		 72PP(pp_regcomp)
73{
97aff369 74 dVAR;
39644a26 75 dSP;
a0d0e21e 76 register PMOP *pm = (PMOP*)cLOGOP->op_other;
a0d0e21e 77 SV *tmpstr;
84679df5 78 REGEXP *re = NULL;
bfed75c6 79
4b5a0d1c 80 /* prevent recompiling under /o and ithreads. */
3db8f154 81#if defined(USE_ITHREADS)
131b3ad0
DM		 82 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
83 if (PL_op->op_flags & OPf_STACKED) {
84 dMARK;
85 SP = MARK;
86 }
87 else
88 (void)POPs;
89 RETURN;
90 }
513629ba 91#endif
d4b87e75
BM		 92
93#define tryAMAGICregexp(rx) \
94 STMT_START { \
6f1401dc 95 SvGETMAGIC(rx); \
d4b87e75 96 if (SvROK(rx) && SvAMAGIC(rx)) { \
31d632c3 97 SV *sv = AMG_CALLunary(rx, regexp_amg); \
d4b87e75
BM		 98 if (sv) { \
99 if (SvROK(sv)) \
100 sv = SvRV(sv); \
101 if (SvTYPE(sv) != SVt_REGEXP) \
102 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
103 rx = sv; \
104 } \
105 } \
106 } STMT_END
107
108
131b3ad0 109 if (PL_op->op_flags & OPf_STACKED) {
486ec47a 110 /* multiple args; concatenate them */
131b3ad0
DM		 111 dMARK; dORIGMARK;
112 tmpstr = PAD_SV(ARGTARG);
76f68e9b 113 sv_setpvs(tmpstr, "");
131b3ad0 114 while (++MARK <= SP) {
d4b87e75 115 SV *msv = *MARK;
79a8d529 116 SV *sv;
d4b87e75 117
79a8d529 118 tryAMAGICregexp(msv);
d4b87e75 119
79a8d529
DM		 120 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
121 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
122 {
123 sv_setsv(tmpstr, sv);
124 continue;
131b3ad0 125 }
a9984b10 126 sv_catsv_nomg(tmpstr, msv);
131b3ad0
DM		 127 }
128 SvSETMAGIC(tmpstr);
129 SP = ORIGMARK;
130 }
d4b87e75 131 else {
131b3ad0 132 tmpstr = POPs;
d4b87e75
BM		 133 tryAMAGICregexp(tmpstr);
134 }
135
136#undef tryAMAGICregexp
513629ba 137
b3eb6a9b 138 if (SvROK(tmpstr)) {
d8f6592e 139 SV * const sv = SvRV(tmpstr);
5c35adbb 140 if (SvTYPE(sv) == SVt_REGEXP)
d2f13c59 141 re = (REGEXP*) sv;
c277df42 142 }
d4b87e75
BM		 143 else if (SvTYPE(tmpstr) == SVt_REGEXP)
144 re = (REGEXP*) tmpstr;
145
5c35adbb 146 if (re) {
69dc4b30
FC		 147 /* The match's LHS's get-magic might need to access this op's reg-
148 exp (as is sometimes the case with $'; see bug 70764). So we
149 must call get-magic now before we replace the regexp. Hopeful-
150 ly this hack can be replaced with the approach described at
151 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
152 /msg122415.html some day. */
455d9033
FC		 153 if(pm->op_type == OP_MATCH) {
154 SV *lhs;
155 const bool was_tainted = PL_tainted;
156 if (pm->op_flags & OPf_STACKED)
69dc4b30 157 lhs = TOPs;
455d9033
FC		 158 else if (pm->op_private & OPpTARGET_MY)
159 lhs = PAD_SV(pm->op_targ);
160 else lhs = DEFSV;
161 SvGETMAGIC(lhs);
162 /* Restore the previous value of PL_tainted (which may have been
163 modified by get-magic), to avoid incorrectly setting the
164 RXf_TAINTED flag further down. */
165 PL_tainted = was_tainted;
166 }
69dc4b30 167
f0826785 168 re = reg_temp_copy(NULL, re);
aaa362c4 169 ReREFCNT_dec(PM_GETRE(pm));
28d8d7f4 170 PM_SETRE(pm, re);
c277df42
IZ		 171 }
172 else {
f3ec07c7
DM		 173 STRLEN len = 0;
174 const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
175
c737faaf 176 re = PM_GETRE(pm);
14a49a24 177 assert (re != (REGEXP*) &PL_sv_undef);
c277df42 178
20408e3c 179 /* Check against the last compiled regexp. */
a11c8683 180 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
220fc49f 181 memNE(RX_PRECOMP(re), t, len))
85aff577 182 {
07bc277f 183 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
73134a2e 184 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
d8f6592e
AL		 185 if (re) {
186 ReREFCNT_dec(re);
14a49a24
NC		 187#ifdef USE_ITHREADS
188 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
189#else
4608196e 190 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
14a49a24 191#endif
1e2e3d02 192 } else if (PL_curcop->cop_hints_hash) {
20439bc7 193 SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
1e2e3d02
YO		 194 if (ptr && SvIOK(ptr) && SvIV(ptr))
195 eng = INT2PTR(regexp_engine*,SvIV(ptr));
c277df42 196 }
664e119d 197
533c011a 198 if (PL_op->op_flags & OPf_SPECIAL)
3280af22 199 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
a0d0e21e 200
b9ad30b4
NC		 201 if (DO_UTF8(tmpstr)) {
202 assert (SvUTF8(tmpstr));
203 } else if (SvUTF8(tmpstr)) {
204 /* Not doing UTF-8, despite what the SV says. Is this only if
205 we're trapped in use 'bytes'? */
206 /* Make a copy of the octet sequence, but without the flag on,
207 as the compiler now honours the SvUTF8 flag on tmpstr. */
208 STRLEN len;
209 const char *const p = SvPV(tmpstr, len);
210 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
211 }
f3ec07c7
DM		 212 else if (SvAMAGIC(tmpstr)) {
213 /* make a copy to avoid extra stringifies */
0479a84a 214 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
f3ec07c7 215 }
c737faaf 216
a9984b10
FC		 217 /* If it is gmagical, create a mortal copy, but without calling
218 get-magic, as we have already done that. */
219 if(SvGMAGICAL(tmpstr)) {
220 SV *mortalcopy = sv_newmortal();
221 sv_setsv_flags(mortalcopy, tmpstr, 0);
222 tmpstr = mortalcopy;
223 }
224
5a8697a7 225 if (eng)
3ab4a224 226 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
5a8697a7 227 else
3ab4a224 228 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
c737faaf 229
f86aaa29 230 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
2cd61cdb 231 inside tie/overload accessors. */
c277df42 232 }
4633a7c4 233 }
c737faaf
YO		 234
235 re = PM_GETRE(pm);
a0d0e21e 236
72311751 237#ifndef INCOMPLETE_TAINTS
3280af22 238 if (PL_tainting) {
9274aefd
DM		 239 if (PL_tainted) {
240 SvTAINTED_on((SV*)re);
07bc277f 241 RX_EXTFLAGS(re) |= RXf_TAINTED;
9274aefd 242 }
72311751
GS		 243 }
244#endif
245
220fc49f 246 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
3280af22 247 pm = PL_curpm;
a0d0e21e 248
c737faaf
YO		 249
250#if !defined(USE_ITHREADS)
251 /* can't change the optree at runtime either */
252 /* PMf_KEEP is handled differently under threads to avoid these problems */
a0d0e21e 253 if (pm->op_pmflags & PMf_KEEP) {
c90c0ff4 254 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
533c011a 255 cLOGOP->op_first->op_next = PL_op->op_next;
a0d0e21e 256 }
c737faaf 257#endif
a0d0e21e
LW		 258 RETURN;
259}
260
261PP(pp_substcont)
262{
97aff369 263 dVAR;
39644a26 264 dSP;
c09156bb 265 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
901017d6
AL		 266 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
267 register SV * const dstr = cx->sb_dstr;
a0d0e21e
LW		 268 register char *s = cx->sb_s;
269 register char *m = cx->sb_m;
270 char *orig = cx->sb_orig;
901017d6 271 register REGEXP * const rx = cx->sb_rx;
c445ea15 272 SV *nsv = NULL;
988e6e7e 273 REGEXP *old = PM_GETRE(pm);
f410a211
NC		 274
275 PERL_ASYNC_CHECK();
276
988e6e7e 277 if(old != rx) {
bfed75c6 278 if(old)
988e6e7e 279 ReREFCNT_dec(old);
d6106309 280 PM_SETRE(pm,ReREFCNT_inc(rx));
d8f2cf8a
AB		 281 }
282
d9f97599 283 rxres_restore(&cx->sb_rxres, rx);
01b35787 284 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
c90c0ff4 285
a0d0e21e 286 if (cx->sb_iters++) {
a3b680e6 287 const I32 saviters = cx->sb_iters;
a0d0e21e 288 if (cx->sb_iters > cx->sb_maxiters)
cea2e8a9 289 DIE(aTHX_ "Substitution loop");
a0d0e21e 290
447ee134
DM		 291 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
292
ef07e810 293 /* See "how taint works" above pp_subst() */
20be6587
DM		 294 if (SvTAINTED(TOPs))
295 cx->sb_rxtainted |= SUBST_TAINT_REPL;
447ee134 296 sv_catsv_nomg(dstr, POPs);
2c296965
YO		 297 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
298 s -= RX_GOFS(rx);
a0d0e21e
LW		 299
300 /* Are we done */
134b8cd8
NC		 301 /* I believe that we can't set REXEC_SCREAM here if
302 SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always
303 equal to s. [See the comment before Perl_re_intuit_start(), which is
304 called from Perl_regexec_flags(), which says that it should be when
305 SvSCREAM() is true.] s, cx->sb_strend and orig will be consistent
306 with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ
307 during the match. */
2c296965
YO		 308 if (CxONCE(cx) || s < orig ||
309 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
310 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
311 ((cx->sb_rflags & REXEC_COPY_STR)
312 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
313 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
a0d0e21e 314 {
8ca8a454 315 SV *targ = cx->sb_targ;
748a9306 316
078c425b
JH		 317 assert(cx->sb_strend >= s);
318 if(cx->sb_strend > s) {
319 if (DO_UTF8(dstr) && !SvUTF8(targ))
320 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
321 else
322 sv_catpvn(dstr, s, cx->sb_strend - s);
323 }
20be6587
DM		 324 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
325 cx->sb_rxtainted |= SUBST_TAINT_PAT;
9212bbba 326
8ca8a454
NC		 327 if (pm->op_pmflags & PMf_NONDESTRUCT) {
328 PUSHs(dstr);
329 /* From here on down we're using the copy, and leaving the
330 original untouched. */
331 targ = dstr;
332 }
333 else {
f8c7b90f 334#ifdef PERL_OLD_COPY_ON_WRITE
8ca8a454
NC		 335 if (SvIsCOW(targ)) {
336 sv_force_normal_flags(targ, SV_COW_DROP_PV);
337 } else
ed252734 338#endif
8ca8a454
NC		 339 {
340 SvPV_free(targ);
341 }
342 SvPV_set(targ, SvPVX(dstr));
343 SvCUR_set(targ, SvCUR(dstr));
344 SvLEN_set(targ, SvLEN(dstr));
345 if (DO_UTF8(dstr))
346 SvUTF8_on(targ);
347 SvPV_set(dstr, NULL);
348
4f4d7508 349 mPUSHi(saviters - 1);
48c036b1 350
8ca8a454
NC		 351 (void)SvPOK_only_UTF8(targ);
352 }
5cd24f17 353
20be6587 354 /* update the taint state of various various variables in
ef07e810
DM		 355 * preparation for final exit.
356 * See "how taint works" above pp_subst() */
20be6587
DM		 357 if (PL_tainting) {
358 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
359 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
360 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
361 )
362 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
363
364 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
365 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
366 )
367 SvTAINTED_on(TOPs); /* taint return value */
368 /* needed for mg_set below */
369 PL_tainted = cBOOL(cx->sb_rxtainted &
370 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
371 SvTAINT(TARG);
372 }
373 /* PL_tainted must be correctly set for this mg_set */
374 SvSETMAGIC(TARG);
375 TAINT_NOT;
4633a7c4 376 LEAVE_SCOPE(cx->sb_oldsave);
a0d0e21e
LW		 377 POPSUBST(cx);
378 RETURNOP(pm->op_next);
20be6587 379 /* NOTREACHED */
a0d0e21e 380 }
8e5e9ebe 381 cx->sb_iters = saviters;
a0d0e21e 382 }
07bc277f 383 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
a0d0e21e
LW		 384 m = s;
385 s = orig;
07bc277f 386 cx->sb_orig = orig = RX_SUBBEG(rx);
a0d0e21e
LW		 387 s = orig + (m - s);
388 cx->sb_strend = s + (cx->sb_strend - m);
389 }
07bc277f 390 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
db79b45b 391 if (m > s) {
bfed75c6 392 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
db79b45b
JH		 393 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
394 else
395 sv_catpvn(dstr, s, m-s);
396 }
07bc277f 397 cx->sb_s = RX_OFFS(rx)[0].end + orig;
084916e3 398 { /* Update the pos() information. */
8ca8a454
NC		 399 SV * const sv
400 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
084916e3 401 MAGIC *mg;
7a7f3e45 402 SvUPGRADE(sv, SVt_PVMG);
14befaf4 403 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
d83f0a82 404#ifdef PERL_OLD_COPY_ON_WRITE
51a9ea20 405 if (SvIsCOW(sv))
d83f0a82
NC		 406 sv_force_normal_flags(sv, 0);
407#endif
408 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
409 NULL, 0);
084916e3 410 }
ce474962 411 mg->mg_len = m - orig;
084916e3 412 }
988e6e7e 413 if (old != rx)
d6106309 414 (void)ReREFCNT_inc(rx);
20be6587 415 /* update the taint state of various various variables in preparation
ef07e810
DM		 416 * for calling the code block.
417 * See "how taint works" above pp_subst() */
20be6587
DM		 418 if (PL_tainting) {
419 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
420 cx->sb_rxtainted |= SUBST_TAINT_PAT;
421
422 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
423 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
424 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
425 )
426 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
427
428 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
429 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
8ca8a454
NC		 430 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
431 ? cx->sb_dstr : cx->sb_targ);
20be6587
DM		 432 TAINT_NOT;
433 }
d9f97599 434 rxres_save(&cx->sb_rxres, rx);
af9838cc 435 PL_curpm = pm;
29f2e912 436 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
a0d0e21e
LW		 437}
438
c90c0ff4 439void
864dbfa3 440Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4 441{
442 UV *p = (UV*)*rsp;
443 U32 i;
7918f24d
NC		 444
445 PERL_ARGS_ASSERT_RXRES_SAVE;
96a5add6 446 PERL_UNUSED_CONTEXT;
c90c0ff4 447
07bc277f 448 if (!p || p[1] < RX_NPARENS(rx)) {
f8c7b90f 449#ifdef PERL_OLD_COPY_ON_WRITE
07bc277f 450 i = 7 + RX_NPARENS(rx) * 2;
ed252734 451#else
07bc277f 452 i = 6 + RX_NPARENS(rx) * 2;
ed252734 453#endif
c90c0ff4 454 if (!p)
a02a5408 455 Newx(p, i, UV);
c90c0ff4 456 else
457 Renew(p, i, UV);
458 *rsp = (void*)p;
459 }
460
07bc277f 461 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
cf93c79d 462 RX_MATCH_COPIED_off(rx);
c90c0ff4 463
f8c7b90f 464#ifdef PERL_OLD_COPY_ON_WRITE
bdd9a1b1
NC		 465 *p++ = PTR2UV(RX_SAVED_COPY(rx));
466 RX_SAVED_COPY(rx) = NULL;
ed252734
NC		 467#endif
468
07bc277f 469 *p++ = RX_NPARENS(rx);
c90c0ff4 470
07bc277f
NC		 471 *p++ = PTR2UV(RX_SUBBEG(rx));
472 *p++ = (UV)RX_SUBLEN(rx);
473 for (i = 0; i <= RX_NPARENS(rx); ++i) {
474 *p++ = (UV)RX_OFFS(rx)[i].start;
475 *p++ = (UV)RX_OFFS(rx)[i].end;
c90c0ff4 476 }
477}
478
9c105995
NC		 479static void
480S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4 481{
482 UV *p = (UV*)*rsp;
483 U32 i;
7918f24d
NC		 484
485 PERL_ARGS_ASSERT_RXRES_RESTORE;
96a5add6 486 PERL_UNUSED_CONTEXT;
c90c0ff4 487
ed252734 488 RX_MATCH_COPY_FREE(rx);
cf93c79d 489 RX_MATCH_COPIED_set(rx, *p);
c90c0ff4 490 *p++ = 0;
491
f8c7b90f 492#ifdef PERL_OLD_COPY_ON_WRITE
bdd9a1b1
NC		 493 if (RX_SAVED_COPY(rx))
494 SvREFCNT_dec (RX_SAVED_COPY(rx));
495 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
ed252734
NC		 496 *p++ = 0;
497#endif
498
07bc277f 499 RX_NPARENS(rx) = *p++;
c90c0ff4 500
07bc277f
NC		 501 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
502 RX_SUBLEN(rx) = (I32)(*p++);
503 for (i = 0; i <= RX_NPARENS(rx); ++i) {
504 RX_OFFS(rx)[i].start = (I32)(*p++);
505 RX_OFFS(rx)[i].end = (I32)(*p++);
c90c0ff4 506 }
507}
508
9c105995
NC		 509static void
510S_rxres_free(pTHX_ void **rsp)
c90c0ff4 511{
44f8325f 512 UV * const p = (UV*)*rsp;
7918f24d
NC		 513
514 PERL_ARGS_ASSERT_RXRES_FREE;
96a5add6 515 PERL_UNUSED_CONTEXT;
c90c0ff4 516
517 if (p) {
94010e71
NC		 518#ifdef PERL_POISON
519 void *tmp = INT2PTR(char*,*p);
520 Safefree(tmp);
521 if (*p)
7e337ee0 522 PoisonFree(*p, 1, sizeof(*p));
94010e71 523#else
56431972 524 Safefree(INT2PTR(char*,*p));
94010e71 525#endif
f8c7b90f 526#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 527 if (p[1]) {
528 SvREFCNT_dec (INT2PTR(SV*,p[1]));
529 }
530#endif
c90c0ff4 531 Safefree(p);
4608196e 532 *rsp = NULL;
c90c0ff4 533 }
534}
535
a701009a
DM		 536#define FORM_NUM_BLANK (1<<30)
537#define FORM_NUM_POINT (1<<29)
538
a0d0e21e
LW		 539PP(pp_formline)
540{
97aff369 541 dVAR; dSP; dMARK; dORIGMARK;
823a54a3 542 register SV * const tmpForm = *++MARK;
086b26f3
DM		 543 SV *formsv; /* contains text of original format */
544 register U32 *fpc; /* format ops program counter */
545 register char *t; /* current append position in target string */
546 const char *f; /* current position in format string */
a0d0e21e 547 register I32 arg;
086b26f3
DM		 548 register SV *sv = NULL; /* current item */
549 const char *item = NULL;/* string value of current item */
550 I32 itemsize = 0; /* length of current item, possibly truncated */
551 I32 fieldsize = 0; /* width of current field */
552 I32 lines = 0; /* number of lines that have been output */
553 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
554 const char *chophere = NULL; /* where to chop current item */
f5ada144 555 STRLEN linemark = 0; /* pos of start of line in output */
65202027 556 NV value;
086b26f3 557 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
a0d0e21e 558 STRLEN len;
26e935cf 559 STRLEN linemax; /* estimate of output size in bytes */
1bd51a4c
IH		 560 bool item_is_utf8 = FALSE;
561 bool targ_is_utf8 = FALSE;
bfed75c6 562 const char *fmt;
74e0ddf7 563 MAGIC *mg = NULL;
4ff700b9
DM		 564 U8 *source; /* source of bytes to append */
565 STRLEN to_copy; /* how may bytes to append */
ea60cfe8 566 char trans; /* what chars to translate */
74e0ddf7 567
3808a683 568 mg = doparseform(tmpForm);
a0d0e21e 569
74e0ddf7 570 fpc = (U32*)mg->mg_ptr;
3808a683
DM		 571 /* the actual string the format was compiled from.
572 * with overload etc, this may not match tmpForm */
573 formsv = mg->mg_obj;
574
74e0ddf7 575
3280af22 576 SvPV_force(PL_formtarget, len);
3808a683 577 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
125b9982 578 SvTAINTED_on(PL_formtarget);
1bd51a4c
IH		 579 if (DO_UTF8(PL_formtarget))
580 targ_is_utf8 = TRUE;
26e935cf
DM		 581 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
582 t = SvGROW(PL_formtarget, len + linemax + 1);
583 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
a0d0e21e 584 t += len;
3808a683 585 f = SvPV_const(formsv, len);
a0d0e21e
LW		 586
587 for (;;) {
588 DEBUG_f( {
bfed75c6 589 const char *name = "???";
a0d0e21e
LW		 590 arg = -1;
591 switch (*fpc) {
592 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
593 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
594 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
595 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
596 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
597
598 case FF_CHECKNL: name = "CHECKNL"; break;
599 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
600 case FF_SPACE: name = "SPACE"; break;
601 case FF_HALFSPACE: name = "HALFSPACE"; break;
602 case FF_ITEM: name = "ITEM"; break;
603 case FF_CHOP: name = "CHOP"; break;
604 case FF_LINEGLOB: name = "LINEGLOB"; break;
605 case FF_NEWLINE: name = "NEWLINE"; break;
606 case FF_MORE: name = "MORE"; break;
607 case FF_LINEMARK: name = "LINEMARK"; break;
608 case FF_END: name = "END"; break;
bfed75c6 609 case FF_0DECIMAL: name = "0DECIMAL"; break;
a1b95068 610 case FF_LINESNGL: name = "LINESNGL"; break;
a0d0e21e
LW		 611 }
612 if (arg >= 0)
bf49b057 613 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
a0d0e21e 614 else
bf49b057 615 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
5f80b19c 616 } );
a0d0e21e
LW		 617 switch (*fpc++) {
618 case FF_LINEMARK:
f5ada144 619 linemark = t - SvPVX(PL_formtarget);
a0d0e21e
LW		 620 lines++;
621 gotsome = FALSE;
622 break;
623
624 case FF_LITERAL:
ea60cfe8
DM		 625 to_copy = *fpc++;
626 source = (U8 *)f;
627 f += to_copy;
628 trans = '~';
75645721 629 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
ea60cfe8 630 goto append;
a0d0e21e
LW		 631
632 case FF_SKIP:
633 f += *fpc++;
634 break;
635
636 case FF_FETCH:
637 arg = *fpc++;
638 f += arg;
639 fieldsize = arg;
640
641 if (MARK < SP)
642 sv = *++MARK;
643 else {
3280af22 644 sv = &PL_sv_no;
a2a5de95 645 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
a0d0e21e 646 }
125b9982
NT		 647 if (SvTAINTED(sv))
648 SvTAINTED_on(PL_formtarget);
a0d0e21e
LW		 649 break;
650
651 case FF_CHECKNL:
5a34cab7
NC		 652 {
653 const char *send;
654 const char *s = item = SvPV_const(sv, len);
655 itemsize = len;
656 if (DO_UTF8(sv)) {
657 itemsize = sv_len_utf8(sv);
658 if (itemsize != (I32)len) {
659 I32 itembytes;
660 if (itemsize > fieldsize) {
661 itemsize = fieldsize;
662 itembytes = itemsize;
663 sv_pos_u2b(sv, &itembytes, 0);
664 }
665 else
666 itembytes = len;
667 send = chophere = s + itembytes;
668 while (s < send) {
669 if (*s & ~31)
670 gotsome = TRUE;
671 else if (*s == '\n')
672 break;
673 s++;
674 }
675 item_is_utf8 = TRUE;
676 itemsize = s - item;
677 sv_pos_b2u(sv, &itemsize);
678 break;
a0ed51b3 679 }
a0ed51b3 680 }
5a34cab7
NC		 681 item_is_utf8 = FALSE;
682 if (itemsize > fieldsize)
683 itemsize = fieldsize;
684 send = chophere = s + itemsize;
685 while (s < send) {
686 if (*s & ~31)
687 gotsome = TRUE;
688 else if (*s == '\n')
689 break;
690 s++;
691 }
692 itemsize = s - item;
693 break;
a0ed51b3 694 }
a0d0e21e
LW		 695
696 case FF_CHECKCHOP:
5a34cab7
NC		 697 {
698 const char *s = item = SvPV_const(sv, len);
699 itemsize = len;
700 if (DO_UTF8(sv)) {
701 itemsize = sv_len_utf8(sv);
702 if (itemsize != (I32)len) {
703 I32 itembytes;
704 if (itemsize <= fieldsize) {
705 const char *send = chophere = s + itemsize;
706 while (s < send) {
707 if (*s == '\r') {
708 itemsize = s - item;
a0ed51b3 709 chophere = s;
a0ed51b3 710 break;
5a34cab7
NC		 711 }
712 if (*s++ & ~31)
a0ed51b3 713 gotsome = TRUE;
a0ed51b3 714 }
a0ed51b3 715 }
5a34cab7
NC		 716 else {
717 const char *send;
718 itemsize = fieldsize;
719 itembytes = itemsize;
720 sv_pos_u2b(sv, &itembytes, 0);
721 send = chophere = s + itembytes;
722 while (s < send || (s == send && isSPACE(*s))) {
723 if (isSPACE(*s)) {
724 if (chopspace)
725 chophere = s;
726 if (*s == '\r')
727 break;
728 }
729 else {
730 if (*s & ~31)
731 gotsome = TRUE;
732 if (strchr(PL_chopset, *s))
733 chophere = s + 1;
734 }
735 s++;
736 }
737 itemsize = chophere - item;
738 sv_pos_b2u(sv, &itemsize);
739 }
740 item_is_utf8 = TRUE;
a0d0e21e
LW		 741 break;
742 }
a0d0e21e 743 }
5a34cab7
NC		 744 item_is_utf8 = FALSE;
745 if (itemsize <= fieldsize) {
746 const char *const send = chophere = s + itemsize;
747 while (s < send) {
748 if (*s == '\r') {
749 itemsize = s - item;
a0d0e21e 750 chophere = s;
a0d0e21e 751 break;
5a34cab7
NC		 752 }
753 if (*s++ & ~31)
a0d0e21e 754 gotsome = TRUE;
a0d0e21e 755 }
a0d0e21e 756 }
5a34cab7
NC		 757 else {
758 const char *send;
759 itemsize = fieldsize;
760 send = chophere = s + itemsize;
761 while (s < send || (s == send && isSPACE(*s))) {
762 if (isSPACE(*s)) {
763 if (chopspace)
764 chophere = s;
765 if (*s == '\r')
766 break;
767 }
768 else {
769 if (*s & ~31)
770 gotsome = TRUE;
771 if (strchr(PL_chopset, *s))
772 chophere = s + 1;
773 }
774 s++;
775 }
776 itemsize = chophere - item;
777 }
778 break;
a0d0e21e 779 }
a0d0e21e
LW		 780
781 case FF_SPACE:
782 arg = fieldsize - itemsize;
783 if (arg) {
784 fieldsize -= arg;
785 while (arg-- > 0)
786 *t++ = ' ';
787 }
788 break;
789
790 case FF_HALFSPACE:
791 arg = fieldsize - itemsize;
792 if (arg) {
793 arg /= 2;
794 fieldsize -= arg;
795 while (arg-- > 0)
796 *t++ = ' ';
797 }
798 break;
799
800 case FF_ITEM:
8aa7beb6
DM		 801 to_copy = itemsize;
802 source = (U8 *)item;
803 trans = 1;
804 if (item_is_utf8) {
805 /* convert to_copy from chars to bytes */
806 U8 *s = source;
807 while (to_copy--)
808 s += UTF8SKIP(s);
809 to_copy = s - source;
a0d0e21e 810 }
8aa7beb6 811 goto append;
a0d0e21e
LW		 812
813 case FF_CHOP:
5a34cab7
NC		 814 {
815 const char *s = chophere;
816 if (chopspace) {
af68e756 817 while (isSPACE(*s))
5a34cab7
NC		 818 s++;
819 }
820 sv_chop(sv,s);
821 SvSETMAGIC(sv);
822 break;
a0d0e21e 823 }
a0d0e21e 824
a1b95068
WL		 825 case FF_LINESNGL:
826 chopspace = 0;
a0d0e21e 827 case FF_LINEGLOB:
5a34cab7 828 {
e32383e2 829 const bool oneline = fpc[-1] == FF_LINESNGL;
5a34cab7 830 const char *s = item = SvPV_const(sv, len);
7440a75b 831 const char *const send = s + len;
7440a75b 832
f3f2f1a3 833 item_is_utf8 = DO_UTF8(sv);
a1137ee5 834 if (!len)
7440a75b 835 break;
ea60cfe8 836 trans = 0;
0d21cefe 837 gotsome = TRUE;
a1137ee5 838 chophere = s + len;
4ff700b9
DM		 839 source = (U8 *) s;
840 to_copy = len;
0d21cefe
DM		 841 while (s < send) {
842 if (*s++ == '\n') {
843 if (oneline) {
844 to_copy = s - SvPVX_const(sv) - 1;
845 chophere = s;
846 break;
847 } else {
848 if (s == send) {
0d21cefe
DM		 849 to_copy--;
850 } else
851 lines++;
1bd51a4c 852 }
a0d0e21e 853 }
0d21cefe 854 }
a2c0032b
DM		 855 }
856
ea60cfe8
DM		 857 append:
858 /* append to_copy bytes from source to PL_formstring.
859 * item_is_utf8 implies source is utf8.
860 * if trans, translate certain characters during the copy */
a2c0032b
DM		 861 {
862 U8 *tmp = NULL;
26e935cf 863 STRLEN grow = 0;
0325ce87
DM		 864
865 SvCUR_set(PL_formtarget,
866 t - SvPVX_const(PL_formtarget));
867
0d21cefe
DM		 868 if (targ_is_utf8 && !item_is_utf8) {
869 source = tmp = bytes_to_utf8(source, &to_copy);
0d21cefe
DM		 870 } else {
871 if (item_is_utf8 && !targ_is_utf8) {
f5ada144 872 U8 *s;
0d21cefe 873 /* Upgrade targ to UTF8, and then we reduce it to
0325ce87
DM		 874 a problem we have a simple solution for.
875 Don't need get magic. */
0d21cefe 876 sv_utf8_upgrade_nomg(PL_formtarget);
0325ce87 877 targ_is_utf8 = TRUE;
f5ada144
DM		 878 /* re-calculate linemark */
879 s = (U8*)SvPVX(PL_formtarget);
26e935cf
DM		 880 /* the bytes we initially allocated to append the
881 * whole line may have been gobbled up during the
882 * upgrade, so allocate a whole new line's worth
883 * for safety */
884 grow = linemax;
f5ada144
DM		 885 while (linemark--)
886 s += UTF8SKIP(s);
887 linemark = s - (U8*)SvPVX(PL_formtarget);
e8e72d41 888 }
0d21cefe
DM		 889 /* Easy. They agree. */
890 assert (item_is_utf8 == targ_is_utf8);
891 }
26e935cf
DM		 892 if (!trans)
893 /* @* and ^* are the only things that can exceed
894 * the linemax, so grow by the output size, plus
895 * a whole new form's worth in case of any further
896 * output */
897 grow = linemax + to_copy;
898 if (grow)
899 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
0d21cefe
DM		 900 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
901
902 Copy(source, t, to_copy, char);
ea60cfe8 903 if (trans) {
8aa7beb6
DM		 904 /* blank out ~ or control chars, depending on trans.
905 * works on bytes not chars, so relies on not
906 * matching utf8 continuation bytes */
ea60cfe8
DM		 907 U8 *s = (U8*)t;
908 U8 *send = s + to_copy;
909 while (s < send) {
8aa7beb6
DM		 910 const int ch = *s;
911 if (trans == '~' ? (ch == '~') :
912#ifdef EBCDIC
913 iscntrl(ch)
914#else
915 (!(ch & ~31))
916#endif
917 )
ea60cfe8
DM		 918 *s = ' ';
919 s++;
920 }
921 }
922
0d21cefe
DM		 923 t += to_copy;
924 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
a1137ee5 925 if (tmp)
0d21cefe 926 Safefree(tmp);
5a34cab7 927 break;
a0d0e21e 928 }
a0d0e21e 929
a1b95068
WL		 930 case FF_0DECIMAL:
931 arg = *fpc++;
932#if defined(USE_LONG_DOUBLE)
10edeb5d 933 fmt = (const char *)
a701009a 934 ((arg & FORM_NUM_POINT) ?
10edeb5d 935 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
a1b95068 936#else
10edeb5d 937 fmt = (const char *)
a701009a 938 ((arg & FORM_NUM_POINT) ?
10edeb5d 939 "%#0*.*f" : "%0*.*f");
a1b95068
WL		 940#endif
941 goto ff_dec;
a0d0e21e 942 case FF_DECIMAL:
a0d0e21e 943 arg = *fpc++;
65202027 944#if defined(USE_LONG_DOUBLE)
10edeb5d 945 fmt = (const char *)
a701009a 946 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
65202027 947#else
10edeb5d 948 fmt = (const char *)
a701009a 949 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
65202027 950#endif
a1b95068 951 ff_dec:
784707d5
JP		 952 /* If the field is marked with ^ and the value is undefined,
953 blank it out. */
a701009a 954 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
784707d5
JP		 955 arg = fieldsize;
956 while (arg--)
957 *t++ = ' ';
958 break;
959 }
960 gotsome = TRUE;
961 value = SvNV(sv);
a1b95068 962 /* overflow evidence */
bfed75c6 963 if (num_overflow(value, fieldsize, arg)) {
a1b95068
WL		 964 arg = fieldsize;
965 while (arg--)
966 *t++ = '#';
967 break;
968 }
784707d5
JP		 969 /* Formats aren't yet marked for locales, so assume "yes". */
970 {
971 STORE_NUMERIC_STANDARD_SET_LOCAL();
a701009a
DM		 972 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
973 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
784707d5
JP		 974 RESTORE_NUMERIC_STANDARD();
975 }
976 t += fieldsize;
977 break;
a1b95068 978
a0d0e21e
LW		 979 case FF_NEWLINE:
980 f++;
f5ada144 981 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
a0d0e21e
LW		 982 t++;
983 *t++ = '\n';
984 break;
985
986 case FF_BLANK:
987 arg = *fpc++;
988 if (gotsome) {
989 if (arg) { /* repeat until fields exhausted? */
11f9eeaf
DM		 990 fpc--;
991 goto end;
a0d0e21e
LW		 992 }
993 }
994 else {
f5ada144 995 t = SvPVX(PL_formtarget) + linemark;
a0d0e21e
LW		 996 lines--;
997 }
998 break;
999
1000 case FF_MORE:
5a34cab7
NC		 1001 {
1002 const char *s = chophere;
1003 const char *send = item + len;
1004 if (chopspace) {
af68e756 1005 while (isSPACE(*s) && (s < send))
5a34cab7 1006 s++;
a0d0e21e 1007 }
5a34cab7
NC		 1008 if (s < send) {
1009 char *s1;
1010 arg = fieldsize - itemsize;
1011 if (arg) {
1012 fieldsize -= arg;
1013 while (arg-- > 0)
1014 *t++ = ' ';
1015 }
1016 s1 = t - 3;
1017 if (strnEQ(s1," ",3)) {
1018 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1019 s1--;
1020 }
1021 *s1++ = '.';
1022 *s1++ = '.';
1023 *s1++ = '.';
a0d0e21e 1024 }
5a34cab7 1025 break;
a0d0e21e 1026 }
a0d0e21e 1027 case FF_END:
11f9eeaf 1028 end:
bf2bec63 1029 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
a0d0e21e 1030 *t = '\0';
b15aece3 1031 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1bd51a4c
IH		 1032 if (targ_is_utf8)
1033 SvUTF8_on(PL_formtarget);
3280af22 1034 FmLINES(PL_formtarget) += lines;
a0d0e21e 1035 SP = ORIGMARK;
11f9eeaf
DM		 1036 if (fpc[-1] == FF_BLANK)
1037 RETURNOP(cLISTOP->op_first);
1038 else
1039 RETPUSHYES;
a0d0e21e
LW		 1040 }
1041 }
1042}
1043
1044PP(pp_grepstart)
1045{
27da23d5 1046 dVAR; dSP;
a0d0e21e
LW		 1047 SV *src;
1048
3280af22 1049 if (PL_stack_base + *PL_markstack_ptr == SP) {
a0d0e21e 1050 (void)POPMARK;
54310121 1051 if (GIMME_V == G_SCALAR)
6e449a3a 1052 mXPUSHi(0);
533c011a 1053 RETURNOP(PL_op->op_next->op_next);
a0d0e21e 1054 }
3280af22 1055 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
897d3989
NC		 1056 Perl_pp_pushmark(aTHX); /* push dst */
1057 Perl_pp_pushmark(aTHX); /* push src */
d343c3ef 1058 ENTER_with_name("grep"); /* enter outer scope */
a0d0e21e
LW		 1059
1060 SAVETMPS;
59f00321
RGS		 1061 if (PL_op->op_private & OPpGREP_LEX)
1062 SAVESPTR(PAD_SVl(PL_op->op_targ));
1063 else
1064 SAVE_DEFSV;
d343c3ef 1065 ENTER_with_name("grep_item"); /* enter inner scope */
7766f137 1066 SAVEVPTR(PL_curpm);
a0d0e21e 1067
3280af22 1068 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 1069 SvTEMP_off(src);
59f00321
RGS		 1070 if (PL_op->op_private & OPpGREP_LEX)
1071 PAD_SVl(PL_op->op_targ) = src;
1072 else
414bf5ae 1073 DEFSV_set(src);
a0d0e21e
LW		 1074
1075 PUTBACK;
533c011a 1076 if (PL_op->op_type == OP_MAPSTART)
897d3989 1077 Perl_pp_pushmark(aTHX); /* push top */
533c011a 1078 return ((LOGOP*)PL_op->op_next)->op_other;
a0d0e21e
LW		 1079}
1080
a0d0e21e
LW		 1081PP(pp_mapwhile)
1082{
27da23d5 1083 dVAR; dSP;
f54cb97a 1084 const I32 gimme = GIMME_V;
544f3153 1085 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
a0d0e21e
LW		 1086 I32 count;
1087 I32 shift;
1088 SV** src;
ac27b0f5 1089 SV** dst;
a0d0e21e 1090
544f3153 1091 /* first, move source pointer to the next item in the source list */
3280af22 1092 ++PL_markstack_ptr[-1];
544f3153
GS		 1093
1094 /* if there are new items, push them into the destination list */
4c90a460 1095 if (items && gimme != G_VOID) {
544f3153
GS		 1096 /* might need to make room back there first */
1097 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1098 /* XXX this implementation is very pessimal because the stack
1099 * is repeatedly extended for every set of items. Is possible
1100 * to do this without any stack extension or copying at all
1101 * by maintaining a separate list over which the map iterates
18ef8bea 1102 * (like foreach does). --gsar */
544f3153
GS		 1103
1104 /* everything in the stack after the destination list moves
1105 * towards the end the stack by the amount of room needed */
1106 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1107
1108 /* items to shift up (accounting for the moved source pointer) */
1109 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
18ef8bea
BT		 1110
1111 /* This optimization is by Ben Tilly and it does
1112 * things differently from what Sarathy (gsar)
1113 * is describing. The downside of this optimization is
1114 * that leaves "holes" (uninitialized and hopefully unused areas)
1115 * to the Perl stack, but on the other hand this
1116 * shouldn't be a problem. If Sarathy's idea gets
1117 * implemented, this optimization should become
1118 * irrelevant. --jhi */
1119 if (shift < count)
1120 shift = count; /* Avoid shifting too often --Ben Tilly */
bfed75c6 1121
924508f0
GS		 1122 EXTEND(SP,shift);
1123 src = SP;
1124 dst = (SP += shift);
3280af22
NIS		 1125 PL_markstack_ptr[-1] += shift;
1126 *PL_markstack_ptr += shift;
544f3153 1127 while (count--)
a0d0e21e
LW		 1128 *dst-- = *src--;
1129 }
544f3153 1130 /* copy the new items down to the destination list */
ac27b0f5 1131 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
22023b26 1132 if (gimme == G_ARRAY) {
b2a2a901
DM		 1133 /* add returned items to the collection (making mortal copies
1134 * if necessary), then clear the current temps stack frame
1135 * *except* for those items. We do this splicing the items
1136 * into the start of the tmps frame (so some items may be on
59d53fd6 1137 * the tmps stack twice), then moving PL_tmps_floor above
b2a2a901
DM		 1138 * them, then freeing the frame. That way, the only tmps that
1139 * accumulate over iterations are the return values for map.
1140 * We have to do to this way so that everything gets correctly
1141 * freed if we die during the map.
1142 */
1143 I32 tmpsbase;
1144 I32 i = items;
1145 /* make space for the slice */
1146 EXTEND_MORTAL(items);
1147 tmpsbase = PL_tmps_floor + 1;
1148 Move(PL_tmps_stack + tmpsbase,
1149 PL_tmps_stack + tmpsbase + items,
1150 PL_tmps_ix - PL_tmps_floor,
1151 SV*);
1152 PL_tmps_ix += items;
1153
1154 while (i-- > 0) {
1155 SV *sv = POPs;
1156 if (!SvTEMP(sv))
1157 sv = sv_mortalcopy(sv);
1158 *dst-- = sv;
1159 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1160 }
1161 /* clear the stack frame except for the items */
1162 PL_tmps_floor += items;
1163 FREETMPS;
1164 /* FREETMPS may have cleared the TEMP flag on some of the items */
1165 i = items;
1166 while (i-- > 0)
1167 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
22023b26 1168 }
bfed75c6 1169 else {
22023b26
TP		 1170 /* scalar context: we don't care about which values map returns
1171 * (we use undef here). And so we certainly don't want to do mortal
1172 * copies of meaningless values. */
1173 while (items-- > 0) {
b988aa42 1174 (void)POPs;
22023b26
TP		 1175 *dst-- = &PL_sv_undef;
1176 }
b2a2a901 1177 FREETMPS;
22023b26 1178 }
a0d0e21e 1179 }
b2a2a901
DM		 1180 else {
1181 FREETMPS;
1182 }
d343c3ef 1183 LEAVE_with_name("grep_item"); /* exit inner scope */
a0d0e21e
LW		 1184
1185 /* All done yet? */
3280af22 1186 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
a0d0e21e
LW		 1187
1188 (void)POPMARK; /* pop top */
d343c3ef 1189 LEAVE_with_name("grep"); /* exit outer scope */
a0d0e21e 1190 (void)POPMARK; /* pop src */
3280af22 1191 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 1192 (void)POPMARK; /* pop dst */
3280af22 1193 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 1194 if (gimme == G_SCALAR) {
7cc47870
RGS		 1195 if (PL_op->op_private & OPpGREP_LEX) {
1196 SV* sv = sv_newmortal();
1197 sv_setiv(sv, items);
1198 PUSHs(sv);
1199 }
1200 else {
1201 dTARGET;
1202 XPUSHi(items);
1203 }
a0d0e21e 1204 }
54310121 1205 else if (gimme == G_ARRAY)
1206 SP += items;
a0d0e21e
LW		 1207 RETURN;
1208 }
1209 else {
1210 SV *src;
1211
d343c3ef 1212 ENTER_with_name("grep_item"); /* enter inner scope */
7766f137 1213 SAVEVPTR(PL_curpm);
a0d0e21e 1214
544f3153 1215 /* set $_ to the new source item */
3280af22 1216 src = PL_stack_base[PL_markstack_ptr[-1]];
a0d0e21e 1217 SvTEMP_off(src);
59f00321
RGS		 1218 if (PL_op->op_private & OPpGREP_LEX)
1219 PAD_SVl(PL_op->op_targ) = src;
1220 else
414bf5ae 1221 DEFSV_set(src);
a0d0e21e
LW		 1222
1223 RETURNOP(cLOGOP->op_other);
1224 }
1225}
1226
a0d0e21e
LW		 1227/* Range stuff. */
1228
1229PP(pp_range)
1230{
97aff369 1231 dVAR;
a0d0e21e 1232 if (GIMME == G_ARRAY)
1a67a97c 1233 return NORMAL;
538573f7 1234 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1a67a97c 1235 return cLOGOP->op_other;
538573f7 1236 else
1a67a97c 1237 return NORMAL;
a0d0e21e
LW		 1238}
1239
1240PP(pp_flip)
1241{
97aff369 1242 dVAR;
39644a26 1243 dSP;
a0d0e21e
LW		 1244
1245 if (GIMME == G_ARRAY) {
1a67a97c 1246 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 1247 }
1248 else {
1249 dTOPss;
44f8325f 1250 SV * const targ = PAD_SV(PL_op->op_targ);
bfed75c6 1251 int flip = 0;
790090df 1252
bfed75c6 1253 if (PL_op->op_private & OPpFLIP_LINENUM) {
4e3399f9
YST		 1254 if (GvIO(PL_last_in_gv)) {
1255 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1256 }
1257 else {
fafc274c 1258 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
44f8325f
AL		 1259 if (gv && GvSV(gv))
1260 flip = SvIV(sv) == SvIV(GvSV(gv));
4e3399f9 1261 }
bfed75c6
AL		 1262 } else {
1263 flip = SvTRUE(sv);
1264 }
1265 if (flip) {
a0d0e21e 1266 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 1267 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1268 sv_setiv(targ, 1);
3e3baf6d 1269 SETs(targ);
a0d0e21e
LW		 1270 RETURN;
1271 }
1272 else {
1273 sv_setiv(targ, 0);
924508f0 1274 SP--;
1a67a97c 1275 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 1276 }
1277 }
76f68e9b 1278 sv_setpvs(TARG, "");
a0d0e21e
LW		 1279 SETs(targ);
1280 RETURN;
1281 }
1282}
1283
8e9bbdb9
RGS		 1284/* This code tries to decide if "$left .. $right" should use the
1285 magical string increment, or if the range is numeric (we make
1286 an exception for .."0" [#18165]). AMS 20021031. */
1287
1288#define RANGE_IS_NUMERIC(left,right) ( \
b0e74086
RGS		 1289 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1290 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
e0ab1c0e 1291 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
b15aece3 1292 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
e0ab1c0e 1293 && (!SvOK(right) || looks_like_number(right))))
8e9bbdb9 1294
a0d0e21e
LW		 1295PP(pp_flop)
1296{
97aff369 1297 dVAR; dSP;
a0d0e21e
LW		 1298
1299 if (GIMME == G_ARRAY) {
1300 dPOPPOPssrl;
86cb7173 1301
5b295bef
RD		 1302 SvGETMAGIC(left);
1303 SvGETMAGIC(right);
a0d0e21e 1304
8e9bbdb9 1305 if (RANGE_IS_NUMERIC(left,right)) {
901017d6
AL		 1306 register IV i, j;
1307 IV max;
4fe3f0fa
MHM		 1308 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1309 (SvOK(right) && SvNV(right) > IV_MAX))
d470f89e 1310 DIE(aTHX_ "Range iterator outside integer range");
a0d0e21e
LW		 1311 i = SvIV(left);
1312 max = SvIV(right);
bbce6d69 1313 if (max >= i) {
c1ab3db2
AK		 1314 j = max - i + 1;
1315 EXTEND_MORTAL(j);
1316 EXTEND(SP, j);
bbce6d69 1317 }
c1ab3db2
AK		 1318 else
1319 j = 0;
1320 while (j--) {
901017d6 1321 SV * const sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW		 1322 PUSHs(sv);
1323 }
1324 }
1325 else {
44f8325f 1326 SV * const final = sv_mortalcopy(right);
13c5b33c 1327 STRLEN len;
823a54a3 1328 const char * const tmps = SvPV_const(final, len);
a0d0e21e 1329
901017d6 1330 SV *sv = sv_mortalcopy(left);
13c5b33c 1331 SvPV_force_nolen(sv);
89ea2908 1332 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1333 XPUSHs(sv);
b15aece3 1334 if (strEQ(SvPVX_const(sv),tmps))
89ea2908 1335 break;
a0d0e21e
LW		 1336 sv = sv_2mortal(newSVsv(sv));
1337 sv_inc(sv);
1338 }
a0d0e21e
LW		 1339 }
1340 }
1341 else {
1342 dTOPss;
901017d6 1343 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
4e3399f9 1344 int flop = 0;
a0d0e21e 1345 sv_inc(targ);
4e3399f9
YST		 1346
1347 if (PL_op->op_private & OPpFLIP_LINENUM) {
1348 if (GvIO(PL_last_in_gv)) {
1349 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1350 }
1351 else {
fafc274c 1352 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
4e3399f9
YST		 1353 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1354 }
1355 }
1356 else {
1357 flop = SvTRUE(sv);
1358 }
1359
1360 if (flop) {
a0d0e21e 1361 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
396482e1 1362 sv_catpvs(targ, "E0");
a0d0e21e
LW		 1363 }
1364 SETs(targ);
1365 }
1366
1367 RETURN;
1368}
1369
1370/* Control. */
1371
27da23d5 1372static const char * const context_name[] = {
515afda2 1373 "pseudo-block",
f31522f3 1374 NULL, /* CXt_WHEN never actually needs "block" */
76753e7f 1375 NULL, /* CXt_BLOCK never actually needs "block" */
f31522f3 1376 NULL, /* CXt_GIVEN never actually needs "block" */
76753e7f
NC		 1377 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1378 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1379 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1380 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
515afda2 1381 "subroutine",
76753e7f 1382 "format",
515afda2 1383 "eval",
515afda2 1384 "substitution",
515afda2
NC		 1385};
1386
76e3520e 1387STATIC I32
06b5626a 1388S_dopoptolabel(pTHX_ const char *label)
a0d0e21e 1389{
97aff369 1390 dVAR;
a0d0e21e 1391 register I32 i;
a0d0e21e 1392
7918f24d
NC		 1393 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1394
a0d0e21e 1395 for (i = cxstack_ix; i >= 0; i--) {
901017d6 1396 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1397 switch (CxTYPE(cx)) {
a0d0e21e 1398 case CXt_SUBST:
a0d0e21e 1399 case CXt_SUB:
7766f137 1400 case CXt_FORMAT:
a0d0e21e 1401 case CXt_EVAL:
0a753a76 1402 case CXt_NULL:
a2a5de95
NC		 1403 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1404 context_name[CxTYPE(cx)], OP_NAME(PL_op));
515afda2
NC		 1405 if (CxTYPE(cx) == CXt_NULL)
1406 return -1;
1407 break;
c6fdafd0 1408 case CXt_LOOP_LAZYIV:
d01136d6 1409 case CXt_LOOP_LAZYSV:
3b719c58
NC		 1410 case CXt_LOOP_FOR:
1411 case CXt_LOOP_PLAIN:
7e8f1eac
AD		 1412 {
1413 const char *cx_label = CxLABEL(cx);
1414 if (!cx_label || strNE(label, cx_label) ) {
1c98cc53 1415 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
7e8f1eac 1416 (long)i, cx_label));
a0d0e21e
LW		 1417 continue;
1418 }
1c98cc53 1419 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
a0d0e21e 1420 return i;
7e8f1eac 1421 }
a0d0e21e
LW		 1422 }
1423 }
1424 return i;
1425}
1426
0d863452
RH		 1427
1428
e50aee73 1429I32
864dbfa3 1430Perl_dowantarray(pTHX)
e50aee73 1431{
97aff369 1432 dVAR;
f54cb97a 1433 const I32 gimme = block_gimme();
54310121 1434 return (gimme == G_VOID) ? G_SCALAR : gimme;
1435}
1436
1437I32
864dbfa3 1438Perl_block_gimme(pTHX)
54310121 1439{
97aff369 1440 dVAR;
06b5626a 1441 const I32 cxix = dopoptosub(cxstack_ix);
e50aee73 1442 if (cxix < 0)
46fc3d4c 1443 return G_VOID;
e50aee73 1444
54310121 1445 switch (cxstack[cxix].blk_gimme) {
d2719217
GS		 1446 case G_VOID:
1447 return G_VOID;
54310121 1448 case G_SCALAR:
e50aee73 1449 return G_SCALAR;
54310121 1450 case G_ARRAY:
1451 return G_ARRAY;
1452 default:
cea2e8a9 1453 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS		 1454 /* NOTREACHED */
1455 return 0;
54310121 1456 }
e50aee73
AD		 1457}
1458
78f9721b
SM		 1459I32
1460Perl_is_lvalue_sub(pTHX)
1461{
97aff369 1462 dVAR;
06b5626a 1463 const I32 cxix = dopoptosub(cxstack_ix);
78f9721b
SM		 1464 assert(cxix >= 0); /* We should only be called from inside subs */
1465
bafb2adc
NC		 1466 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1467 return CxLVAL(cxstack + cxix);
78f9721b
SM		 1468 else
1469 return 0;
1470}
1471
76e3520e 1472STATIC I32
901017d6 1473S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9 1474{
97aff369 1475 dVAR;
a0d0e21e 1476 I32 i;
7918f24d
NC		 1477
1478 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1479
a0d0e21e 1480 for (i = startingblock; i >= 0; i--) {
901017d6 1481 register const PERL_CONTEXT * const cx = &cxstk[i];
6b35e009 1482 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1483 default:
1484 continue;
1485 case CXt_EVAL:
1486 case CXt_SUB:
7766f137 1487 case CXt_FORMAT:
1c98cc53 1488 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
a0d0e21e
LW		 1489 return i;
1490 }
1491 }
1492 return i;
1493}
1494
76e3520e 1495STATIC I32
cea2e8a9 1496S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e 1497{
97aff369 1498 dVAR;
a0d0e21e 1499 I32 i;
a0d0e21e 1500 for (i = startingblock; i >= 0; i--) {
06b5626a 1501 register const PERL_CONTEXT *cx = &cxstack[i];
6b35e009 1502 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1503 default:
1504 continue;
1505 case CXt_EVAL:
1c98cc53 1506 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
a0d0e21e
LW		 1507 return i;
1508 }
1509 }
1510 return i;
1511}
1512
76e3520e 1513STATIC I32
cea2e8a9 1514S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e 1515{
97aff369 1516 dVAR;
a0d0e21e 1517 I32 i;
a0d0e21e 1518 for (i = startingblock; i >= 0; i--) {
901017d6 1519 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1520 switch (CxTYPE(cx)) {
a0d0e21e 1521 case CXt_SUBST:
a0d0e21e 1522 case CXt_SUB:
7766f137 1523 case CXt_FORMAT:
a0d0e21e 1524 case CXt_EVAL:
0a753a76 1525 case CXt_NULL:
a2a5de95
NC		 1526 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1527 context_name[CxTYPE(cx)], OP_NAME(PL_op));
515afda2
NC		 1528 if ((CxTYPE(cx)) == CXt_NULL)
1529 return -1;
1530 break;
c6fdafd0 1531 case CXt_LOOP_LAZYIV:
d01136d6 1532 case CXt_LOOP_LAZYSV:
3b719c58
NC		 1533 case CXt_LOOP_FOR:
1534 case CXt_LOOP_PLAIN:
1c98cc53 1535 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
a0d0e21e
LW		 1536 return i;
1537 }
1538 }
1539 return i;
1540}
1541
0d863452
RH		 1542STATIC I32
1543S_dopoptogiven(pTHX_ I32 startingblock)
1544{
97aff369 1545 dVAR;
0d863452
RH		 1546 I32 i;
1547 for (i = startingblock; i >= 0; i--) {
1548 register const PERL_CONTEXT *cx = &cxstack[i];
1549 switch (CxTYPE(cx)) {
1550 default:
1551 continue;
1552 case CXt_GIVEN:
1c98cc53 1553 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
0d863452 1554 return i;
3b719c58
NC		 1555 case CXt_LOOP_PLAIN:
1556 assert(!CxFOREACHDEF(cx));
1557 break;
c6fdafd0 1558 case CXt_LOOP_LAZYIV:
d01136d6 1559 case CXt_LOOP_LAZYSV:
3b719c58 1560 case CXt_LOOP_FOR:
0d863452 1561 if (CxFOREACHDEF(cx)) {
1c98cc53 1562 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
0d863452
RH		 1563 return i;
1564 }
1565 }
1566 }
1567 return i;
1568}
1569
1570STATIC I32
1571S_dopoptowhen(pTHX_ I32 startingblock)
1572{
97aff369 1573 dVAR;
0d863452
RH		 1574 I32 i;
1575 for (i = startingblock; i >= 0; i--) {
1576 register const PERL_CONTEXT *cx = &cxstack[i];
1577 switch (CxTYPE(cx)) {
1578 default:
1579 continue;
1580 case CXt_WHEN:
1c98cc53 1581 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
0d863452
RH		 1582 return i;
1583 }
1584 }
1585 return i;
1586}
1587
a0d0e21e 1588void
864dbfa3 1589Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1590{
97aff369 1591 dVAR;
a0d0e21e
LW		 1592 I32 optype;
1593
f144f1e3
DM		 1594 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1595 return;
1596
a0d0e21e 1597 while (cxstack_ix > cxix) {
b0d9ce38 1598 SV *sv;
06b5626a 1599 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1c98cc53 1600 DEBUG_CX("UNWIND"); \
a0d0e21e 1601 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1602 switch (CxTYPE(cx)) {
c90c0ff4 1603 case CXt_SUBST:
1604 POPSUBST(cx);
1605 continue; /* not break */
a0d0e21e 1606 case CXt_SUB:
b0d9ce38
GS		 1607 POPSUB(cx,sv);
1608 LEAVESUB(sv);
a0d0e21e
LW		 1609 break;
1610 case CXt_EVAL:
1611 POPEVAL(cx);
1612 break;
c6fdafd0 1613 case CXt_LOOP_LAZYIV:
d01136d6 1614 case CXt_LOOP_LAZYSV:
3b719c58
NC		 1615 case CXt_LOOP_FOR:
1616 case CXt_LOOP_PLAIN:
a0d0e21e
LW		 1617 POPLOOP(cx);
1618 break;
0a753a76 1619 case CXt_NULL:
a0d0e21e 1620 break;
7766f137
GS		 1621 case CXt_FORMAT:
1622 POPFORMAT(cx);
1623 break;
a0d0e21e 1624 }
c90c0ff4 1625 cxstack_ix--;
a0d0e21e 1626 }
1b6737cc 1627 PERL_UNUSED_VAR(optype);
a0d0e21e
LW		 1628}
1629
5a844595
GS		 1630void
1631Perl_qerror(pTHX_ SV *err)
1632{
97aff369 1633 dVAR;
7918f24d
NC		 1634
1635 PERL_ARGS_ASSERT_QERROR;
1636
6b2fb389
DM		 1637 if (PL_in_eval) {
1638 if (PL_in_eval & EVAL_KEEPERR) {
1639 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1640 SvPV_nolen_const(err));
1641 }
1642 else
1643 sv_catsv(ERRSV, err);
1644 }
5a844595
GS		 1645 else if (PL_errors)
1646 sv_catsv(PL_errors, err);
1647 else
be2597df 1648 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
13765c85
DM		 1649 if (PL_parser)
1650 ++PL_parser->error_count;
5a844595
GS		 1651}
1652
bb4c52e0 1653void
c5df3096 1654Perl_die_unwind(pTHX_ SV *msv)
a0d0e21e 1655{
27da23d5 1656 dVAR;
c5df3096 1657 SV *exceptsv = sv_mortalcopy(msv);
96d9b9cd 1658 U8 in_eval = PL_in_eval;
c5df3096 1659 PERL_ARGS_ASSERT_DIE_UNWIND;
87582a92 1660
96d9b9cd 1661 if (in_eval) {
a0d0e21e 1662 I32 cxix;
a0d0e21e 1663 I32 gimme;
a0d0e21e 1664
22a30693
Z		 1665 /*
1666 * Historically, perl used to set ERRSV ($@) early in the die
1667 * process and rely on it not getting clobbered during unwinding.
1668 * That sucked, because it was liable to get clobbered, so the
1669 * setting of ERRSV used to emit the exception from eval{} has
1670 * been moved to much later, after unwinding (see just before
1671 * JMPENV_JUMP below). However, some modules were relying on the
1672 * early setting, by examining $@ during unwinding to use it as
1673 * a flag indicating whether the current unwinding was caused by
1674 * an exception. It was never a reliable flag for that purpose,
1675 * being totally open to false positives even without actual
1676 * clobberage, but was useful enough for production code to
1677 * semantically rely on it.
1678 *
1679 * We'd like to have a proper introspective interface that
1680 * explicitly describes the reason for whatever unwinding
1681 * operations are currently in progress, so that those modules
1682 * work reliably and $@ isn't further overloaded. But we don't
1683 * have one yet. In its absence, as a stopgap measure, ERRSV is
1684 * now *additionally* set here, before unwinding, to serve as the
1685 * (unreliable) flag that it used to.
1686 *
1687 * This behaviour is temporary, and should be removed when a
1688 * proper way to detect exceptional unwinding has been developed.
1689 * As of 2010-12, the authors of modules relying on the hack
1690 * are aware of the issue, because the modules failed on
1691 * perls 5.13.{1..7} which had late setting of $@ without this
1692 * early-setting hack.
1693 */
1694 if (!(in_eval & EVAL_KEEPERR)) {
1695 SvTEMP_off(exceptsv);
1696 sv_setsv(ERRSV, exceptsv);
1697 }
1698
5a844595
GS		 1699 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1700 && PL_curstackinfo->si_prev)
1701 {
bac4b2ad 1702 dounwind(-1);
d3acc0f7 1703 POPSTACK;
bac4b2ad 1704 }
e336de0d 1705
a0d0e21e
LW		 1706 if (cxix >= 0) {
1707 I32 optype;
b6494f15 1708 SV *namesv;
35a4481c 1709 register PERL_CONTEXT *cx;
901017d6 1710 SV **newsp;
8f89e5a9
Z		 1711 COP *oldcop;
1712 JMPENV *restartjmpenv;
1713 OP *restartop;
a0d0e21e
LW		 1714
1715 if (cxix < cxstack_ix)
1716 dounwind(cxix);
1717
3280af22 1718 POPBLOCK(cx,PL_curpm);
6b35e009 1719 if (CxTYPE(cx) != CXt_EVAL) {
7d0994e0 1720 STRLEN msglen;
96d9b9cd 1721 const char* message = SvPVx_const(exceptsv, msglen);
10edeb5d 1722 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
bf49b057 1723 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW		 1724 my_exit(1);
1725 }
1726 POPEVAL(cx);
b6494f15 1727 namesv = cx->blk_eval.old_namesv;
8f89e5a9
Z		 1728 oldcop = cx->blk_oldcop;
1729 restartjmpenv = cx->blk_eval.cur_top_env;
1730 restartop = cx->blk_eval.retop;
a0d0e21e
LW		 1731
1732 if (gimme == G_SCALAR)
3280af22
NIS		 1733 *++newsp = &PL_sv_undef;
1734 PL_stack_sp = newsp;
a0d0e21e
LW		 1735
1736 LEAVE;
748a9306 1737
7fb6a879
GS		 1738 /* LEAVE could clobber PL_curcop (see save_re_context())
1739 * XXX it might be better to find a way to avoid messing with
1740 * PL_curcop in save_re_context() instead, but this is a more
1741 * minimal fix --GSAR */
8f89e5a9 1742 PL_curcop = oldcop;
7fb6a879 1743
7a2e2cd6 1744 if (optype == OP_REQUIRE) {
96d9b9cd 1745 const char* const msg = SvPVx_nolen_const(exceptsv);
b6494f15
VP		 1746 (void)hv_store(GvHVn(PL_incgv),
1747 SvPVX_const(namesv), SvCUR(namesv),
27bcc0a7 1748 &PL_sv_undef, 0);
27e90453
DM		 1749 /* note that unlike pp_entereval, pp_require isn't
1750 * supposed to trap errors. So now that we've popped the
1751 * EVAL that pp_require pushed, and processed the error
1752 * message, rethrow the error */
9fed9930
NC		 1753 Perl_croak(aTHX_ "%sCompilation failed in require",
1754 *msg ? msg : "Unknown error\n");
7a2e2cd6 1755 }
c5df3096 1756 if (in_eval & EVAL_KEEPERR) {
7ce09284
Z		 1757 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1758 SvPV_nolen_const(exceptsv));
96d9b9cd
Z		 1759 }
1760 else {
1761 sv_setsv(ERRSV, exceptsv);
1762 }
8f89e5a9
Z		 1763 PL_restartjmpenv = restartjmpenv;
1764 PL_restartop = restartop;
bb4c52e0
GG		 1765 JMPENV_JUMP(3);
1766 /* NOTREACHED */
a0d0e21e
LW		 1767 }
1768 }
87582a92 1769
96d9b9cd 1770 write_to_stderr(exceptsv);
f86702cc 1771 my_failure_exit();
1772 /* NOTREACHED */
a0d0e21e
LW		 1773}
1774
1775PP(pp_xor)
1776{
97aff369 1777 dVAR; dSP; dPOPTOPssrl;
a0d0e21e
LW		 1778 if (SvTRUE(left) != SvTRUE(right))
1779 RETSETYES;
1780 else
1781 RETSETNO;
1782}
1783
8dff4fc5
BM		 1784/*
1785=for apidoc caller_cx
1786
1787The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1788returned C<PERL_CONTEXT> structure can be interrogated to find all the
1789information returned to Perl by C<caller>. Note that XSUBs don't get a
1790stack frame, so C<caller_cx(0, NULL)> will return information for the
1791immediately-surrounding Perl code.
1792
1793This function skips over the automatic calls to C<&DB::sub> made on the
1794behalf of the debugger. If the stack frame requested was a sub called by
1795C<DB::sub>, the return value will be the frame for the call to
1796C<DB::sub>, since that has the correct line number/etc. for the call
1797site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1798frame for the sub call itself.
1799
1800=cut
1801*/
1802
1803const PERL_CONTEXT *
1804Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
a0d0e21e 1805{
a0d0e21e 1806 register I32 cxix = dopoptosub(cxstack_ix);
901017d6
AL		 1807 register const PERL_CONTEXT *cx;
1808 register const PERL_CONTEXT *ccstack = cxstack;
1809 const PERL_SI *top_si = PL_curstackinfo;
27d41816 1810
a0d0e21e 1811 for (;;) {
2c375eb9
GS		 1812 /* we may be in a higher stacklevel, so dig down deeper */
1813 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1814 top_si = top_si->si_prev;
1815 ccstack = top_si->si_cxstack;
1816 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1817 }
8dff4fc5
BM		 1818 if (cxix < 0)
1819 return NULL;
f2a7f298
DG		 1820 /* caller() should not report the automatic calls to &DB::sub */
1821 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
3280af22 1822 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1823 count++;
1824 if (!count--)
1825 break;
2c375eb9 1826 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1827 }
2c375eb9
GS		 1828
1829 cx = &ccstack[cxix];
8dff4fc5
BM		 1830 if (dbcxp) *dbcxp = cx;
1831
7766f137 1832 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
f54cb97a 1833 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2c375eb9 1834 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1835 field below is defined for any cx. */
f2a7f298
DG		 1836 /* caller() should not report the automatic calls to &DB::sub */
1837 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1838 cx = &ccstack[dbcxix];
06a5b730 1839 }
1840
8dff4fc5
BM		 1841 return cx;
1842}
1843
1844PP(pp_caller)
1845{
1846 dVAR;
1847 dSP;
1848 register const PERL_CONTEXT *cx;
1849 const PERL_CONTEXT *dbcx;
1850 I32 gimme;
1851 const char *stashname;
1852 I32 count = 0;
1853
1854 if (MAXARG)
1855 count = POPi;
1856
1857 cx = caller_cx(count, &dbcx);
1858 if (!cx) {
1859 if (GIMME != G_ARRAY) {
1860 EXTEND(SP, 1);
1861 RETPUSHUNDEF;
1862 }
1863 RETURN;
1864 }
1865
ed094faf 1866 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1867 if (GIMME != G_ARRAY) {
27d41816 1868 EXTEND(SP, 1);
ed094faf 1869 if (!stashname)
3280af22 1870 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1871 else {
1872 dTARGET;
ed094faf 1873 sv_setpv(TARG, stashname);
49d8d3a1
MB		 1874 PUSHs(TARG);
1875 }
a0d0e21e
LW		 1876 RETURN;
1877 }
a0d0e21e 1878
b3ca2e83 1879 EXTEND(SP, 11);
27d41816 1880
ed094faf 1881 if (!stashname)
3280af22 1882 PUSHs(&PL_sv_undef);
49d8d3a1 1883 else
6e449a3a
MHM		 1884 mPUSHs(newSVpv(stashname, 0));
1885 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1886 mPUSHi((I32)CopLINE(cx->blk_oldcop));
a0d0e21e
LW		 1887 if (!MAXARG)
1888 RETURN;
7766f137 1889 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
8dff4fc5 1890 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
7766f137 1891 /* So is ccstack[dbcxix]. */
07b8c804 1892 if (isGV(cvgv)) {
561b68a9 1893 SV * const sv = newSV(0);
c445ea15 1894 gv_efullname3(sv, cvgv, NULL);
6e449a3a 1895 mPUSHs(sv);
bf38a478 1896 PUSHs(boolSV(CxHASARGS(cx)));
07b8c804
RGS		 1897 }
1898 else {
84bafc02 1899 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
bf38a478 1900 PUSHs(boolSV(CxHASARGS(cx)));
07b8c804 1901 }
a0d0e21e
LW		 1902 }
1903 else {
84bafc02 1904 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
6e449a3a 1905 mPUSHi(0);
a0d0e21e 1906 }
54310121 1907 gimme = (I32)cx->blk_gimme;
1908 if (gimme == G_VOID)
3280af22 1909 PUSHs(&PL_sv_undef);
54310121 1910 else
98625aca 1911 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
6b35e009 1912 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1913 /* eval STRING */
85a64632 1914 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
4633a7c4 1915 PUSHs(cx->blk_eval.cur_text);
3280af22 1916 PUSHs(&PL_sv_no);
0f79a09d 1917 }
811a4de9 1918 /* require */
0f79a09d 1919 else if (cx->blk_eval.old_namesv) {
6e449a3a 1920 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
3280af22 1921 PUSHs(&PL_sv_yes);
06a5b730 1922 }
811a4de9
GS		 1923 /* eval BLOCK (try blocks have old_namesv == 0) */
1924 else {
1925 PUSHs(&PL_sv_undef);
1926 PUSHs(&PL_sv_undef);
1927 }
4633a7c4 1928 }
a682de96
GS		 1929 else {
1930 PUSHs(&PL_sv_undef);
1931 PUSHs(&PL_sv_undef);
1932 }
bafb2adc 1933 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
ed094faf 1934 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1935 {
66a1b24b
AL		 1936 AV * const ary = cx->blk_sub.argarray;
1937 const int off = AvARRAY(ary) - AvALLOC(ary);
a0d0e21e 1938
5b235299
NC		 1939 if (!PL_dbargs)
1940 Perl_init_dbargs(aTHX);
a0d0e21e 1941
3280af22
NIS		 1942 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1943 av_extend(PL_dbargs, AvFILLp(ary) + off);
1944 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1945 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1946 }
f3aa04c2
GS		 1947 /* XXX only hints propagated via op_private are currently
1948 * visible (others are not easily accessible, since they
1949 * use the global PL_hints) */
6e449a3a 1950 mPUSHi(CopHINTS_get(cx->blk_oldcop));
e476b1b5
GS		 1951 {
1952 SV * mask ;
72dc9ed5 1953 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba 1954
ac27b0f5 1955 if (old_warnings == pWARN_NONE ||
114bafba 1956 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1957 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
ac27b0f5 1958 else if (old_warnings == pWARN_ALL ||
75b6c4ca
RGS		 1959 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1960 /* Get the bit mask for $warnings::Bits{all}, because
1961 * it could have been extended by warnings::register */
1962 SV **bits_all;
6673a63c 1963 HV * const bits = get_hv("warnings::Bits", 0);
017a3ce5 1964 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
75b6c4ca
RGS		 1965 mask = newSVsv(*bits_all);
1966 }
1967 else {
1968 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1969 }
1970 }
e476b1b5 1971 else
72dc9ed5 1972 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
6e449a3a 1973 mPUSHs(mask);
e476b1b5 1974 }
b3ca2e83 1975
c28fe1ec 1976 PUSHs(cx->blk_oldcop->cop_hints_hash ?
20439bc7 1977 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
b3ca2e83 1978 : &PL_sv_undef);
a0d0e21e
LW		 1979 RETURN;
1980}
1981
a0d0e21e
LW		 1982PP(pp_reset)
1983{
97aff369 1984 dVAR;
39644a26 1985 dSP;
10edeb5d 1986 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
11faa288 1987 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1988 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1989 RETURN;
1990}
1991
dd2155a4
DM		 1992/* like pp_nextstate, but used instead when the debugger is active */
1993
a0d0e21e
LW		 1994PP(pp_dbstate)
1995{
27da23d5 1996 dVAR;
533c011a 1997 PL_curcop = (COP*)PL_op;
a0d0e21e 1998 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1999 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 2000 FREETMPS;
2001
f410a211
NC		 2002 PERL_ASYNC_CHECK();
2003
5df8de69
DM		 2004 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2005 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 2006 {
39644a26 2007 dSP;
c09156bb 2008 register PERL_CONTEXT *cx;
f54cb97a 2009 const I32 gimme = G_ARRAY;
eb160463 2010 U8 hasargs;
0bd48802
AL		 2011 GV * const gv = PL_DBgv;
2012 register CV * const cv = GvCV(gv);
a0d0e21e 2013
a0d0e21e 2014 if (!cv)
cea2e8a9 2015 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 2016
aea4f609
DM		 2017 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2018 /* don't do recursive DB::DB call */
a0d0e21e 2019 return NORMAL;
748a9306 2020
a57c6685 2021 ENTER;
4633a7c4
LW		 2022 SAVETMPS;
2023
3280af22 2024 SAVEI32(PL_debug);
55497cff 2025 SAVESTACK_POS();
3280af22 2026 PL_debug = 0;
748a9306 2027 hasargs = 0;
924508f0 2028 SPAGAIN;
748a9306 2029
aed2304a 2030 if (CvISXSUB(cv)) {
c127bd3a
SF		 2031 CvDEPTH(cv)++;
2032 PUSHMARK(SP);
2033 (void)(*CvXSUB(cv))(aTHX_ cv);
2034 CvDEPTH(cv)--;
2035 FREETMPS;
a57c6685 2036 LEAVE;
c127bd3a
SF		 2037 return NORMAL;
2038 }
2039 else {
2040 PUSHBLOCK(cx, CXt_SUB, SP);
2041 PUSHSUB_DB(cx);
2042 cx->blk_sub.retop = PL_op->op_next;
2043 CvDEPTH(cv)++;
2044 SAVECOMPPAD();
2045 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2046 RETURNOP(CvSTART(cv));
2047 }
a0d0e21e
LW		 2048 }
2049 else
2050 return NORMAL;
2051}
2052
b9d76716
VP		 2053STATIC SV **
2054S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2055{
2056 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2057
2058 if (gimme == G_SCALAR) {
2059 if (MARK < SP)
2060 *++newsp = (SvFLAGS(*SP) & flags) ? *SP : sv_mortalcopy(*SP);
2061 else {
2062 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2063 MARK = newsp;
2064 MEXTEND(MARK, 1);
2065 *++MARK = &PL_sv_undef;
2066 return MARK;
2067 }
2068 }
2069 else if (gimme == G_ARRAY) {
2070 /* in case LEAVE wipes old return values */
2071 while (++MARK <= SP) {
2072 if (SvFLAGS(*MARK) & flags)
2073 *++newsp = *MARK;
2074 else {
2075 *++newsp = sv_mortalcopy(*MARK);
2076 TAINT_NOT; /* Each item is independent */
2077 }
2078 }
2079 /* When this function was called with MARK == newsp, we reach this
2080 * point with SP == newsp. */
2081 }
2082
2083 return newsp;
2084}
2085
2b9a6457
VP		 2086PP(pp_enter)
2087{
2088 dVAR; dSP;
2089 register PERL_CONTEXT *cx;
2090 I32 gimme = OP_GIMME(PL_op, -1);
2091
2092 if (gimme == -1) {
2093 if (cxstack_ix >= 0) {
2094 /* If this flag is set, we're just inside a return, so we should
2095 * store the caller's context */
2096 gimme = (PL_op->op_flags & OPf_SPECIAL)
2097 ? block_gimme()
2098 : cxstack[cxstack_ix].blk_gimme;
2099 } else
2100 gimme = G_SCALAR;
2101 }
2102
2103 ENTER_with_name("block");
2104
2105 SAVETMPS;
2106 PUSHBLOCK(cx, CXt_BLOCK, SP);
2107
2108 RETURN;
2109}
2110
2111PP(pp_leave)
2112{
2113 dVAR; dSP;
2114 register PERL_CONTEXT *cx;
2115 SV **newsp;
2116 PMOP *newpm;
2117 I32 gimme;
2118
2119 if (PL_op->op_flags & OPf_SPECIAL) {
2120 cx = &cxstack[cxstack_ix];
2121 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2122 }
2123
2124 POPBLOCK(cx,newpm);
2125
2126 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2127
2128 TAINT_NOT;
f02ea43c 2129 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2b9a6457
VP		 2130 PL_curpm = newpm; /* Don't pop $1 et al till now */
2131
2132 LEAVE_with_name("block");
2133
2134 RETURN;
2135}
2136
a0d0e21e
LW		 2137PP(pp_enteriter)
2138{
27da23d5 2139 dVAR; dSP; dMARK;
c09156bb 2140 register PERL_CONTEXT *cx;
f54cb97a 2141 const I32 gimme = GIMME_V;
df530c37 2142 void *itervar; /* location of the iteration variable */
840fe433 2143 U8 cxtype = CXt_LOOP_FOR;
a0d0e21e 2144
d343c3ef 2145 ENTER_with_name("loop1");
4633a7c4
LW		 2146 SAVETMPS;
2147
aafca525
DM		 2148 if (PL_op->op_targ) { /* "my" variable */
2149 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
14f338dc
DM		 2150 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2151 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2152 SVs_PADSTALE, SVs_PADSTALE);
2153 }
09edbca0 2154 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
89e00a7c 2155#ifdef USE_ITHREADS
df530c37 2156 itervar = PL_comppad;
89e00a7c 2157#else
aafca525 2158 itervar = &PAD_SVl(PL_op->op_targ);
7766f137 2159#endif
54b9620d 2160 }
aafca525 2161 else { /* symbol table variable */
159b6efe 2162 GV * const gv = MUTABLE_GV(POPs);
f83b46a0
DM		 2163 SV** svp = &GvSV(gv);
2164 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
561b68a9 2165 *svp = newSV(0);
df530c37 2166 itervar = (void *)gv;
54b9620d 2167 }
4633a7c4 2168
0d863452
RH		 2169 if (PL_op->op_private & OPpITER_DEF)
2170 cxtype |= CXp_FOR_DEF;
2171
d343c3ef 2172 ENTER_with_name("loop2");
a0d0e21e 2173
7766f137 2174 PUSHBLOCK(cx, cxtype, SP);
df530c37 2175 PUSHLOOP_FOR(cx, itervar, MARK);
533c011a 2176 if (PL_op->op_flags & OPf_STACKED) {
d01136d6
BS		 2177 SV *maybe_ary = POPs;
2178 if (SvTYPE(maybe_ary) != SVt_PVAV) {
89ea2908 2179 dPOPss;
d01136d6 2180 SV * const right = maybe_ary;
984a4bea
RD		 2181 SvGETMAGIC(sv);
2182 SvGETMAGIC(right);
4fe3f0fa 2183 if (RANGE_IS_NUMERIC(sv,right)) {
d01136d6 2184 cx->cx_type &= ~CXTYPEMASK;
c6fdafd0
NC		 2185 cx->cx_type |= CXt_LOOP_LAZYIV;
2186 /* Make sure that no-one re-orders cop.h and breaks our
2187 assumptions */
2188 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
a2309040
JH		 2189#ifdef NV_PRESERVES_UV
2190 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
2191 (SvNV(sv) > (NV)IV_MAX)))
2192 ||
2193 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
2194 (SvNV(right) < (NV)IV_MIN))))
2195#else
2196 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
2197 ||
2198 ((SvNV(sv) > 0) &&
2199 ((SvUV(sv) > (UV)IV_MAX) ||
2200 (SvNV(sv) > (NV)UV_MAX)))))
2201 ||
2202 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2203 ||
2204 ((SvNV(right) > 0) &&
2205 ((SvUV(right) > (UV)IV_MAX) ||
2206 (SvNV(right) > (NV)UV_MAX))))))
2207#endif
076d9a11 2208 DIE(aTHX_ "Range iterator outside integer range");
d01136d6
BS		 2209 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2210 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
d4665a05
DM		 2211#ifdef DEBUGGING
2212 /* for correct -Dstv display */
2213 cx->blk_oldsp = sp - PL_stack_base;
2214#endif
89ea2908 2215 }
3f63a782 2216 else {
d01136d6
BS		 2217 cx->cx_type &= ~CXTYPEMASK;
2218 cx->cx_type |= CXt_LOOP_LAZYSV;
2219 /* Make sure that no-one re-orders cop.h and breaks our
2220 assumptions */
2221 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2222 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2223 cx->blk_loop.state_u.lazysv.end = right;
2224 SvREFCNT_inc(right);
2225 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
267cc4a8
NC		 2226 /* This will do the upgrade to SVt_PV, and warn if the value
2227 is uninitialised. */
10516c54 2228 (void) SvPV_nolen_const(right);
267cc4a8
NC		 2229 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2230 to replace !SvOK() with a pointer to "". */
2231 if (!SvOK(right)) {
2232 SvREFCNT_dec(right);
d01136d6 2233 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
267cc4a8 2234 }
3f63a782 2235 }
89ea2908 2236 }
d01136d6 2237 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
502c6561 2238 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
d01136d6
BS		 2239 SvREFCNT_inc(maybe_ary);
2240 cx->blk_loop.state_u.ary.ix =
2241 (PL_op->op_private & OPpITER_REVERSED) ?
2242 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2243 -1;
ef3e5ea9 2244 }
89ea2908 2245 }
d01136d6
BS		 2246 else { /* iterating over items on the stack */
2247 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
ef3e5ea9 2248 if (PL_op->op_private & OPpITER_REVERSED) {
d01136d6 2249 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
ef3e5ea9
NC		 2250 }
2251 else {
d01136d6 2252 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
ef3e5ea9 2253 }
4633a7c4 2254 }
a0d0e21e
LW		 2255
2256 RETURN;
2257}
2258
2259PP(pp_enterloop)
2260{
27da23d5 2261 dVAR; dSP;
c09156bb 2262 register PERL_CONTEXT *cx;
f54cb97a 2263 const I32 gimme = GIMME_V;
a0d0e21e 2264
d343c3ef 2265 ENTER_with_name("loop1");
a0d0e21e 2266 SAVETMPS;
d343c3ef 2267 ENTER_with_name("loop2");
a0d0e21e 2268
3b719c58
NC		 2269 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2270 PUSHLOOP_PLAIN(cx, SP);
a0d0e21e
LW		 2271
2272 RETURN;
2273}
2274
2275PP(pp_leaveloop)
2276{
27da23d5 2277 dVAR; dSP;
c09156bb 2278 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2279 I32 gimme;
2280 SV **newsp;
2281 PMOP *newpm;
2282 SV **mark;
2283
2284 POPBLOCK(cx,newpm);
3b719c58 2285 assert(CxTYPE_is_LOOP(cx));
4fdae800 2286 mark = newsp;
a8bba7fa 2287 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 2288
a1f49e72 2289 TAINT_NOT;
b9d76716 2290 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
f86702cc 2291 PUTBACK;
2292
a8bba7fa 2293 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 2294 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2295
d343c3ef
GG		 2296 LEAVE_with_name("loop2");
2297 LEAVE_with_name("loop1");
a0d0e21e 2298
f86702cc 2299 return NORMAL;
a0d0e21e
LW		 2300}
2301
3bdf583b
FC		 2302STATIC void
2303S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
d25b0d7b 2304 PERL_CONTEXT *cx, PMOP *newpm)
3bdf583b 2305{
80422e24 2306 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
3bdf583b 2307 if (gimme == G_SCALAR) {
d25b0d7b
FC		 2308 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2309 SV *sv;
2310 if (MARK < SP) {
2311 assert(MARK+1 == SP);
2312 if ((SvPADTMP(TOPs) ||
2313 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2314 == SVf_READONLY
2315 ) &&
2316 !SvSMAGICAL(TOPs)) {
2317 LEAVE;
2318 cxstack_ix--;
2319 POPSUB(cx,sv);
2320 PL_curpm = newpm;
2321 LEAVESUB(sv);
2322 Perl_croak(aTHX_
2323 "Can't return %s from lvalue subroutine",
2324 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2325 : "a readonly value" : "a temporary");
2326 }
2327 else { /* Can be a localized value
2328 EXTEND_MORTAL(1); * subject to deletion. */
2329 PL_tmps_stack[++PL_tmps_ix] = *SP;
2330 SvREFCNT_inc_void(*SP);
2331 *++newsp = *SP;
2332 }
2333 }
2334 else {
2335 /* sub:lvalue{} will take us here. */
2336 LEAVE;
2337 cxstack_ix--;
2338 POPSUB(cx,sv);
2339 PL_curpm = newpm;
2340 LEAVESUB(sv);
2341 Perl_croak(aTHX_
2342 /* diag_listed_as: Can't return %s from lvalue subroutine*/
2343 "Can't return undef from lvalue subroutine"
2344 );
2345 }
2346 }
2347 else if (MARK < SP) {
3bdf583b
FC		 2348 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2349 *++newsp = SvREFCNT_inc(*SP);
2350 FREETMPS;
2351 sv_2mortal(*newsp);
2352 }
2353 else
e08be60b 2354 *++newsp =
e08be60b
FC		 2355 !SvTEMP(*SP)
2356 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2357 : *SP;
3bdf583b 2358 }
0d235c77
FC		 2359 else {
2360 EXTEND(newsp,1);
3bdf583b 2361 *++newsp = &PL_sv_undef;
0d235c77 2362 }
767eda44
FC		 2363 if (CxLVAL(cx) & OPpENTERSUB_DEREF) {
2364 SvGETMAGIC(TOPs);
2365 if (!SvOK(TOPs)) {
2366 U8 deref_type;
2367 if (cx->blk_sub.retop->op_type == OP_RV2SV)
2368 deref_type = OPpDEREF_SV;
2369 else if (cx->blk_sub.retop->op_type == OP_RV2AV)
2370 deref_type = OPpDEREF_AV;
2371 else {
2372 assert(cx->blk_sub.retop->op_type == OP_RV2HV);
2373 deref_type = OPpDEREF_HV;
2374 }
2375 vivify_ref(TOPs, deref_type);
2376 }
2377 }
3bdf583b
FC		 2378 }
2379 else if (gimme == G_ARRAY) {
767eda44 2380 assert (!(CxLVAL(cx) & OPpENTERSUB_DEREF));
80422e24 2381 if (ref || !CxLVAL(cx))
e08be60b
FC		 2382 while (++MARK <= SP)
2383 *++newsp =
2384 SvTEMP(*MARK)
2385 ? *MARK
80422e24
FC		 2386 : ref && SvFLAGS(*MARK) & SVs_PADTMP
2387 ? sv_mortalcopy(*MARK)
2388 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
e08be60b 2389 else while (++MARK <= SP) {
d25b0d7b
FC		 2390 if (*MARK != &PL_sv_undef
2391 && (SvPADTMP(*MARK)
2392 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2393 == SVf_READONLY
2394 )
2395 ) {
2396 SV *sv;
2397 /* Might be flattened array after $#array = */
2398 PUTBACK;
2399 LEAVE;
2400 cxstack_ix--;
2401 POPSUB(cx,sv);
2402 PL_curpm = newpm;
2403 LEAVESUB(sv);
2404 Perl_croak(aTHX_
2405 "Can't return a %s from lvalue subroutine",
2406 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2407 }
2408 else
4bee03f8
FC		 2409 *++newsp =
2410 SvTEMP(*MARK)
2411 ? *MARK
2412 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
3bdf583b
FC		 2413 }
2414 }
2415 PL_stack_sp = newsp;
2416}
2417
a0d0e21e
LW		 2418PP(pp_return)
2419{
27da23d5 2420 dVAR; dSP; dMARK;
c09156bb 2421 register PERL_CONTEXT *cx;
f86702cc 2422 bool popsub2 = FALSE;
b45de488 2423 bool clear_errsv = FALSE;
fa1e92c4 2424 bool lval = FALSE;
767eda44 2425 bool gmagic = FALSE;
a0d0e21e
LW		 2426 I32 gimme;
2427 SV **newsp;
2428 PMOP *newpm;
2429 I32 optype = 0;
b6494f15 2430 SV *namesv;
b0d9ce38 2431 SV *sv;
b263a1ad 2432 OP *retop = NULL;
a0d0e21e 2433
0bd48802
AL		 2434 const I32 cxix = dopoptosub(cxstack_ix);
2435
9850bf21
RH		 2436 if (cxix < 0) {
2437 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2438 * sort block, which is a CXt_NULL
2439 * not a CXt_SUB */
2440 dounwind(0);
d7507f74
RH		 2441 PL_stack_base[1] = *PL_stack_sp;
2442 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 2443 return 0;
2444 }
9850bf21
RH		 2445 else
2446 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e 2447 }
a0d0e21e
LW		 2448 if (cxix < cxstack_ix)
2449 dounwind(cxix);
2450
d7507f74
RH		 2451 if (CxMULTICALL(&cxstack[cxix])) {
2452 gimme = cxstack[cxix].blk_gimme;
2453 if (gimme == G_VOID)
2454 PL_stack_sp = PL_stack_base;
2455 else if (gimme == G_SCALAR) {
2456 PL_stack_base[1] = *PL_stack_sp;
2457 PL_stack_sp = PL_stack_base + 1;
2458 }
9850bf21 2459 return 0;
d7507f74 2460 }
9850bf21 2461
a0d0e21e 2462 POPBLOCK(cx,newpm);
6b35e009 2463 switch (CxTYPE(cx)) {
a0d0e21e 2464 case CXt_SUB:
f86702cc 2465 popsub2 = TRUE;
fa1e92c4 2466 lval = !!CvLVALUE(cx->blk_sub.cv);
f39bc417 2467 retop = cx->blk_sub.retop;
767eda44 2468 gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
5dd42e15 2469 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW		 2470 break;
2471 case CXt_EVAL:
b45de488
GS		 2472 if (!(PL_in_eval & EVAL_KEEPERR))
2473 clear_errsv = TRUE;
a0d0e21e 2474 POPEVAL(cx);
b6494f15 2475 namesv = cx->blk_eval.old_namesv;
f39bc417 2476 retop = cx->blk_eval.retop;
1d76a5c3
GS		 2477 if (CxTRYBLOCK(cx))
2478 break;
748a9306
LW		 2479 if (optype == OP_REQUIRE &&
2480 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2481 {
54310121 2482 /* Unassume the success we assumed earlier. */
b6494f15
VP		 2483 (void)hv_delete(GvHVn(PL_incgv),
2484 SvPVX_const(namesv), SvCUR(namesv),
2485 G_DISCARD);
2486 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
748a9306 2487 }
a0d0e21e 2488 break;
7766f137
GS		 2489 case CXt_FORMAT:
2490 POPFORMAT(cx);
f39bc417 2491 retop = cx->blk_sub.retop;
7766f137 2492 break;
a0d0e21e 2493 default:
cea2e8a9 2494 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 2495 }
2496
a1f49e72 2497 TAINT_NOT;
d25b0d7b 2498 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
3bdf583b
FC		 2499 else {
2500 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 2501 if (MARK < SP) {
2502 if (popsub2) {
a8bba7fa 2503 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
3ed94dc0 2504 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
a29cdaf0
IZ		 2505 *++newsp = SvREFCNT_inc(*SP);
2506 FREETMPS;
2507 sv_2mortal(*newsp);
959e3673
GS		 2508 }
2509 else {
2510 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 2511 FREETMPS;
959e3673
GS		 2512 *++newsp = sv_mortalcopy(sv);
2513 SvREFCNT_dec(sv);
767eda44 2514 if (gmagic) SvGETMAGIC(sv);
a29cdaf0 2515 }
959e3673 2516 }
3ed94dc0 2517 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
767eda44
FC		 2518 *++newsp = *SP;
2519 if (gmagic) SvGETMAGIC(*SP);
2520 }
959e3673 2521 else
767eda44 2522 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 2523 }
2524 else
a29cdaf0 2525 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 2526 }
2527 else
3280af22 2528 *++newsp = &PL_sv_undef;
3bdf583b
FC		 2529 }
2530 else if (gimme == G_ARRAY) {
a1f49e72 2531 while (++MARK <= SP) {
3ed94dc0 2532 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
f86702cc 2533 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2534 TAINT_NOT; /* Each item is independent */
2535 }
3bdf583b
FC		 2536 }
2537 PL_stack_sp = newsp;
a0d0e21e 2538 }
a0d0e21e 2539
5dd42e15 2540 LEAVE;
f86702cc 2541 /* Stack values are safe: */
2542 if (popsub2) {
5dd42e15 2543 cxstack_ix--;
b0d9ce38 2544 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2545 }
b0d9ce38 2546 else
c445ea15 2547 sv = NULL;
3280af22 2548 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2549
b0d9ce38 2550 LEAVESUB(sv);
8433848b 2551 if (clear_errsv) {
ab69dbc2 2552 CLEAR_ERRSV();
8433848b 2553 }
f39bc417 2554 return retop;
a0d0e21e
LW		 2555}
2556
4f443c3d
FC		 2557/* This duplicates parts of pp_leavesub, so that it can share code with
2558 * pp_return */
2559PP(pp_leavesublv)
2560{
2561 dVAR; dSP;
4f443c3d
FC		 2562 SV **newsp;
2563 PMOP *newpm;
2564 I32 gimme;
2565 register PERL_CONTEXT *cx;
2566 SV *sv;
2567
2568 if (CxMULTICALL(&cxstack[cxstack_ix]))
2569 return 0;
2570
2571 POPBLOCK(cx,newpm);
2572 cxstack_ix++; /* temporarily protect top context */
2573 assert(CvLVALUE(cx->blk_sub.cv));
2574
2575 TAINT_NOT;
2576
0d235c77 2577 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
4f443c3d
FC		 2578
2579 LEAVE;
2580 cxstack_ix--;
2581 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2582 PL_curpm = newpm; /* ... and pop $1 et al */
2583
2584 LEAVESUB(sv);
2585 return cx->blk_sub.retop;
2586}
2587
a0d0e21e
LW		 2588PP(pp_last)
2589{
27da23d5 2590 dVAR; dSP;
a0d0e21e 2591 I32 cxix;
c09156bb 2592 register PERL_CONTEXT *cx;
f86702cc 2593 I32 pop2 = 0;
a0d0e21e 2594 I32 gimme;
8772537c 2595 I32 optype;
b263a1ad 2596 OP *nextop = NULL;
a0d0e21e
LW		 2597 SV **newsp;
2598 PMOP *newpm;
a8bba7fa 2599 SV **mark;
c445ea15 2600 SV *sv = NULL;
9d4ba2ae 2601
a0d0e21e 2602
533c011a 2603 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2604 cxix = dopoptoloop(cxstack_ix);
2605 if (cxix < 0)
a651a37d 2606 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 2607 }
2608 else {
2609 cxix = dopoptolabel(cPVOP->op_pv);
2610 if (cxix < 0)
cea2e8a9 2611 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2612 }
2613 if (cxix < cxstack_ix)
2614 dounwind(cxix);
2615
2616 POPBLOCK(cx,newpm);
5dd42e15 2617 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2618 mark = newsp;
6b35e009 2619 switch (CxTYPE(cx)) {
c6fdafd0 2620 case CXt_LOOP_LAZYIV:
d01136d6 2621 case CXt_LOOP_LAZYSV:
3b719c58
NC		 2622 case CXt_LOOP_FOR:
2623 case CXt_LOOP_PLAIN:
2624 pop2 = CxTYPE(cx);
a8bba7fa 2625 newsp = PL_stack_base + cx->blk_loop.resetsp;
022eaa24 2626 nextop = cx->blk_loop.my_op->op_lastop->op_next;
a0d0e21e 2627 break;
f86702cc 2628 case CXt_SUB:
f86702cc 2629 pop2 = CXt_SUB;
f39bc417 2630 nextop = cx->blk_sub.retop;
a0d0e21e 2631 break;
f86702cc 2632 case CXt_EVAL:
2633 POPEVAL(cx);
f39bc417 2634 nextop = cx->blk_eval.retop;
a0d0e21e 2635 break;
7766f137
GS		 2636 case CXt_FORMAT:
2637 POPFORMAT(cx);
f39bc417 2638 nextop = cx->blk_sub.retop;
7766f137 2639 break;
a0d0e21e 2640 default:
cea2e8a9 2641 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 2642 }
2643
a1f49e72 2644 TAINT_NOT;
b9d76716
VP		 2645 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
2646 pop2 == CXt_SUB ? SVs_TEMP : 0);
f86702cc 2647 PUTBACK;
2648
5dd42e15
DM		 2649 LEAVE;
2650 cxstack_ix--;
f86702cc 2651 /* Stack values are safe: */
2652 switch (pop2) {
c6fdafd0 2653 case CXt_LOOP_LAZYIV:
3b719c58 2654 case CXt_LOOP_PLAIN:
d01136d6 2655 case CXt_LOOP_LAZYSV:
3b719c58 2656 case CXt_LOOP_FOR:
a8bba7fa 2657 POPLOOP(cx); /* release loop vars ... */
4fdae800 2658 LEAVE;
f86702cc 2659 break;
2660 case CXt_SUB:
b0d9ce38 2661 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2662 break;
a0d0e21e 2663 }
3280af22 2664 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2665
b0d9ce38 2666 LEAVESUB(sv);
9d4ba2ae
AL		 2667 PERL_UNUSED_VAR(optype);
2668 PERL_UNUSED_VAR(gimme);
f86702cc 2669 return nextop;
a0d0e21e
LW		 2670}
2671
2672PP(pp_next)
2673{
27da23d5 2674 dVAR;
a0d0e21e 2675 I32 cxix;
c09156bb 2676 register PERL_CONTEXT *cx;
85538317 2677 I32 inner;
a0d0e21e 2678
533c011a 2679 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2680 cxix = dopoptoloop(cxstack_ix);
2681 if (cxix < 0)
a651a37d 2682 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 2683 }
2684 else {
2685 cxix = dopoptolabel(cPVOP->op_pv);
2686 if (cxix < 0)
cea2e8a9 2687 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2688 }
2689 if (cxix < cxstack_ix)
2690 dounwind(cxix);
2691
85538317
GS		 2692 /* clear off anything above the scope we're re-entering, but
2693 * save the rest until after a possible continue block */
2694 inner = PL_scopestack_ix;
1ba6ee2b 2695 TOPBLOCK(cx);
85538317
GS		 2696 if (PL_scopestack_ix < inner)
2697 leave_scope(PL_scopestack[PL_scopestack_ix]);
3a1b2b9e 2698 PL_curcop = cx->blk_oldcop;
d57ce4df 2699 return (cx)->blk_loop.my_op->op_nextop;
a0d0e21e
LW		 2700}
2701
2702PP(pp_redo)
2703{
27da23d5 2704 dVAR;
a0d0e21e 2705 I32 cxix;
c09156bb 2706 register PERL_CONTEXT *cx;
a0d0e21e 2707 I32 oldsave;
a034e688 2708 OP* redo_op;
a0d0e21e 2709
533c011a 2710 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2711 cxix = dopoptoloop(cxstack_ix);
2712 if (cxix < 0)
a651a37d 2713 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 2714 }
2715 else {
2716 cxix = dopoptolabel(cPVOP->op_pv);
2717 if (cxix < 0)
cea2e8a9 2718 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2719 }
2720 if (cxix < cxstack_ix)
2721 dounwind(cxix);
2722
022eaa24 2723 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
a034e688
DM		 2724 if (redo_op->op_type == OP_ENTER) {
2725 /* pop one less context to avoid $x being freed in while (my $x..) */
2726 cxstack_ix++;
2727 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2728 redo_op = redo_op->op_next;
2729 }
2730
a0d0e21e 2731 TOPBLOCK(cx);
3280af22 2732 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2733 LEAVE_SCOPE(oldsave);
936c78b5 2734 FREETMPS;
3a1b2b9e 2735 PL_curcop = cx->blk_oldcop;
a034e688 2736 return redo_op;
a0d0e21e
LW		 2737}
2738
0824fdcb 2739STATIC OP *
bfed75c6 2740S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2741{
97aff369 2742 dVAR;
a0d0e21e 2743 OP **ops = opstack;
bfed75c6 2744 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2745
7918f24d
NC		 2746 PERL_ARGS_ASSERT_DOFINDLABEL;
2747
fc36a67e 2748 if (ops >= oplimit)
cea2e8a9 2749 Perl_croak(aTHX_ too_deep);
11343788
MB		 2750 if (o->op_type == OP_LEAVE ||
2751 o->op_type == OP_SCOPE ||
2752 o->op_type == OP_LEAVELOOP ||
33d34e4c 2753 o->op_type == OP_LEAVESUB ||
11343788 2754 o->op_type == OP_LEAVETRY)
fc36a67e 2755 {
5dc0d613 2756 *ops++ = cUNOPo->op_first;
fc36a67e 2757 if (ops >= oplimit)
cea2e8a9 2758 Perl_croak(aTHX_ too_deep);
fc36a67e 2759 }
c4aa4e48 2760 *ops = 0;
11343788 2761 if (o->op_flags & OPf_KIDS) {
aec46f14 2762 OP *kid;
a0d0e21e 2763 /* First try all the kids at this level, since that's likeliest. */
11343788 2764 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
7e8f1eac
AD		 2765 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2766 const char *kid_label = CopLABEL(kCOP);
2767 if (kid_label && strEQ(kid_label, label))
2768 return kid;
2769 }
a0d0e21e 2770 }
11343788 2771 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2772 if (kid == PL_lastgotoprobe)
a0d0e21e 2773 continue;
ed8d0fe2
SM		 2774 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2775 if (ops == opstack)
2776 *ops++ = kid;
2777 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2778 ops[-1]->op_type == OP_DBSTATE)
2779 ops[-1] = kid;
2780 else
2781 *ops++ = kid;
2782 }
155aba94 2783 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2784 return o;
a0d0e21e
LW		 2785 }
2786 }
c4aa4e48 2787 *ops = 0;
a0d0e21e
LW		 2788 return 0;
2789}
2790
a0d0e21e
LW		 2791PP(pp_goto)
2792{
27da23d5 2793 dVAR; dSP;
cbbf8932 2794 OP *retop = NULL;
a0d0e21e 2795 I32 ix;
c09156bb 2796 register PERL_CONTEXT *cx;
fc36a67e 2797#define GOTO_DEPTH 64
2798 OP *enterops[GOTO_DEPTH];
cbbf8932 2799 const char *label = NULL;
bfed75c6
AL		 2800 const bool do_dump = (PL_op->op_type == OP_DUMP);
2801 static const char must_have_label[] = "goto must have label";
a0d0e21e 2802
533c011a 2803 if (PL_op->op_flags & OPf_STACKED) {
9d4ba2ae 2804 SV * const sv = POPs;
a0d0e21e
LW		 2805
2806 /* This egregious kludge implements goto &subroutine */
2807 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2808 I32 cxix;
c09156bb 2809 register PERL_CONTEXT *cx;
ea726b52 2810 CV *cv = MUTABLE_CV(SvRV(sv));
a0d0e21e
LW		 2811 SV** mark;
2812 I32 items = 0;
2813 I32 oldsave;
b1464ded 2814 bool reified = 0;
a0d0e21e 2815
e8f7dd13 2816 retry:
4aa0a1f7 2817 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2818 const GV * const gv = CvGV(cv);
e8f7dd13 2819 if (gv) {
7fc63493 2820 GV *autogv;
e8f7dd13
GS		 2821 SV *tmpstr;
2822 /* autoloaded stub? */
2823 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2824 goto retry;
2825 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2826 GvNAMELEN(gv), FALSE);
2827 if (autogv && (cv = GvCV(autogv)))
2828 goto retry;
2829 tmpstr = sv_newmortal();
c445ea15 2830 gv_efullname3(tmpstr, gv, NULL);
be2597df 2831 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
4aa0a1f7 2832 }
cea2e8a9 2833 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2834 }
2835
a0d0e21e 2836 /* First do some returnish stuff. */
b37c2d43 2837 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
71fc2216 2838 FREETMPS;
a0d0e21e
LW		 2839 cxix = dopoptosub(cxstack_ix);
2840 if (cxix < 0)
cea2e8a9 2841 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2842 if (cxix < cxstack_ix)
2843 dounwind(cxix);
2844 TOPBLOCK(cx);
2d43a17f 2845 SPAGAIN;
564abe23 2846 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2d43a17f 2847 if (CxTYPE(cx) == CXt_EVAL) {
c74ace89
DM		 2848 if (CxREALEVAL(cx))
2849 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2850 else
2851 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2d43a17f 2852 }
9850bf21
RH		 2853 else if (CxMULTICALL(cx))
2854 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
bafb2adc 2855 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
d8b46c1b 2856 /* put @_ back onto stack */
a0d0e21e 2857 AV* av = cx->blk_sub.argarray;
bfed75c6 2858
93965878 2859 items = AvFILLp(av) + 1;
a45cdc79
DM		 2860 EXTEND(SP, items+1); /* @_ could have been extended. */
2861 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS		 2862 SvREFCNT_dec(GvAV(PL_defgv));
2863 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2864 CLEAR_ARGARRAY(av);
d8b46c1b 2865 /* abandon @_ if it got reified */
62b1ebc2 2866 if (AvREAL(av)) {
b1464ded
DM		 2867 reified = 1;
2868 SvREFCNT_dec(av);
d8b46c1b
GS		 2869 av = newAV();
2870 av_extend(av, items-1);
11ca45c0 2871 AvREIFY_only(av);
ad64d0ec 2872 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
62b1ebc2 2873 }
a0d0e21e 2874 }
aed2304a 2875 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
890ce7af 2876 AV* const av = GvAV(PL_defgv);
1fa4e549 2877 items = AvFILLp(av) + 1;
a45cdc79
DM		 2878 EXTEND(SP, items+1); /* @_ could have been extended. */
2879 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2880 }
a45cdc79
DM		 2881 mark = SP;
2882 SP += items;
6b35e009 2883 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2884 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2885 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2886 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2887 LEAVE_SCOPE(oldsave);
2888
2889 /* Now do some callish stuff. */
2890 SAVETMPS;
5023d17a 2891 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
aed2304a 2892 if (CvISXSUB(cv)) {
b37c2d43 2893 OP* const retop = cx->blk_sub.retop;
9410e98d
RB		 2894 SV **newsp __attribute__unused__;
2895 I32 gimme __attribute__unused__;
b1464ded
DM		 2896 if (reified) {
2897 I32 index;
2898 for (index=0; index<items; index++)
2899 sv_2mortal(SP[-index]);
2900 }
1fa4e549 2901
b37c2d43
AL		 2902 /* XS subs don't have a CxSUB, so pop it */
2903 POPBLOCK(cx, PL_curpm);
2904 /* Push a mark for the start of arglist */
2905 PUSHMARK(mark);
2906 PUTBACK;
2907 (void)(*CvXSUB(cv))(aTHX_ cv);
a57c6685 2908 LEAVE;
5eff7df7 2909 return retop;
a0d0e21e
LW		 2910 }
2911 else {
b37c2d43 2912 AV* const padlist = CvPADLIST(cv);
6b35e009 2913 if (CxTYPE(cx) == CXt_EVAL) {
85a64632 2914 PL_in_eval = CxOLD_IN_EVAL(cx);
3280af22 2915 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22 2916 cx->cx_type = CXt_SUB;
b150fb22 2917 }
a0d0e21e 2918 cx->blk_sub.cv = cv;
1a5b3db4 2919 cx->blk_sub.olddepth = CvDEPTH(cv);
dd2155a4 2920
a0d0e21e
LW		 2921 CvDEPTH(cv)++;
2922 if (CvDEPTH(cv) < 2)
74c765eb 2923 SvREFCNT_inc_simple_void_NN(cv);
dd2155a4 2924 else {
2b9dff67 2925 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
44a8e56a 2926 sub_crush_depth(cv);
26019298 2927 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2928 }
fd617465
DM		 2929 SAVECOMPPAD();
2930 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
bafb2adc 2931 if (CxHASARGS(cx))
6d4ff0d2 2932 {
502c6561 2933 AV *const av = MUTABLE_AV(PAD_SVl(0));
a0d0e21e 2934
3280af22 2935 cx->blk_sub.savearray = GvAV(PL_defgv);
502c6561 2936 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
dd2155a4 2937 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2938 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2939
2940 if (items >= AvMAX(av) + 1) {
b37c2d43 2941 SV **ary = AvALLOC(av);
a0d0e21e
LW		 2942 if (AvARRAY(av) != ary) {
2943 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 2944 AvARRAY(av) = ary;
a0d0e21e
LW		 2945 }
2946 if (items >= AvMAX(av) + 1) {
2947 AvMAX(av) = items - 1;
2948 Renew(ary,items+1,SV*);
2949 AvALLOC(av) = ary;
9c6bc640 2950 AvARRAY(av) = ary;
a0d0e21e
LW		 2951 }
2952 }
a45cdc79 2953 ++mark;
a0d0e21e 2954 Copy(mark,AvARRAY(av),items,SV*);
93965878 2955 AvFILLp(av) = items - 1;
d8b46c1b 2956 assert(!AvREAL(av));
b1464ded
DM		 2957 if (reified) {
2958 /* transfer 'ownership' of refcnts to new @_ */
2959 AvREAL_on(av);
2960 AvREIFY_off(av);
2961 }
a0d0e21e
LW		 2962 while (items--) {
2963 if (*mark)
2964 SvTEMP_off(*mark);
2965 mark++;
2966 }
2967 }
491527d0 2968 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
005a8a35 2969 Perl_get_db_sub(aTHX_ NULL, cv);
b37c2d43 2970 if (PERLDB_GOTO) {
b96d8cd9 2971 CV * const gotocv = get_cvs("DB::goto", 0);
b37c2d43
AL		 2972 if (gotocv) {
2973 PUSHMARK( PL_stack_sp );
ad64d0ec 2974 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
b37c2d43
AL		 2975 PL_stack_sp--;
2976 }
491527d0 2977 }
1ce6579f 2978 }
a0d0e21e
LW		 2979 RETURNOP(CvSTART(cv));
2980 }
2981 }
1614b0e3 2982 else {
0510663f 2983 label = SvPV_nolen_const(sv);
1614b0e3 2984 if (!(do_dump || *label))
cea2e8a9 2985 DIE(aTHX_ must_have_label);
1614b0e3 2986 }
a0d0e21e 2987 }
533c011a 2988 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2989 if (! do_dump)
cea2e8a9 2990 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2991 }
2992 else
2993 label = cPVOP->op_pv;
2994
f410a211
NC		 2995 PERL_ASYNC_CHECK();
2996
a0d0e21e 2997 if (label && *label) {
cbbf8932 2998 OP *gotoprobe = NULL;
3b2447bc 2999 bool leaving_eval = FALSE;
33d34e4c 3000 bool in_block = FALSE;
cbbf8932 3001 PERL_CONTEXT *last_eval_cx = NULL;
a0d0e21e
LW		 3002
3003 /* find label */
3004
d4c19fe8 3005 PL_lastgotoprobe = NULL;
a0d0e21e
LW		 3006 *enterops = 0;
3007 for (ix = cxstack_ix; ix >= 0; ix--) {
3008 cx = &cxstack[ix];
6b35e009 3009 switch (CxTYPE(cx)) {
a0d0e21e 3010 case CXt_EVAL:
3b2447bc 3011 leaving_eval = TRUE;
971ecbe6 3012 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH		 3013 gotoprobe = (last_eval_cx ?
3014 last_eval_cx->blk_eval.old_eval_root :
3015 PL_eval_root);
3016 last_eval_cx = cx;
9c5794fe
RH		 3017 break;
3018 }
3019 /* else fall through */
c6fdafd0 3020 case CXt_LOOP_LAZYIV:
d01136d6 3021 case CXt_LOOP_LAZYSV:
3b719c58
NC		 3022 case CXt_LOOP_FOR:
3023 case CXt_LOOP_PLAIN:
bb5aedc1
VP		 3024 case CXt_GIVEN:
3025 case CXt_WHEN:
a0d0e21e
LW		 3026 gotoprobe = cx->blk_oldcop->op_sibling;
3027 break;
3028 case CXt_SUBST:
3029 continue;
3030 case CXt_BLOCK:
33d34e4c 3031 if (ix) {
a0d0e21e 3032 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE		 3033 in_block = TRUE;
3034 } else
3280af22 3035 gotoprobe = PL_main_root;
a0d0e21e 3036 break;
b3933176 3037 case CXt_SUB:
9850bf21 3038 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
b3933176
CS		 3039 gotoprobe = CvROOT(cx->blk_sub.cv);
3040 break;
3041 }
3042 /* FALL THROUGH */
7766f137 3043 case CXt_FORMAT:
0a753a76 3044 case CXt_NULL:
a651a37d 3045 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 3046 default:
3047 if (ix)
cea2e8a9 3048 DIE(aTHX_ "panic: goto");
3280af22 3049 gotoprobe = PL_main_root;
a0d0e21e
LW		 3050 break;
3051 }
2b597662
GS		 3052 if (gotoprobe) {
3053 retop = dofindlabel(gotoprobe, label,
3054 enterops, enterops + GOTO_DEPTH);
3055 if (retop)
3056 break;
eae48c89
Z		 3057 if (gotoprobe->op_sibling &&
3058 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3059 gotoprobe->op_sibling->op_sibling) {
3060 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3061 label, enterops, enterops + GOTO_DEPTH);
3062 if (retop)
3063 break;
3064 }
2b597662 3065 }
3280af22 3066 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 3067 }
3068 if (!retop)
cea2e8a9 3069 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 3070
3b2447bc
RH		 3071 /* if we're leaving an eval, check before we pop any frames
3072 that we're not going to punt, otherwise the error
3073 won't be caught */
3074
3075 if (leaving_eval && *enterops && enterops[1]) {
3076 I32 i;
3077 for (i = 1; enterops[i]; i++)
3078 if (enterops[i]->op_type == OP_ENTERITER)
3079 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3080 }
3081
b500e03b
GG		 3082 if (*enterops && enterops[1]) {
3083 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3084 if (enterops[i])
3085 deprecate("\"goto\" to jump into a construct");
3086 }
3087
a0d0e21e
LW		 3088 /* pop unwanted frames */
3089
3090 if (ix < cxstack_ix) {
3091 I32 oldsave;
3092
3093 if (ix < 0)
3094 ix = 0;
3095 dounwind(ix);
3096 TOPBLOCK(cx);
3280af22 3097 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 3098 LEAVE_SCOPE(oldsave);
3099 }
3100
3101 /* push wanted frames */
3102
748a9306 3103 if (*enterops && enterops[1]) {
0bd48802 3104 OP * const oldop = PL_op;
33d34e4c
AE		 3105 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3106 for (; enterops[ix]; ix++) {
533c011a 3107 PL_op = enterops[ix];
84902520
TB		 3108 /* Eventually we may want to stack the needed arguments
3109 * for each op. For now, we punt on the hard ones. */
533c011a 3110 if (PL_op->op_type == OP_ENTERITER)
894356b3 3111 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
16c91539 3112 PL_op->op_ppaddr(aTHX);
a0d0e21e 3113 }
533c011a 3114 PL_op = oldop;
a0d0e21e
LW		 3115 }
3116 }
3117
3118 if (do_dump) {
a5f75d66 3119#ifdef VMS
6b88bc9c 3120 if (!retop) retop = PL_main_start;
a5f75d66 3121#endif
3280af22
NIS		 3122 PL_restartop = retop;
3123 PL_do_undump = TRUE;
a0d0e21e
LW		 3124
3125 my_unexec();
3126
3280af22
NIS		 3127 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3128 PL_do_undump = FALSE;
a0d0e21e
LW		 3129 }
3130
3131 RETURNOP(retop);
3132}
3133
3134PP(pp_exit)
3135{
97aff369 3136 dVAR;
39644a26 3137 dSP;
a0d0e21e
LW		 3138 I32 anum;
3139
3140 if (MAXARG < 1)
3141 anum = 0;
ff0cee69 3142 else {
a0d0e21e 3143 anum = SvIVx(POPs);
d98f61e7
GS		 3144#ifdef VMS
3145 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 3146 anum = 0;
96e176bf 3147 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69 3148#endif
3149 }
cc3604b1 3150 PL_exit_flags |= PERL_EXIT_EXPECTED;
81d86705
NC		 3151#ifdef PERL_MAD
3152 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3153 if (anum || !(PL_minus_c && PL_madskills))
3154 my_exit(anum);
3155#else
a0d0e21e 3156 my_exit(anum);
81d86705 3157#endif
3280af22 3158 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 3159 RETURN;
3160}
3161
a0d0e21e
LW		 3162/* Eval. */
3163
0824fdcb 3164STATIC void
cea2e8a9 3165S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 3166{
504618e9 3167 const char *s = SvPVX_const(sv);
890ce7af 3168 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 3169 I32 line = 1;
a0d0e21e 3170
7918f24d
NC		 3171 PERL_ARGS_ASSERT_SAVE_LINES;
3172
a0d0e21e 3173 while (s && s < send) {
f54cb97a 3174 const char *t;
b9f83d2f 3175 SV * const tmpstr = newSV_type(SVt_PVMG);
a0d0e21e 3176
1d963ff3 3177 t = (const char *)memchr(s, '\n', send - s);
a0d0e21e
LW		 3178 if (t)
3179 t++;
3180 else
3181 t = send;
3182
3183 sv_setpvn(tmpstr, s, t - s);
3184 av_store(array, line++, tmpstr);
3185 s = t;
3186 }
3187}
3188
22f16304
RU		 3189/*
3190=for apidoc docatch
3191
3192Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3193
31940 is used as continue inside eval,
3195
31963 is used for a die caught by an inner eval - continue inner loop
3197
3198See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3199establish a local jmpenv to handle exception traps.
3200
3201=cut
3202*/
0824fdcb 3203STATIC OP *
cea2e8a9 3204S_docatch(pTHX_ OP *o)
1e422769 3205{
97aff369 3206 dVAR;
6224f72b 3207 int ret;
06b5626a 3208 OP * const oldop = PL_op;
db36c5a1 3209 dJMPENV;
1e422769 3210
1e422769 3211#ifdef DEBUGGING
54310121 3212 assert(CATCH_GET == TRUE);
1e422769 3213#endif
312caa8e 3214 PL_op = o;
8bffa5f8 3215
14dd3ad8 3216 JMPENV_PUSH(ret);
6224f72b 3217 switch (ret) {
312caa8e 3218 case 0:
abd70938
DM		 3219 assert(cxstack_ix >= 0);
3220 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3221 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8 3222 redo_body:
85aaa934 3223 CALLRUNOPS(aTHX);
312caa8e
CS		 3224 break;
3225 case 3:
8bffa5f8 3226 /* die caught by an inner eval - continue inner loop */
febb3a6d
Z		 3227 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3228 PL_restartjmpenv = NULL;
312caa8e
CS		 3229 PL_op = PL_restartop;
3230 PL_restartop = 0;
3231 goto redo_body;
3232 }
3233 /* FALL THROUGH */
3234 default:
14dd3ad8 3235 JMPENV_POP;
533c011a 3236 PL_op = oldop;
6224f72b 3237 JMPENV_JUMP(ret);
1e422769 3238 /* NOTREACHED */
1e422769 3239 }
14dd3ad8 3240 JMPENV_POP;
533c011a 3241 PL_op = oldop;
5f66b61c 3242 return NULL;
1e422769 3243}
3244
ee23ad3b
NC		 3245/* James Bond: Do you expect me to talk?
3246 Auric Goldfinger: No, Mr. Bond. I expect you to die.
3247
3248 This code is an ugly hack, doesn't work with lexicals in subroutines that are
3249 called more than once, and is only used by regcomp.c, for (?{}) blocks.
3250
3251 Currently it is not used outside the core code. Best if it stays that way.
d59a8b3e
NC		 3252
3253 Hence it's now deprecated, and will be removed.
ee23ad3b 3254*/
c277df42 3255OP *
bfed75c6 3256Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ		 3257/* sv Text to convert to OP tree. */
3258/* startop op_free() this to undo. */
3259/* code Short string id of the caller. */
3260{
d59a8b3e
NC		 3261 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3262 return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3263}
3264
3265/* Don't use this. It will go away without warning once the regexp engine is
3266 refactored not to use it. */
3267OP *
3268Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3269 PAD **padp)
3270{
27da23d5 3271 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ		 3272 PERL_CONTEXT *cx;
3273 SV **newsp;
b094c71d 3274 I32 gimme = G_VOID;
c277df42
IZ		 3275 I32 optype;
3276 OP dummy;
83ee9e09
GS		 3277 char tbuf[TYPE_DIGITS(long) + 12 + 10];
3278 char *tmpbuf = tbuf;
c277df42 3279 char *safestr;
a3985cdc 3280 int runtime;
601f1833 3281 CV* runcv = NULL; /* initialise to avoid compiler warnings */
f7997f86 3282 STRLEN len;
634d6919 3283 bool need_catch;
c277df42 3284
d59a8b3e 3285 PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
7918f24d 3286
d343c3ef 3287 ENTER_with_name("eval");
27fcb6ee 3288 lex_start(sv, NULL, LEX_START_SAME_FILTER);
c277df42
IZ		 3289 SAVETMPS;
3290 /* switch to eval mode */
3291
923e4eb5 3292 if (IN_PERL_COMPILETIME) {
f4dd75d9 3293 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 3294 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 3295 }
83ee9e09 3296 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
9d4ba2ae 3297 SV * const sv = sv_newmortal();
83ee9e09
GS		 3298 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3299 code, (unsigned long)++PL_evalseq,
3300 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3301 tmpbuf = SvPVX(sv);
fc009855 3302 len = SvCUR(sv);
83ee9e09
GS		 3303 }
3304 else
d9fad198
JH		 3305 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3306 (unsigned long)++PL_evalseq);
f4dd75d9 3307 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3308 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3309 SAVECOPLINE(&PL_compiling);
57843af0 3310 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 3311 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3312 deleting the eval's FILEGV from the stash before gv_check() runs
3313 (i.e. before run-time proper). To work around the coredump that
3314 ensues, we always turn GvMULTI_on for any globals that were
3315 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC		 3316 safestr = savepvn(tmpbuf, len);
3317 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 3318 SAVEHINTS();
d1ca3daa 3319#ifdef OP_IN_REGISTER
6b88bc9c 3320 PL_opsave = op;
d1ca3daa 3321#else
7766f137 3322 SAVEVPTR(PL_op);
d1ca3daa 3323#endif
c277df42 3324
a3985cdc 3325 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 3326 runtime = IN_PERL_RUNTIME;
a3985cdc 3327 if (runtime)
558b4424 3328 {
d819b83a 3329 runcv = find_runcv(NULL);
a3985cdc 3330
558b4424
FC		 3331 /* At run time, we have to fetch the hints from PL_curcop. */
3332 PL_hints = PL_curcop->cop_hints;
3333 if (PL_hints & HINT_LOCALIZE_HH) {
3334 /* SAVEHINTS created a new HV in PL_hintgv, which we
3335 need to GC */
3336 SvREFCNT_dec(GvHV(PL_hintgv));
3337 GvHV(PL_hintgv) =
3338 refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3339 hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3340 }
3341 SAVECOMPILEWARNINGS();
3342 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3343 cophh_free(CopHINTHASH_get(&PL_compiling));
3344 /* XXX Does this need to avoid copying a label? */
3345 PL_compiling.cop_hints_hash
3346 = cophh_copy(PL_curcop->cop_hints_hash);
3347 }
3348
533c011a 3349 PL_op = &dummy;
13b51b79 3350 PL_op->op_type = OP_ENTEREVAL;
533c011a 3351 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 3352 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
6b75f042 3353 PUSHEVAL(cx, 0);
634d6919
GG		 3354 need_catch = CATCH_GET;
3355 CATCH_SET(TRUE);
a3985cdc
DM		 3356
3357 if (runtime)
410be5db 3358 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
a3985cdc 3359 else
410be5db 3360 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
634d6919 3361 CATCH_SET(need_catch);
13b51b79 3362 POPBLOCK(cx,PL_curpm);
e84b9f1f 3363 POPEVAL(cx);
c277df42
IZ		 3364
3365 (*startop)->op_type = OP_NULL;
22c35a8c 3366 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
f3548bdc 3367 /* XXX DAPM do this properly one year */
502c6561 3368 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
d343c3ef 3369 LEAVE_with_name("eval");
923e4eb5 3370 if (IN_PERL_COMPILETIME)
623e6609 3371 CopHINTS_set(&PL_compiling, PL_hints);
d1ca3daa 3372#ifdef OP_IN_REGISTER
6b88bc9c 3373 op = PL_opsave;
d1ca3daa 3374#endif
9d4ba2ae
AL		 3375 PERL_UNUSED_VAR(newsp);
3376 PERL_UNUSED_VAR(optype);
3377
410be5db 3378 return PL_eval_start;
c277df42
IZ		 3379}
3380
a3985cdc
DM		 3381
3382/*
3383=for apidoc find_runcv
3384
3385Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM		 3386If db_seqp is non_null, skip CVs that are in the DB package and populate
3387*db_seqp with the cop sequence number at the point that the DB:: code was
3388entered. (allows debuggers to eval in the scope of the breakpoint rather
cf525c36 3389than in the scope of the debugger itself).
a3985cdc
DM		 3390
3391=cut
3392*/
3393
3394CV*
d819b83a 3395Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 3396{
97aff369 3397 dVAR;
a3985cdc 3398 PERL_SI *si;
a3985cdc 3399
d819b83a
DM		 3400 if (db_seqp)
3401 *db_seqp = PL_curcop->cop_seq;
a3985cdc 3402 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 3403 I32 ix;
a3985cdc 3404 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 3405 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a 3406 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1b6737cc 3407 CV * const cv = cx->blk_sub.cv;
d819b83a
DM		 3408 /* skip DB:: code */
3409 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3410 *db_seqp = cx->blk_oldcop->cop_seq;
3411 continue;
3412 }
3413 return cv;
3414 }
a3985cdc
DM		 3415 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3416 return PL_compcv;
3417 }
3418 }
3419 return PL_main_cv;
3420}
3421
3422
27e90453
DM		 3423/* Run yyparse() in a setjmp wrapper. Returns:
3424 * 0: yyparse() successful
3425 * 1: yyparse() failed
3426 * 3: yyparse() died
3427 */
3428STATIC int
28ac2b49 3429S_try_yyparse(pTHX_ int gramtype)
27e90453
DM		 3430{
3431 int ret;
3432 dJMPENV;
3433
3434 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3435 JMPENV_PUSH(ret);
3436 switch (ret) {
3437 case 0:
28ac2b49 3438 ret = yyparse(gramtype) ? 1 : 0;
27e90453
DM		 3439 break;
3440 case 3:
3441 break;
3442 default:
3443 JMPENV_POP;
3444 JMPENV_JUMP(ret);
3445 /* NOTREACHED */
3446 }
3447 JMPENV_POP;
3448 return ret;
3449}
3450
3451
a3985cdc
DM		 3452/* Compile a require/do, an eval '', or a /(?{...})/.
3453 * In the last case, startop is non-null, and contains the address of
3454 * a pointer that should be set to the just-compiled code.
3455 * outside is the lexically enclosing CV (if any) that invoked us.
410be5db
DM		 3456 * Returns a bool indicating whether the compile was successful; if so,
3457 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3458 * pushes undef (also croaks if startop != NULL).
a3985cdc
DM		 3459 */
3460
410be5db 3461STATIC bool
a3985cdc 3462S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 3463{
27da23d5 3464 dVAR; dSP;
46c461b5 3465 OP * const saveop = PL_op;
27e90453
DM		 3466 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3467 int yystatus;
a0d0e21e 3468
27e90453 3469 PL_in_eval = (in_require
6dc8a9e4
IZ		 3470 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3471 : EVAL_INEVAL);
a0d0e21e 3472
1ce6579f 3473 PUSHMARK(SP);
3474
3280af22 3475 SAVESPTR(PL_compcv);
ea726b52 3476 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
1aff0e91 3477 CvEVAL_on(PL_compcv);
2090ab20
JH		 3478 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3479 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3480
a3985cdc 3481 CvOUTSIDE_SEQ(PL_compcv) = seq;
ea726b52 3482 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
a3985cdc 3483
dd2155a4 3484 /* set up a scratch pad */
a0d0e21e 3485
dd2155a4 3486 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
cecbe010 3487 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2c05e328 3488
07055b4c 3489
81d86705
NC		 3490 if (!PL_madskills)
3491 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 3492
a0d0e21e
LW		 3493 /* make sure we compile in the right package */
3494
ed094faf 3495 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 3496 SAVESPTR(PL_curstash);
ed094faf 3497 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 3498 }
3c10abe3 3499 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3280af22
NIS		 3500 SAVESPTR(PL_beginav);
3501 PL_beginav = newAV();
3502 SAVEFREESV(PL_beginav);
3c10abe3
AG		 3503 SAVESPTR(PL_unitcheckav);
3504 PL_unitcheckav = newAV();
3505 SAVEFREESV(PL_unitcheckav);
a0d0e21e 3506
81d86705 3507#ifdef PERL_MAD
9da243ce 3508 SAVEBOOL(PL_madskills);
81d86705
NC		 3509 PL_madskills = 0;
3510#endif
3511
a0d0e21e
LW		 3512 /* try to compile it */
3513
5f66b61c 3514 PL_eval_root = NULL;
3280af22 3515 PL_curcop = &PL_compiling;
fc15ae8f 3516 CopARYBASE_set(PL_curcop, 0);
5f66b61c 3517 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
faef0170 3518 PL_in_eval |= EVAL_KEEPERR;
ab69dbc2
RGS		 3519 else
3520 CLEAR_ERRSV();
27e90453 3521
a88d97bf 3522 CALL_BLOCK_HOOKS(bhk_eval, saveop);
52db365a 3523
27e90453
DM		 3524 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3525 * so honour CATCH_GET and trap it here if necessary */
3526
28ac2b49 3527 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
27e90453
DM		 3528
3529 if (yystatus || PL_parser->error_count || !PL_eval_root) {
0c58d367 3530 SV **newsp; /* Used by POPBLOCK. */
b6494f15 3531 PERL_CONTEXT *cx = NULL;
27e90453 3532 I32 optype; /* Used by POPEVAL. */
b6494f15 3533 SV *namesv = NULL;
9d4ba2ae 3534 const char *msg;
bfed75c6 3535
27e90453
DM		 3536 PERL_UNUSED_VAR(newsp);
3537 PERL_UNUSED_VAR(optype);
3538
c86ffc32
DM		 3539 /* note that if yystatus == 3, then the EVAL CX block has already
3540 * been popped, and various vars restored */
533c011a 3541 PL_op = saveop;
27e90453 3542 if (yystatus != 3) {
c86ffc32
DM		 3543 if (PL_eval_root) {
3544 op_free(PL_eval_root);
3545 PL_eval_root = NULL;
3546 }
27e90453
DM		 3547 SP = PL_stack_base + POPMARK; /* pop original mark */
3548 if (!startop) {
3549 POPBLOCK(cx,PL_curpm);
3550 POPEVAL(cx);
b6494f15 3551 namesv = cx->blk_eval.old_namesv;
27e90453 3552 }
c277df42 3553 }
27e90453
DM		 3554 if (yystatus != 3)
3555 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
9d4ba2ae
AL		 3556
3557 msg = SvPVx_nolen_const(ERRSV);
27e90453 3558 if (in_require) {
b6494f15
VP		 3559 if (!cx) {
3560 /* If cx is still NULL, it means that we didn't go in the
3561 * POPEVAL branch. */
3562 cx = &cxstack[cxstack_ix];
3563 assert(CxTYPE(cx) == CXt_EVAL);
3564 namesv = cx->blk_eval.old_namesv;
3565 }
3566 (void)hv_store(GvHVn(PL_incgv),
3567 SvPVX_const(namesv), SvCUR(namesv),
3568 &PL_sv_undef, 0);
58d3fd3b
SH		 3569 Perl_croak(aTHX_ "%sCompilation failed in require",
3570 *msg ? msg : "Unknown error\n");
5a844595
GS		 3571 }
3572 else if (startop) {
27e90453
DM		 3573 if (yystatus != 3) {
3574 POPBLOCK(cx,PL_curpm);
3575 POPEVAL(cx);
3576 }
5a844595
GS		 3577 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3578 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 3579 }
9d7f88dd 3580 else {
9d7f88dd 3581 if (!*msg) {
6502358f 3582 sv_setpvs(ERRSV, "Compilation error");
9d7f88dd
SR		 3583 }
3584 }
410be5db
DM		 3585 PUSHs(&PL_sv_undef);
3586 PUTBACK;
3587 return FALSE;
a0d0e21e 3588 }
57843af0 3589 CopLINE_set(&PL_compiling, 0);
c277df42 3590 if (startop) {
3280af22 3591 *startop = PL_eval_root;
c277df42 3592 } else
3280af22 3593 SAVEFREEOP(PL_eval_root);
0c58d367
RGS		 3594
3595 /* Set the context for this new optree.
021f53de
GG		 3596 * Propagate the context from the eval(). */
3597 if ((gimme & G_WANT) == G_VOID)
3280af22 3598 scalarvoid(PL_eval_root);
7df0357e 3599 else if ((gimme & G_WANT) == G_ARRAY)
3280af22 3600 list(PL_eval_root);
a0d0e21e 3601 else
3280af22 3602 scalar(PL_eval_root);
a0d0e21e
LW		 3603
3604 DEBUG_x(dump_eval());
3605
55497cff 3606 /* Register with debugger: */
6482a30d 3607 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
b96d8cd9 3608 CV * const cv = get_cvs("DB::postponed", 0);
55497cff 3609 if (cv) {
3610 dSP;
924508f0 3611 PUSHMARK(SP);
ad64d0ec 3612 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
55497cff 3613 PUTBACK;
ad64d0ec 3614 call_sv(MUTABLE_SV(cv), G_DISCARD);
55497cff 3615 }
3616 }
3617
8ed49485
FC		 3618 if (PL_unitcheckav) {
3619 OP *es = PL_eval_start;
3c10abe3 3620 call_list(PL_scopestack_ix, PL_unitcheckav);
8ed49485
FC		 3621 PL_eval_start = es;
3622 }
3c10abe3 3623
a0d0e21e
LW		 3624 /* compiled okay, so do it */
3625
3280af22
NIS		 3626 CvDEPTH(PL_compcv) = 1;
3627 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 3628 PL_op = saveop; /* The caller may need it. */
bc177e6b 3629 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 3630
410be5db
DM		 3631 PUTBACK;
3632 return TRUE;
a0d0e21e
LW		 3633}
3634
a6c40364 3635STATIC PerlIO *
282b29ee 3636S_check_type_and_open(pTHX_ SV *name)
ce8abf5f
SP		 3637{
3638 Stat_t st;
282b29ee
NC		 3639 const char *p = SvPV_nolen_const(name);
3640 const int st_rc = PerlLIO_stat(p, &st);
df528165 3641
7918f24d
NC		 3642 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3643
6b845e56 3644 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
4608196e 3645 return NULL;
ce8abf5f
SP		 3646 }
3647
ccb84406
NC		 3648#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3649 return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3650#else
282b29ee 3651 return PerlIO_open(p, PERL_SCRIPT_MODE);
ccb84406 3652#endif
ce8abf5f
SP		 3653}
3654
75c20bac 3655#ifndef PERL_DISABLE_PMC
ce8abf5f 3656STATIC PerlIO *
282b29ee 3657S_doopen_pm(pTHX_ SV *name)
b295d113 3658{
282b29ee
NC		 3659 STRLEN namelen;
3660 const char *p = SvPV_const(name, namelen);
b295d113 3661
7918f24d
NC		 3662 PERL_ARGS_ASSERT_DOOPEN_PM;
3663
282b29ee 3664 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
eb70bb4a 3665 SV *const pmcsv = sv_newmortal();
a6c40364 3666 Stat_t pmcstat;
50b8ed39 3667
eb70bb4a 3668 SvSetSV_nosteal(pmcsv,name);
282b29ee 3669 sv_catpvn(pmcsv, "c", 1);
50b8ed39 3670
282b29ee
NC		 3671 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3672 return check_type_and_open(pmcsv);
a6c40364 3673 }
282b29ee 3674 return check_type_and_open(name);
75c20bac 3675}
7925835c 3676#else
282b29ee 3677# define doopen_pm(name) check_type_and_open(name)
7925835c 3678#endif /* !PERL_DISABLE_PMC */
b295d113 3679
a0d0e21e
LW		 3680PP(pp_require)
3681{
27da23d5 3682 dVAR; dSP;
c09156bb 3683 register PERL_CONTEXT *cx;
a0d0e21e 3684 SV *sv;
5c144d81 3685 const char *name;
6132ea6c 3686 STRLEN len;
4492be7a
JM		 3687 char * unixname;
3688 STRLEN unixlen;
62f5ad7a 3689#ifdef VMS
4492be7a 3690 int vms_unixname = 0;
62f5ad7a 3691#endif
c445ea15
AL		 3692 const char *tryname = NULL;
3693 SV *namesv = NULL;
f54cb97a 3694 const I32 gimme = GIMME_V;
bbed91b5 3695 int filter_has_file = 0;
c445ea15 3696 PerlIO *tryrsfp = NULL;
34113e50 3697 SV *filter_cache = NULL;
c445ea15
AL		 3698 SV *filter_state = NULL;
3699 SV *filter_sub = NULL;
3700 SV *hook_sv = NULL;
6ec9efec
JH		 3701 SV *encoding;
3702 OP *op;
a0d0e21e
LW		 3703
3704 sv = POPs;
d7aa5382 3705 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
d086148c 3706 sv = sv_2mortal(new_version(sv));
d7aa5382 3707 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 3708 upg_version(PL_patchlevel, TRUE);
149c1637 3709 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3cacfbb9 3710 if ( vcmp(sv,PL_patchlevel) <= 0 )
468aa647 3711 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
e753e3b1
FC		 3712 SVfARG(sv_2mortal(vnormal(sv))),
3713 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3714 );
468aa647
RGS		 3715 }
3716 else {
d1029faa
JP		 3717 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3718 I32 first = 0;
3719 AV *lav;
3720 SV * const req = SvRV(sv);
85fbaab2 3721 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
d1029faa
JP		 3722
3723 /* get the left hand term */
502c6561 3724 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
d1029faa
JP		 3725
3726 first = SvIV(*av_fetch(lav,0,0));
3727 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
85fbaab2 3728 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
d1029faa
JP		 3729 || av_len(lav) > 1 /* FP with > 3 digits */
3730 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3731 ) {
3732 DIE(aTHX_ "Perl %"SVf" required--this is only "
9d056fb0
FC		 3733 "%"SVf", stopped",
3734 SVfARG(sv_2mortal(vnormal(req))),
3735 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3736 );
d1029faa
JP		 3737 }
3738 else { /* probably 'use 5.10' or 'use 5.8' */
af61dbfd 3739 SV *hintsv;
d1029faa
JP		 3740 I32 second = 0;
3741
3742 if (av_len(lav)>=1)
3743 second = SvIV(*av_fetch(lav,1,0));
3744
3745 second /= second >= 600 ? 100 : 10;
af61dbfd
NC		 3746 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3747 (int)first, (int)second);
d1029faa
JP		 3748 upg_version(hintsv, TRUE);
3749
3750 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3751 "--this is only %"SVf", stopped",
1be7d6f3
FC		 3752 SVfARG(sv_2mortal(vnormal(req))),
3753 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3754 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3755 );
d1029faa
JP		 3756 }
3757 }
468aa647 3758 }
d7aa5382 3759
7dfde25d 3760 RETPUSHYES;
a0d0e21e 3761 }
5c144d81 3762 name = SvPV_const(sv, len);
6132ea6c 3763 if (!(name && len > 0 && *name))
cea2e8a9 3764 DIE(aTHX_ "Null filename used");
4633a7c4 3765 TAINT_PROPER("require");
4492be7a
JM		 3766
3767
3768#ifdef VMS
3769 /* The key in the %ENV hash is in the syntax of file passed as the argument
3770 * usually this is in UNIX format, but sometimes in VMS format, which
3771 * can result in a module being pulled in more than once.
3772 * To prevent this, the key must be stored in UNIX format if the VMS
3773 * name can be translated to UNIX.
3774 */
3775 if ((unixname = tounixspec(name, NULL)) != NULL) {
3776 unixlen = strlen(unixname);
3777 vms_unixname = 1;
3778 }
3779 else
3780#endif
3781 {
3782 /* if not VMS or VMS name can not be translated to UNIX, pass it
3783 * through.
3784 */
3785 unixname = (char *) name;
3786 unixlen = len;
3787 }
44f8325f 3788 if (PL_op->op_type == OP_REQUIRE) {
4492be7a
JM		 3789 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3790 unixname, unixlen, 0);
44f8325f
AL		 3791 if ( svp ) {
3792 if (*svp != &PL_sv_undef)
3793 RETPUSHYES;
3794 else
087b5369
RD		 3795 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3796 "Compilation failed in require", unixname);
44f8325f 3797 }
4d8b06f1 3798 }
a0d0e21e
LW		 3799
3800 /* prepare to compile file */
3801
be4b629d 3802 if (path_is_absolute(name)) {
282b29ee 3803 /* At this point, name is SvPVX(sv) */
46fc3d4c 3804 tryname = name;
282b29ee 3805 tryrsfp = doopen_pm(sv);
bf4acbe4 3806 }
be4b629d 3807 if (!tryrsfp) {
44f8325f 3808 AV * const ar = GvAVn(PL_incgv);
a0d0e21e 3809 I32 i;
748a9306 3810#ifdef VMS
4492be7a 3811 if (vms_unixname)
46fc3d4c 3812#endif
3813 {
d0328fd7 3814 namesv = newSV_type(SVt_PV);
46fc3d4c 3815 for (i = 0; i <= AvFILL(ar); i++) {
df528165 3816 SV * const dirsv = *av_fetch(ar, i, TRUE);
bbed91b5 3817
ad64d0ec 3818 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
c38a6530 3819 mg_get(dirsv);
bbed91b5
KF		 3820 if (SvROK(dirsv)) {
3821 int count;
a3b58a99 3822 SV **svp;
bbed91b5
KF		 3823 SV *loader = dirsv;
3824
e14e2dc8
NC		 3825 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3826 && !sv_isobject(loader))
3827 {
502c6561 3828 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
bbed91b5
KF		 3829 }
3830
b900a521 3831 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3832 PTR2UV(SvRV(dirsv)), name);
349d4f2f 3833 tryname = SvPVX_const(namesv);
c445ea15 3834 tryrsfp = NULL;
bbed91b5 3835
d343c3ef 3836 ENTER_with_name("call_INC");
bbed91b5
KF		 3837 SAVETMPS;
3838 EXTEND(SP, 2);
3839
3840 PUSHMARK(SP);
3841 PUSHs(dirsv);
3842 PUSHs(sv);
3843 PUTBACK;
e982885c
NC		 3844 if (sv_isobject(loader))
3845 count = call_method("INC", G_ARRAY);
3846 else
3847 count = call_sv(loader, G_ARRAY);
bbed91b5
KF		 3848 SPAGAIN;
3849
3850 if (count > 0) {
3851 int i = 0;
3852 SV *arg;
3853
3854 SP -= count - 1;
3855 arg = SP[i++];
3856
34113e50
NC		 3857 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3858 && !isGV_with_GP(SvRV(arg))) {
3859 filter_cache = SvRV(arg);
74c765eb 3860 SvREFCNT_inc_simple_void_NN(filter_cache);
34113e50
NC		 3861
3862 if (i < count) {
3863 arg = SP[i++];
3864 }
3865 }
3866
6e592b3a 3867 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
bbed91b5
KF		 3868 arg = SvRV(arg);
3869 }
3870
6e592b3a 3871 if (isGV_with_GP(arg)) {
159b6efe 3872 IO * const io = GvIO((const GV *)arg);
bbed91b5
KF		 3873
3874 ++filter_has_file;
3875
3876 if (io) {
3877 tryrsfp = IoIFP(io);
0f7de14d
NC		 3878 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3879 PerlIO_close(IoOFP(io));
bbed91b5 3880 }
0f7de14d
NC		 3881 IoIFP(io) = NULL;
3882 IoOFP(io) = NULL;
bbed91b5
KF		 3883 }
3884
3885 if (i < count) {
3886 arg = SP[i++];
3887 }
3888 }
3889
3890 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3891 filter_sub = arg;
74c765eb 3892 SvREFCNT_inc_simple_void_NN(filter_sub);
bbed91b5
KF		 3893
3894 if (i < count) {
3895 filter_state = SP[i];
b37c2d43 3896 SvREFCNT_inc_simple_void(filter_state);
bbed91b5 3897 }
34113e50 3898 }
bbed91b5 3899
34113e50
NC		 3900 if (!tryrsfp && (filter_cache || filter_sub)) {
3901 tryrsfp = PerlIO_open(BIT_BUCKET,
3902 PERL_SCRIPT_MODE);
bbed91b5 3903 }
1d06aecd 3904 SP--;
bbed91b5
KF		 3905 }
3906
3907 PUTBACK;
3908 FREETMPS;
d343c3ef 3909 LEAVE_with_name("call_INC");
bbed91b5 3910
c5f55552
NC		 3911 /* Adjust file name if the hook has set an %INC entry.
3912 This needs to happen after the FREETMPS above. */
3913 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3914 if (svp)
3915 tryname = SvPV_nolen_const(*svp);
3916
bbed91b5 3917 if (tryrsfp) {
89ccab8c 3918 hook_sv = dirsv;
bbed91b5
KF		 3919 break;
3920 }
3921
3922 filter_has_file = 0;
34113e50
NC		 3923 if (filter_cache) {
3924 SvREFCNT_dec(filter_cache);
3925 filter_cache = NULL;
3926 }
bbed91b5
KF		 3927 if (filter_state) {
3928 SvREFCNT_dec(filter_state);
c445ea15 3929 filter_state = NULL;
bbed91b5
KF		 3930 }
3931 if (filter_sub) {
3932 SvREFCNT_dec(filter_sub);
c445ea15 3933 filter_sub = NULL;
bbed91b5
KF		 3934 }
3935 }
3936 else {
be4b629d 3937 if (!path_is_absolute(name)
be4b629d 3938 ) {
b640a14a
NC		 3939 const char *dir;
3940 STRLEN dirlen;
3941
3942 if (SvOK(dirsv)) {
3943 dir = SvPV_const(dirsv, dirlen);
3944 } else {
3945 dir = "";
3946 dirlen = 0;
3947 }
3948
e37778c2 3949#ifdef VMS
bbed91b5 3950 char *unixdir;
c445ea15 3951 if ((unixdir = tounixpath(dir, NULL)) == NULL)
bbed91b5
KF		 3952 continue;
3953 sv_setpv(namesv, unixdir);
3954 sv_catpv(namesv, unixname);
e37778c2
NC		 3955#else
3956# ifdef __SYMBIAN32__
27da23d5
JH		 3957 if (PL_origfilename[0] &&
3958 PL_origfilename[1] == ':' &&
3959 !(dir[0] && dir[1] == ':'))
3960 Perl_sv_setpvf(aTHX_ namesv,
3961 "%c:%s\\%s",
3962 PL_origfilename[0],
3963 dir, name);
3964 else
3965 Perl_sv_setpvf(aTHX_ namesv,
3966 "%s\\%s",
3967 dir, name);
e37778c2 3968# else
b640a14a
NC		 3969 /* The equivalent of
3970 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3971 but without the need to parse the format string, or
3972 call strlen on either pointer, and with the correct
3973 allocation up front. */
3974 {
3975 char *tmp = SvGROW(namesv, dirlen + len + 2);
3976
3977 memcpy(tmp, dir, dirlen);
3978 tmp +=dirlen;
3979 *tmp++ = '/';
3980 /* name came from an SV, so it will have a '\0' at the
3981 end that we can copy as part of this memcpy(). */
3982 memcpy(tmp, name, len + 1);
3983
3984 SvCUR_set(namesv, dirlen + len + 1);
282b29ee 3985 SvPOK_on(namesv);
b640a14a 3986 }
27da23d5 3987# endif
bf4acbe4 3988#endif
bbed91b5 3989 TAINT_PROPER("require");
349d4f2f 3990 tryname = SvPVX_const(namesv);
282b29ee 3991 tryrsfp = doopen_pm(namesv);
bbed91b5 3992 if (tryrsfp) {
e63be746
RGS		 3993 if (tryname[0] == '.' && tryname[1] == '/') {
3994 ++tryname;
3995 while (*++tryname == '/');
3996 }
bbed91b5
KF		 3997 break;
3998 }
ff806af2
DM		 3999 else if (errno == EMFILE)
4000 /* no point in trying other paths if out of handles */
4001 break;
be4b629d 4002 }
46fc3d4c 4003 }
a0d0e21e
LW		 4004 }
4005 }
4006 }
b2ef6d44 4007 sv_2mortal(namesv);
a0d0e21e 4008 if (!tryrsfp) {
533c011a 4009 if (PL_op->op_type == OP_REQUIRE) {
e31de809 4010 if(errno == EMFILE) {
c9d5e35e
NC		 4011 /* diag_listed_as: Can't locate %s */
4012 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
e31de809
SP		 4013 } else {
4014 if (namesv) { /* did we lookup @INC? */
44f8325f 4015 AV * const ar = GvAVn(PL_incgv);
e31de809 4016 I32 i;
c9d5e35e
NC		 4017 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4018 for (i = 0; i <= AvFILL(ar); i++) {
4019 sv_catpvs(inc, " ");
4020 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4021 }
4022
4023 /* diag_listed_as: Can't locate %s */
4024 DIE(aTHX_
4025 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
4026 name,
686c4ca0
NC		 4027 (memEQ(name + len - 2, ".h", 3)
4028 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
4029 (memEQ(name + len - 3, ".ph", 4)
c9d5e35e
NC		 4030 ? " (did you run h2ph?)" : ""),
4031 inc
4032 );
4033 }
2683423c 4034 }
c9d5e35e 4035 DIE(aTHX_ "Can't locate %s", name);
a0d0e21e
LW		 4036 }
4037
4038 RETPUSHUNDEF;
4039 }
d8bfb8bd 4040 else
93189314 4041 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW		 4042
4043 /* Assume success here to prevent recursive requirement. */
238d24b4 4044 /* name is never assigned to again, so len is still strlen(name) */
d3a4e64e 4045 /* Check whether a hook in @INC has already filled %INC */
44f8325f 4046 if (!hook_sv) {
4492be7a 4047 (void)hv_store(GvHVn(PL_incgv),
b2ef6d44 4048 unixname, unixlen, newSVpv(tryname,0),0);
44f8325f 4049 } else {
4492be7a 4050 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
44f8325f 4051 if (!svp)
4492be7a
JM		 4052 (void)hv_store(GvHVn(PL_incgv),
4053 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
d3a4e64e 4054 }
a0d0e21e 4055
d343c3ef 4056 ENTER_with_name("eval");
a0d0e21e 4057 SAVETMPS;
b2ef6d44
FC		 4058 SAVECOPFILE_FREE(&PL_compiling);
4059 CopFILE_set(&PL_compiling, tryname);
8eaa0acf 4060 lex_start(NULL, tryrsfp, 0);
e50aee73 4061
b3ac6de7 4062 SAVEHINTS();
3280af22 4063 PL_hints = 0;
f747ebd6 4064 hv_clear(GvHV(PL_hintgv));
27eaf14c 4065
68da3b2f 4066 SAVECOMPILEWARNINGS();
0453d815 4067 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 4068 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 4069 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 4070 PL_compiling.cop_warnings = pWARN_NONE ;
ac27b0f5 4071 else
d3a7d8c7 4072 PL_compiling.cop_warnings = pWARN_STD ;
a0d0e21e 4073
34113e50 4074 if (filter_sub || filter_cache) {
4464f08e
NC		 4075 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4076 than hanging another SV from it. In turn, filter_add() optionally
4077 takes the SV to use as the filter (or creates a new SV if passed
4078 NULL), so simply pass in whatever value filter_cache has. */
4079 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
bbed91b5 4080 IoLINES(datasv) = filter_has_file;
159b6efe
NC		 4081 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4082 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
bbed91b5
KF		 4083 }
4084
4085 /* switch to eval mode */
a0d0e21e 4086 PUSHBLOCK(cx, CXt_EVAL, SP);
6b75f042 4087 PUSHEVAL(cx, name);
f39bc417 4088 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 4089
57843af0
GS		 4090 SAVECOPLINE(&PL_compiling);
4091 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 4092
4093 PUTBACK;
6ec9efec
JH		 4094
4095 /* Store and reset encoding. */
4096 encoding = PL_encoding;
c445ea15 4097 PL_encoding = NULL;
6ec9efec 4098
410be5db
DM		 4099 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
4100 op = DOCATCH(PL_eval_start);
4101 else
4102 op = PL_op->op_next;
bfed75c6 4103
6ec9efec
JH		 4104 /* Restore encoding. */
4105 PL_encoding = encoding;
4106
4107 return op;
a0d0e21e
LW		 4108}
4109
996c9baa
VP		 4110/* This is a op added to hold the hints hash for
4111 pp_entereval. The hash can be modified by the code
4112 being eval'ed, so we return a copy instead. */
4113
4114PP(pp_hintseval)
4115{
4116 dVAR;
4117 dSP;
defdfed5 4118 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
996c9baa
VP		 4119 RETURN;
4120}
4121
4122
a0d0e21e
LW		 4123PP(pp_entereval)
4124{
27da23d5 4125 dVAR; dSP;
c09156bb 4126 register PERL_CONTEXT *cx;
0d863452 4127 SV *sv;
890ce7af 4128 const I32 gimme = GIMME_V;
fd06b02c 4129 const U32 was = PL_breakable_sub_gen;
83ee9e09 4130 char tbuf[TYPE_DIGITS(long) + 12];
78da7625 4131 bool saved_delete = FALSE;
83ee9e09 4132 char *tmpbuf = tbuf;
a0d0e21e 4133 STRLEN len;
a3985cdc 4134 CV* runcv;
d819b83a 4135 U32 seq;
c445ea15 4136 HV *saved_hh = NULL;
e389bba9 4137
0d863452 4138 if (PL_op->op_private & OPpEVAL_HAS_HH) {
85fbaab2 4139 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
0d863452
RH		 4140 }
4141 sv = POPs;
895b760f
DM		 4142 if (!SvPOK(sv)) {
4143 /* make sure we've got a plain PV (no overload etc) before testing
4144 * for taint. Making a copy here is probably overkill, but better
4145 * safe than sorry */
0479a84a
NC		 4146 STRLEN len;
4147 const char * const p = SvPV_const(sv, len);
4148
4149 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
895b760f 4150 }
a0d0e21e 4151
af2d3def 4152 TAINT_IF(SvTAINTED(sv));
748a9306 4153 TAINT_PROPER("eval");
a0d0e21e 4154
d343c3ef 4155 ENTER_with_name("eval");
27fcb6ee 4156 lex_start(sv, NULL, LEX_START_SAME_FILTER);
748a9306 4157 SAVETMPS;
ac27b0f5 4158
a0d0e21e
LW		 4159 /* switch to eval mode */
4160
83ee9e09 4161 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
8b38226b
AL		 4162 SV * const temp_sv = sv_newmortal();
4163 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
83ee9e09
GS		 4164 (unsigned long)++PL_evalseq,
4165 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8b38226b
AL		 4166 tmpbuf = SvPVX(temp_sv);
4167 len = SvCUR(temp_sv);
83ee9e09
GS		 4168 }
4169 else
d9fad198 4170 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 4171 SAVECOPFILE_FREE(&PL_compiling);
57843af0 4172 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 4173 SAVECOPLINE(&PL_compiling);
57843af0 4174 CopLINE_set(&PL_compiling, 1);
55497cff 4175 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4176 deleting the eval's FILEGV from the stash before gv_check() runs
4177 (i.e. before run-time proper). To work around the coredump that
4178 ensues, we always turn GvMULTI_on for any globals that were
4179 introduced within evals. See force_ident(). GSAR 96-10-12 */
b3ac6de7 4180 SAVEHINTS();
533c011a 4181 PL_hints = PL_op->op_targ;
cda55376
AV		 4182 if (saved_hh) {
4183 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
4184 SvREFCNT_dec(GvHV(PL_hintgv));
0d863452 4185 GvHV(PL_hintgv) = saved_hh;
cda55376 4186 }
68da3b2f 4187 SAVECOMPILEWARNINGS();
72dc9ed5 4188 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
20439bc7 4189 cophh_free(CopHINTHASH_get(&PL_compiling));
d6747b7a 4190 if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
47550813
NC		 4191 /* The label, if present, is the first entry on the chain. So rather
4192 than writing a blank label in front of it (which involves an
4193 allocation), just use the next entry in the chain. */
4194 PL_compiling.cop_hints_hash
20439bc7 4195 = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
47550813 4196 /* Check the assumption that this removed the label. */
d6747b7a 4197 assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
47550813
NC		 4198 }
4199 else
20439bc7 4200 PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
d819b83a
DM		 4201 /* special case: an eval '' executed within the DB package gets lexically
4202 * placed in the first non-DB CV rather than the current CV - this
4203 * allows the debugger to execute code, find lexicals etc, in the
4204 * scope of the code being debugged. Passing &seq gets find_runcv
4205 * to do the dirty work for us */
4206 runcv = find_runcv(&seq);
a0d0e21e 4207
6b35e009 4208 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
6b75f042 4209 PUSHEVAL(cx, 0);
f39bc417 4210 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e
LW		 4211
4212 /* prepare to compile string */
4213
a44e3ce2 4214 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
bdc0bf6f 4215 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
78da7625
FC		 4216 else {
4217 char *const safestr = savepvn(tmpbuf, len);
4218 SAVEDELETE(PL_defstash, safestr, len);
4219 saved_delete = TRUE;
4220 }
4221
a0d0e21e 4222 PUTBACK;
f9bddea7
NC		 4223
4224 if (doeval(gimme, NULL, runcv, seq)) {
4225 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4226 ? (PERLDB_LINE || PERLDB_SAVESRC)
4227 : PERLDB_SAVESRC_NOSUBS) {
4228 /* Retain the filegv we created. */
78da7625 4229 } else if (!saved_delete) {
f9bddea7
NC		 4230 char *const safestr = savepvn(tmpbuf, len);
4231 SAVEDELETE(PL_defstash, safestr, len);
4232 }
4233 return DOCATCH(PL_eval_start);
4234 } else {
486ec47a 4235 /* We have already left the scope set up earlier thanks to the LEAVE
f9bddea7 4236 in doeval(). */
eb044b10
NC		 4237 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4238 ? (PERLDB_LINE || PERLDB_SAVESRC)
4239 : PERLDB_SAVESRC_INVALID) {
f9bddea7 4240 /* Retain the filegv we created. */
7857f360 4241 } else if (!saved_delete) {
f9bddea7
NC		 4242 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4243 }
4244 return PL_op->op_next;
4245 }
a0d0e21e
LW		 4246}
4247
4248PP(pp_leaveeval)
4249{
27da23d5 4250 dVAR; dSP;
a0d0e21e
LW		 4251 SV **newsp;
4252 PMOP *newpm;
4253 I32 gimme;
c09156bb 4254 register PERL_CONTEXT *cx;
a0d0e21e 4255 OP *retop;
06b5626a 4256 const U8 save_flags = PL_op -> op_flags;
a0d0e21e 4257 I32 optype;
b6494f15 4258 SV *namesv;
a0d0e21e 4259
011c3814 4260 PERL_ASYNC_CHECK();
a0d0e21e
LW		 4261 POPBLOCK(cx,newpm);
4262 POPEVAL(cx);
b6494f15 4263 namesv = cx->blk_eval.old_namesv;
f39bc417 4264 retop = cx->blk_eval.retop;
a0d0e21e 4265
a1f49e72 4266 TAINT_NOT;
b9d76716
VP		 4267 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4268 gimme, SVs_TEMP);
3280af22 4269 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 4270
4fdae800 4271#ifdef DEBUGGING
3280af22 4272 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 4273#endif
3280af22 4274 CvDEPTH(PL_compcv) = 0;
4fdae800 4275
1ce6579f 4276 if (optype == OP_REQUIRE &&
924508f0 4277 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 4278 {
1ce6579f 4279 /* Unassume the success we assumed earlier. */
b6494f15
VP		 4280 (void)hv_delete(GvHVn(PL_incgv),
4281 SvPVX_const(namesv), SvCUR(namesv),
4282 G_DISCARD);
4283 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4284 SVfARG(namesv));
c5df3096 4285 /* die_unwind() did LEAVE, or we won't be here */
f46d017c
GS		 4286 }
4287 else {
d343c3ef 4288 LEAVE_with_name("eval");
8433848b 4289 if (!(save_flags & OPf_SPECIAL)) {
ab69dbc2 4290 CLEAR_ERRSV();
8433848b 4291 }
a0d0e21e 4292 }
a0d0e21e
LW		 4293
4294 RETURNOP(retop);
4295}
4296
edb2152a
NC		 4297/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4298 close to the related Perl_create_eval_scope. */
4299void
4300Perl_delete_eval_scope(pTHX)
a0d0e21e 4301{
edb2152a
NC		 4302 SV **newsp;
4303 PMOP *newpm;
4304 I32 gimme;
c09156bb 4305 register PERL_CONTEXT *cx;
edb2152a
NC		 4306 I32 optype;
4307
4308 POPBLOCK(cx,newpm);
4309 POPEVAL(cx);
4310 PL_curpm = newpm;
d343c3ef 4311 LEAVE_with_name("eval_scope");
edb2152a
NC		 4312 PERL_UNUSED_VAR(newsp);
4313 PERL_UNUSED_VAR(gimme);
4314 PERL_UNUSED_VAR(optype);
4315}
a0d0e21e 4316
edb2152a
NC		 4317/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4318 also needed by Perl_fold_constants. */
4319PERL_CONTEXT *
4320Perl_create_eval_scope(pTHX_ U32 flags)
4321{
4322 PERL_CONTEXT *cx;
4323 const I32 gimme = GIMME_V;
4324
d343c3ef 4325 ENTER_with_name("eval_scope");
a0d0e21e
LW		 4326 SAVETMPS;
4327
edb2152a 4328 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
6b75f042 4329 PUSHEVAL(cx, 0);
a0d0e21e 4330
faef0170 4331 PL_in_eval = EVAL_INEVAL;
edb2152a
NC		 4332 if (flags & G_KEEPERR)
4333 PL_in_eval |= EVAL_KEEPERR;
ab69dbc2
RGS		 4334 else
4335 CLEAR_ERRSV();
edb2152a
NC		 4336 if (flags & G_FAKINGEVAL) {
4337 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4338 }
4339 return cx;
4340}
4341
4342PP(pp_entertry)
4343{
4344 dVAR;
df528165 4345 PERL_CONTEXT * const cx = create_eval_scope(0);
edb2152a 4346 cx->blk_eval.retop = cLOGOP->op_other->op_next;
533c011a 4347 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 4348}
4349
4350PP(pp_leavetry)
4351{
27da23d5 4352 dVAR; dSP;
a0d0e21e
LW		 4353 SV **newsp;
4354 PMOP *newpm;
4355 I32 gimme;
c09156bb 4356 register PERL_CONTEXT *cx;
a0d0e21e
LW		 4357 I32 optype;
4358
011c3814 4359 PERL_ASYNC_CHECK();
a0d0e21e
LW		 4360 POPBLOCK(cx,newpm);
4361 POPEVAL(cx);
9d4ba2ae 4362 PERL_UNUSED_VAR(optype);
a0d0e21e 4363
a1f49e72 4364 TAINT_NOT;
b9d76716 4365 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
3280af22 4366 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 4367
d343c3ef 4368 LEAVE_with_name("eval_scope");
ab69dbc2 4369 CLEAR_ERRSV();
745cf2ff 4370 RETURN;
a0d0e21e
LW		 4371}
4372
0d863452
RH		 4373PP(pp_entergiven)
4374{
4375 dVAR; dSP;
4376 register PERL_CONTEXT *cx;
4377 const I32 gimme = GIMME_V;
4378
d343c3ef 4379 ENTER_with_name("given");
0d863452
RH		 4380 SAVETMPS;
4381
f7010667 4382 sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
0d863452
RH		 4383
4384 PUSHBLOCK(cx, CXt_GIVEN, SP);
4385 PUSHGIVEN(cx);
4386
4387 RETURN;
4388}
4389
4390PP(pp_leavegiven)
4391{
4392 dVAR; dSP;
4393 register PERL_CONTEXT *cx;
4394 I32 gimme;
4395 SV **newsp;
4396 PMOP *newpm;
96a5add6 4397 PERL_UNUSED_CONTEXT;
0d863452
RH		 4398
4399 POPBLOCK(cx,newpm);
4400 assert(CxTYPE(cx) == CXt_GIVEN);
0d863452 4401
25b991bf 4402 TAINT_NOT;
b9d76716 4403 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
25b991bf 4404 PL_curpm = newpm; /* Don't pop $1 et al till now */
0d863452 4405
d343c3ef 4406 LEAVE_with_name("given");
25b991bf 4407 RETURN;
0d863452
RH		 4408}
4409
4410/* Helper routines used by pp_smartmatch */
4136a0f7 4411STATIC PMOP *
84679df5 4412S_make_matcher(pTHX_ REGEXP *re)
0d863452 4413{
97aff369 4414 dVAR;
0d863452 4415 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
7918f24d
NC		 4416
4417 PERL_ARGS_ASSERT_MAKE_MATCHER;
4418
d6106309 4419 PM_SETRE(matcher, ReREFCNT_inc(re));
7918f24d 4420
0d863452 4421 SAVEFREEOP((OP *) matcher);
d343c3ef 4422 ENTER_with_name("matcher"); SAVETMPS;
0d863452
RH		 4423 SAVEOP();
4424 return matcher;
4425}
4426
4136a0f7 4427STATIC bool
0d863452
RH		 4428S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4429{
97aff369 4430 dVAR;
0d863452 4431 dSP;
7918f24d
NC		 4432
4433 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
0d863452
RH		 4434
4435 PL_op = (OP *) matcher;
4436 XPUSHs(sv);
4437 PUTBACK;
897d3989 4438 (void) Perl_pp_match(aTHX);
0d863452
RH		 4439 SPAGAIN;
4440 return (SvTRUEx(POPs));
4441}
4442
4136a0f7 4443STATIC void
0d863452
RH		 4444S_destroy_matcher(pTHX_ PMOP *matcher)
4445{
97aff369 4446 dVAR;
7918f24d
NC		 4447
4448 PERL_ARGS_ASSERT_DESTROY_MATCHER;
0d863452 4449 PERL_UNUSED_ARG(matcher);
7918f24d 4450
0d863452 4451 FREETMPS;
d343c3ef 4452 LEAVE_with_name("matcher");
0d863452
RH		 4453}
4454
4455/* Do a smart match */
4456PP(pp_smartmatch)
4457{
d7c0d282 4458 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
a0714e2c 4459 return do_smartmatch(NULL, NULL);
0d863452
RH		 4460}
4461
4b021f5f
RGS		 4462/* This version of do_smartmatch() implements the
4463 * table of smart matches that is found in perlsyn.
0d863452 4464 */
4136a0f7 4465STATIC OP *
0d863452
RH		 4466S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4467{
97aff369 4468 dVAR;
0d863452
RH		 4469 dSP;
4470
41e726ac 4471 bool object_on_left = FALSE;
0d863452
RH		 4472 SV *e = TOPs; /* e is for 'expression' */
4473 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
a566f585 4474
6f1401dc
DM		 4475 /* Take care only to invoke mg_get() once for each argument.
4476 * Currently we do this by copying the SV if it's magical. */
4477 if (d) {
4478 if (SvGMAGICAL(d))
4479 d = sv_mortalcopy(d);
4480 }
4481 else
4482 d = &PL_sv_undef;
4483
4484 assert(e);
4485 if (SvGMAGICAL(e))
4486 e = sv_mortalcopy(e);
4487
2c9d2554 4488 /* First of all, handle overload magic of the rightmost argument */
6d743019 4489 if (SvAMAGIC(e)) {
d7c0d282
DM		 4490 SV * tmpsv;
4491 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4492 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4493
4494 tmpsv = amagic_call(d, e, smart_amg, 0);
7c41e62e
RGS		 4495 if (tmpsv) {
4496 SPAGAIN;
4497 (void)POPs;
4498 SETs(tmpsv);
4499 RETURN;
4500 }
d7c0d282 4501 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
7c41e62e 4502 }
62ec5f58 4503
0d863452
RH		 4504 SP -= 2; /* Pop the values */
4505
0d863452 4506
b0138e99 4507 /* ~~ undef */
62ec5f58 4508 if (!SvOK(e)) {
d7c0d282 4509 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
62ec5f58 4510 if (SvOK(d))
33570f8b
RGS		 4511 RETPUSHNO;
4512 else
62ec5f58 4513 RETPUSHYES;
33570f8b 4514 }
e67b97bd 4515
d7c0d282
DM		 4516 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4517 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
62ec5f58 4518 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
d7c0d282 4519 }
41e726ac
RGS		 4520 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4521 object_on_left = TRUE;
62ec5f58 4522
b0138e99 4523 /* ~~ sub */
a4a197da 4524 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
0d863452 4525 I32 c;
41e726ac
RGS		 4526 if (object_on_left) {
4527 goto sm_any_sub; /* Treat objects like scalars */
4528 }
4529 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
a4a197da
RGS		 4530 /* Test sub truth for each key */
4531 HE *he;
4532 bool andedresults = TRUE;
4533 HV *hv = (HV*) SvRV(d);
168ff818 4534 I32 numkeys = hv_iterinit(hv);
d7c0d282 4535 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
168ff818 4536 if (numkeys == 0)
07edf497 4537 RETPUSHYES;
a4a197da 4538 while ( (he = hv_iternext(hv)) ) {
d7c0d282 4539 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
d343c3ef 4540 ENTER_with_name("smartmatch_hash_key_test");
a4a197da
RGS		 4541 SAVETMPS;
4542 PUSHMARK(SP);
4543 PUSHs(hv_iterkeysv(he));
4544 PUTBACK;
4545 c = call_sv(e, G_SCALAR);
4546 SPAGAIN;
4547 if (c == 0)
4548 andedresults = FALSE;
4549 else
4550 andedresults = SvTRUEx(POPs) && andedresults;
4551 FREETMPS;
d343c3ef 4552 LEAVE_with_name("smartmatch_hash_key_test");
a4a197da
RGS		 4553 }
4554 if (andedresults)
4555 RETPUSHYES;
4556 else
4557 RETPUSHNO;
4558 }
4559 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4560 /* Test sub truth for each element */
4561 I32 i;
4562 bool andedresults = TRUE;
4563 AV *av = (AV*) SvRV(d);
4564 const I32 len = av_len(av);
d7c0d282 4565 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
168ff818 4566 if (len == -1)
07edf497 4567 RETPUSHYES;
a4a197da
RGS		 4568 for (i = 0; i <= len; ++i) {
4569 SV * const * const svp = av_fetch(av, i, FALSE);
d7c0d282 4570 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
d343c3ef 4571 ENTER_with_name("smartmatch_array_elem_test");
a4a197da
RGS		 4572 SAVETMPS;
4573 PUSHMARK(SP);
4574 if (svp)
4575 PUSHs(*svp);
4576 PUTBACK;
4577 c = call_sv(e, G_SCALAR);
4578 SPAGAIN;
4579 if (c == 0)
4580 andedresults = FALSE;
4581 else
4582 andedresults = SvTRUEx(POPs) && andedresults;
4583 FREETMPS;
d343c3ef 4584 LEAVE_with_name("smartmatch_array_elem_test");
a4a197da
RGS		 4585 }
4586 if (andedresults)
4587 RETPUSHYES;
4588 else
4589 RETPUSHNO;
4590 }
4591 else {
41e726ac 4592 sm_any_sub:
d7c0d282 4593 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
d343c3ef 4594 ENTER_with_name("smartmatch_coderef");
a4a197da
RGS		 4595 SAVETMPS;
4596 PUSHMARK(SP);
4597 PUSHs(d);
4598 PUTBACK;
4599 c = call_sv(e, G_SCALAR);
4600 SPAGAIN;
4601 if (c == 0)
4602 PUSHs(&PL_sv_no);
4603 else if (SvTEMP(TOPs))
4604 SvREFCNT_inc_void(TOPs);
4605 FREETMPS;
d343c3ef 4606 LEAVE_with_name("smartmatch_coderef");
a4a197da
RGS		 4607 RETURN;
4608 }
0d863452 4609 }
b0138e99 4610 /* ~~ %hash */
61a621c6 4611 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
41e726ac
RGS		 4612 if (object_on_left) {
4613 goto sm_any_hash; /* Treat objects like scalars */
4614 }
4615 else if (!SvOK(d)) {
d7c0d282 4616 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
61a621c6
RGS		 4617 RETPUSHNO;
4618 }
4619 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
0d863452
RH		 4620 /* Check that the key-sets are identical */
4621 HE *he;
61a621c6 4622 HV *other_hv = MUTABLE_HV(SvRV(d));
0d863452
RH		 4623 bool tied = FALSE;
4624 bool other_tied = FALSE;
4625 U32 this_key_count = 0,
4626 other_key_count = 0;
33ed63a2 4627 HV *hv = MUTABLE_HV(SvRV(e));
d7c0d282
DM		 4628
4629 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
0d863452 4630 /* Tied hashes don't know how many keys they have. */
33ed63a2 4631 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
0d863452
RH		 4632 tied = TRUE;
4633 }
ad64d0ec 4634 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
c445ea15 4635 HV * const temp = other_hv;
33ed63a2
RGS		 4636 other_hv = hv;
4637 hv = temp;
0d863452
RH		 4638 tied = TRUE;
4639 }
ad64d0ec 4640 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
0d863452
RH		 4641 other_tied = TRUE;
4642
33ed63a2 4643 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
0d863452
RH		 4644 RETPUSHNO;
4645
4646 /* The hashes have the same number of keys, so it suffices
4647 to check that one is a subset of the other. */
33ed63a2
RGS		 4648 (void) hv_iterinit(hv);
4649 while ( (he = hv_iternext(hv)) ) {
b15feb55 4650 SV *key = hv_iterkeysv(he);
d7c0d282
DM		 4651
4652 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
0d863452
RH		 4653 ++ this_key_count;
4654
b15feb55 4655 if(!hv_exists_ent(other_hv, key, 0)) {
33ed63a2 4656 (void) hv_iterinit(hv); /* reset iterator */
0d863452
RH		 4657 RETPUSHNO;
4658 }
4659 }
4660
4661 if (other_tied) {
4662 (void) hv_iterinit(other_hv);
4663 while ( hv_iternext(other_hv) )
4664 ++other_key_count;
4665 }
4666 else
4667 other_key_count = HvUSEDKEYS(other_hv);
4668
4669 if (this_key_count != other_key_count)
4670 RETPUSHNO;
4671 else
4672 RETPUSHYES;
4673 }
61a621c6
RGS		 4674 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4675 AV * const other_av = MUTABLE_AV(SvRV(d));
c445ea15 4676 const I32 other_len = av_len(other_av) + 1;
0d863452 4677 I32 i;
33ed63a2 4678 HV *hv = MUTABLE_HV(SvRV(e));
71b0fb34 4679
d7c0d282 4680 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
71b0fb34 4681 for (i = 0; i < other_len; ++i) {
c445ea15 4682 SV ** const svp = av_fetch(other_av, i, FALSE);
d7c0d282 4683 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
71b0fb34 4684 if (svp) { /* ??? When can this not happen? */
b15feb55 4685 if (hv_exists_ent(hv, *svp, 0))
71b0fb34
DK		 4686 RETPUSHYES;
4687 }
0d863452 4688 }
71b0fb34 4689 RETPUSHNO;
0d863452 4690 }
a566f585 4691 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
d7c0d282 4692 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
ea0c2dbd
RGS		 4693 sm_regex_hash:
4694 {
4695 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4696 HE *he;
4697 HV *hv = MUTABLE_HV(SvRV(e));
4698
4699 (void) hv_iterinit(hv);
4700 while ( (he = hv_iternext(hv)) ) {
d7c0d282 4701 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
ea0c2dbd
RGS		 4702 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4703 (void) hv_iterinit(hv);
4704 destroy_matcher(matcher);
4705 RETPUSHYES;
4706 }
0d863452 4707 }
ea0c2dbd
RGS		 4708 destroy_matcher(matcher);
4709 RETPUSHNO;
0d863452 4710 }
0d863452
RH		 4711 }
4712 else {
41e726ac 4713 sm_any_hash:
d7c0d282 4714 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
61a621c6 4715 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
0d863452
RH		 4716 RETPUSHYES;
4717 else
4718 RETPUSHNO;
4719 }
4720 }
b0138e99
RGS		 4721 /* ~~ @array */
4722 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
41e726ac
RGS		 4723 if (object_on_left) {
4724 goto sm_any_array; /* Treat objects like scalars */
4725 }
4726 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
b0138e99
RGS		 4727 AV * const other_av = MUTABLE_AV(SvRV(e));
4728 const I32 other_len = av_len(other_av) + 1;
4729 I32 i;
4730
d7c0d282 4731 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
b0138e99
RGS		 4732 for (i = 0; i < other_len; ++i) {
4733 SV ** const svp = av_fetch(other_av, i, FALSE);
d7c0d282
DM		 4734
4735 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
b0138e99 4736 if (svp) { /* ??? When can this not happen? */
b15feb55 4737 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
b0138e99
RGS		 4738 RETPUSHYES;
4739 }
4740 }
4741 RETPUSHNO;
4742 }
4743 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4744 AV *other_av = MUTABLE_AV(SvRV(d));
d7c0d282 4745 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
b0138e99 4746 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
0d863452
RH		 4747 RETPUSHNO;
4748 else {
4749 I32 i;
c445ea15 4750 const I32 other_len = av_len(other_av);
0d863452 4751
a0714e2c 4752 if (NULL == seen_this) {
0d863452 4753 seen_this = newHV();
ad64d0ec 4754 (void) sv_2mortal(MUTABLE_SV(seen_this));
0d863452 4755 }
a0714e2c 4756 if (NULL == seen_other) {
6bc991bf 4757 seen_other = newHV();
ad64d0ec 4758 (void) sv_2mortal(MUTABLE_SV(seen_other));
0d863452
RH		 4759 }
4760 for(i = 0; i <= other_len; ++i) {
b0138e99 4761 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
c445ea15
AL		 4762 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4763
0d863452 4764 if (!this_elem || !other_elem) {
69c3dccf
RGS		 4765 if ((this_elem && SvOK(*this_elem))
4766 || (other_elem && SvOK(*other_elem)))
0d863452
RH		 4767 RETPUSHNO;
4768 }
365c4e3d
RGS		 4769 else if (hv_exists_ent(seen_this,
4770 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4771 hv_exists_ent(seen_other,
4772 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
0d863452
RH		 4773 {
4774 if (*this_elem != *other_elem)
4775 RETPUSHNO;
4776 }
4777 else {
04fe65b0
RGS		 4778 (void)hv_store_ent(seen_this,
4779 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4780 &PL_sv_undef, 0);
4781 (void)hv_store_ent(seen_other,
4782 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4783 &PL_sv_undef, 0);
0d863452 4784 PUSHs(*other_elem);
a566f585 4785 PUSHs(*this_elem);
0d863452
RH		 4786
4787 PUTBACK;
d7c0d282 4788 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
0d863452
RH		 4789 (void) do_smartmatch(seen_this, seen_other);
4790 SPAGAIN;
d7c0d282 4791 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
0d863452
RH		 4792
4793 if (!SvTRUEx(POPs))
4794 RETPUSHNO;
4795 }
4796 }
4797 RETPUSHYES;
4798 }
4799 }
a566f585 4800 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
d7c0d282 4801 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
ea0c2dbd
RGS		 4802 sm_regex_array:
4803 {
4804 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4805 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4806 I32 i;
0d863452 4807
ea0c2dbd
RGS		 4808 for(i = 0; i <= this_len; ++i) {
4809 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
d7c0d282 4810 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
ea0c2dbd
RGS		 4811 if (svp && matcher_matches_sv(matcher, *svp)) {
4812 destroy_matcher(matcher);
4813 RETPUSHYES;
4814 }
0d863452 4815 }
ea0c2dbd
RGS		 4816 destroy_matcher(matcher);
4817 RETPUSHNO;
0d863452 4818 }
0d863452 4819 }
015eb7b9
RGS		 4820 else if (!SvOK(d)) {
4821 /* undef ~~ array */
4822 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
0d863452
RH		 4823 I32 i;
4824
d7c0d282 4825 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
015eb7b9 4826 for (i = 0; i <= this_len; ++i) {
b0138e99 4827 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
d7c0d282 4828 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
015eb7b9 4829 if (!svp || !SvOK(*svp))
0d863452
RH		 4830 RETPUSHYES;
4831 }
4832 RETPUSHNO;
4833 }
015eb7b9 4834 else {
41e726ac
RGS		 4835 sm_any_array:
4836 {
4837 I32 i;
4838 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
0d863452 4839
d7c0d282 4840 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
41e726ac
RGS		 4841 for (i = 0; i <= this_len; ++i) {
4842 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4843 if (!svp)
4844 continue;
015eb7b9 4845
41e726ac
RGS		 4846 PUSHs(d);
4847 PUSHs(*svp);
4848 PUTBACK;
4849 /* infinite recursion isn't supposed to happen here */
d7c0d282 4850 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
41e726ac
RGS		 4851 (void) do_smartmatch(NULL, NULL);
4852 SPAGAIN;
d7c0d282 4853 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
41e726ac
RGS		 4854 if (SvTRUEx(POPs))
4855 RETPUSHYES;
4856 }
4857 RETPUSHNO;
0d863452 4858 }
0d863452
RH		 4859 }
4860 }
b0138e99 4861 /* ~~ qr// */
a566f585 4862 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
ea0c2dbd
RGS		 4863 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4864 SV *t = d; d = e; e = t;
d7c0d282 4865 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
ea0c2dbd
RGS		 4866 goto sm_regex_hash;
4867 }
4868 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4869 SV *t = d; d = e; e = t;
d7c0d282 4870 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
ea0c2dbd
RGS		 4871 goto sm_regex_array;
4872 }
4873 else {
4874 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
0d863452 4875
d7c0d282 4876 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
ea0c2dbd
RGS		 4877 PUTBACK;
4878 PUSHs(matcher_matches_sv(matcher, d)
4879 ? &PL_sv_yes
4880 : &PL_sv_no);
4881 destroy_matcher(matcher);
4882 RETURN;
4883 }
0d863452 4884 }
b0138e99 4885 /* ~~ scalar */
2c9d2554
RGS		 4886 /* See if there is overload magic on left */
4887 else if (object_on_left && SvAMAGIC(d)) {
4888 SV *tmpsv;
d7c0d282
DM		 4889 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4890 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
2c9d2554
RGS		 4891 PUSHs(d); PUSHs(e);
4892 PUTBACK;
4893 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4894 if (tmpsv) {
4895 SPAGAIN;
4896 (void)POPs;
4897 SETs(tmpsv);
4898 RETURN;
4899 }
4900 SP -= 2;
d7c0d282 4901 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
2c9d2554
RGS		 4902 goto sm_any_scalar;
4903 }
fb51372e
RGS		 4904 else if (!SvOK(d)) {
4905 /* undef ~~ scalar ; we already know that the scalar is SvOK */
d7c0d282 4906 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
fb51372e
RGS		 4907 RETPUSHNO;
4908 }
2c9d2554
RGS		 4909 else
4910 sm_any_scalar:
4911 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
d7c0d282
DM		 4912 DEBUG_M(if (SvNIOK(e))
4913 Perl_deb(aTHX_ " applying rule Any-Num\n");
4914 else
4915 Perl_deb(aTHX_ " applying rule Num-numish\n");
4916 );
33ed63a2 4917 /* numeric comparison */
0d863452
RH		 4918 PUSHs(d); PUSHs(e);
4919 PUTBACK;
a98fe34d 4920 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
897d3989 4921 (void) Perl_pp_i_eq(aTHX);
0d863452 4922 else
897d3989 4923 (void) Perl_pp_eq(aTHX);
0d863452
RH		 4924 SPAGAIN;
4925 if (SvTRUEx(POPs))
4926 RETPUSHYES;
4927 else
4928 RETPUSHNO;
4929 }
4930
4931 /* As a last resort, use string comparison */
d7c0d282 4932 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
0d863452
RH		 4933 PUSHs(d); PUSHs(e);
4934 PUTBACK;
897d3989 4935 return Perl_pp_seq(aTHX);
0d863452
RH		 4936}
4937
4938PP(pp_enterwhen)
4939{
4940 dVAR; dSP;
4941 register PERL_CONTEXT *cx;
4942 const I32 gimme = GIMME_V;
4943
4944 /* This is essentially an optimization: if the match
4945 fails, we don't want to push a context and then
4946 pop it again right away, so we skip straight
4947 to the op that follows the leavewhen.
25b991bf 4948 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
0d863452
RH		 4949 */
4950 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
25b991bf 4951 RETURNOP(cLOGOP->op_other->op_next);
0d863452 4952
c08f093b 4953 ENTER_with_name("when");
0d863452
RH		 4954 SAVETMPS;
4955
4956 PUSHBLOCK(cx, CXt_WHEN, SP);
4957 PUSHWHEN(cx);
4958
4959 RETURN;
4960}
4961
4962PP(pp_leavewhen)
4963{
4964 dVAR; dSP;
c08f093b 4965 I32 cxix;
0d863452 4966 register PERL_CONTEXT *cx;
c08f093b 4967 I32 gimme;
0d863452
RH		 4968 SV **newsp;
4969 PMOP *newpm;
4970
c08f093b
VP		 4971 cxix = dopoptogiven(cxstack_ix);
4972 if (cxix < 0)
4973 DIE(aTHX_ "Can't use when() outside a topicalizer");
4974
0d863452
RH		 4975 POPBLOCK(cx,newpm);
4976 assert(CxTYPE(cx) == CXt_WHEN);
4977
c08f093b
VP		 4978 TAINT_NOT;
4979 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
0d863452
RH		 4980 PL_curpm = newpm; /* pop $1 et al */
4981
c08f093b
VP		 4982 LEAVE_with_name("when");
4983
4984 if (cxix < cxstack_ix)
4985 dounwind(cxix);
4986
4987 cx = &cxstack[cxix];
4988
4989 if (CxFOREACH(cx)) {
4990 /* clear off anything above the scope we're re-entering */
4991 I32 inner = PL_scopestack_ix;
4992
4993 TOPBLOCK(cx);
4994 if (PL_scopestack_ix < inner)
4995 leave_scope(PL_scopestack[PL_scopestack_ix]);
4996 PL_curcop = cx->blk_oldcop;
4997
4998 return cx->blk_loop.my_op->op_nextop;
4999 }
5000 else
5001 /* RETURNOP calls PUTBACK which restores the old old sp */
5002 return cx->blk_givwhen.leave_op;
0d863452
RH		 5003}
5004
5005PP(pp_continue)
5006{
c08f093b 5007 dVAR; dSP;
0d863452
RH		 5008 I32 cxix;
5009 register PERL_CONTEXT *cx;
c08f093b
VP		 5010 I32 gimme;
5011 SV **newsp;
5012 PMOP *newpm;
0d863452
RH		 5013
5014 cxix = dopoptowhen(cxstack_ix);
5015 if (cxix < 0)
5016 DIE(aTHX_ "Can't \"continue\" outside a when block");
c08f093b 5017
0d863452
RH		 5018 if (cxix < cxstack_ix)
5019 dounwind(cxix);
5020
c08f093b
VP		 5021 POPBLOCK(cx,newpm);
5022 assert(CxTYPE(cx) == CXt_WHEN);
5023
5024 SP = newsp;
5025 PL_curpm = newpm; /* pop $1 et al */
5026
5027 LEAVE_with_name("when");
5028 RETURNOP(cx->blk_givwhen.leave_op->op_next);
0d863452
RH		 5029}
5030
5031PP(pp_break)
5032{
5033 dVAR;
5034 I32 cxix;
5035 register PERL_CONTEXT *cx;
25b991bf 5036
0d863452 5037 cxix = dopoptogiven(cxstack_ix);
c08f093b
VP		 5038 if (cxix < 0)
5039 DIE(aTHX_ "Can't \"break\" outside a given block");
5040
5041 cx = &cxstack[cxix];
5042 if (CxFOREACH(cx))
0d863452
RH		 5043 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5044
5045 if (cxix < cxstack_ix)
5046 dounwind(cxix);
0d863452 5047
c08f093b
VP		 5048 /* RETURNOP calls PUTBACK which restores the old old sp */
5049 return cx->blk_givwhen.leave_op;
0d863452
RH		 5050}
5051
74e0ddf7 5052static MAGIC *
cea2e8a9 5053S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW		 5054{
5055 STRLEN len;
37ffbfcc 5056 register char *s = SvPV(sv, len);
3808a683 5057 register char *send;
086b26f3
DM		 5058 register char *base = NULL; /* start of current field */
5059 register I32 skipspaces = 0; /* number of contiguous spaces seen */
5060 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5061 bool repeat = FALSE; /* ~~ seen on this line */
5062 bool postspace = FALSE; /* a text field may need right padding */
dea28490
JJ		 5063 U32 *fops;
5064 register U32 *fpc;
086b26f3 5065 U32 *linepc = NULL; /* position of last FF_LINEMARK */
a0d0e21e 5066 register I32 arg;
086b26f3
DM		 5067 bool ischop; /* it's a ^ rather than a @ */
5068 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
a1b95068 5069 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3808a683
DM		 5070 MAGIC *mg = NULL;
5071 SV *sv_copy;
a0d0e21e 5072
7918f24d
NC		 5073 PERL_ARGS_ASSERT_DOPARSEFORM;
5074
55497cff 5075 if (len == 0)
cea2e8a9 5076 Perl_croak(aTHX_ "Null picture in formline");
ac27b0f5 5077
3808a683
DM		 5078 if (SvTYPE(sv) >= SVt_PVMG) {
5079 /* This might, of course, still return NULL. */
5080 mg = mg_find(sv, PERL_MAGIC_fm);
5081 } else {
5082 sv_upgrade(sv, SVt_PVMG);
5083 }
5084
5085 if (mg) {
5086 /* still the same as previously-compiled string? */
5087 SV *old = mg->mg_obj;
5088 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5089 && len == SvCUR(old)
5090 && strnEQ(SvPVX(old), SvPVX(sv), len)
b57b1734
DM		 5091 ) {
5092 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
3808a683 5093 return mg;
b57b1734 5094 }
3808a683 5095
b57b1734 5096 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
3808a683
DM		 5097 Safefree(mg->mg_ptr);
5098 mg->mg_ptr = NULL;
5099 SvREFCNT_dec(old);
5100 mg->mg_obj = NULL;
5101 }
b57b1734
DM		 5102 else {
5103 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
3808a683 5104 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
b57b1734 5105 }
3808a683
DM		 5106
5107 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5108 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5109 send = s + len;
5110
5111
815f25c6
DM		 5112 /* estimate the buffer size needed */
5113 for (base = s; s <= send; s++) {
a1b95068 5114 if (*s == '\n' || *s == '@' || *s == '^')
815f25c6
DM		 5115 maxops += 10;
5116 }
5117 s = base;
c445ea15 5118 base = NULL;
815f25c6 5119
a02a5408 5120 Newx(fops, maxops, U32);
a0d0e21e
LW		 5121 fpc = fops;
5122
5123 if (s < send) {
5124 linepc = fpc;
5125 *fpc++ = FF_LINEMARK;
5126 noblank = repeat = FALSE;
5127 base = s;
5128 }
5129
5130 while (s <= send) {
5131 switch (*s++) {
5132 default:
5133 skipspaces = 0;
5134 continue;
5135
5136 case '~':
5137 if (*s == '~') {
5138 repeat = TRUE;
b57b1734
DM		 5139 skipspaces++;
5140 s++;
a0d0e21e
LW		 5141 }
5142 noblank = TRUE;
a0d0e21e
LW		 5143 /* FALL THROUGH */
5144 case ' ': case '\t':
5145 skipspaces++;
5146 continue;
a1b95068
WL		 5147 case 0:
5148 if (s < send) {
5149 skipspaces = 0;
5150 continue;
5151 } /* else FALL THROUGH */
5152 case '\n':
a0d0e21e
LW		 5153 arg = s - base;
5154 skipspaces++;
5155 arg -= skipspaces;
5156 if (arg) {
5f05dabc 5157 if (postspace)
a0d0e21e 5158 *fpc++ = FF_SPACE;
a0d0e21e 5159 *fpc++ = FF_LITERAL;
76912796 5160 *fpc++ = (U32)arg;
a0d0e21e 5161 }
5f05dabc 5162 postspace = FALSE;
a0d0e21e
LW		 5163 if (s <= send)
5164 skipspaces--;
5165 if (skipspaces) {
5166 *fpc++ = FF_SKIP;
76912796 5167 *fpc++ = (U32)skipspaces;
a0d0e21e
LW		 5168 }
5169 skipspaces = 0;
5170 if (s <= send)
5171 *fpc++ = FF_NEWLINE;
5172 if (noblank) {
5173 *fpc++ = FF_BLANK;
5174 if (repeat)
5175 arg = fpc - linepc + 1;
5176 else
5177 arg = 0;
76912796 5178 *fpc++ = (U32)arg;
a0d0e21e
LW		 5179 }
5180 if (s < send) {
5181 linepc = fpc;
5182 *fpc++ = FF_LINEMARK;
5183 noblank = repeat = FALSE;
5184 base = s;
5185 }
5186 else
5187 s++;
5188 continue;
5189
5190 case '@':
5191 case '^':
5192 ischop = s[-1] == '^';
5193
5194 if (postspace) {
5195 *fpc++ = FF_SPACE;
5196 postspace = FALSE;
5197 }
5198 arg = (s - base) - 1;
5199 if (arg) {
5200 *fpc++ = FF_LITERAL;
76912796 5201 *fpc++ = (U32)arg;
a0d0e21e
LW		 5202 }
5203
5204 base = s - 1;
5205 *fpc++ = FF_FETCH;
086b26f3 5206 if (*s == '*') { /* @* or ^* */
a0d0e21e 5207 s++;
a1b95068
WL		 5208 *fpc++ = 2; /* skip the @* or ^* */
5209 if (ischop) {
5210 *fpc++ = FF_LINESNGL;
5211 *fpc++ = FF_CHOP;
5212 } else
5213 *fpc++ = FF_LINEGLOB;
a0d0e21e 5214 }
086b26f3 5215 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
a701009a 5216 arg = ischop ? FORM_NUM_BLANK : 0;
a0d0e21e
LW		 5217 base = s - 1;
5218 while (*s == '#')
5219 s++;
5220 if (*s == '.') {
06b5626a 5221 const char * const f = ++s;
a0d0e21e
LW		 5222 while (*s == '#')
5223 s++;
a701009a 5224 arg |= FORM_NUM_POINT + (s - f);
a0d0e21e
LW		 5225 }
5226 *fpc++ = s - base; /* fieldsize for FETCH */
5227 *fpc++ = FF_DECIMAL;
76912796 5228 *fpc++ = (U32)arg;
a1b95068 5229 unchopnum |= ! ischop;
784707d5
JP		 5230 }
5231 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
a701009a 5232 arg = ischop ? FORM_NUM_BLANK : 0;
784707d5
JP		 5233 base = s - 1;
5234 s++; /* skip the '0' first */
5235 while (*s == '#')
5236 s++;
5237 if (*s == '.') {
06b5626a 5238 const char * const f = ++s;
784707d5
JP		 5239 while (*s == '#')
5240 s++;
a701009a 5241 arg |= FORM_NUM_POINT + (s - f);
784707d5
JP		 5242 }
5243 *fpc++ = s - base; /* fieldsize for FETCH */
5244 *fpc++ = FF_0DECIMAL;
76912796 5245 *fpc++ = (U32)arg;
a1b95068 5246 unchopnum |= ! ischop;
a0d0e21e 5247 }
086b26f3 5248 else { /* text field */
a0d0e21e
LW		 5249 I32 prespace = 0;
5250 bool ismore = FALSE;
5251
5252 if (*s == '>') {
5253 while (*++s == '>') ;
5254 prespace = FF_SPACE;
5255 }
5256 else if (*s == '|') {
5257 while (*++s == '|') ;
5258 prespace = FF_HALFSPACE;
5259 postspace = TRUE;
5260 }
5261 else {
5262 if (*s == '<')
5263 while (*++s == '<') ;
5264 postspace = TRUE;
5265 }
5266 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5267 s += 3;
5268 ismore = TRUE;
5269 }
5270 *fpc++ = s - base; /* fieldsize for FETCH */
5271
5272 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5273
5274 if (prespace)
76912796 5275 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
a0d0e21e
LW		 5276 *fpc++ = FF_ITEM;
5277 if (ismore)
5278 *fpc++ = FF_MORE;
5279 if (ischop)
5280 *fpc++ = FF_CHOP;
5281 }
5282 base = s;
5283 skipspaces = 0;
5284 continue;
5285 }
5286 }
5287 *fpc++ = FF_END;
5288
815f25c6 5289 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
a0d0e21e 5290 arg = fpc - fops;
74e0ddf7 5291
3808a683 5292 mg->mg_ptr = (char *) fops;
74e0ddf7 5293 mg->mg_len = arg * sizeof(U32);
3808a683
DM		 5294 mg->mg_obj = sv_copy;
5295 mg->mg_flags |= MGf_REFCOUNTED;
a1b95068 5296
bfed75c6 5297 if (unchopnum && repeat)
75f63940 5298 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
74e0ddf7
NC		 5299
5300 return mg;
a1b95068
WL		 5301}
5302
5303
5304STATIC bool
5305S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5306{
5307 /* Can value be printed in fldsize chars, using %*.*f ? */
5308 NV pwr = 1;
5309 NV eps = 0.5;
5310 bool res = FALSE;
5311 int intsize = fldsize - (value < 0 ? 1 : 0);
5312
a701009a 5313 if (frcsize & FORM_NUM_POINT)
a1b95068 5314 intsize--;
a701009a 5315 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
a1b95068
WL		 5316 intsize -= frcsize;
5317
5318 while (intsize--) pwr *= 10.0;
5319 while (frcsize--) eps /= 10.0;
5320
5321 if( value >= 0 ){
5322 if (value + eps >= pwr)
5323 res = TRUE;
5324 } else {
5325 if (value - eps <= -pwr)
5326 res = TRUE;
5327 }
5328 return res;
a0d0e21e 5329}
4e35701f 5330
bbed91b5 5331static I32
0bd48802 5332S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
bbed91b5 5333{
27da23d5 5334 dVAR;
0bd48802 5335 SV * const datasv = FILTER_DATA(idx);
504618e9 5336 const int filter_has_file = IoLINES(datasv);
ad64d0ec
NC		 5337 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5338 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
941a98a0 5339 int status = 0;
ec0b63d7 5340 SV *upstream;
941a98a0 5341 STRLEN got_len;
162177c1
Z		 5342 char *got_p = NULL;
5343 char *prune_from = NULL;
34113e50 5344 bool read_from_cache = FALSE;
bb7a0f54
MHM		 5345 STRLEN umaxlen;
5346
7918f24d
NC		 5347 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5348
bb7a0f54
MHM		 5349 assert(maxlen >= 0);
5350 umaxlen = maxlen;
5675696b 5351
bbed91b5
KF		 5352 /* I was having segfault trouble under Linux 2.2.5 after a
5353 parse error occured. (Had to hack around it with a test
13765c85 5354 for PL_parser->error_count == 0.) Solaris doesn't segfault --
bbed91b5
KF		 5355 not sure where the trouble is yet. XXX */
5356
4464f08e
NC		 5357 {
5358 SV *const cache = datasv;
937b367d
NC		 5359 if (SvOK(cache)) {
5360 STRLEN cache_len;
5361 const char *cache_p = SvPV(cache, cache_len);
941a98a0
NC		 5362 STRLEN take = 0;
5363
bb7a0f54 5364 if (umaxlen) {
941a98a0
NC		 5365 /* Running in block mode and we have some cached data already.
5366 */
bb7a0f54 5367 if (cache_len >= umaxlen) {
941a98a0
NC		 5368 /* In fact, so much data we don't even need to call
5369 filter_read. */
bb7a0f54 5370 take = umaxlen;
941a98a0
NC		 5371 }
5372 } else {
10edeb5d
JH		 5373 const char *const first_nl =
5374 (const char *)memchr(cache_p, '\n', cache_len);
941a98a0
NC		 5375 if (first_nl) {
5376 take = first_nl + 1 - cache_p;
5377 }
5378 }
5379 if (take) {
5380 sv_catpvn(buf_sv, cache_p, take);
5381 sv_chop(cache, cache_p + take);
486ec47a 5382 /* Definitely not EOF */
937b367d
NC		 5383 return 1;
5384 }
941a98a0 5385
937b367d 5386 sv_catsv(buf_sv, cache);
bb7a0f54
MHM		 5387 if (umaxlen) {
5388 umaxlen -= cache_len;
941a98a0 5389 }
937b367d 5390 SvOK_off(cache);
34113e50 5391 read_from_cache = TRUE;
937b367d
NC		 5392 }
5393 }
ec0b63d7 5394
34113e50
NC		 5395 /* Filter API says that the filter appends to the contents of the buffer.
5396 Usually the buffer is "", so the details don't matter. But if it's not,
5397 then clearly what it contains is already filtered by this filter, so we
5398 don't want to pass it in a second time.
5399 I'm going to use a mortal in case the upstream filter croaks. */
ec0b63d7
NC		 5400 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5401 ? sv_newmortal() : buf_sv;
5402 SvUPGRADE(upstream, SVt_PV);
937b367d 5403
bbed91b5 5404 if (filter_has_file) {
67e70b33 5405 status = FILTER_READ(idx+1, upstream, 0);
bbed91b5
KF		 5406 }
5407
34113e50 5408 if (filter_sub && status >= 0) {
39644a26 5409 dSP;
bbed91b5
KF		 5410 int count;
5411
d343c3ef 5412 ENTER_with_name("call_filter_sub");
339c6c60
FC		 5413 save_gp(PL_defgv, 0);
5414 GvINTRO_off(PL_defgv);
d34a6664 5415 SAVEGENERICSV(GvSV(PL_defgv));
bbed91b5
KF		 5416 SAVETMPS;
5417 EXTEND(SP, 2);
5418
414bf5ae 5419 DEFSV_set(upstream);
d34a6664 5420 SvREFCNT_inc_simple_void_NN(upstream);
bbed91b5 5421 PUSHMARK(SP);
6e449a3a 5422 mPUSHi(0);
bbed91b5
KF		 5423 if (filter_state) {
5424 PUSHs(filter_state);
5425 }
5426 PUTBACK;
5427 count = call_sv(filter_sub, G_SCALAR);
5428 SPAGAIN;
5429
5430 if (count > 0) {
5431 SV *out = POPs;
5432 if (SvOK(out)) {
941a98a0 5433 status = SvIV(out);
bbed91b5
KF		 5434 }
5435 }
5436
5437 PUTBACK;
5438 FREETMPS;
d343c3ef 5439 LEAVE_with_name("call_filter_sub");
bbed91b5
KF		 5440 }
5441
941a98a0
NC		 5442 if(SvOK(upstream)) {
5443 got_p = SvPV(upstream, got_len);
bb7a0f54
MHM		 5444 if (umaxlen) {
5445 if (got_len > umaxlen) {
5446 prune_from = got_p + umaxlen;
937b367d 5447 }
941a98a0 5448 } else {
162177c1 5449 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
941a98a0
NC		 5450 if (first_nl && first_nl + 1 < got_p + got_len) {
5451 /* There's a second line here... */
5452 prune_from = first_nl + 1;
937b367d 5453 }
937b367d
NC		 5454 }
5455 }
941a98a0
NC		 5456 if (prune_from) {
5457 /* Oh. Too long. Stuff some in our cache. */
5458 STRLEN cached_len = got_p + got_len - prune_from;
4464f08e 5459 SV *const cache = datasv;
941a98a0 5460
4464f08e 5461 if (SvOK(cache)) {
941a98a0
NC		 5462 /* Cache should be empty. */
5463 assert(!SvCUR(cache));
5464 }
5465
5466 sv_setpvn(cache, prune_from, cached_len);
5467 /* If you ask for block mode, you may well split UTF-8 characters.
5468 "If it breaks, you get to keep both parts"
5469 (Your code is broken if you don't put them back together again
5470 before something notices.) */
5471 if (SvUTF8(upstream)) {
5472 SvUTF8_on(cache);
5473 }
5474 SvCUR_set(upstream, got_len - cached_len);
162177c1 5475 *prune_from = 0;
941a98a0
NC		 5476 /* Can't yet be EOF */
5477 if (status == 0)
5478 status = 1;
5479 }
937b367d 5480
34113e50
NC		 5481 /* If they are at EOF but buf_sv has something in it, then they may never
5482 have touched the SV upstream, so it may be undefined. If we naively
5483 concatenate it then we get a warning about use of uninitialised value.
5484 */
5485 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
937b367d
NC		 5486 sv_catsv(buf_sv, upstream);
5487 }
5488
941a98a0 5489 if (status <= 0) {
bbed91b5 5490 IoLINES(datasv) = 0;
bbed91b5
KF		 5491 if (filter_state) {
5492 SvREFCNT_dec(filter_state);
a0714e2c 5493 IoTOP_GV(datasv) = NULL;
bbed91b5
KF		 5494 }
5495 if (filter_sub) {
5496 SvREFCNT_dec(filter_sub);
a0714e2c 5497 IoBOTTOM_GV(datasv) = NULL;
bbed91b5 5498 }
0bd48802 5499 filter_del(S_run_user_filter);
bbed91b5 5500 }
34113e50
NC		 5501 if (status == 0 && read_from_cache) {
5502 /* If we read some data from the cache (and by getting here it implies
5503 that we emptied the cache) then we aren't yet at EOF, and mustn't
5504 report that to our caller. */
5505 return 1;
5506 }
941a98a0 5507 return status;
bbed91b5 5508}
84d4ea48 5509
be4b629d
CN		 5510/* perhaps someone can come up with a better name for
5511 this? it is not really "absolute", per se ... */
cf42f822 5512static bool
5f66b61c 5513S_path_is_absolute(const char *name)
be4b629d 5514{
7918f24d
NC		 5515 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5516
be4b629d 5517 if (PERL_FILE_IS_ABSOLUTE(name)
3f66cd94 5518#ifdef WIN32
36f064bc
CL		 5519 || (*name == '.' && ((name[1] == '/' ||
5520 (name[1] == '.' && name[2] == '/'))
5521 || (name[1] == '\\' ||
5522 ( name[1] == '.' && name[2] == '\\')))
5523 )
5524#else
be4b629d 5525 || (*name == '.' && (name[1] == '/' ||
0bd48802 5526 (name[1] == '.' && name[2] == '/')))
36f064bc 5527#endif
0bd48802 5528 )
be4b629d
CN		 5529 {
5530 return TRUE;
5531 }
5532 else
5533 return FALSE;
5534}
241d1a3b
NC		 5535
5536/*
5537 * Local variables:
5538 * c-indentation-style: bsd
5539 * c-basic-offset: 4
5540 * indent-tabs-mode: t
5541 * End:
5542 *
37442d52
RGS		 5543 * ex: set ts=8 sts=4 sw=4 noet:
5544 */
Unnamed repository; edit this file 'description' to name the repository.