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