This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add a new macro SvPV_free() which undoes OOK and free()s the PVX(),
[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);
4fdae800 1893 mark = newsp;
a8bba7fa 1894 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1895
a1f49e72 1896 TAINT_NOT;
54310121
PP
1897 if (gimme == G_VOID)
1898 ; /* do nothing */
1899 else if (gimme == G_SCALAR) {
1900 if (mark < SP)
1901 *++newsp = sv_mortalcopy(*SP);
1902 else
3280af22 1903 *++newsp = &PL_sv_undef;
a0d0e21e
LW
1904 }
1905 else {
a1f49e72 1906 while (mark < SP) {
a0d0e21e 1907 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS
1908 TAINT_NOT; /* Each item is independent */
1909 }
a0d0e21e 1910 }
f86702cc
PP
1911 SP = newsp;
1912 PUTBACK;
1913
a8bba7fa 1914 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1915 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1916
a0d0e21e
LW
1917 LEAVE;
1918 LEAVE;
1919
f86702cc 1920 return NORMAL;
a0d0e21e
LW
1921}
1922
1923PP(pp_return)
1924{
27da23d5 1925 dVAR; dSP; dMARK;
a0d0e21e 1926 I32 cxix;
c09156bb 1927 register PERL_CONTEXT *cx;
f86702cc 1928 bool popsub2 = FALSE;
b45de488 1929 bool clear_errsv = FALSE;
a0d0e21e
LW
1930 I32 gimme;
1931 SV **newsp;
1932 PMOP *newpm;
1933 I32 optype = 0;
b0d9ce38 1934 SV *sv;
f39bc417 1935 OP *retop;
a0d0e21e 1936
3280af22 1937 if (PL_curstackinfo->si_type == PERLSI_SORT) {
7766f137
GS
1938 if (cxstack_ix == PL_sortcxix
1939 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1940 {
3280af22
NIS
1941 if (cxstack_ix > PL_sortcxix)
1942 dounwind(PL_sortcxix);
1943 AvARRAY(PL_curstack)[1] = *SP;
1944 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW
1945 return 0;
1946 }
1947 }
1948
1949 cxix = dopoptosub(cxstack_ix);
1950 if (cxix < 0)
cea2e8a9 1951 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW
1952 if (cxix < cxstack_ix)
1953 dounwind(cxix);
1954
1955 POPBLOCK(cx,newpm);
6b35e009 1956 switch (CxTYPE(cx)) {
a0d0e21e 1957 case CXt_SUB:
f86702cc 1958 popsub2 = TRUE;
f39bc417 1959 retop = cx->blk_sub.retop;
5dd42e15 1960 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW
1961 break;
1962 case CXt_EVAL:
b45de488
GS
1963 if (!(PL_in_eval & EVAL_KEEPERR))
1964 clear_errsv = TRUE;
a0d0e21e 1965 POPEVAL(cx);
f39bc417 1966 retop = cx->blk_eval.retop;
1d76a5c3
GS
1967 if (CxTRYBLOCK(cx))
1968 break;
067f92a0 1969 lex_end();
748a9306
LW
1970 if (optype == OP_REQUIRE &&
1971 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1972 {
54310121 1973 /* Unassume the success we assumed earlier. */
0f79a09d
GS
1974 SV *nsv = cx->blk_eval.old_namesv;
1975 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 1976 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
748a9306 1977 }
a0d0e21e 1978 break;
7766f137
GS
1979 case CXt_FORMAT:
1980 POPFORMAT(cx);
f39bc417 1981 retop = cx->blk_sub.retop;
7766f137 1982 break;
a0d0e21e 1983 default:
cea2e8a9 1984 DIE(aTHX_ "panic: return");
a0d0e21e
LW
1985 }
1986
a1f49e72 1987 TAINT_NOT;
a0d0e21e 1988 if (gimme == G_SCALAR) {
a29cdaf0
IZ
1989 if (MARK < SP) {
1990 if (popsub2) {
a8bba7fa 1991 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
1992 if (SvTEMP(TOPs)) {
1993 *++newsp = SvREFCNT_inc(*SP);
1994 FREETMPS;
1995 sv_2mortal(*newsp);
959e3673
GS
1996 }
1997 else {
1998 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 1999 FREETMPS;
959e3673
GS
2000 *++newsp = sv_mortalcopy(sv);
2001 SvREFCNT_dec(sv);
a29cdaf0 2002 }
959e3673
GS
2003 }
2004 else
a29cdaf0 2005 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS
2006 }
2007 else
a29cdaf0 2008 *++newsp = sv_mortalcopy(*SP);
959e3673
GS
2009 }
2010 else
3280af22 2011 *++newsp = &PL_sv_undef;
a0d0e21e 2012 }
54310121 2013 else if (gimme == G_ARRAY) {
a1f49e72 2014 while (++MARK <= SP) {
f86702cc
PP
2015 *++newsp = (popsub2 && SvTEMP(*MARK))
2016 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
2017 TAINT_NOT; /* Each item is independent */
2018 }
a0d0e21e 2019 }
3280af22 2020 PL_stack_sp = newsp;
a0d0e21e 2021
5dd42e15 2022 LEAVE;
f86702cc
PP
2023 /* Stack values are safe: */
2024 if (popsub2) {
5dd42e15 2025 cxstack_ix--;
b0d9ce38 2026 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2027 }
b0d9ce38
GS
2028 else
2029 sv = Nullsv;
3280af22 2030 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2031
b0d9ce38 2032 LEAVESUB(sv);
b45de488
GS
2033 if (clear_errsv)
2034 sv_setpv(ERRSV,"");
f39bc417 2035 return retop;
a0d0e21e
LW
2036}
2037
2038PP(pp_last)
2039{
27da23d5 2040 dVAR; dSP;
a0d0e21e 2041 I32 cxix;
c09156bb 2042 register PERL_CONTEXT *cx;
f86702cc 2043 I32 pop2 = 0;
a0d0e21e
LW
2044 I32 gimme;
2045 I32 optype;
2046 OP *nextop;
2047 SV **newsp;
2048 PMOP *newpm;
a8bba7fa 2049 SV **mark;
b0d9ce38 2050 SV *sv = Nullsv;
a0d0e21e 2051
533c011a 2052 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2053 cxix = dopoptoloop(cxstack_ix);
2054 if (cxix < 0)
a651a37d 2055 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW
2056 }
2057 else {
2058 cxix = dopoptolabel(cPVOP->op_pv);
2059 if (cxix < 0)
cea2e8a9 2060 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW
2061 }
2062 if (cxix < cxstack_ix)
2063 dounwind(cxix);
2064
2065 POPBLOCK(cx,newpm);
5dd42e15 2066 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2067 mark = newsp;
6b35e009 2068 switch (CxTYPE(cx)) {
a0d0e21e 2069 case CXt_LOOP:
f86702cc 2070 pop2 = CXt_LOOP;
a8bba7fa
GS
2071 newsp = PL_stack_base + cx->blk_loop.resetsp;
2072 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 2073 break;
f86702cc 2074 case CXt_SUB:
f86702cc 2075 pop2 = CXt_SUB;
f39bc417 2076 nextop = cx->blk_sub.retop;
a0d0e21e 2077 break;
f86702cc
PP
2078 case CXt_EVAL:
2079 POPEVAL(cx);
f39bc417 2080 nextop = cx->blk_eval.retop;
a0d0e21e 2081 break;
7766f137
GS
2082 case CXt_FORMAT:
2083 POPFORMAT(cx);
f39bc417 2084 nextop = cx->blk_sub.retop;
7766f137 2085 break;
a0d0e21e 2086 default:
cea2e8a9 2087 DIE(aTHX_ "panic: last");
a0d0e21e
LW
2088 }
2089
a1f49e72 2090 TAINT_NOT;
a0d0e21e 2091 if (gimme == G_SCALAR) {
f86702cc
PP
2092 if (MARK < SP)
2093 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2094 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2095 else
3280af22 2096 *++newsp = &PL_sv_undef;
a0d0e21e 2097 }
54310121 2098 else if (gimme == G_ARRAY) {
a1f49e72 2099 while (++MARK <= SP) {
f86702cc
PP
2100 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2101 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
2102 TAINT_NOT; /* Each item is independent */
2103 }
f86702cc
PP
2104 }
2105 SP = newsp;
2106 PUTBACK;
2107
5dd42e15
DM
2108 LEAVE;
2109 cxstack_ix--;
f86702cc
PP
2110 /* Stack values are safe: */
2111 switch (pop2) {
2112 case CXt_LOOP:
a8bba7fa 2113 POPLOOP(cx); /* release loop vars ... */
4fdae800 2114 LEAVE;
f86702cc
PP
2115 break;
2116 case CXt_SUB:
b0d9ce38 2117 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2118 break;
a0d0e21e 2119 }
3280af22 2120 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2121
b0d9ce38 2122 LEAVESUB(sv);
f86702cc 2123 return nextop;
a0d0e21e
LW
2124}
2125
2126PP(pp_next)
2127{
27da23d5 2128 dVAR;
a0d0e21e 2129 I32 cxix;
c09156bb 2130 register PERL_CONTEXT *cx;
85538317 2131 I32 inner;
a0d0e21e 2132
533c011a 2133 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2134 cxix = dopoptoloop(cxstack_ix);
2135 if (cxix < 0)
a651a37d 2136 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW
2137 }
2138 else {
2139 cxix = dopoptolabel(cPVOP->op_pv);
2140 if (cxix < 0)
cea2e8a9 2141 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW
2142 }
2143 if (cxix < cxstack_ix)
2144 dounwind(cxix);
2145
85538317
GS
2146 /* clear off anything above the scope we're re-entering, but
2147 * save the rest until after a possible continue block */
2148 inner = PL_scopestack_ix;
1ba6ee2b 2149 TOPBLOCK(cx);
85538317
GS
2150 if (PL_scopestack_ix < inner)
2151 leave_scope(PL_scopestack[PL_scopestack_ix]);
1ba6ee2b 2152 return cx->blk_loop.next_op;
a0d0e21e
LW
2153}
2154
2155PP(pp_redo)
2156{
27da23d5 2157 dVAR;
a0d0e21e 2158 I32 cxix;
c09156bb 2159 register PERL_CONTEXT *cx;
a0d0e21e
LW
2160 I32 oldsave;
2161
533c011a 2162 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2163 cxix = dopoptoloop(cxstack_ix);
2164 if (cxix < 0)
a651a37d 2165 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW
2166 }
2167 else {
2168 cxix = dopoptolabel(cPVOP->op_pv);
2169 if (cxix < 0)
cea2e8a9 2170 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW
2171 }
2172 if (cxix < cxstack_ix)
2173 dounwind(cxix);
2174
2175 TOPBLOCK(cx);
3280af22 2176 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2177 LEAVE_SCOPE(oldsave);
936c78b5 2178 FREETMPS;
a0d0e21e
LW
2179 return cx->blk_loop.redo_op;
2180}
2181
0824fdcb 2182STATIC OP *
bfed75c6 2183S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2184{
4ea42e7f 2185 OP *kid = Nullop;
a0d0e21e 2186 OP **ops = opstack;
bfed75c6 2187 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2188
fc36a67e 2189 if (ops >= oplimit)
cea2e8a9 2190 Perl_croak(aTHX_ too_deep);
11343788
MB
2191 if (o->op_type == OP_LEAVE ||
2192 o->op_type == OP_SCOPE ||
2193 o->op_type == OP_LEAVELOOP ||
33d34e4c 2194 o->op_type == OP_LEAVESUB ||
11343788 2195 o->op_type == OP_LEAVETRY)
fc36a67e 2196 {
5dc0d613 2197 *ops++ = cUNOPo->op_first;
fc36a67e 2198 if (ops >= oplimit)
cea2e8a9 2199 Perl_croak(aTHX_ too_deep);
fc36a67e 2200 }
c4aa4e48 2201 *ops = 0;
11343788 2202 if (o->op_flags & OPf_KIDS) {
a0d0e21e 2203 /* First try all the kids at this level, since that's likeliest. */
11343788 2204 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS
2205 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2206 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW
2207 return kid;
2208 }
11343788 2209 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2210 if (kid == PL_lastgotoprobe)
a0d0e21e 2211 continue;
ed8d0fe2
SM
2212 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2213 if (ops == opstack)
2214 *ops++ = kid;
2215 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2216 ops[-1]->op_type == OP_DBSTATE)
2217 ops[-1] = kid;
2218 else
2219 *ops++ = kid;
2220 }
155aba94 2221 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2222 return o;
a0d0e21e
LW
2223 }
2224 }
c4aa4e48 2225 *ops = 0;
a0d0e21e
LW
2226 return 0;
2227}
2228
2229PP(pp_dump)
2230{
cea2e8a9 2231 return pp_goto();
a0d0e21e
LW
2232 /*NOTREACHED*/
2233}
2234
2235PP(pp_goto)
2236{
27da23d5 2237 dVAR; dSP;
a0d0e21e
LW
2238 OP *retop = 0;
2239 I32 ix;
c09156bb 2240 register PERL_CONTEXT *cx;
fc36a67e
PP
2241#define GOTO_DEPTH 64
2242 OP *enterops[GOTO_DEPTH];
bfed75c6
AL
2243 const char *label = 0;
2244 const bool do_dump = (PL_op->op_type == OP_DUMP);
2245 static const char must_have_label[] = "goto must have label";
a0d0e21e 2246
533c011a 2247 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2248 SV *sv = POPs;
2d8e6c8d 2249 STRLEN n_a;
a0d0e21e
LW
2250
2251 /* This egregious kludge implements goto &subroutine */
2252 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2253 I32 cxix;
c09156bb 2254 register PERL_CONTEXT *cx;
a0d0e21e
LW
2255 CV* cv = (CV*)SvRV(sv);
2256 SV** mark;
2257 I32 items = 0;
2258 I32 oldsave;
b1464ded 2259 bool reified = 0;
a0d0e21e 2260
e8f7dd13 2261 retry:
4aa0a1f7 2262 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2263 const GV * const gv = CvGV(cv);
e8f7dd13 2264 if (gv) {
7fc63493 2265 GV *autogv;
e8f7dd13
GS
2266 SV *tmpstr;
2267 /* autoloaded stub? */
2268 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2269 goto retry;
2270 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2271 GvNAMELEN(gv), FALSE);
2272 if (autogv && (cv = GvCV(autogv)))
2273 goto retry;
2274 tmpstr = sv_newmortal();
2275 gv_efullname3(tmpstr, gv, Nullch);
35c1215d 2276 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
4aa0a1f7 2277 }
cea2e8a9 2278 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD
2279 }
2280
a0d0e21e 2281 /* First do some returnish stuff. */
7fc63493 2282 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
71fc2216 2283 FREETMPS;
a0d0e21e
LW
2284 cxix = dopoptosub(cxstack_ix);
2285 if (cxix < 0)
cea2e8a9 2286 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW
2287 if (cxix < cxstack_ix)
2288 dounwind(cxix);
2289 TOPBLOCK(cx);
63b28e3f 2290 if (CxREALEVAL(cx))
cea2e8a9 2291 DIE(aTHX_ "Can't goto subroutine from an eval-string");
d8b46c1b
GS
2292 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2293 /* put @_ back onto stack */
a0d0e21e 2294 AV* av = cx->blk_sub.argarray;
bfed75c6 2295
93965878 2296 items = AvFILLp(av) + 1;
a45cdc79
DM
2297 EXTEND(SP, items+1); /* @_ could have been extended. */
2298 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS
2299 SvREFCNT_dec(GvAV(PL_defgv));
2300 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2301 CLEAR_ARGARRAY(av);
d8b46c1b 2302 /* abandon @_ if it got reified */
62b1ebc2 2303 if (AvREAL(av)) {
b1464ded
DM
2304 reified = 1;
2305 SvREFCNT_dec(av);
d8b46c1b
GS
2306 av = newAV();
2307 av_extend(av, items-1);
2308 AvFLAGS(av) = AVf_REIFY;
dd2155a4 2309 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2310 }
a0d0e21e 2311 }
1fa4e549
AD
2312 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2313 AV* av;
3280af22 2314 av = GvAV(PL_defgv);
1fa4e549 2315 items = AvFILLp(av) + 1;
a45cdc79
DM
2316 EXTEND(SP, items+1); /* @_ could have been extended. */
2317 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2318 }
a45cdc79
DM
2319 mark = SP;
2320 SP += items;
6b35e009 2321 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2322 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2323 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2324 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
2325 LEAVE_SCOPE(oldsave);
2326
2327 /* Now do some callish stuff. */
2328 SAVETMPS;
5023d17a 2329 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
a0d0e21e 2330 if (CvXSUB(cv)) {
b1464ded
DM
2331 if (reified) {
2332 I32 index;
2333 for (index=0; index<items; index++)
2334 sv_2mortal(SP[-index]);
2335 }
67caa1fe 2336#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2337 if (CvOLDSTYLE(cv)) {
20ce7b12 2338 I32 (*fp3)(int,int,int);
924508f0
GS
2339 while (SP > mark) {
2340 SP[1] = SP[0];
2341 SP--;
a0d0e21e 2342 }
7766f137 2343 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2344 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2345 mark - PL_stack_base + 1,
ecfc5424 2346 items);
3280af22 2347 SP = PL_stack_base + items;
a0d0e21e 2348 }
67caa1fe
GS
2349 else
2350#endif /* PERL_XSUB_OLDSTYLE */
2351 {
1fa4e549
AD
2352 SV **newsp;
2353 I32 gimme;
2354
1fa4e549 2355 /* Push a mark for the start of arglist */
ac27b0f5 2356 PUSHMARK(mark);
a45cdc79 2357 PUTBACK;
acfe0abc 2358 (void)(*CvXSUB(cv))(aTHX_ cv);
1fa4e549 2359 /* Pop the current context like a decent sub should */
3280af22 2360 POPBLOCK(cx, PL_curpm);
1fa4e549 2361 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW
2362 }
2363 LEAVE;
f39bc417
DM
2364 assert(CxTYPE(cx) == CXt_SUB);
2365 return cx->blk_sub.retop;
a0d0e21e
LW
2366 }
2367 else {
2368 AV* padlist = CvPADLIST(cv);
6b35e009 2369 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS
2370 PL_in_eval = cx->blk_eval.old_in_eval;
2371 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH
2372 cx->cx_type = CXt_SUB;
2373 cx->blk_sub.hasargs = 0;
2374 }
a0d0e21e 2375 cx->blk_sub.cv = cv;
eb160463 2376 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
dd2155a4 2377
a0d0e21e
LW
2378 CvDEPTH(cv)++;
2379 if (CvDEPTH(cv) < 2)
2380 (void)SvREFCNT_inc(cv);
dd2155a4 2381 else {
599cee73 2382 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2383 sub_crush_depth(cv);
26019298 2384 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2385 }
dd2155a4 2386 PAD_SET_CUR(padlist, CvDEPTH(cv));
6d4ff0d2 2387 if (cx->blk_sub.hasargs)
6d4ff0d2 2388 {
dd2155a4 2389 AV* av = (AV*)PAD_SVl(0);
a0d0e21e
LW
2390 SV** ary;
2391
3280af22
NIS
2392 cx->blk_sub.savearray = GvAV(PL_defgv);
2393 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2394 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2395 cx->blk_sub.argarray = av;
a0d0e21e
LW
2396
2397 if (items >= AvMAX(av) + 1) {
2398 ary = AvALLOC(av);
2399 if (AvARRAY(av) != ary) {
2400 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
f880fe2f 2401 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2402 }
2403 if (items >= AvMAX(av) + 1) {
2404 AvMAX(av) = items - 1;
2405 Renew(ary,items+1,SV*);
2406 AvALLOC(av) = ary;
f880fe2f 2407 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2408 }
2409 }
a45cdc79 2410 ++mark;
a0d0e21e 2411 Copy(mark,AvARRAY(av),items,SV*);
93965878 2412 AvFILLp(av) = items - 1;
d8b46c1b 2413 assert(!AvREAL(av));
b1464ded
DM
2414 if (reified) {
2415 /* transfer 'ownership' of refcnts to new @_ */
2416 AvREAL_on(av);
2417 AvREIFY_off(av);
2418 }
a0d0e21e
LW
2419 while (items--) {
2420 if (*mark)
2421 SvTEMP_off(*mark);
2422 mark++;
2423 }
2424 }
491527d0 2425 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a
PP
2426 /*
2427 * We do not care about using sv to call CV;
2428 * it's for informational purposes only.
2429 */
3280af22 2430 SV *sv = GvSV(PL_DBsub);
491527d0 2431 CV *gotocv;
bfed75c6 2432
f398eb67 2433 save_item(sv);
491527d0 2434 if (PERLDB_SUB_NN) {
f398eb67
NC
2435 int type = SvTYPE(sv);
2436 if (type < SVt_PVIV && type != SVt_IV)
2437 sv_upgrade(sv, SVt_PVIV);
7619c85e 2438 (void)SvIOK_on(sv);
45977657 2439 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
491527d0 2440 } else {
491527d0
GS
2441 gv_efullname3(sv, CvGV(cv), Nullch);
2442 }
2443 if ( PERLDB_GOTO
864dbfa3 2444 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2445 PUSHMARK( PL_stack_sp );
864dbfa3 2446 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2447 PL_stack_sp--;
491527d0 2448 }
1ce6579f 2449 }
a0d0e21e
LW
2450 RETURNOP(CvSTART(cv));
2451 }
2452 }
1614b0e3 2453 else {
2d8e6c8d 2454 label = SvPV(sv,n_a);
1614b0e3 2455 if (!(do_dump || *label))
cea2e8a9 2456 DIE(aTHX_ must_have_label);
1614b0e3 2457 }
a0d0e21e 2458 }
533c011a 2459 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2460 if (! do_dump)
cea2e8a9 2461 DIE(aTHX_ must_have_label);
a0d0e21e
LW
2462 }
2463 else
2464 label = cPVOP->op_pv;
2465
2466 if (label && *label) {
2467 OP *gotoprobe = 0;
3b2447bc 2468 bool leaving_eval = FALSE;
33d34e4c 2469 bool in_block = FALSE;
a4f3a277 2470 PERL_CONTEXT *last_eval_cx = 0;
a0d0e21e
LW
2471
2472 /* find label */
2473
3280af22 2474 PL_lastgotoprobe = 0;
a0d0e21e
LW
2475 *enterops = 0;
2476 for (ix = cxstack_ix; ix >= 0; ix--) {
2477 cx = &cxstack[ix];
6b35e009 2478 switch (CxTYPE(cx)) {
a0d0e21e 2479 case CXt_EVAL:
3b2447bc 2480 leaving_eval = TRUE;
971ecbe6 2481 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH
2482 gotoprobe = (last_eval_cx ?
2483 last_eval_cx->blk_eval.old_eval_root :
2484 PL_eval_root);
2485 last_eval_cx = cx;
9c5794fe
RH
2486 break;
2487 }
2488 /* else fall through */
a0d0e21e
LW
2489 case CXt_LOOP:
2490 gotoprobe = cx->blk_oldcop->op_sibling;
2491 break;
2492 case CXt_SUBST:
2493 continue;
2494 case CXt_BLOCK:
33d34e4c 2495 if (ix) {
a0d0e21e 2496 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE
2497 in_block = TRUE;
2498 } else
3280af22 2499 gotoprobe = PL_main_root;
a0d0e21e 2500 break;
b3933176
CS
2501 case CXt_SUB:
2502 if (CvDEPTH(cx->blk_sub.cv)) {
2503 gotoprobe = CvROOT(cx->blk_sub.cv);
2504 break;
2505 }
2506 /* FALL THROUGH */
7766f137 2507 case CXt_FORMAT:
0a753a76 2508 case CXt_NULL:
a651a37d 2509 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW
2510 default:
2511 if (ix)
cea2e8a9 2512 DIE(aTHX_ "panic: goto");
3280af22 2513 gotoprobe = PL_main_root;
a0d0e21e
LW
2514 break;
2515 }
2b597662
GS
2516 if (gotoprobe) {
2517 retop = dofindlabel(gotoprobe, label,
2518 enterops, enterops + GOTO_DEPTH);
2519 if (retop)
2520 break;
2521 }
3280af22 2522 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW
2523 }
2524 if (!retop)
cea2e8a9 2525 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2526
3b2447bc
RH
2527 /* if we're leaving an eval, check before we pop any frames
2528 that we're not going to punt, otherwise the error
2529 won't be caught */
2530
2531 if (leaving_eval && *enterops && enterops[1]) {
2532 I32 i;
2533 for (i = 1; enterops[i]; i++)
2534 if (enterops[i]->op_type == OP_ENTERITER)
2535 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2536 }
2537
a0d0e21e
LW
2538 /* pop unwanted frames */
2539
2540 if (ix < cxstack_ix) {
2541 I32 oldsave;
2542
2543 if (ix < 0)
2544 ix = 0;
2545 dounwind(ix);
2546 TOPBLOCK(cx);
3280af22 2547 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW
2548 LEAVE_SCOPE(oldsave);
2549 }
2550
2551 /* push wanted frames */
2552
748a9306 2553 if (*enterops && enterops[1]) {
533c011a 2554 OP *oldop = PL_op;
33d34e4c
AE
2555 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2556 for (; enterops[ix]; ix++) {
533c011a 2557 PL_op = enterops[ix];
84902520
TB
2558 /* Eventually we may want to stack the needed arguments
2559 * for each op. For now, we punt on the hard ones. */
533c011a 2560 if (PL_op->op_type == OP_ENTERITER)
894356b3 2561 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2562 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2563 }
533c011a 2564 PL_op = oldop;
a0d0e21e
LW
2565 }
2566 }
2567
2568 if (do_dump) {
a5f75d66 2569#ifdef VMS
6b88bc9c 2570 if (!retop) retop = PL_main_start;
a5f75d66 2571#endif
3280af22
NIS
2572 PL_restartop = retop;
2573 PL_do_undump = TRUE;
a0d0e21e
LW
2574
2575 my_unexec();
2576
3280af22
NIS
2577 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2578 PL_do_undump = FALSE;
a0d0e21e
LW
2579 }
2580
2581 RETURNOP(retop);
2582}
2583
2584PP(pp_exit)
2585{
39644a26 2586 dSP;
a0d0e21e
LW
2587 I32 anum;
2588
2589 if (MAXARG < 1)
2590 anum = 0;
ff0cee69 2591 else {
a0d0e21e 2592 anum = SvIVx(POPs);
d98f61e7
GS
2593#ifdef VMS
2594 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2595 anum = 0;
96e176bf 2596 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69
PP
2597#endif
2598 }
cc3604b1 2599 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2600 my_exit(anum);
3280af22 2601 PUSHs(&PL_sv_undef);
a0d0e21e
LW
2602 RETURN;
2603}
2604
2605#ifdef NOTYET
2606PP(pp_nswitch)
2607{
39644a26 2608 dSP;
65202027 2609 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW
2610 register I32 match = I_32(value);
2611
2612 if (value < 0.0) {
65202027 2613 if (((NV)match) > value)
a0d0e21e
LW
2614 --match; /* was fractional--truncate other way */
2615 }
2616 match -= cCOP->uop.scop.scop_offset;
2617 if (match < 0)
2618 match = 0;
2619 else if (match > cCOP->uop.scop.scop_max)
2620 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS
2621 PL_op = cCOP->uop.scop.scop_next[match];
2622 RETURNOP(PL_op);
a0d0e21e
LW
2623}
2624
2625PP(pp_cswitch)
2626{
39644a26 2627 dSP;
a0d0e21e
LW
2628 register I32 match;
2629
6b88bc9c
GS
2630 if (PL_multiline)
2631 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2632 else {
2d8e6c8d
GS
2633 STRLEN n_a;
2634 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW
2635 match -= cCOP->uop.scop.scop_offset;
2636 if (match < 0)
2637 match = 0;
2638 else if (match > cCOP->uop.scop.scop_max)
2639 match = cCOP->uop.scop.scop_max;
6b88bc9c 2640 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2641 }
6b88bc9c 2642 RETURNOP(PL_op);
a0d0e21e
LW
2643}
2644#endif
2645
2646/* Eval. */
2647
0824fdcb 2648STATIC void
cea2e8a9 2649S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2650{
06b5626a
AL
2651 register const char *s = SvPVX(sv);
2652 register const char *send = SvPVX(sv) + SvCUR(sv);
2653 register const char *t;
a0d0e21e
LW
2654 register I32 line = 1;
2655
2656 while (s && s < send) {
2657 SV *tmpstr = NEWSV(85,0);
2658
2659 sv_upgrade(tmpstr, SVt_PVMG);
2660 t = strchr(s, '\n');
2661 if (t)
2662 t++;
2663 else
2664 t = send;
2665
2666 sv_setpvn(tmpstr, s, t - s);
2667 av_store(array, line++, tmpstr);
2668 s = t;
2669 }
2670}
2671
14dd3ad8
GS
2672STATIC void *
2673S_docatch_body(pTHX)
2674{
cea2e8a9 2675 CALLRUNOPS(aTHX);
312caa8e
CS
2676 return NULL;
2677}
2678
0824fdcb 2679STATIC OP *
cea2e8a9 2680S_docatch(pTHX_ OP *o)
1e422769 2681{
6224f72b 2682 int ret;
06b5626a 2683 OP * const oldop = PL_op;
8bffa5f8 2684 OP *retop;
0cdb2077 2685 volatile PERL_SI *cursi = PL_curstackinfo;
db36c5a1 2686 dJMPENV;
1e422769 2687
1e422769 2688#ifdef DEBUGGING
54310121 2689 assert(CATCH_GET == TRUE);
1e422769 2690#endif
312caa8e 2691 PL_op = o;
8bffa5f8
DM
2692
2693 /* Normally, the leavetry at the end of this block of ops will
2694 * pop an op off the return stack and continue there. By setting
2695 * the op to Nullop, we force an exit from the inner runops()
2696 * loop. DAPM.
2697 */
f39bc417
DM
2698 assert(cxstack_ix >= 0);
2699 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2700 retop = cxstack[cxstack_ix].blk_eval.retop;
2701 cxstack[cxstack_ix].blk_eval.retop = Nullop;
8bffa5f8 2702
14dd3ad8 2703 JMPENV_PUSH(ret);
6224f72b 2704 switch (ret) {
312caa8e 2705 case 0:
14dd3ad8
GS
2706 redo_body:
2707 docatch_body();
312caa8e
CS
2708 break;
2709 case 3:
8bffa5f8 2710 /* die caught by an inner eval - continue inner loop */
0cdb2077 2711 if (PL_restartop && cursi == PL_curstackinfo) {
312caa8e
CS
2712 PL_op = PL_restartop;
2713 PL_restartop = 0;
2714 goto redo_body;
2715 }
8bffa5f8
DM
2716 /* a die in this eval - continue in outer loop */
2717 if (!PL_restartop)
2718 break;
312caa8e
CS
2719 /* FALL THROUGH */
2720 default:
14dd3ad8 2721 JMPENV_POP;
533c011a 2722 PL_op = oldop;
6224f72b 2723 JMPENV_JUMP(ret);
1e422769 2724 /* NOTREACHED */
1e422769 2725 }
14dd3ad8 2726 JMPENV_POP;
533c011a 2727 PL_op = oldop;
8bffa5f8 2728 return retop;
1e422769
PP
2729}
2730
c277df42 2731OP *
bfed75c6 2732Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ
2733/* sv Text to convert to OP tree. */
2734/* startop op_free() this to undo. */
2735/* code Short string id of the caller. */
2736{
27da23d5 2737 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ
2738 PERL_CONTEXT *cx;
2739 SV **newsp;
f987c7de 2740 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ
2741 I32 optype;
2742 OP dummy;
155aba94 2743 OP *rop;
83ee9e09
GS
2744 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2745 char *tmpbuf = tbuf;
c277df42 2746 char *safestr;
a3985cdc 2747 int runtime;
40b8d195 2748 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
c277df42
IZ
2749
2750 ENTER;
2751 lex_start(sv);
2752 SAVETMPS;
2753 /* switch to eval mode */
2754
923e4eb5 2755 if (IN_PERL_COMPILETIME) {
f4dd75d9 2756 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2757 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2758 }
83ee9e09
GS
2759 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2760 SV *sv = sv_newmortal();
2761 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2762 code, (unsigned long)++PL_evalseq,
2763 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2764 tmpbuf = SvPVX(sv);
2765 }
2766 else
2767 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
f4dd75d9 2768 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2769 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2770 SAVECOPLINE(&PL_compiling);
57843af0 2771 CopLINE_set(&PL_compiling, 1);
c277df42
IZ
2772 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2773 deleting the eval's FILEGV from the stash before gv_check() runs
2774 (i.e. before run-time proper). To work around the coredump that
2775 ensues, we always turn GvMULTI_on for any globals that were
2776 introduced within evals. See force_ident(). GSAR 96-10-12 */
2777 safestr = savepv(tmpbuf);
3280af22 2778 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2779 SAVEHINTS();
d1ca3daa 2780#ifdef OP_IN_REGISTER
6b88bc9c 2781 PL_opsave = op;
d1ca3daa 2782#else
7766f137 2783 SAVEVPTR(PL_op);
d1ca3daa 2784#endif
c277df42 2785
a3985cdc 2786 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2787 runtime = IN_PERL_RUNTIME;
a3985cdc 2788 if (runtime)
d819b83a 2789 runcv = find_runcv(NULL);
a3985cdc 2790
533c011a 2791 PL_op = &dummy;
13b51b79 2792 PL_op->op_type = OP_ENTEREVAL;
533c011a 2793 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2794 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
cc49e20b 2795 PUSHEVAL(cx, 0, Nullgv);
a3985cdc
DM
2796
2797 if (runtime)
2798 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2799 else
2800 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2801 POPBLOCK(cx,PL_curpm);
e84b9f1f 2802 POPEVAL(cx);
c277df42
IZ
2803
2804 (*startop)->op_type = OP_NULL;
22c35a8c 2805 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2806 lex_end();
f3548bdc
DM
2807 /* XXX DAPM do this properly one year */
2808 *padp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2809 LEAVE;
923e4eb5 2810 if (IN_PERL_COMPILETIME)
eb160463 2811 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
d1ca3daa 2812#ifdef OP_IN_REGISTER
6b88bc9c 2813 op = PL_opsave;
d1ca3daa 2814#endif
c277df42
IZ
2815 return rop;
2816}
2817
a3985cdc
DM
2818
2819/*
2820=for apidoc find_runcv
2821
2822Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM
2823If db_seqp is non_null, skip CVs that are in the DB package and populate
2824*db_seqp with the cop sequence number at the point that the DB:: code was
2825entered. (allows debuggers to eval in the scope of the breakpoint rather
8006bbc3 2826than in in the scope of the debugger itself).
a3985cdc
DM
2827
2828=cut
2829*/
2830
2831CV*
d819b83a 2832Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 2833{
a3985cdc 2834 PERL_SI *si;
a3985cdc 2835
d819b83a
DM
2836 if (db_seqp)
2837 *db_seqp = PL_curcop->cop_seq;
a3985cdc 2838 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 2839 I32 ix;
a3985cdc 2840 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 2841 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a
DM
2842 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2843 CV *cv = cx->blk_sub.cv;
2844 /* skip DB:: code */
2845 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2846 *db_seqp = cx->blk_oldcop->cop_seq;
2847 continue;
2848 }
2849 return cv;
2850 }
a3985cdc
DM
2851 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2852 return PL_compcv;
2853 }
2854 }
2855 return PL_main_cv;
2856}
2857
2858
2859/* Compile a require/do, an eval '', or a /(?{...})/.
2860 * In the last case, startop is non-null, and contains the address of
2861 * a pointer that should be set to the just-compiled code.
2862 * outside is the lexically enclosing CV (if any) that invoked us.
2863 */
2864
4d1ff10f 2865/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2866STATIC OP *
a3985cdc 2867S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 2868{
27da23d5 2869 dVAR; dSP;
533c011a 2870 OP *saveop = PL_op;
a0d0e21e 2871
6dc8a9e4
IZ
2872 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2873 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2874 : EVAL_INEVAL);
a0d0e21e 2875
1ce6579f
PP
2876 PUSHMARK(SP);
2877
3280af22
NIS
2878 SAVESPTR(PL_compcv);
2879 PL_compcv = (CV*)NEWSV(1104,0);
2880 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2881 CvEVAL_on(PL_compcv);
2090ab20
JH
2882 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2883 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2884
a3985cdc 2885 CvOUTSIDE_SEQ(PL_compcv) = seq;
7dafbf52 2886 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
a3985cdc 2887
dd2155a4 2888 /* set up a scratch pad */
a0d0e21e 2889
dd2155a4 2890 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2c05e328 2891
07055b4c 2892
26d9b02f 2893 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2894
a0d0e21e
LW
2895 /* make sure we compile in the right package */
2896
ed094faf 2897 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2898 SAVESPTR(PL_curstash);
ed094faf 2899 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2900 }
3280af22
NIS
2901 SAVESPTR(PL_beginav);
2902 PL_beginav = newAV();
2903 SAVEFREESV(PL_beginav);
24944567 2904 SAVEI32(PL_error_count);
a0d0e21e
LW
2905
2906 /* try to compile it */
2907
3280af22
NIS
2908 PL_eval_root = Nullop;
2909 PL_error_count = 0;
2910 PL_curcop = &PL_compiling;
2911 PL_curcop->cop_arybase = 0;
c277df42 2912 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2913 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2914 else
38a03e6e 2915 sv_setpv(ERRSV,"");
3280af22 2916 if (yyparse() || PL_error_count || !PL_eval_root) {
0c58d367 2917 SV **newsp; /* Used by POPBLOCK. */
4d8b06f1 2918 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2919 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2920 STRLEN n_a;
bfed75c6 2921
533c011a 2922 PL_op = saveop;
3280af22
NIS
2923 if (PL_eval_root) {
2924 op_free(PL_eval_root);
2925 PL_eval_root = Nullop;
a0d0e21e 2926 }
3280af22 2927 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2928 if (!startop) {
3280af22 2929 POPBLOCK(cx,PL_curpm);
c277df42 2930 POPEVAL(cx);
c277df42 2931 }
a0d0e21e
LW
2932 lex_end();
2933 LEAVE;
7a2e2cd6 2934 if (optype == OP_REQUIRE) {
06b5626a 2935 const char* msg = SvPVx(ERRSV, n_a);
4d8b06f1
RD
2936 SV *nsv = cx->blk_eval.old_namesv;
2937 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
27bcc0a7 2938 &PL_sv_undef, 0);
5a844595
GS
2939 DIE(aTHX_ "%sCompilation failed in require",
2940 *msg ? msg : "Unknown error\n");
2941 }
2942 else if (startop) {
06b5626a 2943 const char* msg = SvPVx(ERRSV, n_a);
c277df42 2944
3280af22 2945 POPBLOCK(cx,PL_curpm);
c277df42 2946 POPEVAL(cx);
5a844595
GS
2947 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2948 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2949 }
9d7f88dd 2950 else {
06b5626a 2951 const char* msg = SvPVx(ERRSV, n_a);
9d7f88dd
SR
2952 if (!*msg) {
2953 sv_setpv(ERRSV, "Compilation error");
2954 }
2955 }
a0d0e21e
LW
2956 RETPUSHUNDEF;
2957 }
57843af0 2958 CopLINE_set(&PL_compiling, 0);
c277df42 2959 if (startop) {
3280af22 2960 *startop = PL_eval_root;
c277df42 2961 } else
3280af22 2962 SAVEFREEOP(PL_eval_root);
0c58d367
RGS
2963
2964 /* Set the context for this new optree.
2965 * If the last op is an OP_REQUIRE, force scalar context.
2966 * Otherwise, propagate the context from the eval(). */
2967 if (PL_eval_root->op_type == OP_LEAVEEVAL
2968 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2969 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2970 == OP_REQUIRE)
2971 scalar(PL_eval_root);
2972 else if (gimme & G_VOID)
3280af22 2973 scalarvoid(PL_eval_root);
54310121 2974 else if (gimme & G_ARRAY)
3280af22 2975 list(PL_eval_root);
a0d0e21e 2976 else
3280af22 2977 scalar(PL_eval_root);
a0d0e21e
LW
2978
2979 DEBUG_x(dump_eval());
2980
55497cff 2981 /* Register with debugger: */
84902520 2982 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2983 CV *cv = get_cv("DB::postponed", FALSE);
55497cff
PP
2984 if (cv) {
2985 dSP;
924508f0 2986 PUSHMARK(SP);
cc49e20b 2987 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2988 PUTBACK;
864dbfa3 2989 call_sv((SV*)cv, G_DISCARD);
55497cff
PP
2990 }
2991 }
2992
a0d0e21e
LW
2993 /* compiled okay, so do it */
2994
3280af22
NIS
2995 CvDEPTH(PL_compcv) = 1;
2996 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2997 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 2998 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 2999
3280af22 3000 RETURNOP(PL_eval_start);
a0d0e21e
LW
3001}
3002
a6c40364 3003STATIC PerlIO *
7925835c 3004S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3005{
7925835c 3006#ifndef PERL_DISABLE_PMC
b295d113
TH
3007 STRLEN namelen = strlen(name);
3008 PerlIO *fp;
3009
7894fbab 3010 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 3011 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
06b5626a 3012 const char * const pmc = SvPV_nolen(pmcsv);
b295d113 3013 Stat_t pmstat;
a6c40364
GS
3014 Stat_t pmcstat;
3015 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 3016 fp = PerlIO_open(name, mode);
a6c40364
GS
3017 }
3018 else {
b295d113 3019 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS
3020 pmstat.st_mtime < pmcstat.st_mtime)
3021 {
3022 fp = PerlIO_open(pmc, mode);
3023 }
3024 else {
3025 fp = PerlIO_open(name, mode);
3026 }
b295d113 3027 }
a6c40364
GS
3028 SvREFCNT_dec(pmcsv);
3029 }
3030 else {
3031 fp = PerlIO_open(name, mode);
b295d113 3032 }
b295d113 3033 return fp;
7925835c
RGS
3034#else
3035 return PerlIO_open(name, mode);
3036#endif /* !PERL_DISABLE_PMC */
b295d113
TH
3037}
3038
a0d0e21e
LW
3039PP(pp_require)
3040{
27da23d5 3041 dVAR; dSP;
c09156bb 3042 register PERL_CONTEXT *cx;
a0d0e21e
LW
3043 SV *sv;
3044 char *name;
6132ea6c 3045 STRLEN len;
9c5ffd7c 3046 char *tryname = Nullch;
46fc3d4c 3047 SV *namesv = Nullsv;
a0d0e21e 3048 SV** svp;
986b19de 3049 I32 gimme = GIMME_V;
760ac839 3050 PerlIO *tryrsfp = 0;
2d8e6c8d 3051 STRLEN n_a;
bbed91b5
KF
3052 int filter_has_file = 0;
3053 GV *filter_child_proc = 0;
3054 SV *filter_state = 0;
3055 SV *filter_sub = 0;
89ccab8c 3056 SV *hook_sv = 0;
6ec9efec
JH
3057 SV *encoding;
3058 OP *op;
a0d0e21e
LW
3059
3060 sv = POPs;
d7aa5382
JP
3061 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3062 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
9014280d 3063 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 3064 "v-string in use/require non-portable");
d7aa5382
JP
3065
3066 sv = new_version(sv);
3067 if (!sv_derived_from(PL_patchlevel, "version"))
3068 (void *)upg_version(PL_patchlevel);
3069 if ( vcmp(sv,PL_patchlevel) > 0 )
014ead4b 3070 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
d7aa5382
JP
3071 vstringify(sv), vstringify(PL_patchlevel));
3072
4305d8ab 3073 RETPUSHYES;
a0d0e21e 3074 }
6132ea6c
GS
3075 name = SvPV(sv, len);
3076 if (!(name && len > 0 && *name))
cea2e8a9 3077 DIE(aTHX_ "Null filename used");
4633a7c4 3078 TAINT_PROPER("require");
533c011a 3079 if (PL_op->op_type == OP_REQUIRE &&
27bcc0a7
RGS
3080 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3081 if (*svp != &PL_sv_undef)
4d8b06f1
RD
3082 RETPUSHYES;
3083 else
3084 DIE(aTHX_ "Compilation failed in require");
3085 }
a0d0e21e
LW
3086
3087 /* prepare to compile file */
3088
be4b629d 3089 if (path_is_absolute(name)) {
46fc3d4c 3090 tryname = name;
7925835c 3091 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
bf4acbe4 3092 }
67627c52
JH
3093#ifdef MACOS_TRADITIONAL
3094 if (!tryrsfp) {
3095 char newname[256];
3096
3097 MacPerl_CanonDir(name, newname, 1);
3098 if (path_is_absolute(newname)) {
3099 tryname = newname;
7925835c 3100 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
67627c52
JH
3101 }
3102 }
3103#endif
be4b629d 3104 if (!tryrsfp) {
3280af22 3105 AV *ar = GvAVn(PL_incgv);
a0d0e21e 3106 I32 i;
748a9306 3107#ifdef VMS
46fc3d4c
PP
3108 char *unixname;
3109 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3110#endif
3111 {
3112 namesv = NEWSV(806, 0);
3113 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF
3114 SV *dirsv = *av_fetch(ar, i, TRUE);
3115
3116 if (SvROK(dirsv)) {
3117 int count;
3118 SV *loader = dirsv;
3119
e14e2dc8
NC
3120 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3121 && !sv_isobject(loader))
3122 {
bbed91b5
KF
3123 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3124 }
3125
b900a521 3126 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3127 PTR2UV(SvRV(dirsv)), name);
bbed91b5
KF
3128 tryname = SvPVX(namesv);
3129 tryrsfp = 0;
3130
3131 ENTER;
3132 SAVETMPS;
3133 EXTEND(SP, 2);
3134
3135 PUSHMARK(SP);
3136 PUSHs(dirsv);
3137 PUSHs(sv);
3138 PUTBACK;
e982885c
NC
3139 if (sv_isobject(loader))
3140 count = call_method("INC", G_ARRAY);
3141 else
3142 count = call_sv(loader, G_ARRAY);
bbed91b5
KF
3143 SPAGAIN;
3144
3145 if (count > 0) {
3146 int i = 0;
3147 SV *arg;
3148
3149 SP -= count - 1;
3150 arg = SP[i++];
3151
3152 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3153 arg = SvRV(arg);
3154 }
3155
3156 if (SvTYPE(arg) == SVt_PVGV) {
3157 IO *io = GvIO((GV *)arg);
3158
3159 ++filter_has_file;
3160
3161 if (io) {
3162 tryrsfp = IoIFP(io);
50952442 3163 if (IoTYPE(io) == IoTYPE_PIPE) {
bbed91b5
KF
3164 /* reading from a child process doesn't
3165 nest -- when returning from reading
3166 the inner module, the outer one is
3167 unreadable (closed?) I've tried to
3168 save the gv to manage the lifespan of
3169 the pipe, but this didn't help. XXX */
3170 filter_child_proc = (GV *)arg;
520c758a 3171 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF
3172 }
3173 else {
3174 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3175 PerlIO_close(IoOFP(io));
3176 }
3177 IoIFP(io) = Nullfp;
3178 IoOFP(io) = Nullfp;
3179 }
3180 }
3181
3182 if (i < count) {
3183 arg = SP[i++];
3184 }
3185 }
3186
3187 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3188 filter_sub = arg;
520c758a 3189 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF
3190
3191 if (i < count) {
3192 filter_state = SP[i];
520c758a 3193 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF
3194 }
3195
3196 if (tryrsfp == 0) {
3197 tryrsfp = PerlIO_open("/dev/null",
3198 PERL_SCRIPT_MODE);
3199 }
3200 }
1d06aecd 3201 SP--;
bbed91b5
KF
3202 }
3203
3204 PUTBACK;
3205 FREETMPS;
3206 LEAVE;
3207
3208 if (tryrsfp) {
89ccab8c 3209 hook_sv = dirsv;
bbed91b5
KF
3210 break;
3211 }
3212
3213 filter_has_file = 0;
3214 if (filter_child_proc) {
3215 SvREFCNT_dec(filter_child_proc);
3216 filter_child_proc = 0;
3217 }
3218 if (filter_state) {
3219 SvREFCNT_dec(filter_state);
3220 filter_state = 0;
3221 }
3222 if (filter_sub) {
3223 SvREFCNT_dec(filter_sub);
3224 filter_sub = 0;
3225 }
3226 }
3227 else {
be4b629d
CN
3228 if (!path_is_absolute(name)
3229#ifdef MACOS_TRADITIONAL
3230 /* We consider paths of the form :a:b ambiguous and interpret them first
3231 as global then as local
3232 */
3233 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3234#endif
3235 ) {
bbed91b5 3236 char *dir = SvPVx(dirsv, n_a);
bf4acbe4 3237#ifdef MACOS_TRADITIONAL
67627c52
JH
3238 char buf1[256];
3239 char buf2[256];
3240
3241 MacPerl_CanonDir(name, buf2, 1);
3242 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3243#else
27da23d5 3244# ifdef VMS
bbed91b5
KF
3245 char *unixdir;
3246 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3247 continue;
3248 sv_setpv(namesv, unixdir);
3249 sv_catpv(namesv, unixname);
27da23d5
JH
3250# else
3251# ifdef SYMBIAN
3252 if (PL_origfilename[0] &&
3253 PL_origfilename[1] == ':' &&
3254 !(dir[0] && dir[1] == ':'))
3255 Perl_sv_setpvf(aTHX_ namesv,
3256 "%c:%s\\%s",
3257 PL_origfilename[0],
3258 dir, name);
3259 else
3260 Perl_sv_setpvf(aTHX_ namesv,
3261 "%s\\%s",
3262 dir, name);
3263# else
bbed91b5 3264 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
27da23d5
JH
3265# endif
3266# endif
bf4acbe4 3267#endif
bbed91b5
KF
3268 TAINT_PROPER("require");
3269 tryname = SvPVX(namesv);
7925835c 3270 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
bbed91b5
KF
3271 if (tryrsfp) {
3272 if (tryname[0] == '.' && tryname[1] == '/')
3273 tryname += 2;
3274 break;
3275 }
be4b629d 3276 }
46fc3d4c 3277 }
a0d0e21e
LW
3278 }
3279 }
3280 }
f4dd75d9 3281 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3282 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3283 SvREFCNT_dec(namesv);
a0d0e21e 3284 if (!tryrsfp) {
533c011a 3285 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS
3286 char *msgstr = name;
3287 if (namesv) { /* did we lookup @INC? */
3288 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3289 SV *dirmsgsv = NEWSV(0, 0);
3290 AV *ar = GvAVn(PL_incgv);
3291 I32 i;
3292 sv_catpvn(msg, " in @INC", 8);
3293 if (instr(SvPVX(msg), ".h "))
3294 sv_catpv(msg, " (change .h to .ph maybe?)");
3295 if (instr(SvPVX(msg), ".ph "))
3296 sv_catpv(msg, " (did you run h2ph?)");
3297 sv_catpv(msg, " (@INC contains:");
3298 for (i = 0; i <= AvFILL(ar); i++) {
3299 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 3300 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS
3301 sv_catsv(msg, dirmsgsv);
3302 }
3303 sv_catpvn(msg, ")", 1);
3304 SvREFCNT_dec(dirmsgsv);
3305 msgstr = SvPV_nolen(msg);
2683423c 3306 }
ea071790 3307 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW
3308 }
3309
3310 RETPUSHUNDEF;
3311 }
d8bfb8bd 3312 else
93189314 3313 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW
3314
3315 /* Assume success here to prevent recursive requirement. */
d3a4e64e
RGS
3316 len = strlen(name);
3317 /* Check whether a hook in @INC has already filled %INC */
3318 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3319 (void)hv_store(GvHVn(PL_incgv), name, len,
3320 (hook_sv ? SvREFCNT_inc(hook_sv)
3321 : newSVpv(CopFILE(&PL_compiling), 0)),
3322 0 );
3323 }
a0d0e21e
LW
3324
3325 ENTER;
3326 SAVETMPS;
79cb57f6 3327 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS
3328 SAVEGENERICSV(PL_rsfp_filters);
3329 PL_rsfp_filters = Nullav;
e50aee73 3330
3280af22 3331 PL_rsfp = tryrsfp;
b3ac6de7 3332 SAVEHINTS();
3280af22 3333 PL_hints = 0;
7766f137 3334 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3335 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3336 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3337 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3338 PL_compiling.cop_warnings = pWARN_NONE ;
317ea90d
MS
3339 else if (PL_taint_warn)
3340 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
ac27b0f5 3341 else
d3a7d8c7 3342 PL_compiling.cop_warnings = pWARN_STD ;
ac27b0f5
NIS
3343 SAVESPTR(PL_compiling.cop_io);
3344 PL_compiling.cop_io = Nullsv;
a0d0e21e 3345
bbed91b5
KF
3346 if (filter_sub || filter_child_proc) {
3347 SV *datasv = filter_add(run_user_filter, Nullsv);
3348 IoLINES(datasv) = filter_has_file;
3349 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3350 IoTOP_GV(datasv) = (GV *)filter_state;
3351 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3352 }
3353
3354 /* switch to eval mode */
a0d0e21e 3355 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3356 PUSHEVAL(cx, name, Nullgv);
f39bc417 3357 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 3358
57843af0
GS
3359 SAVECOPLINE(&PL_compiling);
3360 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW
3361
3362 PUTBACK;
6ec9efec
JH
3363
3364 /* Store and reset encoding. */
3365 encoding = PL_encoding;
3366 PL_encoding = Nullsv;
3367
a3985cdc 3368 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
bfed75c6 3369
6ec9efec
JH
3370 /* Restore encoding. */
3371 PL_encoding = encoding;
3372
3373 return op;
a0d0e21e
LW
3374}
3375
3376PP(pp_dofile)
3377{
cea2e8a9 3378 return pp_require();
a0d0e21e
LW
3379}
3380
3381PP(pp_entereval)
3382{
27da23d5 3383 dVAR; dSP;
c09156bb 3384 register PERL_CONTEXT *cx;
a0d0e21e 3385 dPOPss;
3280af22 3386 I32 gimme = GIMME_V, was = PL_sub_generation;
83ee9e09
GS
3387 char tbuf[TYPE_DIGITS(long) + 12];
3388 char *tmpbuf = tbuf;
fc36a67e 3389 char *safestr;
a0d0e21e 3390 STRLEN len;
55497cff 3391 OP *ret;
a3985cdc 3392 CV* runcv;
d819b83a 3393 U32 seq;
a0d0e21e 3394
16a5162e 3395 if (!SvPV(sv,len))
a0d0e21e 3396 RETPUSHUNDEF;
748a9306 3397 TAINT_PROPER("eval");
a0d0e21e
LW
3398
3399 ENTER;
a0d0e21e 3400 lex_start(sv);
748a9306 3401 SAVETMPS;
ac27b0f5 3402
a0d0e21e
LW
3403 /* switch to eval mode */
3404
83ee9e09
GS
3405 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3406 SV *sv = sv_newmortal();
3407 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3408 (unsigned long)++PL_evalseq,
3409 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3410 tmpbuf = SvPVX(sv);
3411 }
3412 else
3413 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 3414 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3415 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3416 SAVECOPLINE(&PL_compiling);
57843af0 3417 CopLINE_set(&PL_compiling, 1);
55497cff
PP
3418 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3419 deleting the eval's FILEGV from the stash before gv_check() runs
3420 (i.e. before run-time proper). To work around the coredump that
3421 ensues, we always turn GvMULTI_on for any globals that were
3422 introduced within evals. See force_ident(). GSAR 96-10-12 */
3423 safestr = savepv(tmpbuf);
3280af22 3424 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3425 SAVEHINTS();
533c011a 3426 PL_hints = PL_op->op_targ;
7766f137 3427 SAVESPTR(PL_compiling.cop_warnings);
f0a6fc86
GS
3428 if (specialWARN(PL_curcop->cop_warnings))
3429 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3430 else {
3431 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3432 SAVEFREESV(PL_compiling.cop_warnings);
599cee73 3433 }
ac27b0f5
NIS
3434 SAVESPTR(PL_compiling.cop_io);
3435 if (specialCopIO(PL_curcop->cop_io))
3436 PL_compiling.cop_io = PL_curcop->cop_io;
3437 else {
3438 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3439 SAVEFREESV(PL_compiling.cop_io);
3440 }
d819b83a
DM
3441 /* special case: an eval '' executed within the DB package gets lexically
3442 * placed in the first non-DB CV rather than the current CV - this
3443 * allows the debugger to execute code, find lexicals etc, in the
3444 * scope of the code being debugged. Passing &seq gets find_runcv
3445 * to do the dirty work for us */
3446 runcv = find_runcv(&seq);
a0d0e21e 3447
6b35e009 3448 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3449 PUSHEVAL(cx, 0, Nullgv);
f39bc417 3450 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e
LW
3451
3452 /* prepare to compile string */
3453
3280af22 3454 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3455 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3456 PUTBACK;
d819b83a 3457 ret = doeval(gimme, NULL, runcv, seq);
eb160463 3458 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
533c011a 3459 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff
PP
3460 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3461 }
1e422769 3462 return DOCATCH(ret);
a0d0e21e
LW
3463}
3464
3465PP(pp_leaveeval)
3466{
27da23d5 3467 dVAR; dSP;
a0d0e21e
LW
3468 register SV **mark;
3469 SV **newsp;
3470 PMOP *newpm;
3471 I32 gimme;
c09156bb 3472 register PERL_CONTEXT *cx;
a0d0e21e 3473 OP *retop;
06b5626a 3474 const U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW
3475 I32 optype;
3476
3477 POPBLOCK(cx,newpm);
3478 POPEVAL(cx);
f39bc417 3479 retop = cx->blk_eval.retop;
a0d0e21e 3480
a1f49e72 3481 TAINT_NOT;
54310121
PP
3482 if (gimme == G_VOID)
3483 MARK = newsp;
3484 else if (gimme == G_SCALAR) {
3485 MARK = newsp + 1;
3486 if (MARK <= SP) {
3487 if (SvFLAGS(TOPs) & SVs_TEMP)
3488 *MARK = TOPs;
3489 else
3490 *MARK = sv_mortalcopy(TOPs);
3491 }
a0d0e21e 3492 else {
54310121 3493 MEXTEND(mark,0);
3280af22 3494 *MARK = &PL_sv_undef;
a0d0e21e 3495 }
a7ec2b44 3496 SP = MARK;
a0d0e21e
LW
3497 }
3498 else {
a1f49e72
CS
3499 /* in case LEAVE wipes old return values */
3500 for (mark = newsp + 1; mark <= SP; mark++) {
3501 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3502 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
3503 TAINT_NOT; /* Each item is independent */
3504 }
3505 }
a0d0e21e 3506 }
3280af22 3507 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3508
4fdae800 3509#ifdef DEBUGGING
3280af22 3510 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3511#endif