This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
performance tweaking op.c
[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,
b94e2f88 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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
PP
51 switch (cxstack[cxix].blk_gimme) {
52 case G_ARRAY:
a0d0e21e 53 RETPUSHYES;
54310121 54 case G_SCALAR:
a0d0e21e 55 RETPUSHNO;
54310121
PP
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;
c445ea15 191 SV *nsv = NULL;
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 282 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
c445ea15 283 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
14befaf4 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
PP
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
PP
312 else
313 Renew(p, i, UV);
314 *rsp = (void*)p;
315 }
316
c445ea15 317 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
cf93c79d 318 RX_MATCH_COPIED_off(rx);
c90c0ff4 319
f8c7b90f 320#ifdef PERL_OLD_COPY_ON_WRITE
ed252734 321 *p++ = PTR2UV(rx->saved_copy);
c445ea15 322 rx->saved_copy = NULL;
ed252734
NC
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
PP
332 }
333}
334
335void
864dbfa3 336Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4
PP
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
PP
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
PP
359 }
360}
361
362void
864dbfa3 363Perl_rxres_free(pTHX_ void **rsp)
c90c0ff4 364{
44f8325f 365 UV * const p = (UV*)*rsp;
c90c0ff4
PP
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
PP
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;
c445ea15
AL
394 register SV *sv = NULL;
395 const char *item = NULL;
9c5ffd7c
JH
396 I32 itemsize = 0;
397 I32 fieldsize = 0;
a0d0e21e 398 I32 lines = 0;
c445ea15
AL
399 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
400 const char *chophere = NULL;
401 char *linemark = NULL;
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;
c445ea15 409 SV * nsv = NULL;
cbbf8932 410 OP * parseres = NULL;
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
LW
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
LW
736 case FF_LINESNGL:
737 chopspace = 0;
738 oneline = TRUE;
739 goto ff_line;
a0d0e21e 740 case FF_LINEGLOB:
a1b95068
LW
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
LW
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
LW
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
PP
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);
396482e1 1179 sv_catpvs(targ, "E0");
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",
0d863452
RH
1196 "format",
1197 "given",
1198 "when"
515afda2
NC
1199};
1200
76e3520e 1201STATIC I32
06b5626a 1202S_dopoptolabel(pTHX_ const char *label)
a0d0e21e
LW
1203{
1204 register I32 i;
a0d0e21e
LW
1205
1206 for (i = cxstack_ix; i >= 0; i--) {
901017d6 1207 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1208 switch (CxTYPE(cx)) {
a0d0e21e 1209 case CXt_SUBST:
a0d0e21e 1210 case CXt_SUB:
7766f137 1211 case CXt_FORMAT:
a0d0e21e 1212 case CXt_EVAL:
0a753a76 1213 case CXt_NULL:
0d863452
RH
1214 case CXt_GIVEN:
1215 case CXt_WHEN:
e476b1b5 1216 if (ckWARN(WARN_EXITING))
515afda2
NC
1217 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1218 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1219 if (CxTYPE(cx) == CXt_NULL)
1220 return -1;
1221 break;
a0d0e21e 1222 case CXt_LOOP:
901017d6 1223 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
cea2e8a9 1224 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
68dc0745 1225 (long)i, cx->blk_loop.label));
a0d0e21e
LW
1226 continue;
1227 }
cea2e8a9 1228 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW
1229 return i;
1230 }
1231 }
1232 return i;
1233}
1234
0d863452
RH
1235
1236
e50aee73 1237I32
864dbfa3 1238Perl_dowantarray(pTHX)
e50aee73 1239{
f54cb97a 1240 const I32 gimme = block_gimme();
54310121
PP
1241 return (gimme == G_VOID) ? G_SCALAR : gimme;
1242}
1243
1244I32
864dbfa3 1245Perl_block_gimme(pTHX)
54310121 1246{
06b5626a 1247 const I32 cxix = dopoptosub(cxstack_ix);
e50aee73 1248 if (cxix < 0)
46fc3d4c 1249 return G_VOID;
e50aee73 1250
54310121 1251 switch (cxstack[cxix].blk_gimme) {
d2719217
GS
1252 case G_VOID:
1253 return G_VOID;
54310121 1254 case G_SCALAR:
e50aee73 1255 return G_SCALAR;
54310121
PP
1256 case G_ARRAY:
1257 return G_ARRAY;
1258 default:
cea2e8a9 1259 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS
1260 /* NOTREACHED */
1261 return 0;
54310121 1262 }
e50aee73
AD
1263}
1264
78f9721b
SM
1265I32
1266Perl_is_lvalue_sub(pTHX)
1267{
06b5626a 1268 const I32 cxix = dopoptosub(cxstack_ix);
78f9721b
SM
1269 assert(cxix >= 0); /* We should only be called from inside subs */
1270
1271 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1272 return cxstack[cxix].blk_sub.lval;
1273 else
1274 return 0;
1275}
1276
76e3520e 1277STATIC I32
cea2e8a9 1278S_dopoptosub(pTHX_ I32 startingblock)
a0d0e21e 1279{
2c375eb9
GS
1280 return dopoptosub_at(cxstack, startingblock);
1281}
1282
1283STATIC I32
901017d6 1284S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9 1285{
a0d0e21e 1286 I32 i;
a0d0e21e 1287 for (i = startingblock; i >= 0; i--) {
901017d6 1288 register const PERL_CONTEXT * const cx = &cxstk[i];
6b35e009 1289 switch (CxTYPE(cx)) {
a0d0e21e
LW
1290 default:
1291 continue;
1292 case CXt_EVAL:
1293 case CXt_SUB:
7766f137 1294 case CXt_FORMAT:
cea2e8a9 1295 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW
1296 return i;
1297 }
1298 }
1299 return i;
1300}
1301
76e3520e 1302STATIC I32
cea2e8a9 1303S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e
LW
1304{
1305 I32 i;
a0d0e21e 1306 for (i = startingblock; i >= 0; i--) {
06b5626a 1307 register const PERL_CONTEXT *cx = &cxstack[i];
6b35e009 1308 switch (CxTYPE(cx)) {
a0d0e21e
LW
1309 default:
1310 continue;
1311 case CXt_EVAL:
cea2e8a9 1312 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW
1313 return i;
1314 }
1315 }
1316 return i;
1317}
1318
76e3520e 1319STATIC I32
cea2e8a9 1320S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e
LW
1321{
1322 I32 i;
a0d0e21e 1323 for (i = startingblock; i >= 0; i--) {
901017d6 1324 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1325 switch (CxTYPE(cx)) {
a0d0e21e 1326 case CXt_SUBST:
a0d0e21e 1327 case CXt_SUB:
7766f137 1328 case CXt_FORMAT:
a0d0e21e 1329 case CXt_EVAL:
0a753a76 1330 case CXt_NULL:
e476b1b5 1331 if (ckWARN(WARN_EXITING))
515afda2
NC
1332 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1333 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1334 if ((CxTYPE(cx)) == CXt_NULL)
1335 return -1;
1336 break;
a0d0e21e 1337 case CXt_LOOP:
cea2e8a9 1338 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW
1339 return i;
1340 }
1341 }
1342 return i;
1343}
1344
0d863452
RH
1345STATIC I32
1346S_dopoptogiven(pTHX_ I32 startingblock)
1347{
1348 I32 i;
1349 for (i = startingblock; i >= 0; i--) {
1350 register const PERL_CONTEXT *cx = &cxstack[i];
1351 switch (CxTYPE(cx)) {
1352 default:
1353 continue;
1354 case CXt_GIVEN:
1355 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1356 return i;
1357 case CXt_LOOP:
1358 if (CxFOREACHDEF(cx)) {
1359 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1360 return i;
1361 }
1362 }
1363 }
1364 return i;
1365}
1366
1367STATIC I32
1368S_dopoptowhen(pTHX_ I32 startingblock)
1369{
1370 I32 i;
1371 for (i = startingblock; i >= 0; i--) {
1372 register const PERL_CONTEXT *cx = &cxstack[i];
1373 switch (CxTYPE(cx)) {
1374 default:
1375 continue;
1376 case CXt_WHEN:
1377 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1378 return i;
1379 }
1380 }
1381 return i;
1382}
1383
a0d0e21e 1384void
864dbfa3 1385Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1386{
a0d0e21e
LW
1387 I32 optype;
1388
1389 while (cxstack_ix > cxix) {
b0d9ce38 1390 SV *sv;
06b5626a 1391 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c90c0ff4 1392 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1393 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1394 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1395 switch (CxTYPE(cx)) {
c90c0ff4
PP
1396 case CXt_SUBST:
1397 POPSUBST(cx);
1398 continue; /* not break */
a0d0e21e 1399 case CXt_SUB:
b0d9ce38
GS
1400 POPSUB(cx,sv);
1401 LEAVESUB(sv);
a0d0e21e
LW
1402 break;
1403 case CXt_EVAL:
1404 POPEVAL(cx);
1405 break;
1406 case CXt_LOOP:
1407 POPLOOP(cx);
1408 break;
0a753a76 1409 case CXt_NULL:
a0d0e21e 1410 break;
7766f137
GS
1411 case CXt_FORMAT:
1412 POPFORMAT(cx);
1413 break;
a0d0e21e 1414 }
c90c0ff4 1415 cxstack_ix--;
a0d0e21e 1416 }
1b6737cc 1417 PERL_UNUSED_VAR(optype);
a0d0e21e
LW
1418}
1419
5a844595
GS
1420void
1421Perl_qerror(pTHX_ SV *err)
1422{
1423 if (PL_in_eval)
1424 sv_catsv(ERRSV, err);
1425 else if (PL_errors)
1426 sv_catsv(PL_errors, err);
1427 else
894356b3 1428 Perl_warn(aTHX_ "%"SVf, err);
5a844595
GS
1429 ++PL_error_count;
1430}
1431
a0d0e21e 1432OP *
35a4481c 1433Perl_die_where(pTHX_ const char *message, STRLEN msglen)
a0d0e21e 1434{
27da23d5 1435 dVAR;
87582a92 1436
3280af22 1437 if (PL_in_eval) {
a0d0e21e 1438 I32 cxix;
a0d0e21e 1439 I32 gimme;
a0d0e21e 1440
4e6ea2c3 1441 if (message) {
faef0170 1442 if (PL_in_eval & EVAL_KEEPERR) {
bfed75c6 1443 static const char prefix[] = "\t(in cleanup) ";
2d03de9c 1444 SV * const err = ERRSV;
c445ea15 1445 const char *e = NULL;
98eae8f5 1446 if (!SvPOK(err))
c69006e4 1447 sv_setpvn(err,"",0);
98eae8f5 1448 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
0510663f 1449 STRLEN len;
349d4f2f 1450 e = SvPV_const(err, len);
0510663f 1451 e += len - msglen;
98eae8f5 1452 if (*e != *message || strNE(e,message))
c445ea15 1453 e = NULL;
98eae8f5
GS
1454 }
1455 if (!e) {
1456 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1457 sv_catpvn(err, prefix, sizeof(prefix)-1);
1458 sv_catpvn(err, message, msglen);
e476b1b5 1459 if (ckWARN(WARN_MISC)) {
504618e9 1460 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
b15aece3 1461 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
4e6ea2c3 1462 }
4633a7c4 1463 }
4633a7c4 1464 }
1aa99e6b 1465 else {
06bf62c7 1466 sv_setpvn(ERRSV, message, msglen);
1aa99e6b 1467 }
4633a7c4 1468 }
4e6ea2c3 1469
5a844595
GS
1470 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1471 && PL_curstackinfo->si_prev)
1472 {
bac4b2ad 1473 dounwind(-1);
d3acc0f7 1474 POPSTACK;
bac4b2ad 1475 }
e336de0d 1476
a0d0e21e
LW
1477 if (cxix >= 0) {
1478 I32 optype;
35a4481c 1479 register PERL_CONTEXT *cx;
901017d6 1480 SV **newsp;
a0d0e21e
LW
1481
1482 if (cxix < cxstack_ix)
1483 dounwind(cxix);
1484
3280af22 1485 POPBLOCK(cx,PL_curpm);
6b35e009 1486 if (CxTYPE(cx) != CXt_EVAL) {
16869676 1487 if (!message)
349d4f2f 1488 message = SvPVx_const(ERRSV, msglen);
bf49b057
GS
1489 PerlIO_write(Perl_error_log, "panic: die ", 11);
1490 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW
1491 my_exit(1);
1492 }
1493 POPEVAL(cx);
1494
1495 if (gimme == G_SCALAR)
3280af22
NIS
1496 *++newsp = &PL_sv_undef;
1497 PL_stack_sp = newsp;
a0d0e21e
LW
1498
1499 LEAVE;
748a9306 1500
7fb6a879
GS
1501 /* LEAVE could clobber PL_curcop (see save_re_context())
1502 * XXX it might be better to find a way to avoid messing with
1503 * PL_curcop in save_re_context() instead, but this is a more
1504 * minimal fix --GSAR */
1505 PL_curcop = cx->blk_oldcop;
1506
7a2e2cd6 1507 if (optype == OP_REQUIRE) {
44f8325f 1508 const char* const msg = SvPVx_nolen_const(ERRSV);
901017d6 1509 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 1510 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 1511 &PL_sv_undef, 0);
5a844595
GS
1512 DIE(aTHX_ "%sCompilation failed in require",
1513 *msg ? msg : "Unknown error\n");
7a2e2cd6 1514 }
f39bc417
DM
1515 assert(CxTYPE(cx) == CXt_EVAL);
1516 return cx->blk_eval.retop;
a0d0e21e
LW
1517 }
1518 }
9cc2fdd3 1519 if (!message)
349d4f2f 1520 message = SvPVx_const(ERRSV, msglen);
87582a92 1521
7ff03255 1522 write_to_stderr(message, msglen);
f86702cc
PP
1523 my_failure_exit();
1524 /* NOTREACHED */
a0d0e21e
LW
1525 return 0;
1526}
1527
1528PP(pp_xor)
1529{
39644a26 1530 dSP; dPOPTOPssrl;
a0d0e21e
LW
1531 if (SvTRUE(left) != SvTRUE(right))
1532 RETSETYES;
1533 else
1534 RETSETNO;
1535}
1536
a0d0e21e
LW
1537PP(pp_caller)
1538{
39644a26 1539 dSP;
a0d0e21e 1540 register I32 cxix = dopoptosub(cxstack_ix);
901017d6
AL
1541 register const PERL_CONTEXT *cx;
1542 register const PERL_CONTEXT *ccstack = cxstack;
1543 const PERL_SI *top_si = PL_curstackinfo;
54310121 1544 I32 gimme;
06b5626a 1545 const char *stashname;
a0d0e21e
LW
1546 I32 count = 0;
1547
1548 if (MAXARG)
1549 count = POPi;
27d41816 1550
a0d0e21e 1551 for (;;) {
2c375eb9
GS
1552 /* we may be in a higher stacklevel, so dig down deeper */
1553 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1554 top_si = top_si->si_prev;
1555 ccstack = top_si->si_cxstack;
1556 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1557 }
a0d0e21e 1558 if (cxix < 0) {
27d41816
DM
1559 if (GIMME != G_ARRAY) {
1560 EXTEND(SP, 1);
a0d0e21e 1561 RETPUSHUNDEF;
27d41816 1562 }
a0d0e21e
LW
1563 RETURN;
1564 }
f2a7f298 1565 /* caller() should not report the automatic calls to &DB::sub */
1566 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
3280af22 1567 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW
1568 count++;
1569 if (!count--)
1570 break;
2c375eb9 1571 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1572 }
2c375eb9
GS
1573
1574 cx = &ccstack[cxix];
7766f137 1575 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
f54cb97a 1576 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2c375eb9 1577 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1578 field below is defined for any cx. */
f2a7f298 1579 /* caller() should not report the automatic calls to &DB::sub */
1580 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1581 cx = &ccstack[dbcxix];
06a5b730
PP
1582 }
1583
ed094faf 1584 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1585 if (GIMME != G_ARRAY) {
27d41816 1586 EXTEND(SP, 1);
ed094faf 1587 if (!stashname)
3280af22 1588 PUSHs(&PL_sv_undef);
49d8d3a1
MB
1589 else {
1590 dTARGET;
ed094faf 1591 sv_setpv(TARG, stashname);
49d8d3a1
MB
1592 PUSHs(TARG);
1593 }
a0d0e21e
LW
1594 RETURN;
1595 }
a0d0e21e 1596
27d41816
DM
1597 EXTEND(SP, 10);
1598
ed094faf 1599 if (!stashname)
3280af22 1600 PUSHs(&PL_sv_undef);
49d8d3a1 1601 else
ed094faf 1602 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
248c2a4d 1603 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
57843af0 1604 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW
1605 if (!MAXARG)
1606 RETURN;
7766f137 1607 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
0bd48802 1608 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
7766f137 1609 /* So is ccstack[dbcxix]. */
07b8c804 1610 if (isGV(cvgv)) {
f54cb97a 1611 SV * const sv = NEWSV(49, 0);
c445ea15 1612 gv_efullname3(sv, cvgv, NULL);
07b8c804
RGS
1613 PUSHs(sv_2mortal(sv));
1614 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1615 }
1616 else {
396482e1 1617 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
72699b0f 1618 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
07b8c804 1619 }
a0d0e21e
LW
1620 }
1621 else {
396482e1 1622 PUSHs(sv_2mortal(newSVpvs("(eval)")));
a0d0e21e
LW
1623 PUSHs(sv_2mortal(newSViv(0)));
1624 }
54310121
PP
1625 gimme = (I32)cx->blk_gimme;
1626 if (gimme == G_VOID)
3280af22 1627 PUSHs(&PL_sv_undef);
54310121
PP
1628 else
1629 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1630 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1631 /* eval STRING */
06a5b730 1632 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1633 PUSHs(cx->blk_eval.cur_text);
3280af22 1634 PUSHs(&PL_sv_no);
0f79a09d 1635 }
811a4de9 1636 /* require */
0f79a09d
GS
1637 else if (cx->blk_eval.old_namesv) {
1638 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
3280af22 1639 PUSHs(&PL_sv_yes);
06a5b730 1640 }
811a4de9
GS
1641 /* eval BLOCK (try blocks have old_namesv == 0) */
1642 else {
1643 PUSHs(&PL_sv_undef);
1644 PUSHs(&PL_sv_undef);
1645 }
4633a7c4 1646 }
a682de96
GS
1647 else {
1648 PUSHs(&PL_sv_undef);
1649 PUSHs(&PL_sv_undef);
1650 }
1651 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1652 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1653 {
66a1b24b
AL
1654 AV * const ary = cx->blk_sub.argarray;
1655 const int off = AvARRAY(ary) - AvALLOC(ary);
a0d0e21e 1656
3280af22 1657 if (!PL_dbargs) {
0bd48802
AL
1658 GV* const tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV);
1659 PL_dbargs = GvAV(gv_AVadd(tmpgv));
a5f75d66 1660 GvMULTI_on(tmpgv);
3ddcf04c 1661 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
a0d0e21e
LW
1662 }
1663
3280af22
NIS
1664 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1665 av_extend(PL_dbargs, AvFILLp(ary) + off);
1666 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1667 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1668 }
f3aa04c2
GS
1669 /* XXX only hints propagated via op_private are currently
1670 * visible (others are not easily accessible, since they
1671 * use the global PL_hints) */
1672 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1673 HINT_PRIVATE_MASK)));
e476b1b5
GS
1674 {
1675 SV * mask ;
0bd48802 1676 SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba 1677
ac27b0f5 1678 if (old_warnings == pWARN_NONE ||
114bafba 1679 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1680 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
ac27b0f5 1681 else if (old_warnings == pWARN_ALL ||
75b6c4ca
RGS
1682 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1683 /* Get the bit mask for $warnings::Bits{all}, because
1684 * it could have been extended by warnings::register */
1685 SV **bits_all;
0bd48802 1686 HV * const bits = get_hv("warnings::Bits", FALSE);
75b6c4ca
RGS
1687 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1688 mask = newSVsv(*bits_all);
1689 }
1690 else {
1691 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1692 }
1693 }
e476b1b5
GS
1694 else
1695 mask = newSVsv(old_warnings);
1696 PUSHs(sv_2mortal(mask));
1697 }
a0d0e21e
LW
1698 RETURN;
1699}
1700
a0d0e21e
LW
1701PP(pp_reset)
1702{
39644a26 1703 dSP;
0bd48802 1704 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
11faa288 1705 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1706 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1707 RETURN;
1708}
1709
dd2155a4
DM
1710/* like pp_nextstate, but used instead when the debugger is active */
1711
a0d0e21e
LW
1712PP(pp_dbstate)
1713{
27da23d5 1714 dVAR;
533c011a 1715 PL_curcop = (COP*)PL_op;
a0d0e21e 1716 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1717 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW
1718 FREETMPS;
1719
5df8de69
DM
1720 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1721 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1722 {
39644a26 1723 dSP;
c09156bb 1724 register PERL_CONTEXT *cx;
f54cb97a 1725 const I32 gimme = G_ARRAY;
eb160463 1726 U8 hasargs;
0bd48802
AL
1727 GV * const gv = PL_DBgv;
1728 register CV * const cv = GvCV(gv);
a0d0e21e 1729
a0d0e21e 1730 if (!cv)
cea2e8a9 1731 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1732
aea4f609
DM
1733 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1734 /* don't do recursive DB::DB call */
a0d0e21e 1735 return NORMAL;
748a9306 1736
4633a7c4
LW
1737 ENTER;
1738 SAVETMPS;
1739
3280af22 1740 SAVEI32(PL_debug);
55497cff 1741 SAVESTACK_POS();
3280af22 1742 PL_debug = 0;
748a9306 1743 hasargs = 0;
924508f0 1744 SPAGAIN;
748a9306 1745
c127bd3a
SF
1746 if (CvXSUB(cv)) {
1747 CvDEPTH(cv)++;
1748 PUSHMARK(SP);
1749 (void)(*CvXSUB(cv))(aTHX_ cv);
1750 CvDEPTH(cv)--;
1751 FREETMPS;
1752 LEAVE;
1753 return NORMAL;
1754 }
1755 else {
1756 PUSHBLOCK(cx, CXt_SUB, SP);
1757 PUSHSUB_DB(cx);
1758 cx->blk_sub.retop = PL_op->op_next;
1759 CvDEPTH(cv)++;
1760 SAVECOMPPAD();
1761 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1762 RETURNOP(CvSTART(cv));
1763 }
a0d0e21e
LW
1764 }
1765 else
1766 return NORMAL;
1767}
1768
a0d0e21e
LW
1769PP(pp_enteriter)
1770{
27da23d5 1771 dVAR; dSP; dMARK;
c09156bb 1772 register PERL_CONTEXT *cx;
f54cb97a 1773 const I32 gimme = GIMME_V;
a0d0e21e 1774 SV **svp;
0d863452 1775 U32 cxtype = CXt_LOOP | CXp_FOREACH;
7766f137
GS
1776#ifdef USE_ITHREADS
1777 void *iterdata;
1778#endif
a0d0e21e 1779
4633a7c4
LW
1780 ENTER;
1781 SAVETMPS;
1782
533c011a 1783 if (PL_op->op_targ) {
14f338dc
DM
1784 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1785 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1786 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1787 SVs_PADSTALE, SVs_PADSTALE);
1788 }
c3564e5c 1789#ifndef USE_ITHREADS
dd2155a4 1790 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
54b9620d 1791 SAVESPTR(*svp);
c3564e5c
GS
1792#else
1793 SAVEPADSV(PL_op->op_targ);
cbfa9890 1794 iterdata = INT2PTR(void*, PL_op->op_targ);
7766f137
GS
1795 cxtype |= CXp_PADVAR;
1796#endif
54b9620d
MB
1797 }
1798 else {
0bd48802 1799 GV * const gv = (GV*)POPs;
7766f137 1800 svp = &GvSV(gv); /* symbol table variable */
0214ae40
GS
1801 SAVEGENERICSV(*svp);
1802 *svp = NEWSV(0,0);
7766f137
GS
1803#ifdef USE_ITHREADS
1804 iterdata = (void*)gv;
1805#endif
54b9620d 1806 }
4633a7c4 1807
0d863452
RH
1808 if (PL_op->op_private & OPpITER_DEF)
1809 cxtype |= CXp_FOR_DEF;
1810
a0d0e21e
LW
1811 ENTER;
1812
7766f137
GS
1813 PUSHBLOCK(cx, cxtype, SP);
1814#ifdef USE_ITHREADS
1815 PUSHLOOP(cx, iterdata, MARK);
1816#else
a0d0e21e 1817 PUSHLOOP(cx, svp, MARK);
7766f137 1818#endif
533c011a 1819 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1820 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA
1821 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1822 dPOPss;
0bd48802 1823 SV * const right = (SV*)cx->blk_loop.iterary;
984a4bea
RD
1824 SvGETMAGIC(sv);
1825 SvGETMAGIC(right);
4fe3f0fa
MHM
1826 if (RANGE_IS_NUMERIC(sv,right)) {
1827 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1828 (SvOK(right) && SvNV(right) >= IV_MAX))
076d9a11
MHM
1829 DIE(aTHX_ "Range iterator outside integer range");
1830 cx->blk_loop.iterix = SvIV(sv);
4fe3f0fa 1831 cx->blk_loop.itermax = SvIV(right);
d4665a05
DM
1832#ifdef DEBUGGING
1833 /* for correct -Dstv display */
1834 cx->blk_oldsp = sp - PL_stack_base;
1835#endif
89ea2908 1836 }
3f63a782 1837 else {
89ea2908 1838 cx->blk_loop.iterlval = newSVsv(sv);
13c5b33c 1839 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
10516c54 1840 (void) SvPV_nolen_const(right);
3f63a782 1841 }
89ea2908 1842 }
ef3e5ea9 1843 else if (PL_op->op_private & OPpITER_REVERSED) {
6e585ca0
DM
1844 cx->blk_loop.itermax = 0;
1845 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
ef3e5ea9
NC
1846
1847 }
89ea2908 1848 }
4633a7c4 1849 else {
3280af22
NIS
1850 cx->blk_loop.iterary = PL_curstack;
1851 AvFILLp(PL_curstack) = SP - PL_stack_base;
ef3e5ea9 1852 if (PL_op->op_private & OPpITER_REVERSED) {
6e585ca0
DM
1853 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1854 cx->blk_loop.iterix = cx->blk_oldsp + 1;
ef3e5ea9
NC
1855 }
1856 else {
1857 cx->blk_loop.iterix = MARK - PL_stack_base;
1858 }
4633a7c4 1859 }
a0d0e21e
LW
1860
1861 RETURN;
1862}
1863
1864PP(pp_enterloop)
1865{
27da23d5 1866 dVAR; dSP;
c09156bb 1867 register PERL_CONTEXT *cx;
f54cb97a 1868 const I32 gimme = GIMME_V;
a0d0e21e
LW
1869
1870 ENTER;
1871 SAVETMPS;
1872 ENTER;
1873
1874 PUSHBLOCK(cx, CXt_LOOP, SP);
1875 PUSHLOOP(cx, 0, SP);
1876
1877 RETURN;
1878}
1879
1880PP(pp_leaveloop)
1881{
27da23d5 1882 dVAR; dSP;
c09156bb 1883 register PERL_CONTEXT *cx;
a0d0e21e
LW
1884 I32 gimme;
1885 SV **newsp;
1886 PMOP *newpm;
1887 SV **mark;
1888
1889 POPBLOCK(cx,newpm);
3a1b2b9e 1890 assert(CxTYPE(cx) == CXt_LOOP);
4fdae800 1891 mark = newsp;
a8bba7fa 1892 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1893
a1f49e72 1894 TAINT_NOT;
54310121
PP
1895 if (gimme == G_VOID)
1896 ; /* do nothing */
1897 else if (gimme == G_SCALAR) {
1898 if (mark < SP)
1899 *++newsp = sv_mortalcopy(*SP);
1900 else
3280af22 1901 *++newsp = &PL_sv_undef;
a0d0e21e
LW
1902 }
1903 else {
a1f49e72 1904 while (mark < SP) {
a0d0e21e 1905 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS
1906 TAINT_NOT; /* Each item is independent */
1907 }
a0d0e21e 1908 }
f86702cc
PP
1909 SP = newsp;
1910 PUTBACK;
1911
a8bba7fa 1912 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1913 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1914
a0d0e21e
LW
1915 LEAVE;
1916 LEAVE;
1917
f86702cc 1918 return NORMAL;
a0d0e21e
LW
1919}
1920
1921PP(pp_return)
1922{
27da23d5 1923 dVAR; dSP; dMARK;
c09156bb 1924 register PERL_CONTEXT *cx;
f86702cc 1925 bool popsub2 = FALSE;
b45de488 1926 bool clear_errsv = FALSE;
a0d0e21e
LW
1927 I32 gimme;
1928 SV **newsp;
1929 PMOP *newpm;
1930 I32 optype = 0;
b0d9ce38 1931 SV *sv;
f39bc417 1932 OP *retop;
a0d0e21e 1933
0bd48802
AL
1934 const I32 cxix = dopoptosub(cxstack_ix);
1935
9850bf21
RH
1936 if (cxix < 0) {
1937 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1938 * sort block, which is a CXt_NULL
1939 * not a CXt_SUB */
1940 dounwind(0);
d7507f74
RH
1941 PL_stack_base[1] = *PL_stack_sp;
1942 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW
1943 return 0;
1944 }
9850bf21
RH
1945 else
1946 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e 1947 }
a0d0e21e
LW
1948 if (cxix < cxstack_ix)
1949 dounwind(cxix);
1950
d7507f74
RH
1951 if (CxMULTICALL(&cxstack[cxix])) {
1952 gimme = cxstack[cxix].blk_gimme;
1953 if (gimme == G_VOID)
1954 PL_stack_sp = PL_stack_base;
1955 else if (gimme == G_SCALAR) {
1956 PL_stack_base[1] = *PL_stack_sp;
1957 PL_stack_sp = PL_stack_base + 1;
1958 }
9850bf21 1959 return 0;
d7507f74 1960 }
9850bf21 1961
a0d0e21e 1962 POPBLOCK(cx,newpm);
6b35e009 1963 switch (CxTYPE(cx)) {
a0d0e21e 1964 case CXt_SUB:
f86702cc 1965 popsub2 = TRUE;
f39bc417 1966 retop = cx->blk_sub.retop;
5dd42e15 1967 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW
1968 break;
1969 case CXt_EVAL:
b45de488
GS
1970 if (!(PL_in_eval & EVAL_KEEPERR))
1971 clear_errsv = TRUE;
a0d0e21e 1972 POPEVAL(cx);
f39bc417 1973 retop = cx->blk_eval.retop;
1d76a5c3
GS
1974 if (CxTRYBLOCK(cx))
1975 break;
067f92a0 1976 lex_end();
748a9306
LW
1977 if (optype == OP_REQUIRE &&
1978 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1979 {
54310121 1980 /* Unassume the success we assumed earlier. */
901017d6 1981 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 1982 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 1983 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
748a9306 1984 }
a0d0e21e 1985 break;
7766f137
GS
1986 case CXt_FORMAT:
1987 POPFORMAT(cx);
f39bc417 1988 retop = cx->blk_sub.retop;
7766f137 1989 break;
a0d0e21e 1990 default:
cea2e8a9 1991 DIE(aTHX_ "panic: return");
a0d0e21e
LW
1992 }
1993
a1f49e72 1994 TAINT_NOT;
a0d0e21e 1995 if (gimme == G_SCALAR) {
a29cdaf0
IZ
1996 if (MARK < SP) {
1997 if (popsub2) {
a8bba7fa 1998 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
1999 if (SvTEMP(TOPs)) {
2000 *++newsp = SvREFCNT_inc(*SP);
2001 FREETMPS;
2002 sv_2mortal(*newsp);
959e3673
GS
2003 }
2004 else {
2005 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 2006 FREETMPS;
959e3673
GS
2007 *++newsp = sv_mortalcopy(sv);
2008 SvREFCNT_dec(sv);
a29cdaf0 2009 }
959e3673
GS
2010 }
2011 else
a29cdaf0 2012 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS
2013 }
2014 else
a29cdaf0 2015 *++newsp = sv_mortalcopy(*SP);
959e3673
GS
2016 }
2017 else
3280af22 2018 *++newsp = &PL_sv_undef;
a0d0e21e 2019 }
54310121 2020 else if (gimme == G_ARRAY) {
a1f49e72 2021 while (++MARK <= SP) {
f86702cc
PP
2022 *++newsp = (popsub2 && SvTEMP(*MARK))
2023 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
2024 TAINT_NOT; /* Each item is independent */
2025 }
a0d0e21e 2026 }
3280af22 2027 PL_stack_sp = newsp;
a0d0e21e 2028
5dd42e15 2029 LEAVE;
f86702cc
PP
2030 /* Stack values are safe: */
2031 if (popsub2) {
5dd42e15 2032 cxstack_ix--;
b0d9ce38 2033 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2034 }
b0d9ce38 2035 else
c445ea15 2036 sv = NULL;
3280af22 2037 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2038
b0d9ce38 2039 LEAVESUB(sv);
b45de488 2040 if (clear_errsv)
c69006e4 2041 sv_setpvn(ERRSV,"",0);
f39bc417 2042 return retop;
a0d0e21e
LW
2043}
2044
2045PP(pp_last)
2046{
27da23d5 2047 dVAR; dSP;
a0d0e21e 2048 I32 cxix;
c09156bb 2049 register PERL_CONTEXT *cx;
f86702cc 2050 I32 pop2 = 0;
a0d0e21e 2051 I32 gimme;
8772537c 2052 I32 optype;
a0d0e21e
LW
2053 OP *nextop;
2054 SV **newsp;
2055 PMOP *newpm;
a8bba7fa 2056 SV **mark;
c445ea15 2057 SV *sv = NULL;
9d4ba2ae 2058
a0d0e21e 2059
533c011a 2060 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2061 cxix = dopoptoloop(cxstack_ix);
2062 if (cxix < 0)
a651a37d 2063 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW
2064 }
2065 else {
2066 cxix = dopoptolabel(cPVOP->op_pv);
2067 if (cxix < 0)
cea2e8a9 2068 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW
2069 }
2070 if (cxix < cxstack_ix)
2071 dounwind(cxix);
2072
2073 POPBLOCK(cx,newpm);
5dd42e15 2074 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2075 mark = newsp;
6b35e009 2076 switch (CxTYPE(cx)) {
a0d0e21e 2077 case CXt_LOOP:
f86702cc 2078 pop2 = CXt_LOOP;
a8bba7fa
GS
2079 newsp = PL_stack_base + cx->blk_loop.resetsp;
2080 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 2081 break;
f86702cc 2082 case CXt_SUB:
f86702cc 2083 pop2 = CXt_SUB;
f39bc417 2084 nextop = cx->blk_sub.retop;
a0d0e21e 2085 break;
f86702cc
PP
2086 case CXt_EVAL:
2087 POPEVAL(cx);
f39bc417 2088 nextop = cx->blk_eval.retop;
a0d0e21e 2089 break;
7766f137
GS
2090 case CXt_FORMAT:
2091 POPFORMAT(cx);
f39bc417 2092 nextop = cx->blk_sub.retop;
7766f137 2093 break;
a0d0e21e 2094 default:
cea2e8a9 2095 DIE(aTHX_ "panic: last");
a0d0e21e
LW
2096 }
2097
a1f49e72 2098 TAINT_NOT;
a0d0e21e 2099 if (gimme == G_SCALAR) {
f86702cc
PP
2100 if (MARK < SP)
2101 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2102 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2103 else
3280af22 2104 *++newsp = &PL_sv_undef;
a0d0e21e 2105 }
54310121 2106 else if (gimme == G_ARRAY) {
a1f49e72 2107 while (++MARK <= SP) {
f86702cc
PP
2108 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2109 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
2110 TAINT_NOT; /* Each item is independent */
2111 }
f86702cc
PP
2112 }
2113 SP = newsp;
2114 PUTBACK;
2115
5dd42e15
DM
2116 LEAVE;
2117 cxstack_ix--;
f86702cc
PP
2118 /* Stack values are safe: */
2119 switch (pop2) {
2120 case CXt_LOOP:
a8bba7fa 2121 POPLOOP(cx); /* release loop vars ... */
4fdae800 2122 LEAVE;
f86702cc
PP
2123 break;
2124 case CXt_SUB:
b0d9ce38 2125 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2126 break;
a0d0e21e 2127 }
3280af22 2128 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2129
b0d9ce38 2130 LEAVESUB(sv);
9d4ba2ae
AL
2131 PERL_UNUSED_VAR(optype);
2132 PERL_UNUSED_VAR(gimme);
f86702cc 2133 return nextop;
a0d0e21e
LW
2134}
2135
2136PP(pp_next)
2137{
27da23d5 2138 dVAR;
a0d0e21e 2139 I32 cxix;
c09156bb 2140 register PERL_CONTEXT *cx;
85538317 2141 I32 inner;
a0d0e21e 2142
533c011a 2143 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2144 cxix = dopoptoloop(cxstack_ix);
2145 if (cxix < 0)
a651a37d 2146 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW
2147 }
2148 else {
2149 cxix = dopoptolabel(cPVOP->op_pv);
2150 if (cxix < 0)
cea2e8a9 2151 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW
2152 }
2153 if (cxix < cxstack_ix)
2154 dounwind(cxix);
2155
85538317
GS
2156 /* clear off anything above the scope we're re-entering, but
2157 * save the rest until after a possible continue block */
2158 inner = PL_scopestack_ix;
1ba6ee2b 2159 TOPBLOCK(cx);
85538317
GS
2160 if (PL_scopestack_ix < inner)
2161 leave_scope(PL_scopestack[PL_scopestack_ix]);
3a1b2b9e 2162 PL_curcop = cx->blk_oldcop;
1ba6ee2b 2163 return cx->blk_loop.next_op;
a0d0e21e
LW
2164}
2165
2166PP(pp_redo)
2167{
27da23d5 2168 dVAR;
a0d0e21e 2169 I32 cxix;
c09156bb 2170 register PERL_CONTEXT *cx;
a0d0e21e 2171 I32 oldsave;
a034e688 2172 OP* redo_op;
a0d0e21e 2173
533c011a 2174 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2175 cxix = dopoptoloop(cxstack_ix);
2176 if (cxix < 0)
a651a37d 2177 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW
2178 }
2179 else {
2180 cxix = dopoptolabel(cPVOP->op_pv);
2181 if (cxix < 0)
cea2e8a9 2182 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW
2183 }
2184 if (cxix < cxstack_ix)
2185 dounwind(cxix);
2186
a034e688
DM
2187 redo_op = cxstack[cxix].blk_loop.redo_op;
2188 if (redo_op->op_type == OP_ENTER) {
2189 /* pop one less context to avoid $x being freed in while (my $x..) */
2190 cxstack_ix++;
2191 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2192 redo_op = redo_op->op_next;
2193 }
2194
a0d0e21e 2195 TOPBLOCK(cx);
3280af22 2196 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2197 LEAVE_SCOPE(oldsave);
936c78b5 2198 FREETMPS;
3a1b2b9e 2199 PL_curcop = cx->blk_oldcop;
a034e688 2200 return redo_op;
a0d0e21e
LW
2201}
2202
0824fdcb 2203STATIC OP *
bfed75c6 2204S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2205{
a0d0e21e 2206 OP **ops = opstack;
bfed75c6 2207 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2208
fc36a67e 2209 if (ops >= oplimit)
cea2e8a9 2210 Perl_croak(aTHX_ too_deep);
11343788
MB
2211 if (o->op_type == OP_LEAVE ||
2212 o->op_type == OP_SCOPE ||
2213 o->op_type == OP_LEAVELOOP ||
33d34e4c 2214 o->op_type == OP_LEAVESUB ||
11343788 2215 o->op_type == OP_LEAVETRY)
fc36a67e 2216 {
5dc0d613 2217 *ops++ = cUNOPo->op_first;
fc36a67e 2218 if (ops >= oplimit)
cea2e8a9 2219 Perl_croak(aTHX_ too_deep);
fc36a67e 2220 }
c4aa4e48 2221 *ops = 0;
11343788 2222 if (o->op_flags & OPf_KIDS) {
aec46f14 2223 OP *kid;
a0d0e21e 2224 /* First try all the kids at this level, since that's likeliest. */
11343788 2225 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS
2226 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2227 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW
2228 return kid;
2229 }
11343788 2230 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2231 if (kid == PL_lastgotoprobe)
a0d0e21e 2232 continue;
ed8d0fe2
SM
2233 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2234 if (ops == opstack)
2235 *ops++ = kid;
2236 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2237 ops[-1]->op_type == OP_DBSTATE)
2238 ops[-1] = kid;
2239 else
2240 *ops++ = kid;
2241 }
155aba94 2242 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2243 return o;
a0d0e21e
LW
2244 }
2245 }
c4aa4e48 2246 *ops = 0;
a0d0e21e
LW
2247 return 0;
2248}
2249
a0d0e21e
LW
2250PP(pp_goto)
2251{
27da23d5 2252 dVAR; dSP;
cbbf8932 2253 OP *retop = NULL;
a0d0e21e 2254 I32 ix;
c09156bb 2255 register PERL_CONTEXT *cx;
fc36a67e
PP
2256#define GOTO_DEPTH 64
2257 OP *enterops[GOTO_DEPTH];
cbbf8932 2258 const char *label = NULL;
bfed75c6
AL
2259 const bool do_dump = (PL_op->op_type == OP_DUMP);
2260 static const char must_have_label[] = "goto must have label";
a0d0e21e 2261
533c011a 2262 if (PL_op->op_flags & OPf_STACKED) {
9d4ba2ae 2263 SV * const sv = POPs;
a0d0e21e
LW
2264
2265 /* This egregious kludge implements goto &subroutine */
2266 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2267 I32 cxix;
c09156bb 2268 register PERL_CONTEXT *cx;
a0d0e21e
LW
2269 CV* cv = (CV*)SvRV(sv);
2270 SV** mark;
2271 I32 items = 0;
2272 I32 oldsave;
b1464ded 2273 bool reified = 0;
a0d0e21e 2274
e8f7dd13 2275 retry:
4aa0a1f7 2276 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2277 const GV * const gv = CvGV(cv);
e8f7dd13 2278 if (gv) {
7fc63493 2279 GV *autogv;
e8f7dd13
GS
2280 SV *tmpstr;
2281 /* autoloaded stub? */
2282 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2283 goto retry;
2284 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2285 GvNAMELEN(gv), FALSE);
2286 if (autogv && (cv = GvCV(autogv)))
2287 goto retry;
2288 tmpstr = sv_newmortal();
c445ea15 2289 gv_efullname3(tmpstr, gv, NULL);
35c1215d 2290 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
4aa0a1f7 2291 }
cea2e8a9 2292 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD
2293 }
2294
a0d0e21e 2295 /* First do some returnish stuff. */
7fc63493 2296 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
71fc2216 2297 FREETMPS;
a0d0e21e
LW
2298 cxix = dopoptosub(cxstack_ix);
2299 if (cxix < 0)
cea2e8a9 2300 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW
2301 if (cxix < cxstack_ix)
2302 dounwind(cxix);
2303 TOPBLOCK(cx);
2d43a17f 2304 SPAGAIN;
564abe23 2305 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2d43a17f 2306 if (CxTYPE(cx) == CXt_EVAL) {
c74ace89
DM
2307 if (CxREALEVAL(cx))
2308 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2309 else
2310 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2d43a17f 2311 }
9850bf21
RH
2312 else if (CxMULTICALL(cx))
2313 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
d8b46c1b
GS
2314 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2315 /* put @_ back onto stack */
a0d0e21e 2316 AV* av = cx->blk_sub.argarray;
bfed75c6 2317
93965878 2318 items = AvFILLp(av) + 1;
a45cdc79
DM
2319 EXTEND(SP, items+1); /* @_ could have been extended. */
2320 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS
2321 SvREFCNT_dec(GvAV(PL_defgv));
2322 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2323 CLEAR_ARGARRAY(av);
d8b46c1b 2324 /* abandon @_ if it got reified */
62b1ebc2 2325 if (AvREAL(av)) {
b1464ded
DM
2326 reified = 1;
2327 SvREFCNT_dec(av);
d8b46c1b
GS
2328 av = newAV();
2329 av_extend(av, items-1);
11ca45c0 2330 AvREIFY_only(av);
dd2155a4 2331 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2332 }
a0d0e21e 2333 }
1fa4e549 2334 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
890ce7af 2335 AV* const av = GvAV(PL_defgv);
1fa4e549 2336 items = AvFILLp(av) + 1;
a45cdc79
DM
2337 EXTEND(SP, items+1); /* @_ could have been extended. */
2338 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2339 }
a45cdc79
DM
2340 mark = SP;
2341 SP += items;
6b35e009 2342 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2343 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2344 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2345 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
2346 LEAVE_SCOPE(oldsave);
2347
2348 /* Now do some callish stuff. */
2349 SAVETMPS;
5023d17a 2350 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
a0d0e21e 2351 if (CvXSUB(cv)) {
5eff7df7 2352 OP* retop = cx->blk_sub.retop;
b1464ded
DM
2353 if (reified) {
2354 I32 index;
2355 for (index=0; index<items; index++)
2356 sv_2mortal(SP[-index]);
2357 }
67caa1fe 2358#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2359 if (CvOLDSTYLE(cv)) {
20ce7b12 2360 I32 (*fp3)(int,int,int);
924508f0
GS
2361 while (SP > mark) {
2362 SP[1] = SP[0];
2363 SP--;
a0d0e21e 2364 }
7766f137 2365 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2366 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2367 mark - PL_stack_base + 1,
ecfc5424 2368 items);
3280af22 2369 SP = PL_stack_base + items;
a0d0e21e 2370 }
67caa1fe
GS
2371 else
2372#endif /* PERL_XSUB_OLDSTYLE */
2373 {
1fa4e549
AD
2374 SV **newsp;
2375 I32 gimme;
2376
5eff7df7
DM
2377 /* XS subs don't have a CxSUB, so pop it */
2378 POPBLOCK(cx, PL_curpm);
1fa4e549 2379 /* Push a mark for the start of arglist */
ac27b0f5 2380 PUSHMARK(mark);
a45cdc79 2381 PUTBACK;
acfe0abc 2382 (void)(*CvXSUB(cv))(aTHX_ cv);
1b6737cc
AL
2383 /* Put these at the bottom since the vars are set but not used */
2384 PERL_UNUSED_VAR(newsp);
2385 PERL_UNUSED_VAR(gimme);
a0d0e21e
LW
2386 }
2387 LEAVE;
5eff7df7 2388 return retop;
a0d0e21e
LW
2389 }
2390 else {
2391 AV* padlist = CvPADLIST(cv);
6b35e009 2392 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS
2393 PL_in_eval = cx->blk_eval.old_in_eval;
2394 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH
2395 cx->cx_type = CXt_SUB;
2396 cx->blk_sub.hasargs = 0;
2397 }
a0d0e21e 2398 cx->blk_sub.cv = cv;
eb160463 2399 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
dd2155a4 2400
a0d0e21e
LW
2401 CvDEPTH(cv)++;
2402 if (CvDEPTH(cv) < 2)
2403 (void)SvREFCNT_inc(cv);
dd2155a4 2404 else {
599cee73 2405 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2406 sub_crush_depth(cv);
26019298 2407 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2408 }
fd617465
DM
2409 SAVECOMPPAD();
2410 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
6d4ff0d2 2411 if (cx->blk_sub.hasargs)
6d4ff0d2 2412 {
dd2155a4 2413 AV* av = (AV*)PAD_SVl(0);
a0d0e21e
LW
2414 SV** ary;
2415
3280af22
NIS
2416 cx->blk_sub.savearray = GvAV(PL_defgv);
2417 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2418 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2419 cx->blk_sub.argarray = av;
a0d0e21e
LW
2420
2421 if (items >= AvMAX(av) + 1) {
2422 ary = AvALLOC(av);
2423 if (AvARRAY(av) != ary) {
2424 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
f880fe2f 2425 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2426 }
2427 if (items >= AvMAX(av) + 1) {
2428 AvMAX(av) = items - 1;
2429 Renew(ary,items+1,SV*);
2430 AvALLOC(av) = ary;
f880fe2f 2431 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2432 }
2433 }
a45cdc79 2434 ++mark;
a0d0e21e 2435 Copy(mark,AvARRAY(av),items,SV*);
93965878 2436 AvFILLp(av) = items - 1;
d8b46c1b 2437 assert(!AvREAL(av));
b1464ded
DM
2438 if (reified) {
2439 /* transfer 'ownership' of refcnts to new @_ */
2440 AvREAL_on(av);
2441 AvREIFY_off(av);
2442 }
a0d0e21e
LW
2443 while (items--) {
2444 if (*mark)
2445 SvTEMP_off(*mark);
2446 mark++;
2447 }
2448 }
491527d0 2449 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a
PP
2450 /*
2451 * We do not care about using sv to call CV;
2452 * it's for informational purposes only.
2453 */
890ce7af 2454 SV * const sv = GvSV(PL_DBsub);
491527d0 2455 CV *gotocv;
bfed75c6 2456
f398eb67 2457 save_item(sv);
491527d0 2458 if (PERLDB_SUB_NN) {
890ce7af 2459 const int type = SvTYPE(sv);
f398eb67
NC
2460 if (type < SVt_PVIV && type != SVt_IV)
2461 sv_upgrade(sv, SVt_PVIV);
7619c85e 2462 (void)SvIOK_on(sv);
45977657 2463 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
491527d0 2464 } else {
c445ea15 2465 gv_efullname3(sv, CvGV(cv), NULL);
491527d0
GS
2466 }
2467 if ( PERLDB_GOTO
864dbfa3 2468 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2469 PUSHMARK( PL_stack_sp );
864dbfa3 2470 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2471 PL_stack_sp--;
491527d0 2472 }
1ce6579f 2473 }
a0d0e21e
LW
2474 RETURNOP(CvSTART(cv));
2475 }
2476 }
1614b0e3 2477 else {
0510663f 2478 label = SvPV_nolen_const(sv);
1614b0e3 2479 if (!(do_dump || *label))
cea2e8a9 2480 DIE(aTHX_ must_have_label);
1614b0e3 2481 }
a0d0e21e 2482 }
533c011a 2483 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2484 if (! do_dump)
cea2e8a9 2485 DIE(aTHX_ must_have_label);
a0d0e21e
LW
2486 }
2487 else
2488 label = cPVOP->op_pv;
2489
2490 if (label && *label) {
cbbf8932 2491 OP *gotoprobe = NULL;
3b2447bc 2492 bool leaving_eval = FALSE;
33d34e4c 2493 bool in_block = FALSE;
cbbf8932 2494 PERL_CONTEXT *last_eval_cx = NULL;
a0d0e21e
LW
2495
2496 /* find label */
2497
3280af22 2498 PL_lastgotoprobe = 0;
a0d0e21e
LW
2499 *enterops = 0;
2500 for (ix = cxstack_ix; ix >= 0; ix--) {
2501 cx = &cxstack[ix];
6b35e009 2502 switch (CxTYPE(cx)) {
a0d0e21e 2503 case CXt_EVAL:
3b2447bc 2504 leaving_eval = TRUE;
971ecbe6 2505 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH
2506 gotoprobe = (last_eval_cx ?
2507 last_eval_cx->blk_eval.old_eval_root :
2508 PL_eval_root);
2509 last_eval_cx = cx;
9c5794fe
RH
2510 break;
2511 }
2512 /* else fall through */
a0d0e21e
LW
2513 case CXt_LOOP:
2514 gotoprobe = cx->blk_oldcop->op_sibling;
2515 break;
2516 case CXt_SUBST:
2517 continue;
2518 case CXt_BLOCK:
33d34e4c 2519 if (ix) {
a0d0e21e 2520 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE
2521 in_block = TRUE;
2522 } else
3280af22 2523 gotoprobe = PL_main_root;
a0d0e21e 2524 break;
b3933176 2525 case CXt_SUB:
9850bf21 2526 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
b3933176
CS
2527 gotoprobe = CvROOT(cx->blk_sub.cv);
2528 break;
2529 }
2530 /* FALL THROUGH */
7766f137 2531 case CXt_FORMAT:
0a753a76 2532 case CXt_NULL:
a651a37d 2533 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW
2534 default:
2535 if (ix)
cea2e8a9 2536 DIE(aTHX_ "panic: goto");
3280af22 2537 gotoprobe = PL_main_root;
a0d0e21e
LW
2538 break;
2539 }
2b597662
GS
2540 if (gotoprobe) {
2541 retop = dofindlabel(gotoprobe, label,
2542 enterops, enterops + GOTO_DEPTH);
2543 if (retop)
2544 break;
2545 }
3280af22 2546 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW
2547 }
2548 if (!retop)
cea2e8a9 2549 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2550
3b2447bc
RH
2551 /* if we're leaving an eval, check before we pop any frames
2552 that we're not going to punt, otherwise the error
2553 won't be caught */
2554
2555 if (leaving_eval && *enterops && enterops[1]) {
2556 I32 i;
2557 for (i = 1; enterops[i]; i++)
2558 if (enterops[i]->op_type == OP_ENTERITER)
2559 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2560 }
2561
a0d0e21e
LW
2562 /* pop unwanted frames */
2563
2564 if (ix < cxstack_ix) {
2565 I32 oldsave;
2566
2567 if (ix < 0)
2568 ix = 0;
2569 dounwind(ix);
2570 TOPBLOCK(cx);
3280af22 2571 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW
2572 LEAVE_SCOPE(oldsave);
2573 }
2574
2575 /* push wanted frames */
2576
748a9306 2577 if (*enterops && enterops[1]) {
0bd48802 2578 OP * const oldop = PL_op;
33d34e4c
AE
2579 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2580 for (; enterops[ix]; ix++) {
533c011a 2581 PL_op = enterops[ix];
84902520
TB
2582 /* Eventually we may want to stack the needed arguments
2583 * for each op. For now, we punt on the hard ones. */
533c011a 2584 if (PL_op->op_type == OP_ENTERITER)
894356b3 2585 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2586 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2587 }
533c011a 2588 PL_op = oldop;
a0d0e21e
LW
2589 }
2590 }
2591
2592 if (do_dump) {
a5f75d66 2593#ifdef VMS
6b88bc9c 2594 if (!retop) retop = PL_main_start;
a5f75d66 2595#endif
3280af22
NIS
2596 PL_restartop = retop;
2597 PL_do_undump = TRUE;
a0d0e21e
LW
2598
2599 my_unexec();
2600
3280af22
NIS
2601 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2602 PL_do_undump = FALSE;
a0d0e21e
LW
2603 }
2604
2605 RETURNOP(retop);
2606}
2607
2608PP(pp_exit)
2609{
39644a26 2610 dSP;
a0d0e21e
LW
2611 I32 anum;
2612
2613 if (MAXARG < 1)
2614 anum = 0;
ff0cee69 2615 else {
a0d0e21e 2616 anum = SvIVx(POPs);
d98f61e7
GS
2617#ifdef VMS
2618 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2619 anum = 0;
96e176bf 2620 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69
PP
2621#endif
2622 }
cc3604b1 2623 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2624 my_exit(anum);
3280af22 2625 PUSHs(&PL_sv_undef);
a0d0e21e
LW
2626 RETURN;
2627}
2628
a0d0e21e
LW
2629/* Eval. */
2630
0824fdcb 2631STATIC void
cea2e8a9 2632S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2633{
504618e9 2634 const char *s = SvPVX_const(sv);
890ce7af 2635 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 2636 I32 line = 1;
a0d0e21e
LW
2637
2638 while (s && s < send) {
f54cb97a 2639 const char *t;
890ce7af 2640 SV * const tmpstr = NEWSV(85,0);
a0d0e21e
LW
2641
2642 sv_upgrade(tmpstr, SVt_PVMG);
2643 t = strchr(s, '\n');
2644 if (t)
2645 t++;
2646 else
2647 t = send;
2648
2649 sv_setpvn(tmpstr, s, t - s);
2650 av_store(array, line++, tmpstr);
2651 s = t;
2652 }
2653}
2654
901017d6 2655STATIC void
14dd3ad8
GS
2656S_docatch_body(pTHX)
2657{
cea2e8a9 2658 CALLRUNOPS(aTHX);
901017d6 2659 return;
312caa8e
CS
2660}
2661
0824fdcb 2662STATIC OP *
cea2e8a9 2663S_docatch(pTHX_ OP *o)
1e422769 2664{
6224f72b 2665 int ret;
06b5626a 2666 OP * const oldop = PL_op;
db36c5a1 2667 dJMPENV;
1e422769 2668
1e422769 2669#ifdef DEBUGGING
54310121 2670 assert(CATCH_GET == TRUE);
1e422769 2671#endif
312caa8e 2672 PL_op = o;
8bffa5f8 2673
14dd3ad8 2674 JMPENV_PUSH(ret);
6224f72b 2675 switch (ret) {
312caa8e 2676 case 0:
abd70938
DM
2677 assert(cxstack_ix >= 0);
2678 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2679 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8
GS
2680 redo_body:
2681 docatch_body();
312caa8e
CS
2682 break;
2683 case 3:
8bffa5f8 2684 /* die caught by an inner eval - continue inner loop */
abd70938
DM
2685
2686 /* NB XXX we rely on the old popped CxEVAL still being at the top
2687 * of the stack; the way die_where() currently works, this
2688 * assumption is valid. In theory The cur_top_env value should be
2689 * returned in another global, the way retop (aka PL_restartop)
2690 * is. */
2691 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2692
2693 if (PL_restartop
2694 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2695 {
312caa8e
CS
2696 PL_op = PL_restartop;
2697 PL_restartop = 0;
2698 goto redo_body;
2699 }
2700 /* FALL THROUGH */
2701 default:
14dd3ad8 2702 JMPENV_POP;
533c011a 2703 PL_op = oldop;
6224f72b 2704 JMPENV_JUMP(ret);
1e422769 2705 /* NOTREACHED */
1e422769 2706 }
14dd3ad8 2707 JMPENV_POP;
533c011a 2708 PL_op = oldop;
745cf2ff 2709 return Nullop;
1e422769
PP
2710}
2711
c277df42 2712OP *
bfed75c6 2713Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ
2714/* sv Text to convert to OP tree. */
2715/* startop op_free() this to undo. */
2716/* code Short string id of the caller. */
2717{
f7997f86 2718 /* FIXME - how much of this code is common with pp_entereval? */
27da23d5 2719 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ
2720 PERL_CONTEXT *cx;
2721 SV **newsp;
b094c71d 2722 I32 gimme = G_VOID;
c277df42
IZ
2723 I32 optype;
2724 OP dummy;
155aba94 2725 OP *rop;
83ee9e09
GS
2726 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2727 char *tmpbuf = tbuf;
c277df42 2728 char *safestr;
a3985cdc 2729 int runtime;
40b8d195 2730 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
f7997f86 2731 STRLEN len;
c277df42
IZ
2732
2733 ENTER;
2734 lex_start(sv);
2735 SAVETMPS;
2736 /* switch to eval mode */
2737
923e4eb5 2738 if (IN_PERL_COMPILETIME) {
f4dd75d9 2739 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2740 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2741 }
83ee9e09 2742 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
9d4ba2ae 2743 SV * const sv = sv_newmortal();
83ee9e09
GS
2744 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2745 code, (unsigned long)++PL_evalseq,
2746 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2747 tmpbuf = SvPVX(sv);
fc009855 2748 len = SvCUR(sv);
83ee9e09
GS
2749 }
2750 else
fc009855
NC
2751 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2752 (unsigned long)++PL_evalseq);
f4dd75d9 2753 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2754 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2755 SAVECOPLINE(&PL_compiling);
57843af0 2756 CopLINE_set(&PL_compiling, 1);
c277df42
IZ
2757 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2758 deleting the eval's FILEGV from the stash before gv_check() runs
2759 (i.e. before run-time proper). To work around the coredump that
2760 ensues, we always turn GvMULTI_on for any globals that were
2761 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC
2762 safestr = savepvn(tmpbuf, len);
2763 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 2764 SAVEHINTS();
d1ca3daa 2765#ifdef OP_IN_REGISTER
6b88bc9c 2766 PL_opsave = op;
d1ca3daa 2767#else
7766f137 2768 SAVEVPTR(PL_op);
d1ca3daa 2769#endif
c277df42 2770
a3985cdc 2771 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2772 runtime = IN_PERL_RUNTIME;
a3985cdc 2773 if (runtime)
d819b83a 2774 runcv = find_runcv(NULL);
a3985cdc 2775
533c011a 2776 PL_op = &dummy;
13b51b79 2777 PL_op->op_type = OP_ENTEREVAL;
533c011a 2778 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2779 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
cc49e20b 2780 PUSHEVAL(cx, 0, Nullgv);
a3985cdc
DM
2781
2782 if (runtime)
2783 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2784 else
2785 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2786 POPBLOCK(cx,PL_curpm);
e84b9f1f 2787 POPEVAL(cx);
c277df42
IZ
2788
2789 (*startop)->op_type = OP_NULL;
22c35a8c 2790 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2791 lex_end();
f3548bdc
DM
2792 /* XXX DAPM do this properly one year */
2793 *padp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2794 LEAVE;
923e4eb5 2795 if (IN_PERL_COMPILETIME)
eb160463 2796 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
d1ca3daa 2797#ifdef OP_IN_REGISTER
6b88bc9c 2798 op = PL_opsave;
d1ca3daa 2799#endif
9d4ba2ae
AL
2800 PERL_UNUSED_VAR(newsp);
2801 PERL_UNUSED_VAR(optype);
2802
c277df42
IZ
2803 return rop;
2804}
2805
a3985cdc
DM
2806
2807/*
2808=for apidoc find_runcv
2809
2810Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM
2811If db_seqp is non_null, skip CVs that are in the DB package and populate
2812*db_seqp with the cop sequence number at the point that the DB:: code was
2813entered. (allows debuggers to eval in the scope of the breakpoint rather
cf525c36 2814than in the scope of the debugger itself).
a3985cdc
DM
2815
2816=cut
2817*/
2818
2819CV*
d819b83a 2820Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 2821{
a3985cdc 2822 PERL_SI *si;
a3985cdc 2823
d819b83a
DM
2824 if (db_seqp)
2825 *db_seqp = PL_curcop->cop_seq;
a3985cdc 2826 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 2827 I32 ix;
a3985cdc 2828 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 2829 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a 2830 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1b6737cc 2831 CV * const cv = cx->blk_sub.cv;
d819b83a
DM
2832 /* skip DB:: code */
2833 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2834 *db_seqp = cx->blk_oldcop->cop_seq;
2835 continue;
2836 }
2837 return cv;
2838 }
a3985cdc
DM
2839 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2840 return PL_compcv;
2841 }
2842 }
2843 return PL_main_cv;
2844}
2845
2846
2847/* Compile a require/do, an eval '', or a /(?{...})/.
2848 * In the last case, startop is non-null, and contains the address of
2849 * a pointer that should be set to the just-compiled code.
2850 * outside is the lexically enclosing CV (if any) that invoked us.
2851 */
2852
4d1ff10f 2853/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2854STATIC OP *
a3985cdc 2855S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 2856{
27da23d5 2857 dVAR; dSP;
46c461b5 2858 OP * const saveop = PL_op;
a0d0e21e 2859
6dc8a9e4
IZ
2860 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2861 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2862 : EVAL_INEVAL);
a0d0e21e 2863
1ce6579f
PP
2864 PUSHMARK(SP);
2865
3280af22
NIS
2866 SAVESPTR(PL_compcv);
2867 PL_compcv = (CV*)NEWSV(1104,0);
2868 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2869 CvEVAL_on(PL_compcv);
2090ab20
JH
2870 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2871 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2872
a3985cdc 2873 CvOUTSIDE_SEQ(PL_compcv) = seq;
7dafbf52 2874 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
a3985cdc 2875
dd2155a4 2876 /* set up a scratch pad */
a0d0e21e 2877
dd2155a4 2878 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2c05e328 2879
07055b4c 2880
26d9b02f 2881 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2882
a0d0e21e
LW
2883 /* make sure we compile in the right package */
2884
ed094faf 2885 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2886 SAVESPTR(PL_curstash);
ed094faf 2887 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2888 }
3280af22
NIS
2889 SAVESPTR(PL_beginav);
2890 PL_beginav = newAV();
2891 SAVEFREESV(PL_beginav);
24944567 2892 SAVEI32(PL_error_count);
a0d0e21e
LW
2893
2894 /* try to compile it */
2895
3280af22
NIS
2896 PL_eval_root = Nullop;
2897 PL_error_count = 0;
2898 PL_curcop = &PL_compiling;
2899 PL_curcop->cop_arybase = 0;
c277df42 2900 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2901 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2902 else
c69006e4 2903 sv_setpvn(ERRSV,"",0);
3280af22 2904 if (yyparse() || PL_error_count || !PL_eval_root) {
0c58d367 2905 SV **newsp; /* Used by POPBLOCK. */
9d4ba2ae 2906 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2907 I32 optype = 0; /* Might be reset by POPEVAL. */
9d4ba2ae 2908 const char *msg;
bfed75c6 2909
533c011a 2910 PL_op = saveop;
3280af22
NIS
2911 if (PL_eval_root) {
2912 op_free(PL_eval_root);
2913 PL_eval_root = Nullop;
a0d0e21e 2914 }
3280af22 2915 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2916 if (!startop) {
3280af22 2917 POPBLOCK(cx,PL_curpm);
c277df42 2918 POPEVAL(cx);
c277df42 2919 }
a0d0e21e
LW
2920 lex_end();
2921 LEAVE;
9d4ba2ae
AL
2922
2923 msg = SvPVx_nolen_const(ERRSV);
7a2e2cd6 2924 if (optype == OP_REQUIRE) {
b464bac0 2925 const SV * const nsv = cx->blk_eval.old_namesv;
504618e9 2926 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 2927 &PL_sv_undef, 0);
5a844595
GS
2928 DIE(aTHX_ "%sCompilation failed in require",
2929 *msg ? msg : "Unknown error\n");
2930 }
2931 else if (startop) {
3280af22 2932 POPBLOCK(cx,PL_curpm);
c277df42 2933 POPEVAL(cx);
5a844595
GS
2934 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2935 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2936 }
9d7f88dd 2937 else {
9d7f88dd
SR
2938 if (!*msg) {
2939 sv_setpv(ERRSV, "Compilation error");
2940 }
2941 }
9d4ba2ae 2942 PERL_UNUSED_VAR(newsp);
a0d0e21e
LW
2943 RETPUSHUNDEF;
2944 }
57843af0 2945 CopLINE_set(&PL_compiling, 0);
c277df42 2946 if (startop) {
3280af22 2947 *startop = PL_eval_root;
c277df42 2948 } else
3280af22 2949 SAVEFREEOP(PL_eval_root);
0c58d367
RGS
2950
2951 /* Set the context for this new optree.
2952 * If the last op is an OP_REQUIRE, force scalar context.
2953 * Otherwise, propagate the context from the eval(). */
2954 if (PL_eval_root->op_type == OP_LEAVEEVAL
2955 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2956 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2957 == OP_REQUIRE)
2958 scalar(PL_eval_root);
2959 else if (gimme & G_VOID)
3280af22 2960 scalarvoid(PL_eval_root);
54310121 2961 else if (gimme & G_ARRAY)
3280af22 2962 list(PL_eval_root);
a0d0e21e 2963 else
3280af22 2964 scalar(PL_eval_root);
a0d0e21e
LW
2965
2966 DEBUG_x(dump_eval());
2967
55497cff 2968 /* Register with debugger: */
84902520 2969 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
890ce7af 2970 CV * const cv = get_cv("DB::postponed", FALSE);
55497cff
PP
2971 if (cv) {
2972 dSP;
924508f0 2973 PUSHMARK(SP);
cc49e20b 2974 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2975 PUTBACK;
864dbfa3 2976 call_sv((SV*)cv, G_DISCARD);
55497cff
PP
2977 }
2978 }
2979
a0d0e21e
LW
2980 /* compiled okay, so do it */
2981
3280af22
NIS
2982 CvDEPTH(PL_compcv) = 1;
2983 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2984 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 2985 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 2986
3280af22 2987 RETURNOP(PL_eval_start);
a0d0e21e
LW
2988}
2989
a6c40364 2990STATIC PerlIO *
ce8abf5f
SP
2991S_check_type_and_open(pTHX_ const char *name, const char *mode)
2992{
2993 Stat_t st;
c445ea15 2994 const int st_rc = PerlLIO_stat(name, &st);
ce8abf5f
SP
2995 if (st_rc < 0) {
2996 return Nullfp;
2997 }
2998
2999 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3000 Perl_die(aTHX_ "%s %s not allowed in require",
3001 S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
3002 }
3003 return PerlIO_open(name, mode);
3004}
3005
3006STATIC PerlIO *
7925835c 3007S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3008{
7925835c 3009#ifndef PERL_DISABLE_PMC
f54cb97a 3010 const STRLEN namelen = strlen(name);
b295d113
TH
3011 PerlIO *fp;
3012
7894fbab 3013 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
9d4ba2ae 3014 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
349d4f2f 3015 const char * const pmc = SvPV_nolen_const(pmcsv);
a6c40364
GS
3016 Stat_t pmcstat;
3017 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
85e8f315 3018 fp = check_type_and_open(name, mode);
a6c40364
GS
3019 }
3020 else {
9d4ba2ae 3021 Stat_t pmstat;
b295d113 3022 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS
3023 pmstat.st_mtime < pmcstat.st_mtime)
3024 {
85e8f315 3025 fp = check_type_and_open(pmc, mode);
a6c40364
GS
3026 }
3027 else {
85e8f315 3028 fp = check_type_and_open(name, mode);
a6c40364 3029 }
b295d113 3030 }
a6c40364
GS
3031 SvREFCNT_dec(pmcsv);
3032 }
3033 else {
85e8f315 3034 fp = check_type_and_open(name, mode);
b295d113 3035 }
b295d113 3036 return fp;
7925835c 3037#else
85e8f315 3038 return check_type_and_open(name, mode);
7925835c 3039#endif /* !PERL_DISABLE_PMC */
b295d113
TH
3040}
3041
a0d0e21e
LW
3042PP(pp_require)
3043{
27da23d5 3044 dVAR; dSP;
c09156bb 3045 register PERL_CONTEXT *cx;
a0d0e21e 3046 SV *sv;
5c144d81 3047 const char *name;
6132ea6c 3048 STRLEN len;
c445ea15
AL
3049 const char *tryname = NULL;
3050 SV *namesv = NULL;
f54cb97a 3051 const I32 gimme = GIMME_V;
bbed91b5 3052 int filter_has_file = 0;
c445ea15
AL
3053 PerlIO *tryrsfp = NULL;
3054 GV *filter_child_proc = NULL;
3055 SV *filter_state = NULL;
3056 SV *filter_sub = NULL;
3057 SV *hook_sv = NULL;
6ec9efec
JH
3058 SV *encoding;
3059 OP *op;
a0d0e21e
LW
3060
3061 sv = POPs;
d7aa5382
JP
3062 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3063 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
9014280d 3064 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 3065 "v-string in use/require non-portable");
d7aa5382
JP
3066
3067 sv = new_version(sv);
3068 if (!sv_derived_from(PL_patchlevel, "version"))
3069 (void *)upg_version(PL_patchlevel);
149c1637 3070 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
468aa647
RGS
3071 if ( vcmp(sv,PL_patchlevel) < 0 )
3072 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3073 vnormal(sv), vnormal(PL_patchlevel));
3074 }
3075 else {
3076 if ( vcmp(sv,PL_patchlevel) > 0 )
3077 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3078 vnormal(sv), vnormal(PL_patchlevel));
3079 }
d7aa5382 3080
4305d8ab 3081 RETPUSHYES;
a0d0e21e 3082 }
5c144d81 3083 name = SvPV_const(sv, len);
6132ea6c 3084 if (!(name && len > 0 && *name))
cea2e8a9 3085 DIE(aTHX_ "Null filename used");
4633a7c4 3086 TAINT_PROPER("require");
44f8325f 3087 if (PL_op->op_type == OP_REQUIRE) {
0bd48802 3088 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
44f8325f
AL
3089 if ( svp ) {
3090 if (*svp != &PL_sv_undef)
3091 RETPUSHYES;
3092 else
3093 DIE(aTHX_ "Compilation failed in require");
3094 }
4d8b06f1 3095 }
a0d0e21e
LW
3096
3097 /* prepare to compile file */
3098
be4b629d 3099 if (path_is_absolute(name)) {
46fc3d4c 3100 tryname = name;
7925835c 3101 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
bf4acbe4 3102 }
67627c52
JH
3103#ifdef MACOS_TRADITIONAL
3104 if (!tryrsfp) {
3105 char newname[256];
3106
3107 MacPerl_CanonDir(name, newname, 1);
3108 if (path_is_absolute(newname)) {
3109 tryname = newname;
7925835c 3110 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
67627c52
JH
3111 }
3112 }
3113#endif
be4b629d 3114 if (!tryrsfp) {
44f8325f 3115 AV * const ar = GvAVn(PL_incgv);
a0d0e21e 3116 I32 i;
748a9306 3117#ifdef VMS
46fc3d4c 3118 char *unixname;
c445ea15 3119 if ((unixname = tounixspec(name, NULL)) != NULL)
46fc3d4c
PP
3120#endif
3121 {
3122 namesv = NEWSV(806, 0);
3123 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF
3124 SV *dirsv = *av_fetch(ar, i, TRUE);
3125
3126 if (SvROK(dirsv)) {
3127 int count;
3128 SV *loader = dirsv;
3129
e14e2dc8
NC
3130 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3131 && !sv_isobject(loader))
3132 {
bbed91b5
KF
3133 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3134 }
3135
b900a521 3136 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3137 PTR2UV(SvRV(dirsv)), name);
349d4f2f 3138 tryname = SvPVX_const(namesv);
c445ea15 3139 tryrsfp = NULL;
bbed91b5
KF
3140
3141 ENTER;
3142 SAVETMPS;
3143 EXTEND(SP, 2);
3144
3145 PUSHMARK(SP);
3146 PUSHs(dirsv);
3147 PUSHs(sv);
3148 PUTBACK;
e982885c
NC
3149 if (sv_isobject(loader))
3150 count = call_method("INC", G_ARRAY);
3151 else
3152 count = call_sv(loader, G_ARRAY);
bbed91b5
KF
3153 SPAGAIN;
3154
3155 if (count > 0) {
3156 int i = 0;
3157 SV *arg;
3158
3159 SP -= count - 1;
3160 arg = SP[i++];
3161
3162 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3163 arg = SvRV(arg);
3164 }
3165
3166 if (SvTYPE(arg) == SVt_PVGV) {
3167 IO *io = GvIO((GV *)arg);
3168
3169 ++filter_has_file;
3170
3171 if (io) {
3172 tryrsfp = IoIFP(io);
50952442 3173 if (IoTYPE(io) == IoTYPE_PIPE) {
bbed91b5
KF
3174 /* reading from a child process doesn't
3175 nest -- when returning from reading
3176 the inner module, the outer one is
3177 unreadable (closed?) I've tried to
3178 save the gv to manage the lifespan of
3179 the pipe, but this didn't help. XXX */
3180 filter_child_proc = (GV *)arg;
520c758a 3181 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF
3182 }
3183 else {
3184 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3185 PerlIO_close(IoOFP(io));
3186 }
3187 IoIFP(io) = Nullfp;
3188 IoOFP(io) = Nullfp;
3189 }
3190 }
3191
3192 if (i < count) {
3193 arg = SP[i++];
3194 }
3195 }
3196
3197 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3198 filter_sub = arg;
520c758a 3199 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF
3200
3201 if (i < count) {
3202 filter_state = SP[i];
520c758a 3203 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF
3204 }
3205
c445ea15
AL
3206 if (!tryrsfp) {
3207 tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE);
bbed91b5
KF
3208 }
3209 }
1d06aecd 3210 SP--;
bbed91b5
KF
3211 }
3212
3213 PUTBACK;
3214 FREETMPS;
3215 LEAVE;
3216
3217 if (tryrsfp) {
89ccab8c 3218 hook_sv = dirsv;
bbed91b5
KF
3219 break;
3220 }
3221
3222 filter_has_file = 0;
3223 if (filter_child_proc) {
3224 SvREFCNT_dec(filter_child_proc);
c445ea15 3225 filter_child_proc = NULL;
bbed91b5
KF
3226 }
3227 if (filter_state) {
3228 SvREFCNT_dec(filter_state);
c445ea15 3229 filter_state = NULL;
bbed91b5
KF
3230 }
3231 if (filter_sub) {
3232 SvREFCNT_dec(filter_sub);
c445ea15 3233 filter_sub = NULL;
bbed91b5
KF
3234 }
3235 }
3236 else {
be4b629d
CN
3237 if (!path_is_absolute(name)
3238#ifdef MACOS_TRADITIONAL
3239 /* We consider paths of the form :a:b ambiguous and interpret them first
3240 as global then as local
3241 */
3242 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3243#endif
3244 ) {
0510663f 3245 const char *dir = SvPVx_nolen_const(dirsv);
bf4acbe4 3246#ifdef MACOS_TRADITIONAL
67627c52
JH
3247 char buf1[256];
3248 char buf2[256];
3249
3250 MacPerl_CanonDir(name, buf2, 1);
3251 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3252#else
27da23d5 3253# ifdef VMS
bbed91b5 3254 char *unixdir;
c445ea15 3255 if ((unixdir = tounixpath(dir, NULL)) == NULL)
bbed91b5
KF
3256 continue;
3257 sv_setpv(namesv, unixdir);
3258 sv_catpv(namesv, unixname);
27da23d5 3259# else
a0fd4948 3260# ifdef __SYMBIAN32__
27da23d5
JH
3261 if (PL_origfilename[0] &&
3262 PL_origfilename[1] == ':' &&
3263 !(dir[0] && dir[1] == ':'))
3264 Perl_sv_setpvf(aTHX_ namesv,
3265 "%c:%s\\%s",
3266 PL_origfilename[0],
3267 dir, name);
3268 else
3269 Perl_sv_setpvf(aTHX_ namesv,
3270 "%s\\%s",
3271 dir, name);
3272# else
bbed91b5 3273 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
27da23d5
JH
3274# endif
3275# endif
bf4acbe4 3276#endif
bbed91b5 3277 TAINT_PROPER("require");
349d4f2f 3278 tryname = SvPVX_const(namesv);
7925835c 3279 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
bbed91b5
KF
3280 if (tryrsfp) {
3281 if (tryname[0] == '.' && tryname[1] == '/')
3282 tryname += 2;
3283 break;
3284 }
be4b629d 3285 }
46fc3d4c 3286 }
a0d0e21e
LW
3287 }
3288 }
3289 }
f4dd75d9 3290 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3291 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3292 SvREFCNT_dec(namesv);
a0d0e21e 3293 if (!tryrsfp) {
533c011a 3294 if (PL_op->op_type == OP_REQUIRE) {
5c144d81 3295 const char *msgstr = name;
e31de809 3296 if(errno == EMFILE) {
b9b739dc
NC
3297 SV * const msg
3298 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3299 Strerror(errno)));
349d4f2f 3300 msgstr = SvPV_nolen_const(msg);
e31de809
SP
3301 } else {
3302 if (namesv) { /* did we lookup @INC? */
44f8325f 3303 AV * const ar = GvAVn(PL_incgv);
e31de809 3304 I32 i;
b8f04b1b
NC
3305 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3306 "%s in @INC%s%s (@INC contains:",
3307 msgstr,
3308 (instr(msgstr, ".h ")
3309 ? " (change .h to .ph maybe?)" : ""),
3310 (instr(msgstr, ".ph ")
3311 ? " (did you run h2ph?)" : "")
3312 ));
3313
e31de809 3314 for (i = 0; i <= AvFILL(ar); i++) {
396482e1 3315 sv_catpvs(msg, " ");
b8f04b1b 3316 sv_catsv(msg, *av_fetch(ar, i, TRUE));
e31de809 3317 }
396482e1 3318 sv_catpvs(msg, ")");
e31de809
SP
3319 msgstr = SvPV_nolen_const(msg);
3320 }
2683423c 3321 }
ea071790 3322 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW
3323 }
3324
3325 RETPUSHUNDEF;
3326 }
d8bfb8bd 3327 else
93189314 3328 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW
3329
3330 /* Assume success here to prevent recursive requirement. */
238d24b4 3331 /* name is never assigned to again, so len is still strlen(name) */
d3a4e64e 3332 /* Check whether a hook in @INC has already filled %INC */
44f8325f
AL
3333 if (!hook_sv) {
3334 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3335 } else {
3336 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3337 if (!svp)
3338 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
d3a4e64e 3339 }
a0d0e21e
LW
3340
3341 ENTER;
3342 SAVETMPS;
396482e1 3343 lex_start(sv_2mortal(newSVpvs("")));
b9d12d37 3344 SAVEGENERICSV(PL_rsfp_filters);
7d49f689 3345 PL_rsfp_filters = NULL;
e50aee73 3346
3280af22 3347 PL_rsfp = tryrsfp;
b3ac6de7 3348 SAVEHINTS();
3280af22 3349 PL_hints = 0;
7766f137 3350 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3351 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3352 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3353 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3354 PL_compiling.cop_warnings = pWARN_NONE ;
317ea90d
MS
3355 else if (PL_taint_warn)
3356 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
ac27b0f5 3357 else
d3a7d8c7 3358 PL_compiling.cop_warnings = pWARN_STD ;
ac27b0f5 3359 SAVESPTR(PL_compiling.cop_io);
c445ea15 3360 PL_compiling.cop_io = NULL;
a0d0e21e 3361
bbed91b5 3362 if (filter_sub || filter_child_proc) {
c445ea15 3363 SV * const datasv = filter_add(S_run_user_filter, NULL);
bbed91b5
KF
3364 IoLINES(datasv) = filter_has_file;
3365 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3366 IoTOP_GV(datasv) = (GV *)filter_state;
3367 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3368 }
3369
3370 /* switch to eval mode */
a0d0e21e 3371 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3372 PUSHEVAL(cx, name, Nullgv);
f39bc417 3373 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 3374
57843af0
GS
3375 SAVECOPLINE(&PL_compiling);
3376 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW
3377
3378 PUTBACK;
6ec9efec
JH
3379
3380 /* Store and reset encoding. */
3381 encoding = PL_encoding;
c445ea15 3382 PL_encoding = NULL;
6ec9efec 3383
a3985cdc 3384 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
bfed75c6 3385
6ec9efec
JH
3386 /* Restore encoding. */
3387 PL_encoding = encoding;
3388
3389 return op;
a0d0e21e
LW
3390}
3391
a0d0e21e
LW
3392PP(pp_entereval)
3393{
27da23d5 3394 dVAR; dSP;
c09156bb 3395 register PERL_CONTEXT *cx;
0d863452 3396 SV *sv;
890ce7af
AL
3397 const I32 gimme = GIMME_V;
3398 const I32 was = PL_sub_generation;
83ee9e09
GS
3399 char tbuf[TYPE_DIGITS(long) + 12];
3400 char *tmpbuf = tbuf;
fc36a67e 3401 char *safestr;
a0d0e21e 3402 STRLEN len;
55497cff 3403 OP *ret;
a3985cdc 3404 CV* runcv;
d819b83a 3405 U32 seq;
c445ea15 3406 HV *saved_hh = NULL;
0d863452
RH
3407
3408 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3409 saved_hh = (HV*) SvREFCNT_inc(POPs);
3410 }
3411 sv = POPs;
a0d0e21e 3412
f7997f86 3413 if (!SvPV_nolen_const(sv))
a0d0e21e 3414 RETPUSHUNDEF;
748a9306 3415 TAINT_PROPER("eval");
a0d0e21e
LW
3416
3417 ENTER;
a0d0e21e 3418 lex_start(sv);
748a9306 3419 SAVETMPS;
ac27b0f5 3420
a0d0e21e
LW
3421 /* switch to eval mode */
3422
83ee9e09 3423 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
890ce7af 3424 SV * const sv = sv_newmortal();
83ee9e09
GS
3425 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3426 (unsigned long)++PL_evalseq,
3427 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3428 tmpbuf = SvPVX(sv);
fc009855 3429 len = SvCUR(sv);
83ee9e09
GS
3430 }
3431 else
fc009855 3432 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 3433 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3434 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3435 SAVECOPLINE(&PL_compiling);
57843af0 3436 CopLINE_set(&PL_compiling, 1);
55497cff
PP
3437 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3438 deleting the eval's FILEGV from the stash before gv_check() runs
3439 (i.e. before run-time proper). To work around the coredump that
3440 ensues, we always turn GvMULTI_on for any globals that were
3441 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC
3442 safestr = savepvn(tmpbuf, len);