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