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