This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update to Module::CoreList 3.04.
[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;
c277df42 78 MAGIC *mg = Null(MAGIC*);
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));
aaa362c4 136 PM_SETRE(pm, Null(REGEXP*)); /* 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
PP
385 Safefree(p);
386 *rsp = Null(void*);
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 {
71315bf2 1081 GV * const gv = gv_fetchpvs(".", GV_ADD, 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 {
71315bf2 1175 GV * const gv = gv_fetchpvs(".", GV_ADD, 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
c127bd3a
SF
1766 if (CvXSUB(cv)) {
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
PP
1915 if (gimme == G_VOID)
1916 ; /* do nothing */
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 }
1fa4e549 2355 else if (CvXSUB(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 */
a0d0e21e 2372 if (CvXSUB(cv)) {
5eff7df7 2373 OP* retop = cx->blk_sub.retop;
b1464ded
DM
2374 if (reified) {
2375 I32 index;
2376 for (index=0; index<items; index++)
2377 sv_2mortal(SP[-index]);
2378 }
67caa1fe 2379#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2380 if (CvOLDSTYLE(cv)) {
20ce7b12 2381 I32 (*fp3)(int,int,int);
924508f0
GS
2382 while (SP > mark) {
2383 SP[1] = SP[0];
2384 SP--;
a0d0e21e 2385 }
7766f137 2386 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2387 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2388 mark - PL_stack_base + 1,
ecfc5424 2389 items);
3280af22 2390 SP = PL_stack_base + items;
a0d0e21e 2391 }
67caa1fe
GS
2392 else
2393#endif /* PERL_XSUB_OLDSTYLE */
2394 {
1fa4e549
AD
2395 SV **newsp;
2396 I32 gimme;
2397
5eff7df7
DM
2398 /* XS subs don't have a CxSUB, so pop it */
2399 POPBLOCK(cx, PL_curpm);
1fa4e549 2400 /* Push a mark for the start of arglist */
ac27b0f5 2401 PUSHMARK(mark);
a45cdc79 2402 PUTBACK;
acfe0abc 2403 (void)(*CvXSUB(cv))(aTHX_ cv);
1b6737cc
AL
2404 /* Put these at the bottom since the vars are set but not used */
2405 PERL_UNUSED_VAR(newsp);
2406 PERL_UNUSED_VAR(gimme);
a0d0e21e
LW
2407 }
2408 LEAVE;
5eff7df7 2409 return retop;
a0d0e21e
LW
2410 }
2411 else {
2412 AV* padlist = CvPADLIST(cv);
6b35e009 2413 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS
2414 PL_in_eval = cx->blk_eval.old_in_eval;
2415 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH
2416 cx->cx_type = CXt_SUB;
2417 cx->blk_sub.hasargs = 0;
2418 }
a0d0e21e 2419 cx->blk_sub.cv = cv;
eb160463 2420 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
dd2155a4 2421
a0d0e21e
LW
2422 CvDEPTH(cv)++;
2423 if (CvDEPTH(cv) < 2)
2424 (void)SvREFCNT_inc(cv);
dd2155a4 2425 else {
599cee73 2426 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2427 sub_crush_depth(cv);
26019298 2428 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2429 }
fd617465
DM
2430 SAVECOMPPAD();
2431 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
6d4ff0d2 2432 if (cx->blk_sub.hasargs)
6d4ff0d2 2433 {
dd2155a4 2434 AV* av = (AV*)PAD_SVl(0);
a0d0e21e
LW
2435 SV** ary;
2436
3280af22
NIS
2437 cx->blk_sub.savearray = GvAV(PL_defgv);
2438 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2439 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2440 cx->blk_sub.argarray = av;
a0d0e21e
LW
2441
2442 if (items >= AvMAX(av) + 1) {
2443 ary = AvALLOC(av);
2444 if (AvARRAY(av) != ary) {
2445 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
f880fe2f 2446 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2447 }
2448 if (items >= AvMAX(av) + 1) {
2449 AvMAX(av) = items - 1;
2450 Renew(ary,items+1,SV*);
2451 AvALLOC(av) = ary;
f880fe2f 2452 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2453 }
2454 }
a45cdc79 2455 ++mark;
a0d0e21e 2456 Copy(mark,AvARRAY(av),items,SV*);
93965878 2457 AvFILLp(av) = items - 1;
d8b46c1b 2458 assert(!AvREAL(av));
b1464ded
DM
2459 if (reified) {
2460 /* transfer 'ownership' of refcnts to new @_ */
2461 AvREAL_on(av);
2462 AvREIFY_off(av);
2463 }
a0d0e21e
LW
2464 while (items--) {
2465 if (*mark)
2466 SvTEMP_off(*mark);
2467 mark++;
2468 }
2469 }
491527d0 2470 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a
PP
2471 /*
2472 * We do not care about using sv to call CV;
2473 * it's for informational purposes only.
2474 */
890ce7af 2475 SV * const sv = GvSV(PL_DBsub);
491527d0 2476 CV *gotocv;
bfed75c6 2477
f398eb67 2478 save_item(sv);
491527d0 2479 if (PERLDB_SUB_NN) {
890ce7af 2480 const int type = SvTYPE(sv);
f398eb67
NC
2481 if (type < SVt_PVIV && type != SVt_IV)
2482 sv_upgrade(sv, SVt_PVIV);
7619c85e 2483 (void)SvIOK_on(sv);
45977657 2484 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
491527d0 2485 } else {
c445ea15 2486 gv_efullname3(sv, CvGV(cv), NULL);
491527d0
GS
2487 }
2488 if ( PERLDB_GOTO
864dbfa3 2489 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2490 PUSHMARK( PL_stack_sp );
864dbfa3 2491 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2492 PL_stack_sp--;
491527d0 2493 }
1ce6579f 2494 }
a0d0e21e
LW
2495 RETURNOP(CvSTART(cv));
2496 }
2497 }
1614b0e3 2498 else {
0510663f 2499 label = SvPV_nolen_const(sv);
1614b0e3 2500 if (!(do_dump || *label))
cea2e8a9 2501 DIE(aTHX_ must_have_label);
1614b0e3 2502 }
a0d0e21e 2503 }
533c011a 2504 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2505 if (! do_dump)
cea2e8a9 2506 DIE(aTHX_ must_have_label);
a0d0e21e
LW
2507 }
2508 else
2509 label = cPVOP->op_pv;
2510
2511 if (label && *label) {
cbbf8932 2512 OP *gotoprobe = NULL;
3b2447bc 2513 bool leaving_eval = FALSE;
33d34e4c 2514 bool in_block = FALSE;
cbbf8932 2515 PERL_CONTEXT *last_eval_cx = NULL;
a0d0e21e
LW
2516
2517 /* find label */
2518
3280af22 2519 PL_lastgotoprobe = 0;
a0d0e21e
LW
2520 *enterops = 0;
2521 for (ix = cxstack_ix; ix >= 0; ix--) {
2522 cx = &cxstack[ix];
6b35e009 2523 switch (CxTYPE(cx)) {
a0d0e21e 2524 case CXt_EVAL:
3b2447bc 2525 leaving_eval = TRUE;
971ecbe6 2526 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH
2527 gotoprobe = (last_eval_cx ?
2528 last_eval_cx->blk_eval.old_eval_root :
2529 PL_eval_root);
2530 last_eval_cx = cx;
9c5794fe
RH
2531 break;
2532 }
2533 /* else fall through */
a0d0e21e
LW
2534 case CXt_LOOP:
2535 gotoprobe = cx->blk_oldcop->op_sibling;
2536 break;
2537 case CXt_SUBST:
2538 continue;
2539 case CXt_BLOCK:
33d34e4c 2540 if (ix) {
a0d0e21e 2541 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE
2542 in_block = TRUE;
2543 } else
3280af22 2544 gotoprobe = PL_main_root;
a0d0e21e 2545 break;
b3933176 2546 case CXt_SUB:
9850bf21 2547 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
b3933176
CS
2548 gotoprobe = CvROOT(cx->blk_sub.cv);
2549 break;
2550 }
2551 /* FALL THROUGH */
7766f137 2552 case CXt_FORMAT:
0a753a76 2553 case CXt_NULL:
a651a37d 2554 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW
2555 default:
2556 if (ix)
cea2e8a9 2557 DIE(aTHX_ "panic: goto");
3280af22 2558 gotoprobe = PL_main_root;
a0d0e21e
LW
2559 break;
2560 }
2b597662
GS
2561 if (gotoprobe) {
2562 retop = dofindlabel(gotoprobe, label,
2563 enterops, enterops + GOTO_DEPTH);
2564 if (retop)
2565 break;
2566 }
3280af22 2567 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW
2568 }
2569 if (!retop)
cea2e8a9 2570 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2571
3b2447bc
RH
2572 /* if we're leaving an eval, check before we pop any frames
2573 that we're not going to punt, otherwise the error
2574 won't be caught */
2575
2576 if (leaving_eval && *enterops && enterops[1]) {
2577 I32 i;
2578 for (i = 1; enterops[i]; i++)
2579 if (enterops[i]->op_type == OP_ENTERITER)
2580 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2581 }
2582
a0d0e21e
LW
2583 /* pop unwanted frames */
2584
2585 if (ix < cxstack_ix) {
2586 I32 oldsave;
2587
2588 if (ix < 0)
2589 ix = 0;
2590 dounwind(ix);
2591 TOPBLOCK(cx);
3280af22 2592 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW
2593 LEAVE_SCOPE(oldsave);
2594 }
2595
2596 /* push wanted frames */
2597
748a9306 2598 if (*enterops && enterops[1]) {
0bd48802 2599 OP * const oldop = PL_op;
33d34e4c
AE
2600 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2601 for (; enterops[ix]; ix++) {
533c011a 2602 PL_op = enterops[ix];
84902520
TB
2603 /* Eventually we may want to stack the needed arguments
2604 * for each op. For now, we punt on the hard ones. */
533c011a 2605 if (PL_op->op_type == OP_ENTERITER)
894356b3 2606 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2607 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2608 }
533c011a 2609 PL_op = oldop;
a0d0e21e
LW
2610 }
2611 }
2612
2613 if (do_dump) {
a5f75d66 2614#ifdef VMS
6b88bc9c 2615 if (!retop) retop = PL_main_start;
a5f75d66 2616#endif
3280af22
NIS
2617 PL_restartop = retop;
2618 PL_do_undump = TRUE;
a0d0e21e
LW
2619
2620 my_unexec();
2621
3280af22
NIS
2622 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2623 PL_do_undump = FALSE;
a0d0e21e
LW
2624 }
2625
2626 RETURNOP(retop);
2627}
2628
2629PP(pp_exit)
2630{
97aff369 2631 dVAR;
39644a26 2632 dSP;
a0d0e21e
LW
2633 I32 anum;
2634
2635 if (MAXARG < 1)
2636 anum = 0;
ff0cee69 2637 else {
a0d0e21e 2638 anum = SvIVx(POPs);
d98f61e7
GS
2639#ifdef VMS
2640 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2641 anum = 0;
96e176bf 2642 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69
PP
2643#endif
2644 }
cc3604b1 2645 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2646 my_exit(anum);
3280af22 2647 PUSHs(&PL_sv_undef);
a0d0e21e
LW
2648 RETURN;
2649}
2650
a0d0e21e
LW
2651/* Eval. */
2652
0824fdcb 2653STATIC void
cea2e8a9 2654S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2655{
504618e9 2656 const char *s = SvPVX_const(sv);
890ce7af 2657 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 2658 I32 line = 1;
a0d0e21e
LW
2659
2660 while (s && s < send) {
f54cb97a 2661 const char *t;
561b68a9 2662 SV * const tmpstr = newSV(0);
a0d0e21e
LW
2663
2664 sv_upgrade(tmpstr, SVt_PVMG);
2665 t = strchr(s, '\n');
2666 if (t)
2667 t++;
2668 else
2669 t = send;
2670
2671 sv_setpvn(tmpstr, s, t - s);
2672 av_store(array, line++, tmpstr);
2673 s = t;
2674 }
2675}
2676
901017d6 2677STATIC void
14dd3ad8
GS
2678S_docatch_body(pTHX)
2679{
97aff369 2680 dVAR;
cea2e8a9 2681 CALLRUNOPS(aTHX);
901017d6 2682 return;
312caa8e
CS
2683}
2684
0824fdcb 2685STATIC OP *
cea2e8a9 2686S_docatch(pTHX_ OP *o)
1e422769 2687{
97aff369 2688 dVAR;
6224f72b 2689 int ret;
06b5626a 2690 OP * const oldop = PL_op;
db36c5a1 2691 dJMPENV;
1e422769 2692
1e422769 2693#ifdef DEBUGGING
54310121 2694 assert(CATCH_GET == TRUE);
1e422769 2695#endif
312caa8e 2696 PL_op = o;
8bffa5f8 2697
14dd3ad8 2698 JMPENV_PUSH(ret);
6224f72b 2699 switch (ret) {
312caa8e 2700 case 0:
abd70938
DM
2701 assert(cxstack_ix >= 0);
2702 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2703 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8
GS
2704 redo_body:
2705 docatch_body();
312caa8e
CS
2706 break;
2707 case 3:
8bffa5f8 2708 /* die caught by an inner eval - continue inner loop */
abd70938
DM
2709
2710 /* NB XXX we rely on the old popped CxEVAL still being at the top
2711 * of the stack; the way die_where() currently works, this
2712 * assumption is valid. In theory The cur_top_env value should be
2713 * returned in another global, the way retop (aka PL_restartop)
2714 * is. */
2715 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2716
2717 if (PL_restartop
2718 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2719 {
312caa8e
CS
2720 PL_op = PL_restartop;
2721 PL_restartop = 0;
2722 goto redo_body;
2723 }
2724 /* FALL THROUGH */
2725 default:
14dd3ad8 2726 JMPENV_POP;
533c011a 2727 PL_op = oldop;
6224f72b 2728 JMPENV_JUMP(ret);
1e422769 2729 /* NOTREACHED */
1e422769 2730 }
14dd3ad8 2731 JMPENV_POP;
533c011a 2732 PL_op = oldop;
745cf2ff 2733 return Nullop;
1e422769
PP
2734}
2735
c277df42 2736OP *
bfed75c6 2737Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ
2738/* sv Text to convert to OP tree. */
2739/* startop op_free() this to undo. */
2740/* code Short string id of the caller. */
2741{
f7997f86 2742 /* FIXME - how much of this code is common with pp_entereval? */
27da23d5 2743 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ
2744 PERL_CONTEXT *cx;
2745 SV **newsp;
b094c71d 2746 I32 gimme = G_VOID;
c277df42
IZ
2747 I32 optype;
2748 OP dummy;
155aba94 2749 OP *rop;
83ee9e09
GS
2750 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2751 char *tmpbuf = tbuf;
c277df42 2752 char *safestr;
a3985cdc 2753 int runtime;
40b8d195 2754 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
f7997f86 2755 STRLEN len;
c277df42
IZ
2756
2757 ENTER;
2758 lex_start(sv);
2759 SAVETMPS;
2760 /* switch to eval mode */
2761
923e4eb5 2762 if (IN_PERL_COMPILETIME) {
f4dd75d9 2763 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2764 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2765 }
83ee9e09 2766 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
9d4ba2ae 2767 SV * const sv = sv_newmortal();
83ee9e09
GS
2768 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2769 code, (unsigned long)++PL_evalseq,
2770 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2771 tmpbuf = SvPVX(sv);
fc009855 2772 len = SvCUR(sv);
83ee9e09
GS
2773 }
2774 else
fc009855
NC
2775 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2776 (unsigned long)++PL_evalseq);
f4dd75d9 2777 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2778 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2779 SAVECOPLINE(&PL_compiling);
57843af0 2780 CopLINE_set(&PL_compiling, 1);
c277df42
IZ
2781 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2782 deleting the eval's FILEGV from the stash before gv_check() runs
2783 (i.e. before run-time proper). To work around the coredump that
2784 ensues, we always turn GvMULTI_on for any globals that were
2785 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC
2786 safestr = savepvn(tmpbuf, len);
2787 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 2788 SAVEHINTS();
d1ca3daa 2789#ifdef OP_IN_REGISTER
6b88bc9c 2790 PL_opsave = op;
d1ca3daa 2791#else
7766f137 2792 SAVEVPTR(PL_op);
d1ca3daa 2793#endif
c277df42 2794
a3985cdc 2795 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2796 runtime = IN_PERL_RUNTIME;
a3985cdc 2797 if (runtime)
d819b83a 2798 runcv = find_runcv(NULL);
a3985cdc 2799
533c011a 2800 PL_op = &dummy;
13b51b79 2801 PL_op->op_type = OP_ENTEREVAL;
533c011a 2802 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2803 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
cc49e20b 2804 PUSHEVAL(cx, 0, Nullgv);
a3985cdc
DM
2805
2806 if (runtime)
2807 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2808 else
2809 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2810 POPBLOCK(cx,PL_curpm);
e84b9f1f 2811 POPEVAL(cx);
c277df42
IZ
2812
2813 (*startop)->op_type = OP_NULL;
22c35a8c 2814 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2815 lex_end();
f3548bdc
DM
2816 /* XXX DAPM do this properly one year */
2817 *padp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2818 LEAVE;
923e4eb5 2819 if (IN_PERL_COMPILETIME)
eb160463 2820 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
d1ca3daa 2821#ifdef OP_IN_REGISTER
6b88bc9c 2822 op = PL_opsave;
d1ca3daa 2823#endif
9d4ba2ae
AL
2824 PERL_UNUSED_VAR(newsp);
2825 PERL_UNUSED_VAR(optype);
2826
c277df42
IZ
2827 return rop;
2828}
2829
a3985cdc
DM
2830
2831/*
2832=for apidoc find_runcv
2833
2834Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM
2835If db_seqp is non_null, skip CVs that are in the DB package and populate
2836*db_seqp with the cop sequence number at the point that the DB:: code was
2837entered. (allows debuggers to eval in the scope of the breakpoint rather
cf525c36 2838than in the scope of the debugger itself).
a3985cdc
DM
2839
2840=cut
2841*/
2842
2843CV*
d819b83a 2844Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 2845{
97aff369 2846 dVAR;
a3985cdc 2847 PERL_SI *si;
a3985cdc 2848
d819b83a
DM
2849 if (db_seqp)
2850 *db_seqp = PL_curcop->cop_seq;
a3985cdc 2851 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 2852 I32 ix;
a3985cdc 2853 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 2854 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a 2855 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1b6737cc 2856 CV * const cv = cx->blk_sub.cv;
d819b83a
DM
2857 /* skip DB:: code */
2858 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2859 *db_seqp = cx->blk_oldcop->cop_seq;
2860 continue;
2861 }
2862 return cv;
2863 }
a3985cdc
DM
2864 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2865 return PL_compcv;
2866 }
2867 }
2868 return PL_main_cv;
2869}
2870
2871
2872/* Compile a require/do, an eval '', or a /(?{...})/.
2873 * In the last case, startop is non-null, and contains the address of
2874 * a pointer that should be set to the just-compiled code.
2875 * outside is the lexically enclosing CV (if any) that invoked us.
2876 */
2877
4d1ff10f 2878/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2879STATIC OP *
a3985cdc 2880S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 2881{
27da23d5 2882 dVAR; dSP;
46c461b5 2883 OP * const saveop = PL_op;
a0d0e21e 2884
6dc8a9e4
IZ
2885 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2886 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2887 : EVAL_INEVAL);
a0d0e21e 2888
1ce6579f
PP
2889 PUSHMARK(SP);
2890
3280af22 2891 SAVESPTR(PL_compcv);
561b68a9 2892 PL_compcv = (CV*)newSV(0);
3280af22 2893 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2894 CvEVAL_on(PL_compcv);
2090ab20
JH
2895 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2896 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2897
a3985cdc 2898 CvOUTSIDE_SEQ(PL_compcv) = seq;
7dafbf52 2899 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
a3985cdc 2900
dd2155a4 2901 /* set up a scratch pad */
a0d0e21e 2902
dd2155a4 2903 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2c05e328 2904
07055b4c 2905
26d9b02f 2906 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2907
a0d0e21e
LW
2908 /* make sure we compile in the right package */
2909
ed094faf 2910 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2911 SAVESPTR(PL_curstash);
ed094faf 2912 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2913 }
3280af22
NIS
2914 SAVESPTR(PL_beginav);
2915 PL_beginav = newAV();
2916 SAVEFREESV(PL_beginav);
24944567 2917 SAVEI32(PL_error_count);
a0d0e21e
LW
2918
2919 /* try to compile it */
2920
3280af22
NIS
2921 PL_eval_root = Nullop;
2922 PL_error_count = 0;
2923 PL_curcop = &PL_compiling;
2924 PL_curcop->cop_arybase = 0;
ae706db4 2925 if (saveop && saveop->op_type != OP_REQUIRE && saveop->op_flags & OPf_SPECIAL)
faef0170 2926 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2927 else
c69006e4 2928 sv_setpvn(ERRSV,"",0);
3280af22 2929 if (yyparse() || PL_error_count || !PL_eval_root) {
0c58d367 2930 SV **newsp; /* Used by POPBLOCK. */
9d4ba2ae 2931 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2932 I32 optype = 0; /* Might be reset by POPEVAL. */
9d4ba2ae 2933 const char *msg;
bfed75c6 2934
533c011a 2935 PL_op = saveop;
3280af22
NIS
2936 if (PL_eval_root) {
2937 op_free(PL_eval_root);
2938 PL_eval_root = Nullop;
a0d0e21e 2939 }
3280af22 2940 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2941 if (!startop) {
3280af22 2942 POPBLOCK(cx,PL_curpm);
c277df42 2943 POPEVAL(cx);
c277df42 2944 }
a0d0e21e
LW
2945 lex_end();
2946 LEAVE;
9d4ba2ae
AL
2947
2948 msg = SvPVx_nolen_const(ERRSV);
7a2e2cd6 2949 if (optype == OP_REQUIRE) {
b464bac0 2950 const SV * const nsv = cx->blk_eval.old_namesv;
504618e9 2951 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 2952 &PL_sv_undef, 0);
5a844595
GS
2953 DIE(aTHX_ "%sCompilation failed in require",
2954 *msg ? msg : "Unknown error\n");
2955 }
2956 else if (startop) {
3280af22 2957 POPBLOCK(cx,PL_curpm);
c277df42 2958 POPEVAL(cx);
5a844595
GS
2959 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2960 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2961 }
9d7f88dd 2962 else {
9d7f88dd
SR
2963 if (!*msg) {
2964 sv_setpv(ERRSV, "Compilation error");
2965 }
2966 }
9d4ba2ae 2967 PERL_UNUSED_VAR(newsp);
a0d0e21e
LW
2968 RETPUSHUNDEF;
2969 }
57843af0 2970 CopLINE_set(&PL_compiling, 0);
c277df42 2971 if (startop) {
3280af22 2972 *startop = PL_eval_root;
c277df42 2973 } else
3280af22 2974 SAVEFREEOP(PL_eval_root);
0c58d367
RGS
2975
2976 /* Set the context for this new optree.
2977 * If the last op is an OP_REQUIRE, force scalar context.
2978 * Otherwise, propagate the context from the eval(). */
2979 if (PL_eval_root->op_type == OP_LEAVEEVAL
2980 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2981 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2982 == OP_REQUIRE)
2983 scalar(PL_eval_root);
2984 else if (gimme & G_VOID)
3280af22 2985 scalarvoid(PL_eval_root);
54310121 2986 else if (gimme & G_ARRAY)
3280af22 2987 list(PL_eval_root);
a0d0e21e 2988 else
3280af22 2989 scalar(PL_eval_root);
a0d0e21e
LW
2990
2991 DEBUG_x(dump_eval());
2992
55497cff 2993 /* Register with debugger: */
84902520 2994 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
890ce7af 2995 CV * const cv = get_cv("DB::postponed", FALSE);
55497cff
PP
2996 if (cv) {
2997 dSP;
924508f0 2998 PUSHMARK(SP);
cc49e20b 2999 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 3000 PUTBACK;
864dbfa3 3001 call_sv((SV*)cv, G_DISCARD);
55497cff
PP
3002 }
3003 }
3004
a0d0e21e
LW
3005 /* compiled okay, so do it */
3006
3280af22
NIS
3007 CvDEPTH(PL_compcv) = 1;
3008 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 3009 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 3010 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 3011
3280af22 3012 RETURNOP(PL_eval_start);
a0d0e21e
LW
3013}
3014
a6c40364 3015STATIC PerlIO *
ce8abf5f
SP
3016S_check_type_and_open(pTHX_ const char *name, const char *mode)
3017{
3018 Stat_t st;
c445ea15 3019 const int st_rc = PerlLIO_stat(name, &st);
ce8abf5f
SP
3020 if (st_rc < 0) {
3021 return Nullfp;
3022 }
3023
3024 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3025 Perl_die(aTHX_ "%s %s not allowed in require",
3026 S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
3027 }
3028 return PerlIO_open(name, mode);
3029}
3030
3031STATIC PerlIO *
7925835c 3032S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3033{
7925835c 3034#ifndef PERL_DISABLE_PMC
f54cb97a 3035 const STRLEN namelen = strlen(name);
b295d113
TH
3036 PerlIO *fp;
3037
7894fbab 3038 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
9d4ba2ae 3039 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
349d4f2f 3040 const char * const pmc = SvPV_nolen_const(pmcsv);
a6c40364
GS
3041 Stat_t pmcstat;
3042 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
85e8f315 3043 fp = check_type_and_open(name, mode);
a6c40364
GS
3044 }
3045 else {
9d4ba2ae 3046 Stat_t pmstat;
b295d113 3047 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS
3048 pmstat.st_mtime < pmcstat.st_mtime)
3049 {
85e8f315 3050 fp = check_type_and_open(pmc, mode);
a6c40364
GS
3051 }
3052 else {
85e8f315 3053 fp = check_type_and_open(name, mode);
a6c40364 3054 }
b295d113 3055 }
a6c40364
GS
3056 SvREFCNT_dec(pmcsv);
3057 }
3058 else {
85e8f315 3059 fp = check_type_and_open(name, mode);
b295d113 3060 }
b295d113 3061 return fp;
7925835c 3062#else
85e8f315 3063 return check_type_and_open(name, mode);
7925835c 3064#endif /* !PERL_DISABLE_PMC */
b295d113
TH
3065}
3066
a0d0e21e
LW
3067PP(pp_require)
3068{
27da23d5 3069 dVAR; dSP;
c09156bb 3070 register PERL_CONTEXT *cx;
a0d0e21e 3071 SV *sv;
5c144d81 3072 const char *name;
6132ea6c 3073 STRLEN len;
c445ea15
AL
3074 const char *tryname = NULL;
3075 SV *namesv = NULL;
f54cb97a 3076 const I32 gimme = GIMME_V;
bbed91b5 3077 int filter_has_file = 0;
c445ea15
AL
3078 PerlIO *tryrsfp = NULL;
3079 GV *filter_child_proc = NULL;
3080 SV *filter_state = NULL;
3081 SV *filter_sub = NULL;
3082 SV *hook_sv = NULL;
6ec9efec
JH
3083 SV *encoding;
3084 OP *op;
a0d0e21e
LW
3085
3086 sv = POPs;
d7aa5382
JP
3087 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3088 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
9014280d 3089 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 3090 "v-string in use/require non-portable");
d7aa5382
JP
3091
3092 sv = new_version(sv);
3093 if (!sv_derived_from(PL_patchlevel, "version"))
2593c6c6 3094 upg_version(PL_patchlevel);
149c1637 3095 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
468aa647
RGS
3096 if ( vcmp(sv,PL_patchlevel) < 0 )
3097 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3098 vnormal(sv), vnormal(PL_patchlevel));
3099 }
3100 else {
3101 if ( vcmp(sv,PL_patchlevel) > 0 )
3102 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3103 vnormal(sv), vnormal(PL_patchlevel));
3104 }
d7aa5382 3105
4305d8ab 3106 RETPUSHYES;
a0d0e21e 3107 }
5c144d81 3108 name = SvPV_const(sv, len);
6132ea6c 3109 if (!(name && len > 0 && *name))
cea2e8a9 3110 DIE(aTHX_ "Null filename used");
4633a7c4 3111 TAINT_PROPER("require");
44f8325f 3112 if (PL_op->op_type == OP_REQUIRE) {
0bd48802 3113 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
44f8325f
AL
3114 if ( svp ) {
3115 if (*svp != &PL_sv_undef)
3116 RETPUSHYES;
3117 else
3118 DIE(aTHX_ "Compilation failed in require");
3119 }
4d8b06f1 3120 }
a0d0e21e
LW
3121
3122 /* prepare to compile file */
3123
be4b629d 3124 if (path_is_absolute(name)) {
46fc3d4c 3125 tryname = name;
7925835c 3126 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
bf4acbe4 3127 }
67627c52
JH
3128#ifdef MACOS_TRADITIONAL
3129 if (!tryrsfp) {
3130 char newname[256];
3131
3132 MacPerl_CanonDir(name, newname, 1);
3133 if (path_is_absolute(newname)) {
3134 tryname = newname;
7925835c 3135 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
67627c52
JH
3136 }
3137 }
3138#endif
be4b629d 3139 if (!tryrsfp) {
44f8325f 3140 AV * const ar = GvAVn(PL_incgv);
a0d0e21e 3141 I32 i;
748a9306 3142#ifdef VMS
46fc3d4c 3143 char *unixname;
c445ea15 3144 if ((unixname = tounixspec(name, NULL)) != NULL)
46fc3d4c
PP
3145#endif
3146 {
561b68a9 3147 namesv = newSV(0);
46fc3d4c 3148 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF
3149 SV *dirsv = *av_fetch(ar, i, TRUE);
3150
3151 if (SvROK(dirsv)) {
3152 int count;
3153 SV *loader = dirsv;
3154
e14e2dc8
NC
3155 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3156 && !sv_isobject(loader))
3157 {
bbed91b5
KF
3158 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3159 }
3160
b900a521 3161 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3162 PTR2UV(SvRV(dirsv)), name);
349d4f2f 3163 tryname = SvPVX_const(namesv);
c445ea15 3164 tryrsfp = NULL;
bbed91b5
KF
3165
3166 ENTER;
3167 SAVETMPS;
3168 EXTEND(SP, 2);
3169
3170 PUSHMARK(SP);
3171 PUSHs(dirsv);
3172 PUSHs(sv);
3173 PUTBACK;
e982885c
NC
3174 if (sv_isobject(loader))
3175 count = call_method("INC", G_ARRAY);
3176 else
3177 count = call_sv(loader, G_ARRAY);
bbed91b5
KF
3178 SPAGAIN;
3179
3180 if (count > 0) {
3181 int i = 0;
3182 SV *arg;
3183
3184 SP -= count - 1;
3185 arg = SP[i++];
3186
3187 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3188 arg = SvRV(arg);
3189 }
3190
3191 if (SvTYPE(arg) == SVt_PVGV) {
3192 IO *io = GvIO((GV *)arg);
3193
3194 ++filter_has_file;
3195
3196 if (io) {
3197 tryrsfp = IoIFP(io);
50952442 3198 if (IoTYPE(io) == IoTYPE_PIPE) {
bbed91b5
KF
3199 /* reading from a child process doesn't
3200 nest -- when returning from reading
3201 the inner module, the outer one is
3202 unreadable (closed?) I've tried to
3203 save the gv to manage the lifespan of
3204 the pipe, but this didn't help. XXX */
3205 filter_child_proc = (GV *)arg;
520c758a 3206 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF
3207 }
3208 else {
3209 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3210 PerlIO_close(IoOFP(io));
3211 }
3212 IoIFP(io) = Nullfp;
3213 IoOFP(io) = Nullfp;
3214 }
3215 }
3216
3217 if (i < count) {
3218 arg = SP[i++];
3219 }
3220 }
3221
3222 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3223 filter_sub = arg;
520c758a 3224 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF
3225
3226 if (i < count) {
3227 filter_state = SP[i];
520c758a 3228 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF
3229 }
3230
c445ea15
AL
3231 if (!tryrsfp) {
3232 tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE);
bbed91b5
KF
3233 }
3234 }
1d06aecd 3235 SP--;
bbed91b5
KF
3236 }
3237
3238 PUTBACK;
3239 FREETMPS;
3240 LEAVE;
3241
3242 if (tryrsfp) {
89ccab8c 3243 hook_sv = dirsv;
bbed91b5
KF
3244 break;
3245 }
3246
3247 filter_has_file = 0;
3248 if (filter_child_proc) {
3249 SvREFCNT_dec(filter_child_proc);
c445ea15 3250 filter_child_proc = NULL;
bbed91b5
KF
3251 }
3252 if (filter_state) {
3253 SvREFCNT_dec(filter_state);
c445ea15 3254 filter_state = NULL;
bbed91b5
KF
3255 }
3256 if (filter_sub) {
3257 SvREFCNT_dec(filter_sub);
c445ea15 3258 filter_sub = NULL;
bbed91b5
KF
3259 }
3260 }
3261 else {
be4b629d
CN
3262 if (!path_is_absolute(name)
3263#ifdef MACOS_TRADITIONAL
3264 /* We consider paths of the form :a:b ambiguous and interpret them first
3265 as global then as local
3266 */
3267 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3268#endif
3269 ) {
0510663f 3270 const char *dir = SvPVx_nolen_const(dirsv);
bf4acbe4 3271#ifdef MACOS_TRADITIONAL
67627c52
JH
3272 char buf1[256];
3273 char buf2[256];
3274
3275 MacPerl_CanonDir(name, buf2, 1);
3276 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3277#else
27da23d5 3278# ifdef VMS
bbed91b5 3279 char *unixdir;
c445ea15 3280 if ((unixdir = tounixpath(dir, NULL)) == NULL)
bbed91b5
KF
3281 continue;
3282 sv_setpv(namesv, unixdir);
3283 sv_catpv(namesv, unixname);
27da23d5 3284# else
a0fd4948 3285# ifdef __SYMBIAN32__
27da23d5
JH
3286 if (PL_origfilename[0] &&
3287 PL_origfilename[1] == ':' &&
3288 !(dir[0] && dir[1] == ':'))
3289 Perl_sv_setpvf(aTHX_ namesv,
3290 "%c:%s\\%s",
3291 PL_origfilename[0],
3292 dir, name);
3293 else
3294 Perl_sv_setpvf(aTHX_ namesv,
3295 "%s\\%s",
3296 dir, name);
3297# else
bbed91b5 3298 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
27da23d5
JH
3299# endif
3300# endif
bf4acbe4 3301#endif
bbed91b5 3302 TAINT_PROPER("require");
349d4f2f 3303 tryname = SvPVX_const(namesv);
7925835c 3304 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
bbed91b5
KF
3305 if (tryrsfp) {
3306 if (tryname[0] == '.' && tryname[1] == '/')
3307 tryname += 2;
3308 break;
3309 }
be4b629d 3310 }
46fc3d4c 3311 }
a0d0e21e
LW
3312 }
3313 }
3314 }
f4dd75d9 3315 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3316 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3317 SvREFCNT_dec(namesv);
a0d0e21e 3318 if (!tryrsfp) {
533c011a 3319 if (PL_op->op_type == OP_REQUIRE) {
5c144d81 3320 const char *msgstr = name;
e31de809 3321 if(errno == EMFILE) {
b9b739dc
NC
3322 SV * const msg
3323 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3324 Strerror(errno)));
349d4f2f 3325 msgstr = SvPV_nolen_const(msg);
e31de809
SP
3326 } else {
3327 if (namesv) { /* did we lookup @INC? */
44f8325f 3328 AV * const ar = GvAVn(PL_incgv);
e31de809 3329 I32 i;
b8f04b1b
NC
3330 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3331 "%s in @INC%s%s (@INC contains:",
3332 msgstr,
3333 (instr(msgstr, ".h ")
3334 ? " (change .h to .ph maybe?)" : ""),
3335 (instr(msgstr, ".ph ")
3336 ? " (did you run h2ph?)" : "")
3337 ));
3338
e31de809 3339 for (i = 0; i <= AvFILL(ar); i++) {
396482e1 3340 sv_catpvs(msg, " ");
b8f04b1b 3341 sv_catsv(msg, *av_fetch(ar, i, TRUE));
e31de809 3342 }
396482e1 3343 sv_catpvs(msg, ")");
e31de809
SP
3344 msgstr = SvPV_nolen_const(msg);
3345 }
2683423c 3346 }
ea071790 3347 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW
3348 }
3349
3350 RETPUSHUNDEF;
3351 }
d8bfb8bd 3352 else
93189314 3353 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW
3354
3355 /* Assume success here to prevent recursive requirement. */
238d24b4 3356 /* name is never assigned to again, so len is still strlen(name) */
d3a4e64e 3357 /* Check whether a hook in @INC has already filled %INC */
44f8325f
AL
3358 if (!hook_sv) {
3359 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3360 } else {
3361 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3362 if (!svp)
3363 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
d3a4e64e 3364 }
a0d0e21e
LW
3365
3366 ENTER;
3367 SAVETMPS;
396482e1 3368 lex_start(sv_2mortal(newSVpvs("")));
b9d12d37 3369 SAVEGENERICSV(PL_rsfp_filters);
7d49f689 3370 PL_rsfp_filters = NULL;
e50aee73 3371
3280af22 3372 PL_rsfp = tryrsfp;
b3ac6de7 3373 SAVEHINTS();
3280af22 3374 PL_hints = 0;
7766f137 3375 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3376 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3377 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3378 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3379 PL_compiling.cop_warnings = pWARN_NONE ;
317ea90d
MS
3380 else if (PL_taint_warn)
3381 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
ac27b0f5 3382 else
d3a7d8c7 3383 PL_compiling.cop_warnings = pWARN_STD ;
ac27b0f5 3384 SAVESPTR(PL_compiling.cop_io);
c445ea15 3385 PL_compiling.cop_io = NULL;
a0d0e21e 3386
bbed91b5 3387 if (filter_sub || filter_child_proc) {
c445ea15 3388 SV * const datasv = filter_add(S_run_user_filter, NULL);
bbed91b5
KF
3389 IoLINES(datasv) = filter_has_file;
3390 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3391 IoTOP_GV(datasv) = (GV *)filter_state;
3392 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3393 }
3394
3395 /* switch to eval mode */
a0d0e21e 3396 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3397 PUSHEVAL(cx, name, Nullgv);
f39bc417 3398 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 3399
57843af0
GS
3400 SAVECOPLINE(&PL_compiling);
3401 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW
3402
3403 PUTBACK;
6ec9efec
JH
3404
3405 /* Store and reset encoding. */
3406 encoding = PL_encoding;
c445ea15 3407 PL_encoding = NULL;
6ec9efec 3408
a3985cdc 3409 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
bfed75c6 3410
6ec9efec
JH
3411 /* Restore encoding. */
3412 PL_encoding = encoding;
3413
3414 return op;
a0d0e21e
LW
3415}
3416
a0d0e21e
LW
3417PP(pp_entereval)
3418{
27da23d5 3419 dVAR; dSP;
c09156bb 3420 register PERL_CONTEXT *cx;
0d863452 3421 SV *sv;
890ce7af
AL
3422 const I32 gimme = GIMME_V;
3423 const I32 was = PL_sub_generation;
83ee9e09
GS
3424 char tbuf[TYPE_DIGITS(long) + 12];
3425 char *tmpbuf = tbuf;
fc36a67e 3426 char *safestr;
a0d0e21e 3427 STRLEN len;
55497cff 3428 OP *ret;
a3985cdc 3429 CV* runcv;
d819b83a 3430 U32 seq;
c445ea15