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