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