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