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
Un-TODO a fixed test
[perl5.git] / pp_ctl.c
CommitLineData
a0d0e21e
LW		 1/* pp_ctl.c
2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
241d1a3b 4 * 2000, 2001, 2002, 2003, 2004, 2005, 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/*
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
166f8a29
DM		 20/* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
25 *
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
28 */
29
30
a0d0e21e 31#include "EXTERN.h"
864dbfa3 32#define PERL_IN_PP_CTL_C
a0d0e21e
LW		 33#include "perl.h"
34
35#ifndef WORD_ALIGN
dea28490 36#define WORD_ALIGN sizeof(U32)
a0d0e21e
LW		 37#endif
38
54310121 39#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
1e422769 40
a0d0e21e
LW		 41PP(pp_wantarray)
42{
39644a26 43 dSP;
a0d0e21e
LW		 44 I32 cxix;
45 EXTEND(SP, 1);
46
47 cxix = dopoptosub(cxstack_ix);
48 if (cxix < 0)
49 RETPUSHUNDEF;
50
54310121 51 switch (cxstack[cxix].blk_gimme) {
52 case G_ARRAY:
a0d0e21e 53 RETPUSHYES;
54310121 54 case G_SCALAR:
a0d0e21e 55 RETPUSHNO;
54310121 56 default:
57 RETPUSHUNDEF;
58 }
a0d0e21e
LW		 59}
60
2cd61cdb
IZ		 61PP(pp_regcreset)
62{
63 /* XXXX Should store the old value to allow for tie/overload - and
64 restore in regcomp, where marked with XXXX. */
3280af22 65 PL_reginterp_cnt = 0;
0b4182de 66 TAINT_NOT;
2cd61cdb
IZ		 67 return NORMAL;
68}
69
b3eb6a9b
GS		 70PP(pp_regcomp)
71{
39644a26 72 dSP;
a0d0e21e 73 register PMOP *pm = (PMOP*)cLOGOP->op_other;
a0d0e21e 74 SV *tmpstr;
c277df42 75 MAGIC *mg = Null(MAGIC*);
bfed75c6 76
4b5a0d1c 77 /* prevent recompiling under /o and ithreads. */
3db8f154 78#if defined(USE_ITHREADS)
131b3ad0
DM		 79 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
80 if (PL_op->op_flags & OPf_STACKED) {
81 dMARK;
82 SP = MARK;
83 }
84 else
85 (void)POPs;
86 RETURN;
87 }
513629ba 88#endif
131b3ad0
DM		 89 if (PL_op->op_flags & OPf_STACKED) {
90 /* multiple args; concatentate them */
91 dMARK; dORIGMARK;
92 tmpstr = PAD_SV(ARGTARG);
93 sv_setpvn(tmpstr, "", 0);
94 while (++MARK <= SP) {
95 if (PL_amagic_generation) {
96 SV *sv;
97 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
98 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
99 {
100 sv_setsv(tmpstr, sv);
101 continue;
102 }
103 }
104 sv_catsv(tmpstr, *MARK);
105 }
106 SvSETMAGIC(tmpstr);
107 SP = ORIGMARK;
108 }
109 else
110 tmpstr = POPs;
513629ba 111
b3eb6a9b 112 if (SvROK(tmpstr)) {
227a8b4b 113 SV *sv = SvRV(tmpstr);
c277df42 114 if(SvMAGICAL(sv))
14befaf4 115 mg = mg_find(sv, PERL_MAGIC_qr);
c277df42 116 }
b3eb6a9b 117 if (mg) {
44f8325f 118 regexp * const re = (regexp *)mg->mg_obj;
aaa362c4
RS		 119 ReREFCNT_dec(PM_GETRE(pm));
120 PM_SETRE(pm, ReREFCNT_inc(re));
c277df42
IZ		 121 }
122 else {
e62f0680
NC		 123 STRLEN len;
124 const char *t = SvPV_const(tmpstr, len);
c277df42 125
20408e3c 126 /* Check against the last compiled regexp. */
aaa362c4 127 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
eb160463 128 PM_GETRE(pm)->prelen != (I32)len ||
aaa362c4 129 memNE(PM_GETRE(pm)->precomp, t, len))
85aff577 130 {
aaa362c4 131 if (PM_GETRE(pm)) {
d8f2cf8a 132 ReREFCNT_dec(PM_GETRE(pm));
aaa362c4 133 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
c277df42 134 }
533c011a 135 if (PL_op->op_flags & OPf_SPECIAL)
3280af22 136 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
a0d0e21e 137
c277df42 138 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
84e09d5e
JH		 139 if (DO_UTF8(tmpstr))
140 pm->op_pmdynflags |= PMdf_DYN_UTF8;
141 else {
142 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
143 if (pm->op_pmdynflags & PMdf_UTF8)
144 t = (char*)bytes_to_utf8((U8*)t, &len);
145 }
e62f0680 146 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
84e09d5e
JH		 147 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
148 Safefree(t);
f86aaa29 149 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
2cd61cdb 150 inside tie/overload accessors. */
c277df42 151 }
4633a7c4 152 }
a0d0e21e 153
72311751 154#ifndef INCOMPLETE_TAINTS
3280af22
NIS		 155 if (PL_tainting) {
156 if (PL_tainted)
72311751
GS		 157 pm->op_pmdynflags |= PMdf_TAINTED;
158 else
159 pm->op_pmdynflags &= ~PMdf_TAINTED;
160 }
161#endif
162
aaa362c4 163 if (!PM_GETRE(pm)->prelen && PL_curpm)
3280af22 164 pm = PL_curpm;
17cbf7cc
AMS		 165 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
166 pm->op_pmflags |= PMf_WHITE;
16bdb4ac 167 else
17cbf7cc 168 pm->op_pmflags &= ~PMf_WHITE;
a0d0e21e 169
2360cd68 170 /* XXX runtime compiled output needs to move to the pad */
a0d0e21e 171 if (pm->op_pmflags & PMf_KEEP) {
c90c0ff4 172 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
3db8f154 173#if !defined(USE_ITHREADS)
2360cd68 174 /* XXX can't change the optree at runtime either */
533c011a 175 cLOGOP->op_first->op_next = PL_op->op_next;
2360cd68 176#endif
a0d0e21e
LW		 177 }
178 RETURN;
179}
180
181PP(pp_substcont)
182{
39644a26 183 dSP;
c09156bb 184 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
901017d6
AL		 185 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
186 register SV * const dstr = cx->sb_dstr;
a0d0e21e
LW		 187 register char *s = cx->sb_s;
188 register char *m = cx->sb_m;
189 char *orig = cx->sb_orig;
901017d6 190 register REGEXP * const rx = cx->sb_rx;
db79b45b 191 SV *nsv = Nullsv;
988e6e7e
AE		 192 REGEXP *old = PM_GETRE(pm);
193 if(old != rx) {
bfed75c6 194 if(old)
988e6e7e 195 ReREFCNT_dec(old);
d8f2cf8a 196 PM_SETRE(pm,rx);
d8f2cf8a
AB		 197 }
198
d9f97599 199 rxres_restore(&cx->sb_rxres, rx);
01b35787 200 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
c90c0ff4 201
a0d0e21e 202 if (cx->sb_iters++) {
a3b680e6 203 const I32 saviters = cx->sb_iters;
a0d0e21e 204 if (cx->sb_iters > cx->sb_maxiters)
cea2e8a9 205 DIE(aTHX_ "Substitution loop");
a0d0e21e 206
48c036b1
GS		 207 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
208 cx->sb_rxtainted |= 2;
a0d0e21e 209 sv_catsv(dstr, POPs);
8ff629d9 210 FREETMPS; /* Prevent excess tmp stack */
a0d0e21e
LW		 211
212 /* Are we done */
cea2e8a9 213 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
9661b544 214 s == m, cx->sb_targ, NULL,
22e551b9 215 ((cx->sb_rflags & REXEC_COPY_STR)
cf93c79d
IZ		 216 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
217 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
a0d0e21e 218 {
823a54a3 219 SV * const targ = cx->sb_targ;
748a9306 220
078c425b
JH		 221 assert(cx->sb_strend >= s);
222 if(cx->sb_strend > s) {
223 if (DO_UTF8(dstr) && !SvUTF8(targ))
224 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
225 else
226 sv_catpvn(dstr, s, cx->sb_strend - s);
227 }
48c036b1 228 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
9212bbba 229
f8c7b90f 230#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 231 if (SvIsCOW(targ)) {
232 sv_force_normal_flags(targ, SV_COW_DROP_PV);
233 } else
234#endif
235 {
8bd4d4c5 236 SvPV_free(targ);
ed252734 237 }
f880fe2f 238 SvPV_set(targ, SvPVX(dstr));
748a9306
LW		 239 SvCUR_set(targ, SvCUR(dstr));
240 SvLEN_set(targ, SvLEN(dstr));
1aa99e6b
IH		 241 if (DO_UTF8(dstr))
242 SvUTF8_on(targ);
f880fe2f 243 SvPV_set(dstr, (char*)0);
748a9306 244 sv_free(dstr);
48c036b1
GS		 245
246 TAINT_IF(cx->sb_rxtainted & 1);
22e13caa 247 PUSHs(sv_2mortal(newSViv(saviters - 1)));
48c036b1 248
ffc61ed2 249 (void)SvPOK_only_UTF8(targ);
48c036b1 250 TAINT_IF(cx->sb_rxtainted);
a0d0e21e 251 SvSETMAGIC(targ);
9212bbba 252 SvTAINT(targ);
5cd24f17 253
4633a7c4 254 LEAVE_SCOPE(cx->sb_oldsave);
d8f2cf8a 255 ReREFCNT_dec(rx);
a0d0e21e
LW		 256 POPSUBST(cx);
257 RETURNOP(pm->op_next);
258 }
8e5e9ebe 259 cx->sb_iters = saviters;
a0d0e21e 260 }
cf93c79d 261 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 262 m = s;
263 s = orig;
cf93c79d 264 cx->sb_orig = orig = rx->subbeg;
a0d0e21e
LW		 265 s = orig + (m - s);
266 cx->sb_strend = s + (cx->sb_strend - m);
267 }
cf93c79d 268 cx->sb_m = m = rx->startp[0] + orig;
db79b45b 269 if (m > s) {
bfed75c6 270 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
db79b45b
JH		 271 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
272 else
273 sv_catpvn(dstr, s, m-s);
274 }
cf93c79d 275 cx->sb_s = rx->endp[0] + orig;
084916e3 276 { /* Update the pos() information. */
44f8325f 277 SV * const sv = cx->sb_targ;
084916e3
JH		 278 MAGIC *mg;
279 I32 i;
280 if (SvTYPE(sv) < SVt_PVMG)
862a34c6 281 SvUPGRADE(sv, SVt_PVMG);
14befaf4
DM		 282 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
283 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
284 mg = mg_find(sv, PERL_MAGIC_regex_global);
084916e3
JH		 285 }
286 i = m - orig;
287 if (DO_UTF8(sv))
288 sv_pos_b2u(sv, &i);
289 mg->mg_len = i;
290 }
988e6e7e 291 if (old != rx)
454f1e26 292 (void)ReREFCNT_inc(rx);
d9f97599
GS		 293 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
294 rxres_save(&cx->sb_rxres, rx);
a0d0e21e
LW		 295 RETURNOP(pm->op_pmreplstart);
296}
297
c90c0ff4 298void
864dbfa3 299Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4 300{
301 UV *p = (UV*)*rsp;
302 U32 i;
303
d9f97599 304 if (!p || p[1] < rx->nparens) {
f8c7b90f 305#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 306 i = 7 + rx->nparens * 2;
307#else
d9f97599 308 i = 6 + rx->nparens * 2;
ed252734 309#endif
c90c0ff4 310 if (!p)
a02a5408 311 Newx(p, i, UV);
c90c0ff4 312 else
313 Renew(p, i, UV);
314 *rsp = (void*)p;
315 }
316
56431972 317 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
cf93c79d 318 RX_MATCH_COPIED_off(rx);
c90c0ff4 319
f8c7b90f 320#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 321 *p++ = PTR2UV(rx->saved_copy);
322 rx->saved_copy = Nullsv;
323#endif
324
d9f97599 325 *p++ = rx->nparens;
c90c0ff4 326
56431972 327 *p++ = PTR2UV(rx->subbeg);
cf93c79d 328 *p++ = (UV)rx->sublen;
d9f97599
GS		 329 for (i = 0; i <= rx->nparens; ++i) {
330 *p++ = (UV)rx->startp[i];
331 *p++ = (UV)rx->endp[i];
c90c0ff4 332 }
333}
334
335void
864dbfa3 336Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4 337{
338 UV *p = (UV*)*rsp;
339 U32 i;
340
ed252734 341 RX_MATCH_COPY_FREE(rx);
cf93c79d 342 RX_MATCH_COPIED_set(rx, *p);
c90c0ff4 343 *p++ = 0;
344
f8c7b90f 345#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 346 if (rx->saved_copy)
347 SvREFCNT_dec (rx->saved_copy);
348 rx->saved_copy = INT2PTR(SV*,*p);
349 *p++ = 0;
350#endif
351
d9f97599 352 rx->nparens = *p++;
c90c0ff4 353
56431972 354 rx->subbeg = INT2PTR(char*,*p++);
cf93c79d 355 rx->sublen = (I32)(*p++);
d9f97599 356 for (i = 0; i <= rx->nparens; ++i) {
cf93c79d
IZ		 357 rx->startp[i] = (I32)(*p++);
358 rx->endp[i] = (I32)(*p++);
c90c0ff4 359 }
360}
361
362void
864dbfa3 363Perl_rxres_free(pTHX_ void **rsp)
c90c0ff4 364{
44f8325f 365 UV * const p = (UV*)*rsp;
c90c0ff4 366
367 if (p) {
94010e71
NC		 368#ifdef PERL_POISON
369 void *tmp = INT2PTR(char*,*p);
370 Safefree(tmp);
371 if (*p)
372 Poison(*p, 1, sizeof(*p));
373#else
56431972 374 Safefree(INT2PTR(char*,*p));
94010e71 375#endif
f8c7b90f 376#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 377 if (p[1]) {
378 SvREFCNT_dec (INT2PTR(SV*,p[1]));
379 }
380#endif
c90c0ff4 381 Safefree(p);
382 *rsp = Null(void*);
383 }
384}
385
a0d0e21e
LW		 386PP(pp_formline)
387{
39644a26 388 dSP; dMARK; dORIGMARK;
823a54a3 389 register SV * const tmpForm = *++MARK;
dea28490 390 register U32 *fpc;
a0d0e21e 391 register char *t;
245d4a47 392 const char *f;
a0d0e21e 393 register I32 arg;
9c5ffd7c 394 register SV *sv = Nullsv;
5a34cab7 395 const char *item = Nullch;
9c5ffd7c
JH		 396 I32 itemsize = 0;
397 I32 fieldsize = 0;
a0d0e21e 398 I32 lines = 0;
3280af22 399 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
5a34cab7 400 const char *chophere = Nullch;
9c5ffd7c 401 char *linemark = Nullch;
65202027 402 NV value;
9c5ffd7c 403 bool gotsome = FALSE;
a0d0e21e 404 STRLEN len;
823a54a3 405 const STRLEN fudge = SvPOK(tmpForm)
24c89738 406 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
1bd51a4c
IH		 407 bool item_is_utf8 = FALSE;
408 bool targ_is_utf8 = FALSE;
78da4d13 409 SV * nsv = Nullsv;
a1b95068 410 OP * parseres = 0;
bfed75c6 411 const char *fmt;
a1b95068 412 bool oneline;
a0d0e21e 413
76e3520e 414 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
445b3f51
GS		 415 if (SvREADONLY(tmpForm)) {
416 SvREADONLY_off(tmpForm);
a1b95068 417 parseres = doparseform(tmpForm);
445b3f51
GS		 418 SvREADONLY_on(tmpForm);
419 }
420 else
a1b95068
WL		 421 parseres = doparseform(tmpForm);
422 if (parseres)
423 return parseres;
a0d0e21e 424 }
3280af22 425 SvPV_force(PL_formtarget, len);
1bd51a4c
IH		 426 if (DO_UTF8(PL_formtarget))
427 targ_is_utf8 = TRUE;
a0ed51b3 428 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
a0d0e21e 429 t += len;
245d4a47 430 f = SvPV_const(tmpForm, len);
a0d0e21e 431 /* need to jump to the next word */
245d4a47 432 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
a0d0e21e
LW		 433
434 for (;;) {
435 DEBUG_f( {
bfed75c6 436 const char *name = "???";
a0d0e21e
LW		 437 arg = -1;
438 switch (*fpc) {
439 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
440 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
441 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
442 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
443 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
444
445 case FF_CHECKNL: name = "CHECKNL"; break;
446 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
447 case FF_SPACE: name = "SPACE"; break;
448 case FF_HALFSPACE: name = "HALFSPACE"; break;
449 case FF_ITEM: name = "ITEM"; break;
450 case FF_CHOP: name = "CHOP"; break;
451 case FF_LINEGLOB: name = "LINEGLOB"; break;
452 case FF_NEWLINE: name = "NEWLINE"; break;
453 case FF_MORE: name = "MORE"; break;
454 case FF_LINEMARK: name = "LINEMARK"; break;
455 case FF_END: name = "END"; break;
bfed75c6 456 case FF_0DECIMAL: name = "0DECIMAL"; break;
a1b95068 457 case FF_LINESNGL: name = "LINESNGL"; break;
a0d0e21e
LW		 458 }
459 if (arg >= 0)
bf49b057 460 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
a0d0e21e 461 else
bf49b057 462 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
5f80b19c 463 } );
a0d0e21e
LW		 464 switch (*fpc++) {
465 case FF_LINEMARK:
466 linemark = t;
a0d0e21e
LW		 467 lines++;
468 gotsome = FALSE;
469 break;
470
471 case FF_LITERAL:
472 arg = *fpc++;
1bd51a4c 473 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
b15aece3 474 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
78da4d13
JH		 475 *t = '\0';
476 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
477 t = SvEND(PL_formtarget);
1bd51a4c
IH		 478 break;
479 }
480 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
b15aece3 481 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1bd51a4c
IH		 482 *t = '\0';
483 sv_utf8_upgrade(PL_formtarget);
484 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
485 t = SvEND(PL_formtarget);
486 targ_is_utf8 = TRUE;
487 }
a0d0e21e
LW		 488 while (arg--)
489 *t++ = *f++;
490 break;
491
492 case FF_SKIP:
493 f += *fpc++;
494 break;
495
496 case FF_FETCH:
497 arg = *fpc++;
498 f += arg;
499 fieldsize = arg;
500
501 if (MARK < SP)
502 sv = *++MARK;
503 else {
3280af22 504 sv = &PL_sv_no;
599cee73 505 if (ckWARN(WARN_SYNTAX))
9014280d 506 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
a0d0e21e
LW		 507 }
508 break;
509
510 case FF_CHECKNL:
5a34cab7
NC		 511 {
512 const char *send;
513 const char *s = item = SvPV_const(sv, len);
514 itemsize = len;
515 if (DO_UTF8(sv)) {
516 itemsize = sv_len_utf8(sv);
517 if (itemsize != (I32)len) {
518 I32 itembytes;
519 if (itemsize > fieldsize) {
520 itemsize = fieldsize;
521 itembytes = itemsize;
522 sv_pos_u2b(sv, &itembytes, 0);
523 }
524 else
525 itembytes = len;
526 send = chophere = s + itembytes;
527 while (s < send) {
528 if (*s & ~31)
529 gotsome = TRUE;
530 else if (*s == '\n')
531 break;
532 s++;
533 }
534 item_is_utf8 = TRUE;
535 itemsize = s - item;
536 sv_pos_b2u(sv, &itemsize);
537 break;
a0ed51b3 538 }
a0ed51b3 539 }
5a34cab7
NC		 540 item_is_utf8 = FALSE;
541 if (itemsize > fieldsize)
542 itemsize = fieldsize;
543 send = chophere = s + itemsize;
544 while (s < send) {
545 if (*s & ~31)
546 gotsome = TRUE;
547 else if (*s == '\n')
548 break;
549 s++;
550 }
551 itemsize = s - item;
552 break;
a0ed51b3 553 }
a0d0e21e
LW		 554
555 case FF_CHECKCHOP:
5a34cab7
NC		 556 {
557 const char *s = item = SvPV_const(sv, len);
558 itemsize = len;
559 if (DO_UTF8(sv)) {
560 itemsize = sv_len_utf8(sv);
561 if (itemsize != (I32)len) {
562 I32 itembytes;
563 if (itemsize <= fieldsize) {
564 const char *send = chophere = s + itemsize;
565 while (s < send) {
566 if (*s == '\r') {
567 itemsize = s - item;
a0ed51b3 568 chophere = s;
a0ed51b3 569 break;
5a34cab7
NC		 570 }
571 if (*s++ & ~31)
a0ed51b3 572 gotsome = TRUE;
a0ed51b3 573 }
a0ed51b3 574 }
5a34cab7
NC		 575 else {
576 const char *send;
577 itemsize = fieldsize;
578 itembytes = itemsize;
579 sv_pos_u2b(sv, &itembytes, 0);
580 send = chophere = s + itembytes;
581 while (s < send || (s == send && isSPACE(*s))) {
582 if (isSPACE(*s)) {
583 if (chopspace)
584 chophere = s;
585 if (*s == '\r')
586 break;
587 }
588 else {
589 if (*s & ~31)
590 gotsome = TRUE;
591 if (strchr(PL_chopset, *s))
592 chophere = s + 1;
593 }
594 s++;
595 }
596 itemsize = chophere - item;
597 sv_pos_b2u(sv, &itemsize);
598 }
599 item_is_utf8 = TRUE;
a0d0e21e
LW		 600 break;
601 }
a0d0e21e 602 }
5a34cab7
NC		 603 item_is_utf8 = FALSE;
604 if (itemsize <= fieldsize) {
605 const char *const send = chophere = s + itemsize;
606 while (s < send) {
607 if (*s == '\r') {
608 itemsize = s - item;
a0d0e21e 609 chophere = s;
a0d0e21e 610 break;
5a34cab7
NC		 611 }
612 if (*s++ & ~31)
a0d0e21e 613 gotsome = TRUE;
a0d0e21e 614 }
a0d0e21e 615 }
5a34cab7
NC		 616 else {
617 const char *send;
618 itemsize = fieldsize;
619 send = chophere = s + itemsize;
620 while (s < send || (s == send && isSPACE(*s))) {
621 if (isSPACE(*s)) {
622 if (chopspace)
623 chophere = s;
624 if (*s == '\r')
625 break;
626 }
627 else {
628 if (*s & ~31)
629 gotsome = TRUE;
630 if (strchr(PL_chopset, *s))
631 chophere = s + 1;
632 }
633 s++;
634 }
635 itemsize = chophere - item;
636 }
637 break;
a0d0e21e 638 }
a0d0e21e
LW		 639
640 case FF_SPACE:
641 arg = fieldsize - itemsize;
642 if (arg) {
643 fieldsize -= arg;
644 while (arg-- > 0)
645 *t++ = ' ';
646 }
647 break;
648
649 case FF_HALFSPACE:
650 arg = fieldsize - itemsize;
651 if (arg) {
652 arg /= 2;
653 fieldsize -= arg;
654 while (arg-- > 0)
655 *t++ = ' ';
656 }
657 break;
658
659 case FF_ITEM:
5a34cab7
NC		 660 {
661 const char *s = item;
662 arg = itemsize;
663 if (item_is_utf8) {
664 if (!targ_is_utf8) {
665 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
666 *t = '\0';
667 sv_utf8_upgrade(PL_formtarget);
668 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
669 t = SvEND(PL_formtarget);
670 targ_is_utf8 = TRUE;
a0ed51b3 671 }
5a34cab7
NC		 672 while (arg--) {
673 if (UTF8_IS_CONTINUED(*s)) {
674 STRLEN skip = UTF8SKIP(s);
675 switch (skip) {
676 default:
677 Move(s,t,skip,char);
678 s += skip;
679 t += skip;
680 break;
681 case 7: *t++ = *s++;
682 case 6: *t++ = *s++;
683 case 5: *t++ = *s++;
684 case 4: *t++ = *s++;
685 case 3: *t++ = *s++;
686 case 2: *t++ = *s++;
687 case 1: *t++ = *s++;
688 }
689 }
690 else {
691 if ( !((*t++ = *s++) & ~31) )
692 t[-1] = ' ';
693 }
a0ed51b3 694 }
5a34cab7 695 break;
a0ed51b3 696 }
5a34cab7
NC		 697 if (targ_is_utf8 && !item_is_utf8) {
698 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
699 *t = '\0';
700 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
701 for (; t < SvEND(PL_formtarget); t++) {
78da4d13 702#ifdef EBCDIC
901017d6 703 const int ch = *t;
5a34cab7 704 if (iscntrl(ch))
78da4d13 705#else
5a34cab7 706 if (!(*t & ~31))
78da4d13 707#endif
5a34cab7
NC		 708 *t = ' ';
709 }
710 break;
78da4d13 711 }
5a34cab7 712 while (arg--) {
9d116dd7 713#ifdef EBCDIC
901017d6 714 const int ch = *t++ = *s++;
5a34cab7 715 if (iscntrl(ch))
a0d0e21e 716#else
5a34cab7 717 if ( !((*t++ = *s++) & ~31) )
a0d0e21e 718#endif
5a34cab7
NC		 719 t[-1] = ' ';
720 }
721 break;
a0d0e21e 722 }
a0d0e21e
LW		 723
724 case FF_CHOP:
5a34cab7
NC		 725 {
726 const char *s = chophere;
727 if (chopspace) {
af68e756 728 while (isSPACE(*s))
5a34cab7
NC		 729 s++;
730 }
731 sv_chop(sv,s);
732 SvSETMAGIC(sv);
733 break;
a0d0e21e 734 }
a0d0e21e 735
a1b95068
WL		 736 case FF_LINESNGL:
737 chopspace = 0;
738 oneline = TRUE;
739 goto ff_line;
a0d0e21e 740 case FF_LINEGLOB:
a1b95068
WL		 741 oneline = FALSE;
742 ff_line:
5a34cab7
NC		 743 {
744 const char *s = item = SvPV_const(sv, len);
745 itemsize = len;
746 if ((item_is_utf8 = DO_UTF8(sv)))
747 itemsize = sv_len_utf8(sv);
748 if (itemsize) {
749 bool chopped = FALSE;
750 const char *const send = s + len;
751 gotsome = TRUE;
752 chophere = s + itemsize;
753 while (s < send) {
754 if (*s++ == '\n') {
755 if (oneline) {
756 chopped = TRUE;
757 chophere = s;
758 break;
759 } else {
760 if (s == send) {
761 itemsize--;
762 chopped = TRUE;
763 } else
764 lines++;
765 }
1bd51a4c 766 }
a0d0e21e 767 }
5a34cab7
NC		 768 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
769 if (targ_is_utf8)
770 SvUTF8_on(PL_formtarget);
771 if (oneline) {
772 SvCUR_set(sv, chophere - item);
773 sv_catsv(PL_formtarget, sv);
774 SvCUR_set(sv, itemsize);
775 } else
776 sv_catsv(PL_formtarget, sv);
777 if (chopped)
778 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
779 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
780 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
781 if (item_is_utf8)
782 targ_is_utf8 = TRUE;
a0d0e21e 783 }
5a34cab7 784 break;
a0d0e21e 785 }
a0d0e21e 786
a1b95068
WL		 787 case FF_0DECIMAL:
788 arg = *fpc++;
789#if defined(USE_LONG_DOUBLE)
790 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
791#else
792 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
793#endif
794 goto ff_dec;
a0d0e21e 795 case FF_DECIMAL:
a0d0e21e 796 arg = *fpc++;
65202027 797#if defined(USE_LONG_DOUBLE)
a1b95068 798 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
65202027 799#else
a1b95068 800 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
65202027 801#endif
a1b95068 802 ff_dec:
784707d5
JP		 803 /* If the field is marked with ^ and the value is undefined,
804 blank it out. */
784707d5
JP		 805 if ((arg & 512) && !SvOK(sv)) {
806 arg = fieldsize;
807 while (arg--)
808 *t++ = ' ';
809 break;
810 }
811 gotsome = TRUE;
812 value = SvNV(sv);
a1b95068 813 /* overflow evidence */
bfed75c6 814 if (num_overflow(value, fieldsize, arg)) {
a1b95068
WL		 815 arg = fieldsize;
816 while (arg--)
817 *t++ = '#';
818 break;
819 }
784707d5
JP		 820 /* Formats aren't yet marked for locales, so assume "yes". */
821 {
822 STORE_NUMERIC_STANDARD_SET_LOCAL();
a1b95068 823 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
784707d5
JP		 824 RESTORE_NUMERIC_STANDARD();
825 }
826 t += fieldsize;
827 break;
a1b95068 828
a0d0e21e
LW		 829 case FF_NEWLINE:
830 f++;
831 while (t-- > linemark && *t == ' ') ;
832 t++;
833 *t++ = '\n';
834 break;
835
836 case FF_BLANK:
837 arg = *fpc++;
838 if (gotsome) {
839 if (arg) { /* repeat until fields exhausted? */
840 *t = '\0';
b15aece3 841 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
3280af22 842 lines += FmLINES(PL_formtarget);
a0d0e21e
LW		 843 if (lines == 200) {
844 arg = t - linemark;
845 if (strnEQ(linemark, linemark - arg, arg))
cea2e8a9 846 DIE(aTHX_ "Runaway format");
a0d0e21e 847 }
1bd51a4c
IH		 848 if (targ_is_utf8)
849 SvUTF8_on(PL_formtarget);
3280af22 850 FmLINES(PL_formtarget) = lines;
a0d0e21e
LW		 851 SP = ORIGMARK;
852 RETURNOP(cLISTOP->op_first);
853 }
854 }
855 else {
856 t = linemark;
857 lines--;
858 }
859 break;
860
861 case FF_MORE:
5a34cab7
NC		 862 {
863 const char *s = chophere;
864 const char *send = item + len;
865 if (chopspace) {
af68e756 866 while (isSPACE(*s) && (s < send))
5a34cab7 867 s++;
a0d0e21e 868 }
5a34cab7
NC		 869 if (s < send) {
870 char *s1;
871 arg = fieldsize - itemsize;
872 if (arg) {
873 fieldsize -= arg;
874 while (arg-- > 0)
875 *t++ = ' ';
876 }
877 s1 = t - 3;
878 if (strnEQ(s1," ",3)) {
879 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
880 s1--;
881 }
882 *s1++ = '.';
883 *s1++ = '.';
884 *s1++ = '.';
a0d0e21e 885 }
5a34cab7 886 break;
a0d0e21e 887 }
a0d0e21e
LW		 888 case FF_END:
889 *t = '\0';
b15aece3 890 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1bd51a4c
IH		 891 if (targ_is_utf8)
892 SvUTF8_on(PL_formtarget);
3280af22 893 FmLINES(PL_formtarget) += lines;
a0d0e21e
LW		 894 SP = ORIGMARK;
895 RETPUSHYES;
896 }
897 }
898}
899
900PP(pp_grepstart)
901{
27da23d5 902 dVAR; dSP;
a0d0e21e
LW		 903 SV *src;
904
3280af22 905 if (PL_stack_base + *PL_markstack_ptr == SP) {
a0d0e21e 906 (void)POPMARK;
54310121 907 if (GIMME_V == G_SCALAR)
0b024f31 908 XPUSHs(sv_2mortal(newSViv(0)));
533c011a 909 RETURNOP(PL_op->op_next->op_next);
a0d0e21e 910 }
3280af22 911 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
cea2e8a9
GS		 912 pp_pushmark(); /* push dst */
913 pp_pushmark(); /* push src */
a0d0e21e
LW		 914 ENTER; /* enter outer scope */
915
916 SAVETMPS;
59f00321
RGS		 917 if (PL_op->op_private & OPpGREP_LEX)
918 SAVESPTR(PAD_SVl(PL_op->op_targ));
919 else
920 SAVE_DEFSV;
a0d0e21e 921 ENTER; /* enter inner scope */
7766f137 922 SAVEVPTR(PL_curpm);
a0d0e21e 923
3280af22 924 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 925 SvTEMP_off(src);
59f00321
RGS		 926 if (PL_op->op_private & OPpGREP_LEX)
927 PAD_SVl(PL_op->op_targ) = src;
928 else
929 DEFSV = src;
a0d0e21e
LW		 930
931 PUTBACK;
533c011a 932 if (PL_op->op_type == OP_MAPSTART)
cea2e8a9 933 pp_pushmark(); /* push top */
533c011a 934 return ((LOGOP*)PL_op->op_next)->op_other;
a0d0e21e
LW		 935}
936
a0d0e21e
LW		 937PP(pp_mapwhile)
938{
27da23d5 939 dVAR; dSP;
f54cb97a 940 const I32 gimme = GIMME_V;
544f3153 941 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
a0d0e21e
LW		 942 I32 count;
943 I32 shift;
944 SV** src;
ac27b0f5 945 SV** dst;
a0d0e21e 946
544f3153 947 /* first, move source pointer to the next item in the source list */
3280af22 948 ++PL_markstack_ptr[-1];
544f3153
GS		 949
950 /* if there are new items, push them into the destination list */
4c90a460 951 if (items && gimme != G_VOID) {
544f3153
GS		 952 /* might need to make room back there first */
953 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
954 /* XXX this implementation is very pessimal because the stack
955 * is repeatedly extended for every set of items. Is possible
956 * to do this without any stack extension or copying at all
957 * by maintaining a separate list over which the map iterates
18ef8bea 958 * (like foreach does). --gsar */
544f3153
GS		 959
960 /* everything in the stack after the destination list moves
961 * towards the end the stack by the amount of room needed */
962 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
963
964 /* items to shift up (accounting for the moved source pointer) */
965 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
18ef8bea
BT		 966
967 /* This optimization is by Ben Tilly and it does
968 * things differently from what Sarathy (gsar)
969 * is describing. The downside of this optimization is
970 * that leaves "holes" (uninitialized and hopefully unused areas)
971 * to the Perl stack, but on the other hand this
972 * shouldn't be a problem. If Sarathy's idea gets
973 * implemented, this optimization should become
974 * irrelevant. --jhi */
975 if (shift < count)
976 shift = count; /* Avoid shifting too often --Ben Tilly */
bfed75c6 977
924508f0
GS		 978 EXTEND(SP,shift);
979 src = SP;
980 dst = (SP += shift);
3280af22
NIS		 981 PL_markstack_ptr[-1] += shift;
982 *PL_markstack_ptr += shift;
544f3153 983 while (count--)
a0d0e21e
LW		 984 *dst-- = *src--;
985 }
544f3153 986 /* copy the new items down to the destination list */
ac27b0f5 987 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
22023b26
TP		 988 if (gimme == G_ARRAY) {
989 while (items-- > 0)
990 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
991 }
bfed75c6 992 else {
22023b26
TP		 993 /* scalar context: we don't care about which values map returns
994 * (we use undef here). And so we certainly don't want to do mortal
995 * copies of meaningless values. */
996 while (items-- > 0) {
b988aa42 997 (void)POPs;
22023b26
TP		 998 *dst-- = &PL_sv_undef;
999 }
1000 }
a0d0e21e
LW		 1001 }
1002 LEAVE; /* exit inner scope */
1003
1004 /* All done yet? */
3280af22 1005 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
a0d0e21e
LW		 1006
1007 (void)POPMARK; /* pop top */
1008 LEAVE; /* exit outer scope */
1009 (void)POPMARK; /* pop src */
3280af22 1010 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 1011 (void)POPMARK; /* pop dst */
3280af22 1012 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 1013 if (gimme == G_SCALAR) {
7cc47870
RGS		 1014 if (PL_op->op_private & OPpGREP_LEX) {
1015 SV* sv = sv_newmortal();
1016 sv_setiv(sv, items);
1017 PUSHs(sv);
1018 }
1019 else {
1020 dTARGET;
1021 XPUSHi(items);
1022 }
a0d0e21e 1023 }
54310121 1024 else if (gimme == G_ARRAY)
1025 SP += items;
a0d0e21e
LW		 1026 RETURN;
1027 }
1028 else {
1029 SV *src;
1030
1031 ENTER; /* enter inner scope */
7766f137 1032 SAVEVPTR(PL_curpm);
a0d0e21e 1033
544f3153 1034 /* set $_ to the new source item */
3280af22 1035 src = PL_stack_base[PL_markstack_ptr[-1]];
a0d0e21e 1036 SvTEMP_off(src);
59f00321
RGS		 1037 if (PL_op->op_private & OPpGREP_LEX)
1038 PAD_SVl(PL_op->op_targ) = src;
1039 else
1040 DEFSV = src;
a0d0e21e
LW		 1041
1042 RETURNOP(cLOGOP->op_other);
1043 }
1044}
1045
a0d0e21e
LW		 1046/* Range stuff. */
1047
1048PP(pp_range)
1049{
1050 if (GIMME == G_ARRAY)
1a67a97c 1051 return NORMAL;
538573f7 1052 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1a67a97c 1053 return cLOGOP->op_other;
538573f7 1054 else
1a67a97c 1055 return NORMAL;
a0d0e21e
LW		 1056}
1057
1058PP(pp_flip)
1059{
39644a26 1060 dSP;
a0d0e21e
LW		 1061
1062 if (GIMME == G_ARRAY) {
1a67a97c 1063 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 1064 }
1065 else {
1066 dTOPss;
44f8325f 1067 SV * const targ = PAD_SV(PL_op->op_targ);
bfed75c6 1068 int flip = 0;
790090df 1069
bfed75c6 1070 if (PL_op->op_private & OPpFLIP_LINENUM) {
4e3399f9
YST		 1071 if (GvIO(PL_last_in_gv)) {
1072 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1073 }
1074 else {
44f8325f
AL		 1075 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1076 if (gv && GvSV(gv))
1077 flip = SvIV(sv) == SvIV(GvSV(gv));
4e3399f9 1078 }
bfed75c6
AL		 1079 } else {
1080 flip = SvTRUE(sv);
1081 }
1082 if (flip) {
a0d0e21e 1083 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 1084 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1085 sv_setiv(targ, 1);
3e3baf6d 1086 SETs(targ);
a0d0e21e
LW		 1087 RETURN;
1088 }
1089 else {
1090 sv_setiv(targ, 0);
924508f0 1091 SP--;
1a67a97c 1092 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 1093 }
1094 }
c69006e4 1095 sv_setpvn(TARG, "", 0);
a0d0e21e
LW		 1096 SETs(targ);
1097 RETURN;
1098 }
1099}
1100
8e9bbdb9
RGS		 1101/* This code tries to decide if "$left .. $right" should use the
1102 magical string increment, or if the range is numeric (we make
1103 an exception for .."0" [#18165]). AMS 20021031. */
1104
1105#define RANGE_IS_NUMERIC(left,right) ( \
b0e74086
RGS		 1106 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1107 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
e0ab1c0e 1108 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
b15aece3 1109 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
e0ab1c0e 1110 && (!SvOK(right) || looks_like_number(right))))
8e9bbdb9 1111
a0d0e21e
LW		 1112PP(pp_flop)
1113{
39644a26 1114 dSP;
a0d0e21e
LW		 1115
1116 if (GIMME == G_ARRAY) {
1117 dPOPPOPssrl;
86cb7173 1118
5b295bef
RD		 1119 SvGETMAGIC(left);
1120 SvGETMAGIC(right);
a0d0e21e 1121
8e9bbdb9 1122 if (RANGE_IS_NUMERIC(left,right)) {
901017d6
AL		 1123 register IV i, j;
1124 IV max;
4fe3f0fa
MHM		 1125 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1126 (SvOK(right) && SvNV(right) > IV_MAX))
d470f89e 1127 DIE(aTHX_ "Range iterator outside integer range");
a0d0e21e
LW		 1128 i = SvIV(left);
1129 max = SvIV(right);
bbce6d69 1130 if (max >= i) {
c1ab3db2
AK		 1131 j = max - i + 1;
1132 EXTEND_MORTAL(j);
1133 EXTEND(SP, j);
bbce6d69 1134 }
c1ab3db2
AK		 1135 else
1136 j = 0;
1137 while (j--) {
901017d6 1138 SV * const sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW		 1139 PUSHs(sv);
1140 }
1141 }
1142 else {
44f8325f 1143 SV * const final = sv_mortalcopy(right);
13c5b33c 1144 STRLEN len;
823a54a3 1145 const char * const tmps = SvPV_const(final, len);
a0d0e21e 1146
901017d6 1147 SV *sv = sv_mortalcopy(left);
13c5b33c 1148 SvPV_force_nolen(sv);
89ea2908 1149 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1150 XPUSHs(sv);
b15aece3 1151 if (strEQ(SvPVX_const(sv),tmps))
89ea2908 1152 break;
a0d0e21e
LW		 1153 sv = sv_2mortal(newSVsv(sv));
1154 sv_inc(sv);
1155 }
a0d0e21e
LW		 1156 }
1157 }
1158 else {
1159 dTOPss;
901017d6 1160 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
4e3399f9 1161 int flop = 0;
a0d0e21e 1162 sv_inc(targ);
4e3399f9
YST		 1163
1164 if (PL_op->op_private & OPpFLIP_LINENUM) {
1165 if (GvIO(PL_last_in_gv)) {
1166 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1167 }
1168 else {
901017d6 1169 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
4e3399f9
YST		 1170 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1171 }
1172 }
1173 else {
1174 flop = SvTRUE(sv);
1175 }
1176
1177 if (flop) {
a0d0e21e 1178 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
901017d6 1179 sv_catpvn(targ, "E0", 2);
a0d0e21e
LW		 1180 }
1181 SETs(targ);
1182 }
1183
1184 RETURN;
1185}
1186
1187/* Control. */
1188
27da23d5 1189static const char * const context_name[] = {
515afda2
NC		 1190 "pseudo-block",
1191 "subroutine",
1192 "eval",
1193 "loop",
1194 "substitution",
1195 "block",
1196 "format"
1197};
1198
76e3520e 1199STATIC I32
06b5626a 1200S_dopoptolabel(pTHX_ const char *label)
a0d0e21e
LW		 1201{
1202 register I32 i;
a0d0e21e
LW		 1203
1204 for (i = cxstack_ix; i >= 0; i--) {
901017d6 1205 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1206 switch (CxTYPE(cx)) {
a0d0e21e 1207 case CXt_SUBST:
a0d0e21e 1208 case CXt_SUB:
7766f137 1209 case CXt_FORMAT:
a0d0e21e 1210 case CXt_EVAL:
0a753a76 1211 case CXt_NULL:
e476b1b5 1212 if (ckWARN(WARN_EXITING))
515afda2
NC		 1213 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1214 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1215 if (CxTYPE(cx) == CXt_NULL)
1216 return -1;
1217 break;
a0d0e21e 1218 case CXt_LOOP:
901017d6 1219 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
cea2e8a9 1220 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
68dc0745 1221 (long)i, cx->blk_loop.label));
a0d0e21e
LW		 1222 continue;
1223 }
cea2e8a9 1224 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW		 1225 return i;
1226 }
1227 }
1228 return i;
1229}
1230
e50aee73 1231I32
864dbfa3 1232Perl_dowantarray(pTHX)
e50aee73 1233{
f54cb97a 1234 const I32 gimme = block_gimme();
54310121 1235 return (gimme == G_VOID) ? G_SCALAR : gimme;
1236}
1237
1238I32
864dbfa3 1239Perl_block_gimme(pTHX)
54310121 1240{
06b5626a 1241 const I32 cxix = dopoptosub(cxstack_ix);
e50aee73 1242 if (cxix < 0)
46fc3d4c 1243 return G_VOID;
e50aee73 1244
54310121 1245 switch (cxstack[cxix].blk_gimme) {
d2719217
GS		 1246 case G_VOID:
1247 return G_VOID;
54310121 1248 case G_SCALAR:
e50aee73 1249 return G_SCALAR;
54310121 1250 case G_ARRAY:
1251 return G_ARRAY;
1252 default:
cea2e8a9 1253 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS		 1254 /* NOTREACHED */
1255 return 0;
54310121 1256 }
e50aee73
AD		 1257}
1258
78f9721b
SM		 1259I32
1260Perl_is_lvalue_sub(pTHX)
1261{
06b5626a 1262 const I32 cxix = dopoptosub(cxstack_ix);
78f9721b
SM		 1263 assert(cxix >= 0); /* We should only be called from inside subs */
1264
1265 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1266 return cxstack[cxix].blk_sub.lval;
1267 else
1268 return 0;
1269}
1270
76e3520e 1271STATIC I32
cea2e8a9 1272S_dopoptosub(pTHX_ I32 startingblock)
a0d0e21e 1273{
2c375eb9
GS		 1274 return dopoptosub_at(cxstack, startingblock);
1275}
1276
1277STATIC I32
901017d6 1278S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9 1279{
a0d0e21e 1280 I32 i;
a0d0e21e 1281 for (i = startingblock; i >= 0; i--) {
901017d6 1282 register const PERL_CONTEXT * const cx = &cxstk[i];
6b35e009 1283 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1284 default:
1285 continue;
1286 case CXt_EVAL:
1287 case CXt_SUB:
7766f137 1288 case CXt_FORMAT:
cea2e8a9 1289 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW		 1290 return i;
1291 }
1292 }
1293 return i;
1294}
1295
76e3520e 1296STATIC I32
cea2e8a9 1297S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e
LW		 1298{
1299 I32 i;
a0d0e21e 1300 for (i = startingblock; i >= 0; i--) {
06b5626a 1301 register const PERL_CONTEXT *cx = &cxstack[i];
6b35e009 1302 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1303 default:
1304 continue;
1305 case CXt_EVAL:
cea2e8a9 1306 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW		 1307 return i;
1308 }
1309 }
1310 return i;
1311}
1312
76e3520e 1313STATIC I32
cea2e8a9 1314S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e
LW		 1315{
1316 I32 i;
a0d0e21e 1317 for (i = startingblock; i >= 0; i--) {
901017d6 1318 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1319 switch (CxTYPE(cx)) {
a0d0e21e 1320 case CXt_SUBST:
a0d0e21e 1321 case CXt_SUB:
7766f137 1322 case CXt_FORMAT:
a0d0e21e 1323 case CXt_EVAL:
0a753a76 1324 case CXt_NULL:
e476b1b5 1325 if (ckWARN(WARN_EXITING))
515afda2
NC		 1326 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1327 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1328 if ((CxTYPE(cx)) == CXt_NULL)
1329 return -1;
1330 break;
a0d0e21e 1331 case CXt_LOOP:
cea2e8a9 1332 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW		 1333 return i;
1334 }
1335 }
1336 return i;
1337}
1338
1339void
864dbfa3 1340Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1341{
a0d0e21e
LW		 1342 I32 optype;
1343
1344 while (cxstack_ix > cxix) {
b0d9ce38 1345 SV *sv;
06b5626a 1346 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c90c0ff4 1347 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1348 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1349 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1350 switch (CxTYPE(cx)) {
c90c0ff4 1351 case CXt_SUBST:
1352 POPSUBST(cx);
1353 continue; /* not break */
a0d0e21e 1354 case CXt_SUB:
b0d9ce38
GS		 1355 POPSUB(cx,sv);
1356 LEAVESUB(sv);
a0d0e21e
LW		 1357 break;
1358 case CXt_EVAL:
1359 POPEVAL(cx);
1360 break;
1361 case CXt_LOOP:
1362 POPLOOP(cx);
1363 break;
0a753a76 1364 case CXt_NULL:
a0d0e21e 1365 break;
7766f137
GS		 1366 case CXt_FORMAT:
1367 POPFORMAT(cx);
1368 break;
a0d0e21e 1369 }
c90c0ff4 1370 cxstack_ix--;
a0d0e21e 1371 }
1b6737cc 1372 PERL_UNUSED_VAR(optype);
a0d0e21e
LW		 1373}
1374
5a844595
GS		 1375void
1376Perl_qerror(pTHX_ SV *err)
1377{
1378 if (PL_in_eval)
1379 sv_catsv(ERRSV, err);
1380 else if (PL_errors)
1381 sv_catsv(PL_errors, err);
1382 else
894356b3 1383 Perl_warn(aTHX_ "%"SVf, err);
5a844595
GS		 1384 ++PL_error_count;
1385}
1386
a0d0e21e 1387OP *
35a4481c 1388Perl_die_where(pTHX_ const char *message, STRLEN msglen)
a0d0e21e 1389{
27da23d5 1390 dVAR;
87582a92 1391
3280af22 1392 if (PL_in_eval) {
a0d0e21e 1393 I32 cxix;
a0d0e21e 1394 I32 gimme;
a0d0e21e 1395
4e6ea2c3 1396 if (message) {
faef0170 1397 if (PL_in_eval & EVAL_KEEPERR) {
bfed75c6 1398 static const char prefix[] = "\t(in cleanup) ";
2d03de9c 1399 SV * const err = ERRSV;
06b5626a 1400 const char *e = Nullch;
98eae8f5 1401 if (!SvPOK(err))
c69006e4 1402 sv_setpvn(err,"",0);
98eae8f5 1403 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
0510663f 1404 STRLEN len;
349d4f2f 1405 e = SvPV_const(err, len);
0510663f 1406 e += len - msglen;
98eae8f5
GS		 1407 if (*e != *message || strNE(e,message))
1408 e = Nullch;
1409 }
1410 if (!e) {
1411 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1412 sv_catpvn(err, prefix, sizeof(prefix)-1);
1413 sv_catpvn(err, message, msglen);
e476b1b5 1414 if (ckWARN(WARN_MISC)) {
504618e9 1415 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
b15aece3 1416 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
4e6ea2c3 1417 }
4633a7c4 1418 }
4633a7c4 1419 }
1aa99e6b 1420 else {
06bf62c7 1421 sv_setpvn(ERRSV, message, msglen);
1aa99e6b 1422 }
4633a7c4 1423 }
4e6ea2c3 1424
5a844595
GS		 1425 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1426 && PL_curstackinfo->si_prev)
1427 {
bac4b2ad 1428 dounwind(-1);
d3acc0f7 1429 POPSTACK;
bac4b2ad 1430 }
e336de0d 1431
a0d0e21e
LW		 1432 if (cxix >= 0) {
1433 I32 optype;
35a4481c 1434 register PERL_CONTEXT *cx;
901017d6 1435 SV **newsp;
a0d0e21e
LW		 1436
1437 if (cxix < cxstack_ix)
1438 dounwind(cxix);
1439
3280af22 1440 POPBLOCK(cx,PL_curpm);
6b35e009 1441 if (CxTYPE(cx) != CXt_EVAL) {
16869676 1442 if (!message)
349d4f2f 1443 message = SvPVx_const(ERRSV, msglen);
bf49b057
GS		 1444 PerlIO_write(Perl_error_log, "panic: die ", 11);
1445 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW		 1446 my_exit(1);
1447 }
1448 POPEVAL(cx);
1449
1450 if (gimme == G_SCALAR)
3280af22
NIS		 1451 *++newsp = &PL_sv_undef;
1452 PL_stack_sp = newsp;
a0d0e21e
LW		 1453
1454 LEAVE;
748a9306 1455
7fb6a879
GS		 1456 /* LEAVE could clobber PL_curcop (see save_re_context())
1457 * XXX it might be better to find a way to avoid messing with
1458 * PL_curcop in save_re_context() instead, but this is a more
1459 * minimal fix --GSAR */
1460 PL_curcop = cx->blk_oldcop;
1461
7a2e2cd6 1462 if (optype == OP_REQUIRE) {
44f8325f 1463 const char* const msg = SvPVx_nolen_const(ERRSV);
901017d6 1464 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 1465 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 1466 &PL_sv_undef, 0);
5a844595
GS		 1467 DIE(aTHX_ "%sCompilation failed in require",
1468 *msg ? msg : "Unknown error\n");
7a2e2cd6 1469 }
f39bc417
DM		 1470 assert(CxTYPE(cx) == CXt_EVAL);
1471 return cx->blk_eval.retop;
a0d0e21e
LW		 1472 }
1473 }
9cc2fdd3 1474 if (!message)
349d4f2f 1475 message = SvPVx_const(ERRSV, msglen);
87582a92 1476
7ff03255 1477 write_to_stderr(message, msglen);
f86702cc 1478 my_failure_exit();
1479 /* NOTREACHED */
a0d0e21e
LW		 1480 return 0;
1481}
1482
1483PP(pp_xor)
1484{
39644a26 1485 dSP; dPOPTOPssrl;
a0d0e21e
LW		 1486 if (SvTRUE(left) != SvTRUE(right))
1487 RETSETYES;
1488 else
1489 RETSETNO;
1490}
1491
a0d0e21e
LW		 1492PP(pp_caller)
1493{
39644a26 1494 dSP;
a0d0e21e 1495 register I32 cxix = dopoptosub(cxstack_ix);
901017d6
AL		 1496 register const PERL_CONTEXT *cx;
1497 register const PERL_CONTEXT *ccstack = cxstack;
1498 const PERL_SI *top_si = PL_curstackinfo;
54310121 1499 I32 gimme;
06b5626a 1500 const char *stashname;
a0d0e21e
LW		 1501 I32 count = 0;
1502
1503 if (MAXARG)
1504 count = POPi;
27d41816 1505
a0d0e21e 1506 for (;;) {
2c375eb9
GS		 1507 /* we may be in a higher stacklevel, so dig down deeper */
1508 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1509 top_si = top_si->si_prev;
1510 ccstack = top_si->si_cxstack;
1511 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1512 }
a0d0e21e 1513 if (cxix < 0) {
27d41816
DM		 1514 if (GIMME != G_ARRAY) {
1515 EXTEND(SP, 1);
a0d0e21e 1516 RETPUSHUNDEF;
27d41816 1517 }
a0d0e21e
LW		 1518 RETURN;
1519 }
f2a7f298
DG		 1520 /* caller() should not report the automatic calls to &DB::sub */
1521 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
3280af22 1522 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1523 count++;
1524 if (!count--)
1525 break;
2c375eb9 1526 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1527 }
2c375eb9
GS		 1528
1529 cx = &ccstack[cxix];
7766f137 1530 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
f54cb97a 1531 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2c375eb9 1532 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1533 field below is defined for any cx. */
f2a7f298
DG		 1534 /* caller() should not report the automatic calls to &DB::sub */
1535 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1536 cx = &ccstack[dbcxix];
06a5b730 1537 }
1538
ed094faf 1539 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1540 if (GIMME != G_ARRAY) {
27d41816 1541 EXTEND(SP, 1);
ed094faf 1542 if (!stashname)
3280af22 1543 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1544 else {
1545 dTARGET;
ed094faf 1546 sv_setpv(TARG, stashname);
49d8d3a1
MB		 1547 PUSHs(TARG);
1548 }
a0d0e21e
LW		 1549 RETURN;
1550 }
a0d0e21e 1551
27d41816
DM		 1552 EXTEND(SP, 10);
1553
ed094faf 1554 if (!stashname)
3280af22 1555 PUSHs(&PL_sv_undef);
49d8d3a1 1556 else
ed094faf 1557 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
248c2a4d 1558 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
57843af0 1559 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW		 1560 if (!MAXARG)
1561 RETURN;
7766f137 1562 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
0bd48802 1563 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
7766f137 1564 /* So is ccstack[dbcxix]. */
07b8c804 1565 if (isGV(cvgv)) {
f54cb97a 1566 SV * const sv = NEWSV(49, 0);
07b8c804
RGS		 1567 gv_efullname3(sv, cvgv, Nullch);
1568 PUSHs(sv_2mortal(sv));
1569 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1570 }
1571 else {
1572 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
72699b0f 1573 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
07b8c804 1574 }
a0d0e21e
LW		 1575 }
1576 else {
79cb57f6 1577 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
a0d0e21e
LW		 1578 PUSHs(sv_2mortal(newSViv(0)));
1579 }
54310121 1580 gimme = (I32)cx->blk_gimme;
1581 if (gimme == G_VOID)
3280af22 1582 PUSHs(&PL_sv_undef);
54310121 1583 else
1584 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1585 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1586 /* eval STRING */
06a5b730 1587 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1588 PUSHs(cx->blk_eval.cur_text);
3280af22 1589 PUSHs(&PL_sv_no);
0f79a09d 1590 }
811a4de9 1591 /* require */
0f79a09d
GS		 1592 else if (cx->blk_eval.old_namesv) {
1593 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
3280af22 1594 PUSHs(&PL_sv_yes);
06a5b730 1595 }
811a4de9
GS		 1596 /* eval BLOCK (try blocks have old_namesv == 0) */
1597 else {
1598 PUSHs(&PL_sv_undef);
1599 PUSHs(&PL_sv_undef);
1600 }
4633a7c4 1601 }
a682de96
GS		 1602 else {
1603 PUSHs(&PL_sv_undef);
1604 PUSHs(&PL_sv_undef);
1605 }
1606 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1607 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1608 {
66a1b24b
AL		 1609 AV * const ary = cx->blk_sub.argarray;
1610 const int off = AvARRAY(ary) - AvALLOC(ary);
a0d0e21e 1611
3280af22 1612 if (!PL_dbargs) {
0bd48802
AL		 1613 GV* const tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV);
1614 PL_dbargs = GvAV(gv_AVadd(tmpgv));
a5f75d66 1615 GvMULTI_on(tmpgv);
3ddcf04c 1616 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
a0d0e21e
LW		 1617 }
1618
3280af22
NIS		 1619 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1620 av_extend(PL_dbargs, AvFILLp(ary) + off);
1621 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1622 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1623 }
f3aa04c2
GS		 1624 /* XXX only hints propagated via op_private are currently
1625 * visible (others are not easily accessible, since they
1626 * use the global PL_hints) */
1627 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1628 HINT_PRIVATE_MASK)));
e476b1b5
GS		 1629 {
1630 SV * mask ;
0bd48802 1631 SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba 1632
ac27b0f5 1633 if (old_warnings == pWARN_NONE ||
114bafba 1634 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1635 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
ac27b0f5 1636 else if (old_warnings == pWARN_ALL ||
75b6c4ca
RGS		 1637 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1638 /* Get the bit mask for $warnings::Bits{all}, because
1639 * it could have been extended by warnings::register */
1640 SV **bits_all;
0bd48802 1641 HV * const bits = get_hv("warnings::Bits", FALSE);
75b6c4ca
RGS		 1642 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1643 mask = newSVsv(*bits_all);
1644 }
1645 else {
1646 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1647 }
1648 }
e476b1b5
GS		 1649 else
1650 mask = newSVsv(old_warnings);
1651 PUSHs(sv_2mortal(mask));
1652 }
a0d0e21e
LW		 1653 RETURN;
1654}
1655
a0d0e21e
LW		 1656PP(pp_reset)
1657{
39644a26 1658 dSP;
0bd48802 1659 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
11faa288 1660 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1661 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1662 RETURN;
1663}
1664
dd2155a4
DM		 1665/* like pp_nextstate, but used instead when the debugger is active */
1666
a0d0e21e
LW		 1667PP(pp_dbstate)
1668{
27da23d5 1669 dVAR;
533c011a 1670 PL_curcop = (COP*)PL_op;
a0d0e21e 1671 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1672 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1673 FREETMPS;
1674
5df8de69
DM		 1675 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1676 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1677 {
39644a26 1678 dSP;
c09156bb 1679 register PERL_CONTEXT *cx;
f54cb97a 1680 const I32 gimme = G_ARRAY;
eb160463 1681 U8 hasargs;
0bd48802
AL		 1682 GV * const gv = PL_DBgv;
1683 register CV * const cv = GvCV(gv);
a0d0e21e 1684
a0d0e21e 1685 if (!cv)
cea2e8a9 1686 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1687
aea4f609
DM		 1688 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1689 /* don't do recursive DB::DB call */
a0d0e21e 1690 return NORMAL;
748a9306 1691
4633a7c4
LW		 1692 ENTER;
1693 SAVETMPS;
1694
3280af22 1695 SAVEI32(PL_debug);
55497cff 1696 SAVESTACK_POS();
3280af22 1697 PL_debug = 0;
748a9306 1698 hasargs = 0;
924508f0 1699 SPAGAIN;
748a9306 1700
c127bd3a
SF		 1701 if (CvXSUB(cv)) {
1702 CvDEPTH(cv)++;
1703 PUSHMARK(SP);
1704 (void)(*CvXSUB(cv))(aTHX_ cv);
1705 CvDEPTH(cv)--;
1706 FREETMPS;
1707 LEAVE;
1708 return NORMAL;
1709 }
1710 else {
1711 PUSHBLOCK(cx, CXt_SUB, SP);
1712 PUSHSUB_DB(cx);
1713 cx->blk_sub.retop = PL_op->op_next;
1714 CvDEPTH(cv)++;
1715 SAVECOMPPAD();
1716 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1717 RETURNOP(CvSTART(cv));
1718 }
a0d0e21e
LW		 1719 }
1720 else
1721 return NORMAL;
1722}
1723
a0d0e21e
LW		 1724PP(pp_enteriter)
1725{
27da23d5 1726 dVAR; dSP; dMARK;
c09156bb 1727 register PERL_CONTEXT *cx;
f54cb97a 1728 const I32 gimme = GIMME_V;
a0d0e21e 1729 SV **svp;
7766f137
GS		 1730 U32 cxtype = CXt_LOOP;
1731#ifdef USE_ITHREADS
1732 void *iterdata;
1733#endif
a0d0e21e 1734
4633a7c4
LW		 1735 ENTER;
1736 SAVETMPS;
1737
533c011a 1738 if (PL_op->op_targ) {
14f338dc
DM		 1739 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1740 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1741 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1742 SVs_PADSTALE, SVs_PADSTALE);
1743 }
c3564e5c 1744#ifndef USE_ITHREADS
dd2155a4 1745 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
54b9620d 1746 SAVESPTR(*svp);
c3564e5c
GS		 1747#else
1748 SAVEPADSV(PL_op->op_targ);
cbfa9890 1749 iterdata = INT2PTR(void*, PL_op->op_targ);
7766f137
GS		 1750 cxtype |= CXp_PADVAR;
1751#endif
54b9620d
MB		 1752 }
1753 else {
0bd48802 1754 GV * const gv = (GV*)POPs;
7766f137 1755 svp = &GvSV(gv); /* symbol table variable */
0214ae40
GS		 1756 SAVEGENERICSV(*svp);
1757 *svp = NEWSV(0,0);
7766f137
GS		 1758#ifdef USE_ITHREADS
1759 iterdata = (void*)gv;
1760#endif
54b9620d 1761 }
4633a7c4 1762
a0d0e21e
LW		 1763 ENTER;
1764
7766f137
GS		 1765 PUSHBLOCK(cx, cxtype, SP);
1766#ifdef USE_ITHREADS
1767 PUSHLOOP(cx, iterdata, MARK);
1768#else
a0d0e21e 1769 PUSHLOOP(cx, svp, MARK);
7766f137 1770#endif
533c011a 1771 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1772 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1773 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1774 dPOPss;
0bd48802 1775 SV * const right = (SV*)cx->blk_loop.iterary;
984a4bea
RD		 1776 SvGETMAGIC(sv);
1777 SvGETMAGIC(right);
4fe3f0fa
MHM		 1778 if (RANGE_IS_NUMERIC(sv,right)) {
1779 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1780 (SvOK(right) && SvNV(right) >= IV_MAX))
076d9a11
MHM		 1781 DIE(aTHX_ "Range iterator outside integer range");
1782 cx->blk_loop.iterix = SvIV(sv);
4fe3f0fa 1783 cx->blk_loop.itermax = SvIV(right);
d4665a05
DM		 1784#ifdef DEBUGGING
1785 /* for correct -Dstv display */
1786 cx->blk_oldsp = sp - PL_stack_base;
1787#endif
89ea2908 1788 }
3f63a782 1789 else {
89ea2908 1790 cx->blk_loop.iterlval = newSVsv(sv);
13c5b33c 1791 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
10516c54 1792 (void) SvPV_nolen_const(right);
3f63a782 1793 }
89ea2908 1794 }
ef3e5ea9 1795 else if (PL_op->op_private & OPpITER_REVERSED) {
6e585ca0
DM		 1796 cx->blk_loop.itermax = 0;
1797 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
ef3e5ea9
NC		 1798
1799 }
89ea2908 1800 }
4633a7c4 1801 else {
3280af22
NIS		 1802 cx->blk_loop.iterary = PL_curstack;
1803 AvFILLp(PL_curstack) = SP - PL_stack_base;
ef3e5ea9 1804 if (PL_op->op_private & OPpITER_REVERSED) {
6e585ca0
DM		 1805 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1806 cx->blk_loop.iterix = cx->blk_oldsp + 1;
ef3e5ea9
NC		 1807 }
1808 else {
1809 cx->blk_loop.iterix = MARK - PL_stack_base;
1810 }
4633a7c4 1811 }
a0d0e21e
LW		 1812
1813 RETURN;
1814}
1815
1816PP(pp_enterloop)
1817{
27da23d5 1818 dVAR; dSP;
c09156bb 1819 register PERL_CONTEXT *cx;
f54cb97a 1820 const I32 gimme = GIMME_V;
a0d0e21e
LW		 1821
1822 ENTER;
1823 SAVETMPS;
1824 ENTER;
1825
1826 PUSHBLOCK(cx, CXt_LOOP, SP);
1827 PUSHLOOP(cx, 0, SP);
1828
1829 RETURN;
1830}
1831
1832PP(pp_leaveloop)
1833{
27da23d5 1834 dVAR; dSP;
c09156bb 1835 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1836 I32 gimme;
1837 SV **newsp;
1838 PMOP *newpm;
1839 SV **mark;
1840
1841 POPBLOCK(cx,newpm);
3a1b2b9e 1842 assert(CxTYPE(cx) == CXt_LOOP);
4fdae800 1843 mark = newsp;
a8bba7fa 1844 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1845
a1f49e72 1846 TAINT_NOT;
54310121 1847 if (gimme == G_VOID)
1848 ; /* do nothing */
1849 else if (gimme == G_SCALAR) {
1850 if (mark < SP)
1851 *++newsp = sv_mortalcopy(*SP);
1852 else
3280af22 1853 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1854 }
1855 else {
a1f49e72 1856 while (mark < SP) {
a0d0e21e 1857 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1858 TAINT_NOT; /* Each item is independent */
1859 }
a0d0e21e 1860 }
f86702cc 1861 SP = newsp;
1862 PUTBACK;
1863
a8bba7fa 1864 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1865 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1866
a0d0e21e
LW		 1867 LEAVE;
1868 LEAVE;
1869
f86702cc 1870 return NORMAL;
a0d0e21e
LW		 1871}
1872
1873PP(pp_return)
1874{
27da23d5 1875 dVAR; dSP; dMARK;
c09156bb 1876 register PERL_CONTEXT *cx;
f86702cc 1877 bool popsub2 = FALSE;
b45de488 1878 bool clear_errsv = FALSE;
a0d0e21e
LW		 1879 I32 gimme;
1880 SV **newsp;
1881 PMOP *newpm;
1882 I32 optype = 0;
b0d9ce38 1883 SV *sv;
f39bc417 1884 OP *retop;
a0d0e21e 1885
0bd48802
AL		 1886 const I32 cxix = dopoptosub(cxstack_ix);
1887
9850bf21
RH		 1888 if (cxix < 0) {
1889 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1890 * sort block, which is a CXt_NULL
1891 * not a CXt_SUB */
1892 dounwind(0);
d7507f74
RH		 1893 PL_stack_base[1] = *PL_stack_sp;
1894 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1895 return 0;
1896 }
9850bf21
RH		 1897 else
1898 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e 1899 }
a0d0e21e
LW		 1900 if (cxix < cxstack_ix)
1901 dounwind(cxix);
1902
d7507f74
RH		 1903 if (CxMULTICALL(&cxstack[cxix])) {
1904 gimme = cxstack[cxix].blk_gimme;
1905 if (gimme == G_VOID)
1906 PL_stack_sp = PL_stack_base;
1907 else if (gimme == G_SCALAR) {
1908 PL_stack_base[1] = *PL_stack_sp;
1909 PL_stack_sp = PL_stack_base + 1;
1910 }
9850bf21 1911 return 0;
d7507f74 1912 }
9850bf21 1913
a0d0e21e 1914 POPBLOCK(cx,newpm);
6b35e009 1915 switch (CxTYPE(cx)) {
a0d0e21e 1916 case CXt_SUB:
f86702cc 1917 popsub2 = TRUE;
f39bc417 1918 retop = cx->blk_sub.retop;
5dd42e15 1919 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW		 1920 break;
1921 case CXt_EVAL:
b45de488
GS		 1922 if (!(PL_in_eval & EVAL_KEEPERR))
1923 clear_errsv = TRUE;
a0d0e21e 1924 POPEVAL(cx);
f39bc417 1925 retop = cx->blk_eval.retop;
1d76a5c3
GS		 1926 if (CxTRYBLOCK(cx))
1927 break;
067f92a0 1928 lex_end();
748a9306
LW		 1929 if (optype == OP_REQUIRE &&
1930 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1931 {
54310121 1932 /* Unassume the success we assumed earlier. */
901017d6 1933 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 1934 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 1935 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
748a9306 1936 }
a0d0e21e 1937 break;
7766f137
GS		 1938 case CXt_FORMAT:
1939 POPFORMAT(cx);
f39bc417 1940 retop = cx->blk_sub.retop;
7766f137 1941 break;
a0d0e21e 1942 default:
cea2e8a9 1943 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 1944 }
1945
a1f49e72 1946 TAINT_NOT;
a0d0e21e 1947 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 1948 if (MARK < SP) {
1949 if (popsub2) {
a8bba7fa 1950 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ		 1951 if (SvTEMP(TOPs)) {
1952 *++newsp = SvREFCNT_inc(*SP);
1953 FREETMPS;
1954 sv_2mortal(*newsp);
959e3673
GS		 1955 }
1956 else {
1957 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 1958 FREETMPS;
959e3673
GS		 1959 *++newsp = sv_mortalcopy(sv);
1960 SvREFCNT_dec(sv);
a29cdaf0 1961 }
959e3673
GS		 1962 }
1963 else
a29cdaf0 1964 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS		 1965 }
1966 else
a29cdaf0 1967 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 1968 }
1969 else
3280af22 1970 *++newsp = &PL_sv_undef;
a0d0e21e 1971 }
54310121 1972 else if (gimme == G_ARRAY) {
a1f49e72 1973 while (++MARK <= SP) {
f86702cc 1974 *++newsp = (popsub2 && SvTEMP(*MARK))
1975 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1976 TAINT_NOT; /* Each item is independent */
1977 }
a0d0e21e 1978 }
3280af22 1979 PL_stack_sp = newsp;
a0d0e21e 1980
5dd42e15 1981 LEAVE;
f86702cc 1982 /* Stack values are safe: */
1983 if (popsub2) {
5dd42e15 1984 cxstack_ix--;
b0d9ce38 1985 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1986 }
b0d9ce38
GS		 1987 else
1988 sv = Nullsv;
3280af22 1989 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1990
b0d9ce38 1991 LEAVESUB(sv);
b45de488 1992 if (clear_errsv)
c69006e4 1993 sv_setpvn(ERRSV,"",0);
f39bc417 1994 return retop;
a0d0e21e
LW		 1995}
1996
1997PP(pp_last)
1998{
27da23d5 1999 dVAR; dSP;
a0d0e21e 2000 I32 cxix;
c09156bb 2001 register PERL_CONTEXT *cx;
f86702cc 2002 I32 pop2 = 0;
a0d0e21e 2003 I32 gimme;
8772537c 2004 I32 optype;
a0d0e21e
LW		 2005 OP *nextop;
2006 SV **newsp;
2007 PMOP *newpm;
a8bba7fa 2008 SV **mark;
b0d9ce38 2009 SV *sv = Nullsv;
9d4ba2ae 2010
a0d0e21e 2011
533c011a 2012 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2013 cxix = dopoptoloop(cxstack_ix);
2014 if (cxix < 0)
a651a37d 2015 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 2016 }
2017 else {
2018 cxix = dopoptolabel(cPVOP->op_pv);
2019 if (cxix < 0)
cea2e8a9 2020 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2021 }
2022 if (cxix < cxstack_ix)
2023 dounwind(cxix);
2024
2025 POPBLOCK(cx,newpm);
5dd42e15 2026 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2027 mark = newsp;
6b35e009 2028 switch (CxTYPE(cx)) {
a0d0e21e 2029 case CXt_LOOP:
f86702cc 2030 pop2 = CXt_LOOP;
a8bba7fa
GS		 2031 newsp = PL_stack_base + cx->blk_loop.resetsp;
2032 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 2033 break;
f86702cc 2034 case CXt_SUB:
f86702cc 2035 pop2 = CXt_SUB;
f39bc417 2036 nextop = cx->blk_sub.retop;
a0d0e21e 2037 break;
f86702cc 2038 case CXt_EVAL:
2039 POPEVAL(cx);
f39bc417 2040 nextop = cx->blk_eval.retop;
a0d0e21e 2041 break;
7766f137
GS		 2042 case CXt_FORMAT:
2043 POPFORMAT(cx);
f39bc417 2044 nextop = cx->blk_sub.retop;
7766f137 2045 break;
a0d0e21e 2046 default:
cea2e8a9 2047 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 2048 }
2049
a1f49e72 2050 TAINT_NOT;
a0d0e21e 2051 if (gimme == G_SCALAR) {
f86702cc 2052 if (MARK < SP)
2053 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2054 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2055 else
3280af22 2056 *++newsp = &PL_sv_undef;
a0d0e21e 2057 }
54310121 2058 else if (gimme == G_ARRAY) {
a1f49e72 2059 while (++MARK <= SP) {
f86702cc 2060 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2061 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2062 TAINT_NOT; /* Each item is independent */
2063 }
f86702cc 2064 }
2065 SP = newsp;
2066 PUTBACK;
2067
5dd42e15
DM		 2068 LEAVE;
2069 cxstack_ix--;
f86702cc 2070 /* Stack values are safe: */
2071 switch (pop2) {
2072 case CXt_LOOP:
a8bba7fa 2073 POPLOOP(cx); /* release loop vars ... */
4fdae800 2074 LEAVE;
f86702cc 2075 break;
2076 case CXt_SUB:
b0d9ce38 2077 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2078 break;
a0d0e21e 2079 }
3280af22 2080 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2081
b0d9ce38 2082 LEAVESUB(sv);
9d4ba2ae
AL		 2083 PERL_UNUSED_VAR(optype);
2084 PERL_UNUSED_VAR(gimme);
f86702cc 2085 return nextop;
a0d0e21e
LW		 2086}
2087
2088PP(pp_next)
2089{
27da23d5 2090 dVAR;
a0d0e21e 2091 I32 cxix;
c09156bb 2092 register PERL_CONTEXT *cx;
85538317 2093 I32 inner;
a0d0e21e 2094
533c011a 2095 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2096 cxix = dopoptoloop(cxstack_ix);
2097 if (cxix < 0)
a651a37d 2098 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 2099 }
2100 else {
2101 cxix = dopoptolabel(cPVOP->op_pv);
2102 if (cxix < 0)
cea2e8a9 2103 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2104 }
2105 if (cxix < cxstack_ix)
2106 dounwind(cxix);
2107
85538317
GS		 2108 /* clear off anything above the scope we're re-entering, but
2109 * save the rest until after a possible continue block */
2110 inner = PL_scopestack_ix;
1ba6ee2b 2111 TOPBLOCK(cx);
85538317
GS		 2112 if (PL_scopestack_ix < inner)
2113 leave_scope(PL_scopestack[PL_scopestack_ix]);
3a1b2b9e 2114 PL_curcop = cx->blk_oldcop;
1ba6ee2b 2115 return cx->blk_loop.next_op;
a0d0e21e
LW		 2116}
2117
2118PP(pp_redo)
2119{
27da23d5 2120 dVAR;
a0d0e21e 2121 I32 cxix;
c09156bb 2122 register PERL_CONTEXT *cx;
a0d0e21e 2123 I32 oldsave;
a034e688 2124 OP* redo_op;
a0d0e21e 2125
533c011a 2126 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2127 cxix = dopoptoloop(cxstack_ix);
2128 if (cxix < 0)
a651a37d 2129 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 2130 }
2131 else {
2132 cxix = dopoptolabel(cPVOP->op_pv);
2133 if (cxix < 0)
cea2e8a9 2134 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2135 }
2136 if (cxix < cxstack_ix)
2137 dounwind(cxix);
2138
a034e688
DM		 2139 redo_op = cxstack[cxix].blk_loop.redo_op;
2140 if (redo_op->op_type == OP_ENTER) {
2141 /* pop one less context to avoid $x being freed in while (my $x..) */
2142 cxstack_ix++;
2143 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2144 redo_op = redo_op->op_next;
2145 }
2146
a0d0e21e 2147 TOPBLOCK(cx);
3280af22 2148 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2149 LEAVE_SCOPE(oldsave);
936c78b5 2150 FREETMPS;
3a1b2b9e 2151 PL_curcop = cx->blk_oldcop;
a034e688 2152 return redo_op;
a0d0e21e
LW		 2153}
2154
0824fdcb 2155STATIC OP *
bfed75c6 2156S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2157{
a0d0e21e 2158 OP **ops = opstack;
bfed75c6 2159 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2160
fc36a67e 2161 if (ops >= oplimit)
cea2e8a9 2162 Perl_croak(aTHX_ too_deep);
11343788
MB		 2163 if (o->op_type == OP_LEAVE ||
2164 o->op_type == OP_SCOPE ||
2165 o->op_type == OP_LEAVELOOP ||
33d34e4c 2166 o->op_type == OP_LEAVESUB ||
11343788 2167 o->op_type == OP_LEAVETRY)
fc36a67e 2168 {
5dc0d613 2169 *ops++ = cUNOPo->op_first;
fc36a67e 2170 if (ops >= oplimit)
cea2e8a9 2171 Perl_croak(aTHX_ too_deep);
fc36a67e 2172 }
c4aa4e48 2173 *ops = 0;
11343788 2174 if (o->op_flags & OPf_KIDS) {
aec46f14 2175 OP *kid;
a0d0e21e 2176 /* First try all the kids at this level, since that's likeliest. */
11343788 2177 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 2178 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2179 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 2180 return kid;
2181 }
11343788 2182 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2183 if (kid == PL_lastgotoprobe)
a0d0e21e 2184 continue;
ed8d0fe2
SM		 2185 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2186 if (ops == opstack)
2187 *ops++ = kid;
2188 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2189 ops[-1]->op_type == OP_DBSTATE)
2190 ops[-1] = kid;
2191 else
2192 *ops++ = kid;
2193 }
155aba94 2194 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2195 return o;
a0d0e21e
LW		 2196 }
2197 }
c4aa4e48 2198 *ops = 0;
a0d0e21e
LW		 2199 return 0;
2200}
2201
a0d0e21e
LW		 2202PP(pp_goto)
2203{
27da23d5 2204 dVAR; dSP;
a0d0e21e
LW		 2205 OP *retop = 0;
2206 I32 ix;
c09156bb 2207 register PERL_CONTEXT *cx;
fc36a67e 2208#define GOTO_DEPTH 64
2209 OP *enterops[GOTO_DEPTH];
bfed75c6
AL		 2210 const char *label = 0;
2211 const bool do_dump = (PL_op->op_type == OP_DUMP);
2212 static const char must_have_label[] = "goto must have label";
a0d0e21e 2213
533c011a 2214 if (PL_op->op_flags & OPf_STACKED) {
9d4ba2ae 2215 SV * const sv = POPs;
a0d0e21e
LW		 2216
2217 /* This egregious kludge implements goto &subroutine */
2218 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2219 I32 cxix;
c09156bb 2220 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2221 CV* cv = (CV*)SvRV(sv);
2222 SV** mark;
2223 I32 items = 0;
2224 I32 oldsave;
b1464ded 2225 bool reified = 0;
a0d0e21e 2226
e8f7dd13 2227 retry:
4aa0a1f7 2228 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2229 const GV * const gv = CvGV(cv);
e8f7dd13 2230 if (gv) {
7fc63493 2231 GV *autogv;
e8f7dd13
GS		 2232 SV *tmpstr;
2233 /* autoloaded stub? */
2234 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2235 goto retry;
2236 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2237 GvNAMELEN(gv), FALSE);
2238 if (autogv && (cv = GvCV(autogv)))
2239 goto retry;
2240 tmpstr = sv_newmortal();
2241 gv_efullname3(tmpstr, gv, Nullch);
35c1215d 2242 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
4aa0a1f7 2243 }
cea2e8a9 2244 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2245 }
2246
a0d0e21e 2247 /* First do some returnish stuff. */
7fc63493 2248 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
71fc2216 2249 FREETMPS;
a0d0e21e
LW		 2250 cxix = dopoptosub(cxstack_ix);
2251 if (cxix < 0)
cea2e8a9 2252 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2253 if (cxix < cxstack_ix)
2254 dounwind(cxix);
2255 TOPBLOCK(cx);
2d43a17f 2256 SPAGAIN;
564abe23 2257 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2d43a17f 2258 if (CxTYPE(cx) == CXt_EVAL) {
c74ace89
DM		 2259 if (CxREALEVAL(cx))
2260 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2261 else
2262 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2d43a17f 2263 }
9850bf21
RH		 2264 else if (CxMULTICALL(cx))
2265 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
d8b46c1b
GS		 2266 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2267 /* put @_ back onto stack */
a0d0e21e 2268 AV* av = cx->blk_sub.argarray;
bfed75c6 2269
93965878 2270 items = AvFILLp(av) + 1;
a45cdc79
DM		 2271 EXTEND(SP, items+1); /* @_ could have been extended. */
2272 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS		 2273 SvREFCNT_dec(GvAV(PL_defgv));
2274 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2275 CLEAR_ARGARRAY(av);
d8b46c1b 2276 /* abandon @_ if it got reified */
62b1ebc2 2277 if (AvREAL(av)) {
b1464ded
DM		 2278 reified = 1;
2279 SvREFCNT_dec(av);
d8b46c1b
GS		 2280 av = newAV();
2281 av_extend(av, items-1);
11ca45c0 2282 AvREIFY_only(av);
dd2155a4 2283 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2284 }
a0d0e21e 2285 }
1fa4e549 2286 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
890ce7af 2287 AV* const av = GvAV(PL_defgv);
1fa4e549 2288 items = AvFILLp(av) + 1;
a45cdc79
DM		 2289 EXTEND(SP, items+1); /* @_ could have been extended. */
2290 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2291 }
a45cdc79
DM		 2292 mark = SP;
2293 SP += items;
6b35e009 2294 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2295 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2296 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2297 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2298 LEAVE_SCOPE(oldsave);
2299
2300 /* Now do some callish stuff. */
2301 SAVETMPS;
5023d17a 2302 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
a0d0e21e 2303 if (CvXSUB(cv)) {
5eff7df7 2304 OP* retop = cx->blk_sub.retop;
b1464ded
DM		 2305 if (reified) {
2306 I32 index;
2307 for (index=0; index<items; index++)
2308 sv_2mortal(SP[-index]);
2309 }
67caa1fe 2310#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2311 if (CvOLDSTYLE(cv)) {
20ce7b12 2312 I32 (*fp3)(int,int,int);
924508f0
GS		 2313 while (SP > mark) {
2314 SP[1] = SP[0];
2315 SP--;
a0d0e21e 2316 }
7766f137 2317 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2318 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2319 mark - PL_stack_base + 1,
ecfc5424 2320 items);
3280af22 2321 SP = PL_stack_base + items;
a0d0e21e 2322 }
67caa1fe
GS		 2323 else
2324#endif /* PERL_XSUB_OLDSTYLE */
2325 {
1fa4e549
AD		 2326 SV **newsp;
2327 I32 gimme;
2328
5eff7df7
DM		 2329 /* XS subs don't have a CxSUB, so pop it */
2330 POPBLOCK(cx, PL_curpm);
1fa4e549 2331 /* Push a mark for the start of arglist */
ac27b0f5 2332 PUSHMARK(mark);
a45cdc79 2333 PUTBACK;
acfe0abc 2334 (void)(*CvXSUB(cv))(aTHX_ cv);
1b6737cc
AL		 2335 /* Put these at the bottom since the vars are set but not used */
2336 PERL_UNUSED_VAR(newsp);
2337 PERL_UNUSED_VAR(gimme);
a0d0e21e
LW		 2338 }
2339 LEAVE;
5eff7df7 2340 return retop;
a0d0e21e
LW		 2341 }
2342 else {
2343 AV* padlist = CvPADLIST(cv);
6b35e009 2344 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2345 PL_in_eval = cx->blk_eval.old_in_eval;
2346 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2347 cx->cx_type = CXt_SUB;
2348 cx->blk_sub.hasargs = 0;
2349 }
a0d0e21e 2350 cx->blk_sub.cv = cv;
eb160463 2351 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
dd2155a4 2352
a0d0e21e
LW		 2353 CvDEPTH(cv)++;
2354 if (CvDEPTH(cv) < 2)
2355 (void)SvREFCNT_inc(cv);
dd2155a4 2356 else {
599cee73 2357 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2358 sub_crush_depth(cv);
26019298 2359 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2360 }
fd617465
DM		 2361 SAVECOMPPAD();
2362 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
6d4ff0d2 2363 if (cx->blk_sub.hasargs)
6d4ff0d2 2364 {
dd2155a4 2365 AV* av = (AV*)PAD_SVl(0);
a0d0e21e
LW		 2366 SV** ary;
2367
3280af22
NIS		 2368 cx->blk_sub.savearray = GvAV(PL_defgv);
2369 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2370 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2371 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2372
2373 if (items >= AvMAX(av) + 1) {
2374 ary = AvALLOC(av);
2375 if (AvARRAY(av) != ary) {
2376 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
f880fe2f 2377 SvPV_set(av, (char*)ary);
a0d0e21e
LW		 2378 }
2379 if (items >= AvMAX(av) + 1) {
2380 AvMAX(av) = items - 1;
2381 Renew(ary,items+1,SV*);
2382 AvALLOC(av) = ary;
f880fe2f 2383 SvPV_set(av, (char*)ary);
a0d0e21e
LW		 2384 }
2385 }
a45cdc79 2386 ++mark;
a0d0e21e 2387 Copy(mark,AvARRAY(av),items,SV*);
93965878 2388 AvFILLp(av) = items - 1;
d8b46c1b 2389 assert(!AvREAL(av));
b1464ded
DM		 2390 if (reified) {
2391 /* transfer 'ownership' of refcnts to new @_ */
2392 AvREAL_on(av);
2393 AvREIFY_off(av);
2394 }
a0d0e21e
LW		 2395 while (items--) {
2396 if (*mark)
2397 SvTEMP_off(*mark);
2398 mark++;
2399 }
2400 }
491527d0 2401 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2402 /*
2403 * We do not care about using sv to call CV;
2404 * it's for informational purposes only.
2405 */
890ce7af 2406 SV * const sv = GvSV(PL_DBsub);
491527d0 2407 CV *gotocv;
bfed75c6 2408
f398eb67 2409 save_item(sv);
491527d0 2410 if (PERLDB_SUB_NN) {
890ce7af 2411 const int type = SvTYPE(sv);
f398eb67
NC		 2412 if (type < SVt_PVIV && type != SVt_IV)
2413 sv_upgrade(sv, SVt_PVIV);
7619c85e 2414 (void)SvIOK_on(sv);
45977657 2415 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
491527d0 2416 } else {
491527d0
GS		 2417 gv_efullname3(sv, CvGV(cv), Nullch);
2418 }
2419 if ( PERLDB_GOTO
864dbfa3 2420 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2421 PUSHMARK( PL_stack_sp );
864dbfa3 2422 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2423 PL_stack_sp--;
491527d0 2424 }
1ce6579f 2425 }
a0d0e21e
LW		 2426 RETURNOP(CvSTART(cv));
2427 }
2428 }
1614b0e3 2429 else {
0510663f 2430 label = SvPV_nolen_const(sv);
1614b0e3 2431 if (!(do_dump || *label))
cea2e8a9 2432 DIE(aTHX_ must_have_label);
1614b0e3 2433 }
a0d0e21e 2434 }
533c011a 2435 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2436 if (! do_dump)
cea2e8a9 2437 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2438 }
2439 else
2440 label = cPVOP->op_pv;
2441
2442 if (label && *label) {
2443 OP *gotoprobe = 0;
3b2447bc 2444 bool leaving_eval = FALSE;
33d34e4c 2445 bool in_block = FALSE;
a4f3a277 2446 PERL_CONTEXT *last_eval_cx = 0;
a0d0e21e
LW		 2447
2448 /* find label */
2449
3280af22 2450 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2451 *enterops = 0;
2452 for (ix = cxstack_ix; ix >= 0; ix--) {
2453 cx = &cxstack[ix];
6b35e009 2454 switch (CxTYPE(cx)) {
a0d0e21e 2455 case CXt_EVAL:
3b2447bc 2456 leaving_eval = TRUE;
971ecbe6 2457 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH		 2458 gotoprobe = (last_eval_cx ?
2459 last_eval_cx->blk_eval.old_eval_root :
2460 PL_eval_root);
2461 last_eval_cx = cx;
9c5794fe
RH		 2462 break;
2463 }
2464 /* else fall through */
a0d0e21e
LW		 2465 case CXt_LOOP:
2466 gotoprobe = cx->blk_oldcop->op_sibling;
2467 break;
2468 case CXt_SUBST:
2469 continue;
2470 case CXt_BLOCK:
33d34e4c 2471 if (ix) {
a0d0e21e 2472 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE		 2473 in_block = TRUE;
2474 } else
3280af22 2475 gotoprobe = PL_main_root;
a0d0e21e 2476 break;
b3933176 2477 case CXt_SUB:
9850bf21 2478 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
b3933176
CS		 2479 gotoprobe = CvROOT(cx->blk_sub.cv);
2480 break;
2481 }
2482 /* FALL THROUGH */
7766f137 2483 case CXt_FORMAT:
0a753a76 2484 case CXt_NULL:
a651a37d 2485 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 2486 default:
2487 if (ix)
cea2e8a9 2488 DIE(aTHX_ "panic: goto");
3280af22 2489 gotoprobe = PL_main_root;
a0d0e21e
LW		 2490 break;
2491 }
2b597662
GS		 2492 if (gotoprobe) {
2493 retop = dofindlabel(gotoprobe, label,
2494 enterops, enterops + GOTO_DEPTH);
2495 if (retop)
2496 break;
2497 }
3280af22 2498 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2499 }
2500 if (!retop)
cea2e8a9 2501 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2502
3b2447bc
RH		 2503 /* if we're leaving an eval, check before we pop any frames
2504 that we're not going to punt, otherwise the error
2505 won't be caught */
2506
2507 if (leaving_eval && *enterops && enterops[1]) {
2508 I32 i;
2509 for (i = 1; enterops[i]; i++)
2510 if (enterops[i]->op_type == OP_ENTERITER)
2511 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2512 }
2513
a0d0e21e
LW		 2514 /* pop unwanted frames */
2515
2516 if (ix < cxstack_ix) {
2517 I32 oldsave;
2518
2519 if (ix < 0)
2520 ix = 0;
2521 dounwind(ix);
2522 TOPBLOCK(cx);
3280af22 2523 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2524 LEAVE_SCOPE(oldsave);
2525 }
2526
2527 /* push wanted frames */
2528
748a9306 2529 if (*enterops && enterops[1]) {
0bd48802 2530 OP * const oldop = PL_op;
33d34e4c
AE		 2531 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2532 for (; enterops[ix]; ix++) {
533c011a 2533 PL_op = enterops[ix];
84902520
TB		 2534 /* Eventually we may want to stack the needed arguments
2535 * for each op. For now, we punt on the hard ones. */
533c011a 2536 if (PL_op->op_type == OP_ENTERITER)
894356b3 2537 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2538 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2539 }
533c011a 2540 PL_op = oldop;
a0d0e21e
LW		 2541 }
2542 }
2543
2544 if (do_dump) {
a5f75d66 2545#ifdef VMS
6b88bc9c 2546 if (!retop) retop = PL_main_start;
a5f75d66 2547#endif
3280af22
NIS		 2548 PL_restartop = retop;
2549 PL_do_undump = TRUE;
a0d0e21e
LW		 2550
2551 my_unexec();
2552
3280af22
NIS		 2553 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2554 PL_do_undump = FALSE;
a0d0e21e
LW		 2555 }
2556
2557 RETURNOP(retop);
2558}
2559
2560PP(pp_exit)
2561{
39644a26 2562 dSP;
a0d0e21e
LW		 2563 I32 anum;
2564
2565 if (MAXARG < 1)
2566 anum = 0;
ff0cee69 2567 else {
a0d0e21e 2568 anum = SvIVx(POPs);
d98f61e7
GS		 2569#ifdef VMS
2570 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2571 anum = 0;
96e176bf 2572 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69 2573#endif
2574 }
cc3604b1 2575 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2576 my_exit(anum);
3280af22 2577 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2578 RETURN;
2579}
2580
2581#ifdef NOTYET
2582PP(pp_nswitch)
2583{
39644a26 2584 dSP;
f54cb97a 2585 const NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2586 register I32 match = I_32(value);
2587
2588 if (value < 0.0) {
65202027 2589 if (((NV)match) > value)
a0d0e21e
LW		 2590 --match; /* was fractional--truncate other way */
2591 }
2592 match -= cCOP->uop.scop.scop_offset;
2593 if (match < 0)
2594 match = 0;
2595 else if (match > cCOP->uop.scop.scop_max)
2596 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2597 PL_op = cCOP->uop.scop.scop_next[match];
2598 RETURNOP(PL_op);
a0d0e21e
LW		 2599}
2600
2601PP(pp_cswitch)
2602{
39644a26 2603 dSP;
a0d0e21e
LW		 2604 register I32 match;
2605
6b88bc9c
GS		 2606 if (PL_multiline)
2607 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2608 else {
0510663f 2609 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
a0d0e21e
LW		 2610 match -= cCOP->uop.scop.scop_offset;
2611 if (match < 0)
2612 match = 0;
2613 else if (match > cCOP->uop.scop.scop_max)
2614 match = cCOP->uop.scop.scop_max;
6b88bc9c 2615 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2616 }
6b88bc9c 2617 RETURNOP(PL_op);
a0d0e21e
LW		 2618}
2619#endif
2620
2621/* Eval. */
2622
0824fdcb 2623STATIC void
cea2e8a9 2624S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2625{
504618e9 2626 const char *s = SvPVX_const(sv);
890ce7af 2627 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 2628 I32 line = 1;
a0d0e21e
LW		 2629
2630 while (s && s < send) {
f54cb97a 2631 const char *t;
890ce7af 2632 SV * const tmpstr = NEWSV(85,0);
a0d0e21e
LW		 2633
2634 sv_upgrade(tmpstr, SVt_PVMG);
2635 t = strchr(s, '\n');
2636 if (t)
2637 t++;
2638 else
2639 t = send;
2640
2641 sv_setpvn(tmpstr, s, t - s);
2642 av_store(array, line++, tmpstr);
2643 s = t;
2644 }
2645}
2646
901017d6 2647STATIC void
14dd3ad8
GS		 2648S_docatch_body(pTHX)
2649{
cea2e8a9 2650 CALLRUNOPS(aTHX);
901017d6 2651 return;
312caa8e
CS		 2652}
2653
0824fdcb 2654STATIC OP *
cea2e8a9 2655S_docatch(pTHX_ OP *o)
1e422769 2656{
6224f72b 2657 int ret;
06b5626a 2658 OP * const oldop = PL_op;
db36c5a1 2659 dJMPENV;
1e422769 2660
1e422769 2661#ifdef DEBUGGING
54310121 2662 assert(CATCH_GET == TRUE);
1e422769 2663#endif
312caa8e 2664 PL_op = o;
8bffa5f8 2665
14dd3ad8 2666 JMPENV_PUSH(ret);
6224f72b 2667 switch (ret) {
312caa8e 2668 case 0:
abd70938
DM		 2669 assert(cxstack_ix >= 0);
2670 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2671 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8
GS		 2672 redo_body:
2673 docatch_body();
312caa8e
CS		 2674 break;
2675 case 3:
8bffa5f8 2676 /* die caught by an inner eval - continue inner loop */
abd70938
DM		 2677
2678 /* NB XXX we rely on the old popped CxEVAL still being at the top
2679 * of the stack; the way die_where() currently works, this
2680 * assumption is valid. In theory The cur_top_env value should be
2681 * returned in another global, the way retop (aka PL_restartop)
2682 * is. */
2683 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2684
2685 if (PL_restartop
2686 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2687 {
312caa8e
CS		 2688 PL_op = PL_restartop;
2689 PL_restartop = 0;
2690 goto redo_body;
2691 }
2692 /* FALL THROUGH */
2693 default:
14dd3ad8 2694 JMPENV_POP;
533c011a 2695 PL_op = oldop;
6224f72b 2696 JMPENV_JUMP(ret);
1e422769 2697 /* NOTREACHED */
1e422769 2698 }
14dd3ad8 2699 JMPENV_POP;
533c011a 2700 PL_op = oldop;
745cf2ff 2701 return Nullop;
1e422769 2702}
2703
c277df42 2704OP *
bfed75c6 2705Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ		 2706/* sv Text to convert to OP tree. */
2707/* startop op_free() this to undo. */
2708/* code Short string id of the caller. */
2709{
f7997f86 2710 /* FIXME - how much of this code is common with pp_entereval? */
27da23d5 2711 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ		 2712 PERL_CONTEXT *cx;
2713 SV **newsp;
b094c71d 2714 I32 gimme = G_VOID;
c277df42
IZ		 2715 I32 optype;
2716 OP dummy;
155aba94 2717 OP *rop;
83ee9e09
GS		 2718 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2719 char *tmpbuf = tbuf;
c277df42 2720 char *safestr;
a3985cdc 2721 int runtime;
40b8d195 2722 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
f7997f86 2723 STRLEN len;
c277df42
IZ		 2724
2725 ENTER;
2726 lex_start(sv);
2727 SAVETMPS;
2728 /* switch to eval mode */
2729
923e4eb5 2730 if (IN_PERL_COMPILETIME) {
f4dd75d9 2731 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2732 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2733 }
83ee9e09 2734 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
9d4ba2ae 2735 SV * const sv = sv_newmortal();
83ee9e09
GS		 2736 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2737 code, (unsigned long)++PL_evalseq,
2738 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2739 tmpbuf = SvPVX(sv);
fc009855 2740 len = SvCUR(sv);
83ee9e09
GS		 2741 }
2742 else
fc009855
NC		 2743 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2744 (unsigned long)++PL_evalseq);
f4dd75d9 2745 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2746 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2747 SAVECOPLINE(&PL_compiling);
57843af0 2748 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2749 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2750 deleting the eval's FILEGV from the stash before gv_check() runs
2751 (i.e. before run-time proper). To work around the coredump that
2752 ensues, we always turn GvMULTI_on for any globals that were
2753 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC		 2754 safestr = savepvn(tmpbuf, len);
2755 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 2756 SAVEHINTS();
d1ca3daa 2757#ifdef OP_IN_REGISTER
6b88bc9c 2758 PL_opsave = op;
d1ca3daa 2759#else
7766f137 2760 SAVEVPTR(PL_op);
d1ca3daa 2761#endif
c277df42 2762
a3985cdc 2763 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2764 runtime = IN_PERL_RUNTIME;
a3985cdc 2765 if (runtime)
d819b83a 2766 runcv = find_runcv(NULL);
a3985cdc 2767
533c011a 2768 PL_op = &dummy;
13b51b79 2769 PL_op->op_type = OP_ENTEREVAL;
533c011a 2770 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2771 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
cc49e20b 2772 PUSHEVAL(cx, 0, Nullgv);
a3985cdc
DM		 2773
2774 if (runtime)
2775 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2776 else
2777 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2778 POPBLOCK(cx,PL_curpm);
e84b9f1f 2779 POPEVAL(cx);
c277df42
IZ		 2780
2781 (*startop)->op_type = OP_NULL;
22c35a8c 2782 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2783 lex_end();
f3548bdc
DM		 2784 /* XXX DAPM do this properly one year */
2785 *padp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2786 LEAVE;
923e4eb5 2787 if (IN_PERL_COMPILETIME)
eb160463 2788 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
d1ca3daa 2789#ifdef OP_IN_REGISTER
6b88bc9c 2790 op = PL_opsave;
d1ca3daa 2791#endif
9d4ba2ae
AL		 2792 PERL_UNUSED_VAR(newsp);
2793 PERL_UNUSED_VAR(optype);
2794
c277df42
IZ		 2795 return rop;
2796}
2797
a3985cdc
DM		 2798
2799/*
2800=for apidoc find_runcv
2801
2802Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM		 2803If db_seqp is non_null, skip CVs that are in the DB package and populate
2804*db_seqp with the cop sequence number at the point that the DB:: code was
2805entered. (allows debuggers to eval in the scope of the breakpoint rather
cf525c36 2806than in the scope of the debugger itself).
a3985cdc
DM		 2807
2808=cut
2809*/
2810
2811CV*
d819b83a 2812Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 2813{
a3985cdc 2814 PERL_SI *si;
a3985cdc 2815
d819b83a
DM		 2816 if (db_seqp)
2817 *db_seqp = PL_curcop->cop_seq;
a3985cdc 2818 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 2819 I32 ix;
a3985cdc 2820 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 2821 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a 2822 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1b6737cc 2823 CV * const cv = cx->blk_sub.cv;
d819b83a
DM		 2824 /* skip DB:: code */
2825 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2826 *db_seqp = cx->blk_oldcop->cop_seq;
2827 continue;
2828 }
2829 return cv;
2830 }
a3985cdc
DM		 2831 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2832 return PL_compcv;
2833 }
2834 }
2835 return PL_main_cv;
2836}
2837
2838
2839/* Compile a require/do, an eval '', or a /(?{...})/.
2840 * In the last case, startop is non-null, and contains the address of
2841 * a pointer that should be set to the just-compiled code.
2842 * outside is the lexically enclosing CV (if any) that invoked us.
2843 */
2844
4d1ff10f 2845/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2846STATIC OP *
a3985cdc 2847S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 2848{
27da23d5 2849 dVAR; dSP;
46c461b5 2850 OP * const saveop = PL_op;
a0d0e21e 2851
6dc8a9e4
IZ		 2852 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2853 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2854 : EVAL_INEVAL);
a0d0e21e 2855
1ce6579f 2856 PUSHMARK(SP);
2857
3280af22
NIS		 2858 SAVESPTR(PL_compcv);
2859 PL_compcv = (CV*)NEWSV(1104,0);
2860 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2861 CvEVAL_on(PL_compcv);
2090ab20
JH		 2862 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2863 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2864
a3985cdc 2865 CvOUTSIDE_SEQ(PL_compcv) = seq;
7dafbf52 2866 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
a3985cdc 2867
dd2155a4 2868 /* set up a scratch pad */
a0d0e21e 2869
dd2155a4 2870 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2c05e328 2871
07055b4c 2872
26d9b02f 2873 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2874
a0d0e21e
LW		 2875 /* make sure we compile in the right package */
2876
ed094faf 2877 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2878 SAVESPTR(PL_curstash);
ed094faf 2879 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2880 }
3280af22
NIS		 2881 SAVESPTR(PL_beginav);
2882 PL_beginav = newAV();
2883 SAVEFREESV(PL_beginav);
24944567 2884 SAVEI32(PL_error_count);
a0d0e21e
LW		 2885
2886 /* try to compile it */
2887
3280af22
NIS		 2888 PL_eval_root = Nullop;
2889 PL_error_count = 0;
2890 PL_curcop = &PL_compiling;
2891 PL_curcop->cop_arybase = 0;
c277df42 2892 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2893 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2894 else
c69006e4 2895 sv_setpvn(ERRSV,"",0);
3280af22 2896 if (yyparse() || PL_error_count || !PL_eval_root) {
0c58d367 2897 SV **newsp; /* Used by POPBLOCK. */
9d4ba2ae 2898 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2899 I32 optype = 0; /* Might be reset by POPEVAL. */
9d4ba2ae 2900 const char *msg;
bfed75c6 2901
533c011a 2902 PL_op = saveop;
3280af22
NIS		 2903 if (PL_eval_root) {
2904 op_free(PL_eval_root);
2905 PL_eval_root = Nullop;
a0d0e21e 2906 }
3280af22 2907 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2908 if (!startop) {
3280af22 2909 POPBLOCK(cx,PL_curpm);
c277df42 2910 POPEVAL(cx);
c277df42 2911 }
a0d0e21e
LW		 2912 lex_end();
2913 LEAVE;
9d4ba2ae
AL		 2914
2915 msg = SvPVx_nolen_const(ERRSV);
7a2e2cd6 2916 if (optype == OP_REQUIRE) {
b464bac0 2917 const SV * const nsv = cx->blk_eval.old_namesv;
504618e9 2918 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 2919 &PL_sv_undef, 0);
5a844595
GS		 2920 DIE(aTHX_ "%sCompilation failed in require",
2921 *msg ? msg : "Unknown error\n");
2922 }
2923 else if (startop) {
3280af22 2924 POPBLOCK(cx,PL_curpm);
c277df42 2925 POPEVAL(cx);
5a844595
GS		 2926 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2927 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2928 }
9d7f88dd 2929 else {
9d7f88dd
SR		 2930 if (!*msg) {
2931 sv_setpv(ERRSV, "Compilation error");
2932 }
2933 }
9d4ba2ae 2934 PERL_UNUSED_VAR(newsp);
a0d0e21e
LW		 2935 RETPUSHUNDEF;
2936 }
57843af0 2937 CopLINE_set(&PL_compiling, 0);
c277df42 2938 if (startop) {
3280af22 2939 *startop = PL_eval_root;
c277df42 2940 } else
3280af22 2941 SAVEFREEOP(PL_eval_root);
0c58d367
RGS		 2942
2943 /* Set the context for this new optree.
2944 * If the last op is an OP_REQUIRE, force scalar context.
2945 * Otherwise, propagate the context from the eval(). */
2946 if (PL_eval_root->op_type == OP_LEAVEEVAL
2947 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2948 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2949 == OP_REQUIRE)
2950 scalar(PL_eval_root);
2951 else if (gimme & G_VOID)
3280af22 2952 scalarvoid(PL_eval_root);
54310121 2953 else if (gimme & G_ARRAY)
3280af22 2954 list(PL_eval_root);
a0d0e21e 2955 else
3280af22 2956 scalar(PL_eval_root);
a0d0e21e
LW		 2957
2958 DEBUG_x(dump_eval());
2959
55497cff 2960 /* Register with debugger: */
84902520 2961 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
890ce7af 2962 CV * const cv = get_cv("DB::postponed", FALSE);
55497cff 2963 if (cv) {
2964 dSP;
924508f0 2965 PUSHMARK(SP);
cc49e20b 2966 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2967 PUTBACK;
864dbfa3 2968 call_sv((SV*)cv, G_DISCARD);
55497cff 2969 }
2970 }
2971
a0d0e21e
LW		 2972 /* compiled okay, so do it */
2973
3280af22
NIS		 2974 CvDEPTH(PL_compcv) = 1;
2975 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2976 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 2977 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 2978
3280af22 2979 RETURNOP(PL_eval_start);
a0d0e21e
LW		 2980}
2981
a6c40364 2982STATIC PerlIO *
ce8abf5f
SP		 2983S_check_type_and_open(pTHX_ const char *name, const char *mode)
2984{
2985 Stat_t st;
2986 int st_rc;
2987 st_rc = PerlLIO_stat(name, &st);
2988 if (st_rc < 0) {
2989 return Nullfp;
2990 }
2991
2992 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
2993 Perl_die(aTHX_ "%s %s not allowed in require",
2994 S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
2995 }
2996 return PerlIO_open(name, mode);
2997}
2998
2999STATIC PerlIO *
7925835c 3000S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3001{
7925835c 3002#ifndef PERL_DISABLE_PMC
f54cb97a 3003 const STRLEN namelen = strlen(name);
b295d113
TH		 3004 PerlIO *fp;
3005
7894fbab 3006 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
9d4ba2ae 3007 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
349d4f2f 3008 const char * const pmc = SvPV_nolen_const(pmcsv);
a6c40364
GS		 3009 Stat_t pmcstat;
3010 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
85e8f315 3011 fp = check_type_and_open(name, mode);
a6c40364
GS		 3012 }
3013 else {
9d4ba2ae 3014 Stat_t pmstat;
b295d113 3015 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 3016 pmstat.st_mtime < pmcstat.st_mtime)
3017 {
85e8f315 3018 fp = check_type_and_open(pmc, mode);
a6c40364
GS		 3019 }
3020 else {
85e8f315 3021 fp = check_type_and_open(name, mode);
a6c40364 3022 }
b295d113 3023 }
a6c40364
GS		 3024 SvREFCNT_dec(pmcsv);
3025 }
3026 else {
85e8f315 3027 fp = check_type_and_open(name, mode);
b295d113 3028 }
b295d113 3029 return fp;
7925835c 3030#else
85e8f315 3031 return check_type_and_open(name, mode);
7925835c 3032#endif /* !PERL_DISABLE_PMC */
b295d113
TH		 3033}
3034
a0d0e21e
LW		 3035PP(pp_require)
3036{
27da23d5 3037 dVAR; dSP;
c09156bb 3038 register PERL_CONTEXT *cx;
a0d0e21e 3039 SV *sv;
5c144d81 3040 const char *name;
6132ea6c 3041 STRLEN len;
5c144d81 3042 const char *tryname = Nullch;
46fc3d4c 3043 SV *namesv = Nullsv;
f54cb97a 3044 const I32 gimme = GIMME_V;
760ac839 3045 PerlIO *tryrsfp = 0;
bbed91b5
KF		 3046 int filter_has_file = 0;
3047 GV *filter_child_proc = 0;
3048 SV *filter_state = 0;
3049 SV *filter_sub = 0;
89ccab8c 3050 SV *hook_sv = 0;
6ec9efec
JH		 3051 SV *encoding;
3052 OP *op;
a0d0e21e
LW		 3053
3054 sv = POPs;
d7aa5382
JP		 3055 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3056 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
9014280d 3057 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 3058 "v-string in use/require non-portable");
d7aa5382
JP		 3059
3060 sv = new_version(sv);
3061 if (!sv_derived_from(PL_patchlevel, "version"))
3062 (void *)upg_version(PL_patchlevel);
149c1637 3063 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
468aa647
RGS		 3064 if ( vcmp(sv,PL_patchlevel) < 0 )
3065 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3066 vnormal(sv), vnormal(PL_patchlevel));
3067 }
3068 else {
3069 if ( vcmp(sv,PL_patchlevel) > 0 )
3070 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3071 vnormal(sv), vnormal(PL_patchlevel));
3072 }
d7aa5382 3073
4305d8ab 3074 RETPUSHYES;
a0d0e21e 3075 }
5c144d81 3076 name = SvPV_const(sv, len);
6132ea6c 3077 if (!(name && len > 0 && *name))
cea2e8a9 3078 DIE(aTHX_ "Null filename used");
4633a7c4 3079 TAINT_PROPER("require");
44f8325f 3080 if (PL_op->op_type == OP_REQUIRE) {
0bd48802 3081 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
44f8325f
AL		 3082 if ( svp ) {
3083 if (*svp != &PL_sv_undef)
3084 RETPUSHYES;
3085 else
3086 DIE(aTHX_ "Compilation failed in require");
3087 }
4d8b06f1 3088 }
a0d0e21e
LW		 3089
3090 /* prepare to compile file */
3091
be4b629d 3092 if (path_is_absolute(name)) {
46fc3d4c 3093 tryname = name;
7925835c 3094 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
bf4acbe4 3095 }
67627c52
JH		 3096#ifdef MACOS_TRADITIONAL
3097 if (!tryrsfp) {
3098 char newname[256];
3099
3100 MacPerl_CanonDir(name, newname, 1);
3101 if (path_is_absolute(newname)) {
3102 tryname = newname;
7925835c 3103 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
67627c52
JH		 3104 }
3105 }
3106#endif
be4b629d 3107 if (!tryrsfp) {
44f8325f 3108 AV * const ar = GvAVn(PL_incgv);
a0d0e21e 3109 I32 i;
748a9306 3110#ifdef VMS
46fc3d4c 3111 char *unixname;
b8ffc8df 3112 if ((unixname = tounixspec(name, Nullch)) != Nullch)
46fc3d4c 3113#endif
3114 {
3115 namesv = NEWSV(806, 0);
3116 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF		 3117 SV *dirsv = *av_fetch(ar, i, TRUE);
3118
3119 if (SvROK(dirsv)) {
3120 int count;
3121 SV *loader = dirsv;
3122
e14e2dc8
NC		 3123 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3124 && !sv_isobject(loader))
3125 {
bbed91b5
KF		 3126 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3127 }
3128
b900a521 3129 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3130 PTR2UV(SvRV(dirsv)), name);
349d4f2f 3131 tryname = SvPVX_const(namesv);
bbed91b5
KF		 3132 tryrsfp = 0;
3133
3134 ENTER;
3135 SAVETMPS;
3136 EXTEND(SP, 2);
3137
3138 PUSHMARK(SP);
3139 PUSHs(dirsv);
3140 PUSHs(sv);
3141 PUTBACK;
e982885c
NC		 3142 if (sv_isobject(loader))
3143 count = call_method("INC", G_ARRAY);
3144 else
3145 count = call_sv(loader, G_ARRAY);
bbed91b5
KF		 3146 SPAGAIN;
3147
3148 if (count > 0) {
3149 int i = 0;
3150 SV *arg;
3151
3152 SP -= count - 1;
3153 arg = SP[i++];
3154
3155 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3156 arg = SvRV(arg);
3157 }
3158
3159 if (SvTYPE(arg) == SVt_PVGV) {
3160 IO *io = GvIO((GV *)arg);
3161
3162 ++filter_has_file;
3163
3164 if (io) {
3165 tryrsfp = IoIFP(io);
50952442 3166 if (IoTYPE(io) == IoTYPE_PIPE) {
bbed91b5
KF		 3167 /* reading from a child process doesn't
3168 nest -- when returning from reading
3169 the inner module, the outer one is
3170 unreadable (closed?) I've tried to
3171 save the gv to manage the lifespan of
3172 the pipe, but this didn't help. XXX */
3173 filter_child_proc = (GV *)arg;
520c758a 3174 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF		 3175 }
3176 else {
3177 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3178 PerlIO_close(IoOFP(io));
3179 }
3180 IoIFP(io) = Nullfp;
3181 IoOFP(io) = Nullfp;
3182 }
3183 }
3184
3185 if (i < count) {
3186 arg = SP[i++];
3187 }
3188 }
3189
3190 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3191 filter_sub = arg;
520c758a 3192 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 3193
3194 if (i < count) {
3195 filter_state = SP[i];
520c758a 3196 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF		 3197 }
3198
3199 if (tryrsfp == 0) {
3200 tryrsfp = PerlIO_open("/dev/null",
3201 PERL_SCRIPT_MODE);
3202 }
3203 }
1d06aecd 3204 SP--;
bbed91b5
KF		 3205 }
3206
3207 PUTBACK;
3208 FREETMPS;
3209 LEAVE;
3210
3211 if (tryrsfp) {
89ccab8c 3212 hook_sv = dirsv;
bbed91b5
KF		 3213 break;
3214 }
3215
3216 filter_has_file = 0;
3217 if (filter_child_proc) {
3218 SvREFCNT_dec(filter_child_proc);
3219 filter_child_proc = 0;
3220 }
3221 if (filter_state) {
3222 SvREFCNT_dec(filter_state);
3223 filter_state = 0;
3224 }
3225 if (filter_sub) {
3226 SvREFCNT_dec(filter_sub);
3227 filter_sub = 0;
3228 }
3229 }
3230 else {
be4b629d
CN		 3231 if (!path_is_absolute(name)
3232#ifdef MACOS_TRADITIONAL
3233 /* We consider paths of the form :a:b ambiguous and interpret them first
3234 as global then as local
3235 */
3236 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3237#endif
3238 ) {
0510663f 3239 const char *dir = SvPVx_nolen_const(dirsv);
bf4acbe4 3240#ifdef MACOS_TRADITIONAL
67627c52
JH		 3241 char buf1[256];
3242 char buf2[256];
3243
3244 MacPerl_CanonDir(name, buf2, 1);
3245 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3246#else
27da23d5 3247# ifdef VMS
bbed91b5 3248 char *unixdir;
b8ffc8df 3249 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
bbed91b5
KF		 3250 continue;
3251 sv_setpv(namesv, unixdir);
3252 sv_catpv(namesv, unixname);
27da23d5 3253# else
a0fd4948 3254# ifdef __SYMBIAN32__
27da23d5
JH		 3255 if (PL_origfilename[0] &&
3256 PL_origfilename[1] == ':' &&
3257 !(dir[0] && dir[1] == ':'))
3258 Perl_sv_setpvf(aTHX_ namesv,
3259 "%c:%s\\%s",
3260 PL_origfilename[0],
3261 dir, name);
3262 else
3263 Perl_sv_setpvf(aTHX_ namesv,
3264 "%s\\%s",
3265 dir, name);
3266# else
bbed91b5 3267 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
27da23d5
JH		 3268# endif
3269# endif
bf4acbe4 3270#endif
bbed91b5 3271 TAINT_PROPER("require");
349d4f2f 3272 tryname = SvPVX_const(namesv);
7925835c 3273 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
bbed91b5
KF		 3274 if (tryrsfp) {
3275 if (tryname[0] == '.' && tryname[1] == '/')
3276 tryname += 2;
3277 break;
3278 }
be4b629d 3279 }
46fc3d4c 3280 }
a0d0e21e
LW		 3281 }
3282 }
3283 }
f4dd75d9 3284 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3285 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3286 SvREFCNT_dec(namesv);
a0d0e21e 3287 if (!tryrsfp) {
533c011a 3288 if (PL_op->op_type == OP_REQUIRE) {
5c144d81 3289 const char *msgstr = name;
e31de809 3290 if(errno == EMFILE) {
44f8325f 3291 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
e31de809
SP		 3292 sv_catpv(msg, ": ");
3293 sv_catpv(msg, Strerror(errno));
349d4f2f 3294 msgstr = SvPV_nolen_const(msg);
e31de809
SP		 3295 } else {
3296 if (namesv) { /* did we lookup @INC? */
44f8325f
AL		 3297 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3298 SV * const dirmsgsv = NEWSV(0, 0);
3299 AV * const ar = GvAVn(PL_incgv);
e31de809
SP		 3300 I32 i;
3301 sv_catpvn(msg, " in @INC", 8);
3302 if (instr(SvPVX_const(msg), ".h "))
3303 sv_catpv(msg, " (change .h to .ph maybe?)");
3304 if (instr(SvPVX_const(msg), ".ph "))
3305 sv_catpv(msg, " (did you run h2ph?)");
3306 sv_catpv(msg, " (@INC contains:");
3307 for (i = 0; i <= AvFILL(ar); i++) {
3308 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3309 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3310 sv_catsv(msg, dirmsgsv);
3311 }
3312 sv_catpvn(msg, ")", 1);
3313 SvREFCNT_dec(dirmsgsv);
3314 msgstr = SvPV_nolen_const(msg);
3315 }
2683423c 3316 }
ea071790 3317 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 3318 }
3319
3320 RETPUSHUNDEF;
3321 }
d8bfb8bd 3322 else
93189314 3323 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW		 3324
3325 /* Assume success here to prevent recursive requirement. */
238d24b4 3326 /* name is never assigned to again, so len is still strlen(name) */
d3a4e64e 3327 /* Check whether a hook in @INC has already filled %INC */
44f8325f
AL		 3328 if (!hook_sv) {
3329 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3330 } else {
3331 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3332 if (!svp)
3333 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
d3a4e64e 3334 }
a0d0e21e
LW		 3335
3336 ENTER;
3337 SAVETMPS;
79cb57f6 3338 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37 3339 SAVEGENERICSV(PL_rsfp_filters);
7d49f689 3340 PL_rsfp_filters = NULL;
e50aee73 3341
3280af22 3342 PL_rsfp = tryrsfp;
b3ac6de7 3343 SAVEHINTS();
3280af22 3344 PL_hints = 0;
7766f137 3345 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3346 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3347 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3348 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3349 PL_compiling.cop_warnings = pWARN_NONE ;
317ea90d
MS		 3350 else if (PL_taint_warn)
3351 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
ac27b0f5 3352 else
d3a7d8c7 3353 PL_compiling.cop_warnings = pWARN_STD ;
ac27b0f5
NIS		 3354 SAVESPTR(PL_compiling.cop_io);
3355 PL_compiling.cop_io = Nullsv;
a0d0e21e 3356
bbed91b5 3357 if (filter_sub || filter_child_proc) {
0bd48802 3358 SV * const datasv = filter_add(S_run_user_filter, Nullsv);
bbed91b5
KF		 3359 IoLINES(datasv) = filter_has_file;
3360 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3361 IoTOP_GV(datasv) = (GV *)filter_state;
3362 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3363 }
3364
3365 /* switch to eval mode */
a0d0e21e 3366 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3367 PUSHEVAL(cx, name, Nullgv);
f39bc417 3368 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 3369
57843af0
GS		 3370 SAVECOPLINE(&PL_compiling);
3371 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3372
3373 PUTBACK;
6ec9efec
JH		 3374
3375 /* Store and reset encoding. */
3376 encoding = PL_encoding;
3377 PL_encoding = Nullsv;
3378
a3985cdc 3379 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
bfed75c6 3380
6ec9efec
JH		 3381 /* Restore encoding. */
3382 PL_encoding = encoding;
3383
3384 return op;
a0d0e21e
LW		 3385}
3386
a0d0e21e
LW		 3387PP(pp_entereval)
3388{
27da23d5 3389 dVAR; dSP;
c09156bb 3390 register PERL_CONTEXT *cx;
a0d0e21e 3391 dPOPss;
890ce7af
AL		 3392 const I32 gimme = GIMME_V;
3393 const I32 was = PL_sub_generation;
83ee9e09
GS		 3394 char tbuf[TYPE_DIGITS(long) + 12];
3395 char *tmpbuf = tbuf;
fc36a67e 3396 char *safestr;
a0d0e21e 3397 STRLEN len;
55497cff 3398 OP *ret;
a3985cdc 3399 CV* runcv;
d819b83a 3400 U32 seq;
a0d0e21e 3401
f7997f86 3402 if (!SvPV_nolen_const(sv))
a0d0e21e 3403 RETPUSHUNDEF;
748a9306 3404 TAINT_PROPER("eval");
a0d0e21e
LW		 3405
3406 ENTER;
a0d0e21e 3407 lex_start(sv);
748a9306 3408 SAVETMPS;
ac27b0f5 3409
a0d0e21e
LW		 3410 /* switch to eval mode */
3411
83ee9e09 3412 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
890ce7af 3413 SV * const sv = sv_newmortal();
83ee9e09
GS		 3414 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3415 (unsigned long)++PL_evalseq,
3416 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3417 tmpbuf = SvPVX(sv);
fc009855 3418 len = SvCUR(sv);
83ee9e09
GS		 3419 }
3420 else
fc009855 3421 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 3422 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3423 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3424 SAVECOPLINE(&PL_compiling);
57843af0 3425 CopLINE_set(&PL_compiling, 1);
55497cff 3426 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3427 deleting the eval's FILEGV from the stash before gv_check() runs
3428 (i.e. before run-time proper). To work around the coredump that
3429 ensues, we always turn GvMULTI_on for any globals that were
3430 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC		 3431 safestr = savepvn(tmpbuf, len);
3432 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 3433 SAVEHINTS();
533c011a 3434 PL_hints = PL_op->op_targ;
7766f137 3435 SAVESPTR(PL_compiling.cop_warnings);
f0a6fc86
GS		 3436 if (specialWARN(PL_curcop->cop_warnings))
3437 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3438 else {
3439 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3440 SAVEFREESV(PL_compiling.cop_warnings);
599cee73 3441 }
ac27b0f5
NIS		 3442 SAVESPTR(PL_compiling.cop_io);
3443 if (specialCopIO(PL_curcop->cop_io))
3444 PL_compiling.cop_io = PL_curcop->cop_io;
3445 else {
3446 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3447 SAVEFREESV(PL_compiling.cop_io);
3448 }
d819b83a
DM		 3449 /* special case: an eval '' executed within the DB package gets lexically
3450 * placed in the first non-DB CV rather than the current CV - this
3451 * allows the debugger to execute code, find lexicals etc, in the
3452 * scope of the code being debugged. Passing &seq gets find_runcv
3453 * to do the dirty work for us */
3454