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