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