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