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