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