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