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