This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #34976] substr uses utf8 length cache incorrectly
[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 }
f880fe2f 247 SvPV_set(targ, SvPVX(dstr));
748a9306
LW
248 SvCUR_set(targ, SvCUR(dstr));
249 SvLEN_set(targ, SvLEN(dstr));
1aa99e6b
IH
250 if (DO_UTF8(dstr))
251 SvUTF8_on(targ);
f880fe2f 252 SvPV_set(dstr, (char*)0);
748a9306 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
06b5626a 1198S_dopoptolabel(pTHX_ const char *label)
a0d0e21e
LW
1199{
1200 register I32 i;
a0d0e21e
LW
1201
1202 for (i = cxstack_ix; i >= 0; i--) {
06b5626a 1203 register const PERL_CONTEXT *cx = &cxstack[i];
6b35e009 1204 switch (CxTYPE(cx)) {
a0d0e21e 1205 case CXt_SUBST:
a0d0e21e 1206 case CXt_SUB:
7766f137 1207 case CXt_FORMAT:
a0d0e21e 1208 case CXt_EVAL:
0a753a76 1209 case CXt_NULL:
e476b1b5 1210 if (ckWARN(WARN_EXITING))
515afda2
NC
1211 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1212 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1213 if (CxTYPE(cx) == CXt_NULL)
1214 return -1;
1215 break;
a0d0e21e
LW
1216 case CXt_LOOP:
1217 if (!cx->blk_loop.label ||
1218 strNE(label, cx->blk_loop.label) ) {
cea2e8a9 1219 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
68dc0745 1220 (long)i, cx->blk_loop.label));
a0d0e21e
LW
1221 continue;
1222 }
cea2e8a9 1223 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW
1224 return i;
1225 }
1226 }
1227 return i;
1228}
1229
e50aee73 1230I32
864dbfa3 1231Perl_dowantarray(pTHX)
e50aee73 1232{
54310121
PP
1233 I32 gimme = block_gimme();
1234 return (gimme == G_VOID) ? G_SCALAR : gimme;
1235}
1236
1237I32
864dbfa3 1238Perl_block_gimme(pTHX)
54310121 1239{
06b5626a 1240 const I32 cxix = dopoptosub(cxstack_ix);
e50aee73 1241 if (cxix < 0)
46fc3d4c 1242 return G_VOID;
e50aee73 1243
54310121 1244 switch (cxstack[cxix].blk_gimme) {
d2719217
GS
1245 case G_VOID:
1246 return G_VOID;
54310121 1247 case G_SCALAR:
e50aee73 1248 return G_SCALAR;
54310121
PP
1249 case G_ARRAY:
1250 return G_ARRAY;
1251 default:
cea2e8a9 1252 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS
1253 /* NOTREACHED */
1254 return 0;
54310121 1255 }
e50aee73
AD
1256}
1257
78f9721b
SM
1258I32
1259Perl_is_lvalue_sub(pTHX)
1260{
06b5626a 1261 const I32 cxix = dopoptosub(cxstack_ix);
78f9721b
SM
1262 assert(cxix >= 0); /* We should only be called from inside subs */
1263
1264 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1265 return cxstack[cxix].blk_sub.lval;
1266 else
1267 return 0;
1268}
1269
76e3520e 1270STATIC I32
cea2e8a9 1271S_dopoptosub(pTHX_ I32 startingblock)
a0d0e21e 1272{
2c375eb9
GS
1273 return dopoptosub_at(cxstack, startingblock);
1274}
1275
1276STATIC I32
cea2e8a9 1277S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9 1278{
a0d0e21e 1279 I32 i;
a0d0e21e 1280 for (i = startingblock; i >= 0; i--) {
06b5626a 1281 register const PERL_CONTEXT *cx = &cxstk[i];
6b35e009 1282 switch (CxTYPE(cx)) {
a0d0e21e
LW
1283 default:
1284 continue;
1285 case CXt_EVAL:
1286 case CXt_SUB:
7766f137 1287 case CXt_FORMAT:
cea2e8a9 1288 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW
1289 return i;
1290 }
1291 }
1292 return i;
1293}
1294
76e3520e 1295STATIC I32
cea2e8a9 1296S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e
LW
1297{
1298 I32 i;
a0d0e21e 1299 for (i = startingblock; i >= 0; i--) {
06b5626a 1300 register const PERL_CONTEXT *cx = &cxstack[i];
6b35e009 1301 switch (CxTYPE(cx)) {
a0d0e21e
LW
1302 default:
1303 continue;
1304 case CXt_EVAL:
cea2e8a9 1305 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW
1306 return i;
1307 }
1308 }
1309 return i;
1310}
1311
76e3520e 1312STATIC I32
cea2e8a9 1313S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e
LW
1314{
1315 I32 i;
a0d0e21e 1316 for (i = startingblock; i >= 0; i--) {
06b5626a 1317 register const PERL_CONTEXT *cx = &cxstack[i];
6b35e009 1318 switch (CxTYPE(cx)) {
a0d0e21e 1319 case CXt_SUBST:
a0d0e21e 1320 case CXt_SUB:
7766f137 1321 case CXt_FORMAT:
a0d0e21e 1322 case CXt_EVAL:
0a753a76 1323 case CXt_NULL:
e476b1b5 1324 if (ckWARN(WARN_EXITING))
515afda2
NC
1325 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1326 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1327 if ((CxTYPE(cx)) == CXt_NULL)
1328 return -1;
1329 break;
a0d0e21e 1330 case CXt_LOOP:
cea2e8a9 1331 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW
1332 return i;
1333 }
1334 }
1335 return i;
1336}
1337
1338void
864dbfa3 1339Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1340{
a0d0e21e
LW
1341 I32 optype;
1342
1343 while (cxstack_ix > cxix) {
b0d9ce38 1344 SV *sv;
06b5626a 1345 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c90c0ff4 1346 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1347 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1348 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1349 switch (CxTYPE(cx)) {
c90c0ff4
PP
1350 case CXt_SUBST:
1351 POPSUBST(cx);
1352 continue; /* not break */
a0d0e21e 1353 case CXt_SUB:
b0d9ce38
GS
1354 POPSUB(cx,sv);
1355 LEAVESUB(sv);
a0d0e21e
LW
1356 break;
1357 case CXt_EVAL:
1358 POPEVAL(cx);
1359 break;
1360 case CXt_LOOP:
1361 POPLOOP(cx);
1362 break;
0a753a76 1363 case CXt_NULL:
a0d0e21e 1364 break;
7766f137
GS
1365 case CXt_FORMAT:
1366 POPFORMAT(cx);
1367 break;
a0d0e21e 1368 }
c90c0ff4 1369 cxstack_ix--;
a0d0e21e
LW
1370 }
1371}
1372
5a844595
GS
1373void
1374Perl_qerror(pTHX_ SV *err)
1375{
1376 if (PL_in_eval)
1377 sv_catsv(ERRSV, err);
1378 else if (PL_errors)
1379 sv_catsv(PL_errors, err);
1380 else
894356b3 1381 Perl_warn(aTHX_ "%"SVf, err);
5a844595
GS
1382 ++PL_error_count;
1383}
1384
a0d0e21e 1385OP *
35a4481c 1386Perl_die_where(pTHX_ const char *message, STRLEN msglen)
a0d0e21e 1387{
2d8e6c8d 1388 STRLEN n_a;
87582a92 1389
3280af22 1390 if (PL_in_eval) {
a0d0e21e 1391 I32 cxix;
a0d0e21e
LW
1392 I32 gimme;
1393 SV **newsp;
1394
4e6ea2c3 1395 if (message) {
faef0170 1396 if (PL_in_eval & EVAL_KEEPERR) {
bfed75c6 1397 static const char prefix[] = "\t(in cleanup) ";
98eae8f5 1398 SV *err = ERRSV;
06b5626a 1399 const char *e = Nullch;
98eae8f5
GS
1400 if (!SvPOK(err))
1401 sv_setpv(err,"");
1402 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1403 e = SvPV(err, n_a);
1404 e += n_a - msglen;
1405 if (*e != *message || strNE(e,message))
1406 e = Nullch;
1407 }
1408 if (!e) {
1409 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1410 sv_catpvn(err, prefix, sizeof(prefix)-1);
1411 sv_catpvn(err, message, msglen);
e476b1b5 1412 if (ckWARN(WARN_MISC)) {
98eae8f5 1413 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
9014280d 1414 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
4e6ea2c3 1415 }
4633a7c4 1416 }
4633a7c4 1417 }
1aa99e6b 1418 else {
06bf62c7 1419 sv_setpvn(ERRSV, message, msglen);
1aa99e6b 1420 }
4633a7c4 1421 }
4e6ea2c3 1422
5a844595
GS
1423 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1424 && PL_curstackinfo->si_prev)
1425 {
bac4b2ad 1426 dounwind(-1);
d3acc0f7 1427 POPSTACK;
bac4b2ad 1428 }
e336de0d 1429
a0d0e21e
LW
1430 if (cxix >= 0) {
1431 I32 optype;
35a4481c 1432 register PERL_CONTEXT *cx;
a0d0e21e
LW
1433
1434 if (cxix < cxstack_ix)
1435 dounwind(cxix);
1436
3280af22 1437 POPBLOCK(cx,PL_curpm);
6b35e009 1438 if (CxTYPE(cx) != CXt_EVAL) {
16869676
SG
1439 if (!message)
1440 message = SvPVx(ERRSV, msglen);
bf49b057
GS
1441 PerlIO_write(Perl_error_log, "panic: die ", 11);
1442 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW
1443 my_exit(1);
1444 }
1445 POPEVAL(cx);
1446
1447 if (gimme == G_SCALAR)
3280af22
NIS
1448 *++newsp = &PL_sv_undef;
1449 PL_stack_sp = newsp;
a0d0e21e
LW
1450
1451 LEAVE;
748a9306 1452
7fb6a879
GS
1453 /* LEAVE could clobber PL_curcop (see save_re_context())
1454 * XXX it might be better to find a way to avoid messing with
1455 * PL_curcop in save_re_context() instead, but this is a more
1456 * minimal fix --GSAR */
1457 PL_curcop = cx->blk_oldcop;
1458
7a2e2cd6 1459 if (optype == OP_REQUIRE) {
35a4481c
AL
1460 const char* msg = SvPVx(ERRSV, n_a);
1461 SV *nsv = cx->blk_eval.old_namesv;
1462 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
27bcc0a7 1463 &PL_sv_undef, 0);
5a844595
GS
1464 DIE(aTHX_ "%sCompilation failed in require",
1465 *msg ? msg : "Unknown error\n");
7a2e2cd6 1466 }
f39bc417
DM
1467 assert(CxTYPE(cx) == CXt_EVAL);
1468 return cx->blk_eval.retop;
a0d0e21e
LW
1469 }
1470 }
9cc2fdd3 1471 if (!message)
06bf62c7 1472 message = SvPVx(ERRSV, msglen);
87582a92 1473
7ff03255 1474 write_to_stderr(message, msglen);
f86702cc
PP
1475 my_failure_exit();
1476 /* NOTREACHED */
a0d0e21e
LW
1477 return 0;
1478}
1479
1480PP(pp_xor)
1481{
39644a26 1482 dSP; dPOPTOPssrl;
a0d0e21e
LW
1483 if (SvTRUE(left) != SvTRUE(right))
1484 RETSETYES;
1485 else
1486 RETSETNO;
1487}
1488
1489PP(pp_andassign)
1490{
39644a26 1491 dSP;
a0d0e21e
LW
1492 if (!SvTRUE(TOPs))
1493 RETURN;
1494 else
1495 RETURNOP(cLOGOP->op_other);
1496}
1497
1498PP(pp_orassign)
1499{
39644a26 1500 dSP;
a0d0e21e
LW
1501 if (SvTRUE(TOPs))
1502 RETURN;
1503 else
1504 RETURNOP(cLOGOP->op_other);
1505}
c963b151
BD
1506
1507PP(pp_dorassign)
1508{
1509 dSP;
1510 register SV* sv;
1511
1512 sv = TOPs;
1513 if (!sv || !SvANY(sv)) {
1514 RETURNOP(cLOGOP->op_other);
1515 }
1516
1517 switch (SvTYPE(sv)) {
1518 case SVt_PVAV:
1519 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1520 RETURN;
1521 break;
1522 case SVt_PVHV:
1523 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1524 RETURN;
1525 break;
1526 case SVt_PVCV:
1527 if (CvROOT(sv) || CvXSUB(sv))
1528 RETURN;
1529 break;
1530 default:
1531 if (SvGMAGICAL(sv))
1532 mg_get(sv);
1533 if (SvOK(sv))
1534 RETURN;
1535 }
1536
1537 RETURNOP(cLOGOP->op_other);
1538}
1539
a0d0e21e
LW
1540PP(pp_caller)
1541{
39644a26 1542 dSP;
a0d0e21e 1543 register I32 cxix = dopoptosub(cxstack_ix);
c09156bb 1544 register PERL_CONTEXT *cx;
2c375eb9 1545 register PERL_CONTEXT *ccstack = cxstack;
3280af22 1546 PERL_SI *top_si = PL_curstackinfo;
a0d0e21e 1547 I32 dbcxix;
54310121 1548 I32 gimme;
06b5626a 1549 const char *stashname;
a0d0e21e
LW
1550 SV *sv;
1551 I32 count = 0;
1552
1553 if (MAXARG)
1554 count = POPi;
27d41816 1555
a0d0e21e 1556 for (;;) {
2c375eb9
GS
1557 /* we may be in a higher stacklevel, so dig down deeper */
1558 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1559 top_si = top_si->si_prev;
1560 ccstack = top_si->si_cxstack;
1561 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1562 }
a0d0e21e 1563 if (cxix < 0) {
27d41816
DM
1564 if (GIMME != G_ARRAY) {
1565 EXTEND(SP, 1);
a0d0e21e 1566 RETPUSHUNDEF;
27d41816 1567 }
a0d0e21e
LW
1568 RETURN;
1569 }
f2a7f298 1570 /* caller() should not report the automatic calls to &DB::sub */
1571 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
3280af22 1572 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW
1573 count++;
1574 if (!count--)
1575 break;
2c375eb9 1576 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1577 }
2c375eb9
GS
1578
1579 cx = &ccstack[cxix];
7766f137 1580 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2c375eb9
GS
1581 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1582 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1583 field below is defined for any cx. */
f2a7f298 1584 /* caller() should not report the automatic calls to &DB::sub */
1585 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1586 cx = &ccstack[dbcxix];
06a5b730
PP
1587 }
1588
ed094faf 1589 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1590 if (GIMME != G_ARRAY) {
27d41816 1591 EXTEND(SP, 1);
ed094faf 1592 if (!stashname)
3280af22 1593 PUSHs(&PL_sv_undef);
49d8d3a1
MB
1594 else {
1595 dTARGET;
ed094faf 1596 sv_setpv(TARG, stashname);
49d8d3a1
MB
1597 PUSHs(TARG);
1598 }
a0d0e21e
LW
1599 RETURN;
1600 }
a0d0e21e 1601
27d41816
DM
1602 EXTEND(SP, 10);
1603
ed094faf 1604 if (!stashname)
3280af22 1605 PUSHs(&PL_sv_undef);
49d8d3a1 1606 else
ed094faf 1607 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
248c2a4d 1608 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
57843af0 1609 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW
1610 if (!MAXARG)
1611 RETURN;
7766f137 1612 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
07b8c804 1613 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
7766f137 1614 /* So is ccstack[dbcxix]. */
07b8c804
RGS
1615 if (isGV(cvgv)) {
1616 sv = NEWSV(49, 0);
1617 gv_efullname3(sv, cvgv, Nullch);
1618 PUSHs(sv_2mortal(sv));
1619 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1620 }
1621 else {
1622 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
72699b0f 1623 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
07b8c804 1624 }
a0d0e21e
LW
1625 }
1626 else {
79cb57f6 1627 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
a0d0e21e
LW
1628 PUSHs(sv_2mortal(newSViv(0)));
1629 }
54310121
PP
1630 gimme = (I32)cx->blk_gimme;
1631 if (gimme == G_VOID)
3280af22 1632 PUSHs(&PL_sv_undef);
54310121
PP
1633 else
1634 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1635 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1636 /* eval STRING */
06a5b730 1637 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1638 PUSHs(cx->blk_eval.cur_text);
3280af22 1639 PUSHs(&PL_sv_no);
0f79a09d 1640 }
811a4de9 1641 /* require */
0f79a09d
GS
1642 else if (cx->blk_eval.old_namesv) {
1643 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
3280af22 1644 PUSHs(&PL_sv_yes);
06a5b730 1645 }
811a4de9
GS
1646 /* eval BLOCK (try blocks have old_namesv == 0) */
1647 else {
1648 PUSHs(&PL_sv_undef);
1649 PUSHs(&PL_sv_undef);
1650 }
4633a7c4 1651 }
a682de96
GS
1652 else {
1653 PUSHs(&PL_sv_undef);
1654 PUSHs(&PL_sv_undef);
1655 }
1656 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1657 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1658 {
a0d0e21e 1659 AV *ary = cx->blk_sub.argarray;
06b5626a 1660 const int off = AvARRAY(ary) - AvALLOC(ary);
a0d0e21e 1661
3280af22 1662 if (!PL_dbargs) {
a0d0e21e 1663 GV* tmpgv;
3280af22 1664 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1665 SVt_PVAV)));
a5f75d66 1666 GvMULTI_on(tmpgv);
3ddcf04c 1667 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
a0d0e21e
LW
1668 }
1669
3280af22
NIS
1670 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1671 av_extend(PL_dbargs, AvFILLp(ary) + off);
1672 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1673 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1674 }
f3aa04c2
GS
1675 /* XXX only hints propagated via op_private are currently
1676 * visible (others are not easily accessible, since they
1677 * use the global PL_hints) */
1678 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1679 HINT_PRIVATE_MASK)));
e476b1b5
GS
1680 {
1681 SV * mask ;
1682 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba 1683
ac27b0f5 1684 if (old_warnings == pWARN_NONE ||
114bafba 1685 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1686 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
ac27b0f5 1687 else if (old_warnings == pWARN_ALL ||
75b6c4ca
RGS
1688 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1689 /* Get the bit mask for $warnings::Bits{all}, because
1690 * it could have been extended by warnings::register */
1691 SV **bits_all;
1692 HV *bits = get_hv("warnings::Bits", FALSE);
1693 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1694 mask = newSVsv(*bits_all);
1695 }
1696 else {
1697 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1698 }
1699 }
e476b1b5
GS
1700 else
1701 mask = newSVsv(old_warnings);
1702 PUSHs(sv_2mortal(mask));
1703 }
a0d0e21e
LW
1704 RETURN;
1705}
1706
a0d0e21e
LW
1707PP(pp_reset)
1708{
39644a26 1709 dSP;
bfed75c6 1710 const char *tmps;
2d8e6c8d 1711 STRLEN n_a;
a0d0e21e
LW
1712
1713 if (MAXARG < 1)
1714 tmps = "";
1715 else
2d8e6c8d 1716 tmps = POPpx;
11faa288 1717 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1718 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1719 RETURN;
1720}
1721
1722PP(pp_lineseq)
1723{
1724 return NORMAL;
1725}
1726
dd2155a4
DM
1727/* like pp_nextstate, but used instead when the debugger is active */
1728
a0d0e21e
LW
1729PP(pp_dbstate)
1730{
533c011a 1731 PL_curcop = (COP*)PL_op;
a0d0e21e 1732 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1733 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW
1734 FREETMPS;
1735
5df8de69
DM
1736 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1737 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1738 {
39644a26 1739 dSP;
a0d0e21e 1740 register CV *cv;
c09156bb 1741 register PERL_CONTEXT *cx;
748a9306 1742 I32 gimme = G_ARRAY;
eb160463 1743 U8 hasargs;
a0d0e21e
LW
1744 GV *gv;
1745
3280af22 1746 gv = PL_DBgv;
a0d0e21e 1747 cv = GvCV(gv);
a0d0e21e 1748 if (!cv)
cea2e8a9 1749 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1750
aea4f609
DM
1751 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1752 /* don't do recursive DB::DB call */
a0d0e21e 1753 return NORMAL;
748a9306 1754
4633a7c4
LW
1755 ENTER;
1756 SAVETMPS;
1757
3280af22 1758 SAVEI32(PL_debug);
55497cff 1759 SAVESTACK_POS();
3280af22 1760 PL_debug = 0;
748a9306 1761 hasargs = 0;
924508f0 1762 SPAGAIN;
748a9306 1763
924508f0 1764 PUSHBLOCK(cx, CXt_SUB, SP);
ee98a1d6 1765 PUSHSUB_DB(cx);
f39bc417 1766 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 1767 CvDEPTH(cv)++;
dd2155a4 1768 PAD_SET_CUR(CvPADLIST(cv),1);
a0d0e21e
LW
1769 RETURNOP(CvSTART(cv));
1770 }
1771 else
1772 return NORMAL;
1773}
1774
1775PP(pp_scope)
1776{
1777 return NORMAL;
1778}
1779
1780PP(pp_enteriter)
1781{
39644a26 1782 dSP; dMARK;
c09156bb 1783 register PERL_CONTEXT *cx;
54310121 1784 I32 gimme = GIMME_V;
a0d0e21e 1785 SV **svp;
7766f137
GS
1786 U32 cxtype = CXt_LOOP;
1787#ifdef USE_ITHREADS
1788 void *iterdata;
1789#endif
a0d0e21e 1790
4633a7c4
LW
1791 ENTER;
1792 SAVETMPS;
1793
533c011a 1794 if (PL_op->op_targ) {
14f338dc
DM
1795 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1796 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1797 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1798 SVs_PADSTALE, SVs_PADSTALE);
1799 }
c3564e5c 1800#ifndef USE_ITHREADS
dd2155a4 1801 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
54b9620d 1802 SAVESPTR(*svp);
c3564e5c
GS
1803#else
1804 SAVEPADSV(PL_op->op_targ);
cbfa9890 1805 iterdata = INT2PTR(void*, PL_op->op_targ);
7766f137
GS
1806 cxtype |= CXp_PADVAR;
1807#endif
54b9620d
MB
1808 }
1809 else {
7766f137
GS
1810 GV *gv = (GV*)POPs;
1811 svp = &GvSV(gv); /* symbol table variable */
0214ae40
GS
1812 SAVEGENERICSV(*svp);
1813 *svp = NEWSV(0,0);
7766f137
GS
1814#ifdef USE_ITHREADS
1815 iterdata = (void*)gv;
1816#endif
54b9620d 1817 }
4633a7c4 1818
a0d0e21e
LW
1819 ENTER;
1820
7766f137
GS
1821 PUSHBLOCK(cx, cxtype, SP);
1822#ifdef USE_ITHREADS
1823 PUSHLOOP(cx, iterdata, MARK);
1824#else
a0d0e21e 1825 PUSHLOOP(cx, svp, MARK);
7766f137 1826#endif
533c011a 1827 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1828 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA
1829 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1830 dPOPss;
4fe3f0fa
MHM
1831 SV *right = (SV*)cx->blk_loop.iterary;
1832 if (RANGE_IS_NUMERIC(sv,right)) {
1833 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1834 (SvOK(right) && SvNV(right) >= IV_MAX))
076d9a11
MHM
1835 DIE(aTHX_ "Range iterator outside integer range");
1836 cx->blk_loop.iterix = SvIV(sv);
4fe3f0fa 1837 cx->blk_loop.itermax = SvIV(right);
89ea2908 1838 }
3f63a782
MHM
1839 else {
1840 STRLEN n_a;
89ea2908 1841 cx->blk_loop.iterlval = newSVsv(sv);
4fe3f0fa
MHM
1842 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1843 (void) SvPV(right,n_a);
3f63a782 1844 }
89ea2908 1845 }
ef3e5ea9 1846 else if (PL_op->op_private & OPpITER_REVERSED) {
e682d7b7 1847 cx->blk_loop.itermax = -1;
ef3e5ea9
NC
1848 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1849
1850 }
89ea2908 1851 }
4633a7c4 1852 else {
3280af22
NIS
1853 cx->blk_loop.iterary = PL_curstack;
1854 AvFILLp(PL_curstack) = SP - PL_stack_base;
ef3e5ea9
NC
1855 if (PL_op->op_private & OPpITER_REVERSED) {
1856 cx->blk_loop.itermax = MARK - PL_stack_base;
1857 cx->blk_loop.iterix = cx->blk_oldsp;
1858 }
1859 else {
1860 cx->blk_loop.iterix = MARK - PL_stack_base;
1861 }
4633a7c4 1862 }
a0d0e21e
LW
1863
1864 RETURN;
1865}
1866
1867PP(pp_enterloop)
1868{
39644a26 1869 dSP;
c09156bb 1870 register PERL_CONTEXT *cx;
54310121 1871 I32 gimme = GIMME_V;
a0d0e21e
LW
1872
1873 ENTER;
1874 SAVETMPS;
1875 ENTER;
1876
1877 PUSHBLOCK(cx, CXt_LOOP, SP);
1878 PUSHLOOP(cx, 0, SP);
1879
1880 RETURN;
1881}
1882
1883PP(pp_leaveloop)
1884{
39644a26 1885 dSP;
c09156bb 1886 register PERL_CONTEXT *cx;
a0d0e21e
LW
1887 I32 gimme;
1888 SV **newsp;
1889 PMOP *newpm;
1890 SV **mark;
1891
1892 POPBLOCK(cx,newpm);
4fdae800 1893 mark = newsp;
a8bba7fa 1894 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1895
a1f49e72 1896 TAINT_NOT;
54310121
PP
1897 if (gimme == G_VOID)
1898 ; /* do nothing */
1899 else if (gimme == G_SCALAR) {
1900 if (mark < SP)
1901 *++newsp = sv_mortalcopy(*SP);
1902 else
3280af22 1903 *++newsp = &PL_sv_undef;
a0d0e21e
LW
1904 }
1905 else {
a1f49e72 1906 while (mark < SP) {
a0d0e21e 1907 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS
1908 TAINT_NOT; /* Each item is independent */
1909 }
a0d0e21e 1910 }
f86702cc
PP
1911 SP = newsp;
1912 PUTBACK;
1913
a8bba7fa 1914 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1915 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1916
a0d0e21e
LW
1917 LEAVE;
1918 LEAVE;
1919
f86702cc 1920 return NORMAL;
a0d0e21e
LW
1921}
1922
1923PP(pp_return)
1924{
39644a26 1925 dSP; dMARK;
a0d0e21e 1926 I32 cxix;
c09156bb 1927 register PERL_CONTEXT *cx;
f86702cc 1928 bool popsub2 = FALSE;
b45de488 1929 bool clear_errsv = FALSE;
a0d0e21e
LW
1930 I32 gimme;
1931 SV **newsp;
1932 PMOP *newpm;
1933 I32 optype = 0;
b0d9ce38 1934 SV *sv;
f39bc417 1935 OP *retop;
a0d0e21e 1936
3280af22 1937 if (PL_curstackinfo->si_type == PERLSI_SORT) {
7766f137
GS
1938 if (cxstack_ix == PL_sortcxix
1939 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1940 {
3280af22
NIS
1941 if (cxstack_ix > PL_sortcxix)
1942 dounwind(PL_sortcxix);
1943 AvARRAY(PL_curstack)[1] = *SP;
1944 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW
1945 return 0;
1946 }
1947 }
1948
1949 cxix = dopoptosub(cxstack_ix);
1950 if (cxix < 0)
cea2e8a9 1951 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW
1952 if (cxix < cxstack_ix)
1953 dounwind(cxix);
1954
1955 POPBLOCK(cx,newpm);
6b35e009 1956 switch (CxTYPE(cx)) {
a0d0e21e 1957 case CXt_SUB:
f86702cc 1958 popsub2 = TRUE;
f39bc417 1959 retop = cx->blk_sub.retop;
5dd42e15 1960 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW
1961 break;
1962 case CXt_EVAL:
b45de488
GS
1963 if (!(PL_in_eval & EVAL_KEEPERR))
1964 clear_errsv = TRUE;
a0d0e21e 1965 POPEVAL(cx);
f39bc417 1966 retop = cx->blk_eval.retop;
1d76a5c3
GS
1967 if (CxTRYBLOCK(cx))
1968 break;
067f92a0 1969 lex_end();
748a9306
LW
1970 if (optype == OP_REQUIRE &&
1971 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1972 {
54310121 1973 /* Unassume the success we assumed earlier. */
0f79a09d
GS
1974 SV *nsv = cx->blk_eval.old_namesv;
1975 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 1976 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
748a9306 1977 }
a0d0e21e 1978 break;
7766f137
GS
1979 case CXt_FORMAT:
1980 POPFORMAT(cx);
f39bc417 1981 retop = cx->blk_sub.retop;
7766f137 1982 break;
a0d0e21e 1983 default:
cea2e8a9 1984 DIE(aTHX_ "panic: return");
a0d0e21e
LW
1985 }
1986
a1f49e72 1987 TAINT_NOT;
a0d0e21e 1988 if (gimme == G_SCALAR) {
a29cdaf0
IZ
1989 if (MARK < SP) {
1990 if (popsub2) {
a8bba7fa 1991 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
1992 if (SvTEMP(TOPs)) {
1993 *++newsp = SvREFCNT_inc(*SP);
1994 FREETMPS;
1995 sv_2mortal(*newsp);
959e3673
GS
1996 }
1997 else {
1998 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 1999 FREETMPS;
959e3673
GS
2000 *++newsp = sv_mortalcopy(sv);
2001 SvREFCNT_dec(sv);
a29cdaf0 2002 }
959e3673
GS
2003 }
2004 else
a29cdaf0 2005 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS
2006 }
2007 else
a29cdaf0 2008 *++newsp = sv_mortalcopy(*SP);
959e3673
GS
2009 }
2010 else
3280af22 2011 *++newsp = &PL_sv_undef;
a0d0e21e 2012 }
54310121 2013 else if (gimme == G_ARRAY) {
a1f49e72 2014 while (++MARK <= SP) {
f86702cc
PP
2015 *++newsp = (popsub2 && SvTEMP(*MARK))
2016 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
2017 TAINT_NOT; /* Each item is independent */
2018 }
a0d0e21e 2019 }
3280af22 2020 PL_stack_sp = newsp;
a0d0e21e 2021
5dd42e15 2022 LEAVE;
f86702cc
PP
2023 /* Stack values are safe: */
2024 if (popsub2) {
5dd42e15 2025 cxstack_ix--;
b0d9ce38 2026 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2027 }
b0d9ce38
GS
2028 else
2029 sv = Nullsv;
3280af22 2030 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2031
b0d9ce38 2032 LEAVESUB(sv);
b45de488
GS
2033 if (clear_errsv)
2034 sv_setpv(ERRSV,"");
f39bc417 2035 return retop;
a0d0e21e
LW
2036}
2037
2038PP(pp_last)
2039{
39644a26 2040 dSP;
a0d0e21e 2041 I32 cxix;
c09156bb 2042 register PERL_CONTEXT *cx;
f86702cc 2043 I32 pop2 = 0;
a0d0e21e
LW
2044 I32 gimme;
2045 I32 optype;
2046 OP *nextop;
2047 SV **newsp;
2048 PMOP *newpm;
a8bba7fa 2049 SV **mark;
b0d9ce38 2050 SV *sv = Nullsv;
a0d0e21e 2051
533c011a 2052 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2053 cxix = dopoptoloop(cxstack_ix);
2054 if (cxix < 0)
a651a37d 2055 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW
2056 }
2057 else {
2058 cxix = dopoptolabel(cPVOP->op_pv);
2059 if (cxix < 0)
cea2e8a9 2060 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW
2061 }
2062 if (cxix < cxstack_ix)
2063 dounwind(cxix);
2064
2065 POPBLOCK(cx,newpm);
5dd42e15 2066 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2067 mark = newsp;
6b35e009 2068 switch (CxTYPE(cx)) {
a0d0e21e 2069 case CXt_LOOP:
f86702cc 2070 pop2 = CXt_LOOP;
a8bba7fa
GS
2071 newsp = PL_stack_base + cx->blk_loop.resetsp;
2072 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 2073 break;
f86702cc 2074 case CXt_SUB:
f86702cc 2075 pop2 = CXt_SUB;
f39bc417 2076 nextop = cx->blk_sub.retop;
a0d0e21e 2077 break;
f86702cc
PP
2078 case CXt_EVAL:
2079 POPEVAL(cx);
f39bc417 2080 nextop = cx->blk_eval.retop;
a0d0e21e 2081 break;
7766f137
GS
2082 case CXt_FORMAT:
2083 POPFORMAT(cx);
f39bc417 2084 nextop = cx->blk_sub.retop;
7766f137 2085 break;
a0d0e21e 2086 default:
cea2e8a9 2087 DIE(aTHX_ "panic: last");
a0d0e21e
LW
2088 }
2089
a1f49e72 2090 TAINT_NOT;
a0d0e21e 2091 if (gimme == G_SCALAR) {
f86702cc
PP
2092 if (MARK < SP)
2093 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2094 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2095 else
3280af22 2096 *++newsp = &PL_sv_undef;
a0d0e21e 2097 }
54310121 2098 else if (gimme == G_ARRAY) {
a1f49e72 2099 while (++MARK <= SP) {
f86702cc
PP
2100 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2101 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
2102 TAINT_NOT; /* Each item is independent */
2103 }
f86702cc
PP
2104 }
2105 SP = newsp;
2106 PUTBACK;
2107
5dd42e15
DM
2108 LEAVE;
2109 cxstack_ix--;
f86702cc
PP
2110 /* Stack values are safe: */
2111 switch (pop2) {
2112 case CXt_LOOP:
a8bba7fa 2113 POPLOOP(cx); /* release loop vars ... */
4fdae800 2114 LEAVE;
f86702cc
PP
2115 break;
2116 case CXt_SUB:
b0d9ce38 2117 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2118 break;
a0d0e21e 2119 }
3280af22 2120 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2121
b0d9ce38 2122 LEAVESUB(sv);
f86702cc 2123 return nextop;
a0d0e21e
LW
2124}
2125
2126PP(pp_next)
2127{
2128 I32 cxix;
c09156bb 2129 register PERL_CONTEXT *cx;
85538317 2130 I32 inner;
a0d0e21e 2131
533c011a 2132 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2133 cxix = dopoptoloop(cxstack_ix);
2134 if (cxix < 0)
a651a37d 2135 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW
2136 }
2137 else {
2138 cxix = dopoptolabel(cPVOP->op_pv);
2139 if (cxix < 0)
cea2e8a9 2140 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW
2141 }
2142 if (cxix < cxstack_ix)
2143 dounwind(cxix);
2144
85538317
GS
2145 /* clear off anything above the scope we're re-entering, but
2146 * save the rest until after a possible continue block */
2147 inner = PL_scopestack_ix;
1ba6ee2b 2148 TOPBLOCK(cx);
85538317
GS
2149 if (PL_scopestack_ix < inner)
2150 leave_scope(PL_scopestack[PL_scopestack_ix]);
1ba6ee2b 2151 return cx->blk_loop.next_op;
a0d0e21e
LW
2152}
2153
2154PP(pp_redo)
2155{
2156 I32 cxix;
c09156bb 2157 register PERL_CONTEXT *cx;
a0d0e21e
LW
2158 I32 oldsave;
2159
533c011a 2160 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2161 cxix = dopoptoloop(cxstack_ix);
2162 if (cxix < 0)
a651a37d 2163 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW
2164 }
2165 else {
2166 cxix = dopoptolabel(cPVOP->op_pv);
2167 if (cxix < 0)
cea2e8a9 2168 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW
2169 }
2170 if (cxix < cxstack_ix)
2171 dounwind(cxix);
2172
2173 TOPBLOCK(cx);
3280af22 2174 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2175 LEAVE_SCOPE(oldsave);
936c78b5 2176 FREETMPS;
a0d0e21e
LW
2177 return cx->blk_loop.redo_op;
2178}
2179
0824fdcb 2180STATIC OP *
bfed75c6 2181S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2182{
4ea42e7f 2183 OP *kid = Nullop;
a0d0e21e 2184 OP **ops = opstack;
bfed75c6 2185 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2186
fc36a67e 2187 if (ops >= oplimit)
cea2e8a9 2188 Perl_croak(aTHX_ too_deep);
11343788
MB
2189 if (o->op_type == OP_LEAVE ||
2190 o->op_type == OP_SCOPE ||
2191 o->op_type == OP_LEAVELOOP ||
33d34e4c 2192 o->op_type == OP_LEAVESUB ||
11343788 2193 o->op_type == OP_LEAVETRY)
fc36a67e 2194 {
5dc0d613 2195 *ops++ = cUNOPo->op_first;
fc36a67e 2196 if (ops >= oplimit)
cea2e8a9 2197 Perl_croak(aTHX_ too_deep);
fc36a67e 2198 }
c4aa4e48 2199 *ops = 0;
11343788 2200 if (o->op_flags & OPf_KIDS) {
a0d0e21e 2201 /* First try all the kids at this level, since that's likeliest. */
11343788 2202 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS
2203 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2204 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW
2205 return kid;
2206 }
11343788 2207 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2208 if (kid == PL_lastgotoprobe)
a0d0e21e 2209 continue;
ed8d0fe2
SM
2210 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2211 if (ops == opstack)
2212 *ops++ = kid;
2213 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2214 ops[-1]->op_type == OP_DBSTATE)
2215 ops[-1] = kid;
2216 else
2217 *ops++ = kid;
2218 }
155aba94 2219 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2220 return o;
a0d0e21e
LW
2221 }
2222 }
c4aa4e48 2223 *ops = 0;
a0d0e21e
LW
2224 return 0;
2225}
2226
2227PP(pp_dump)
2228{
cea2e8a9 2229 return pp_goto();
a0d0e21e
LW
2230 /*NOTREACHED*/
2231}
2232
2233PP(pp_goto)
2234{
39644a26 2235 dSP;
a0d0e21e
LW
2236 OP *retop = 0;
2237 I32 ix;
c09156bb 2238 register PERL_CONTEXT *cx;
fc36a67e
PP
2239#define GOTO_DEPTH 64
2240 OP *enterops[GOTO_DEPTH];
bfed75c6
AL
2241 const char *label = 0;
2242 const bool do_dump = (PL_op->op_type == OP_DUMP);
2243 static const char must_have_label[] = "goto must have label";
a0d0e21e 2244
533c011a 2245 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2246 SV *sv = POPs;
2d8e6c8d 2247 STRLEN n_a;
a0d0e21e
LW
2248
2249 /* This egregious kludge implements goto &subroutine */
2250 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2251 I32 cxix;
c09156bb 2252 register PERL_CONTEXT *cx;
a0d0e21e
LW
2253 CV* cv = (CV*)SvRV(sv);
2254 SV** mark;
2255 I32 items = 0;
2256 I32 oldsave;
b1464ded 2257 bool reified = 0;
a0d0e21e 2258
e8f7dd13 2259 retry:
4aa0a1f7 2260 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2261 const GV * const gv = CvGV(cv);
e8f7dd13 2262 if (gv) {
7fc63493 2263 GV *autogv;
e8f7dd13
GS
2264 SV *tmpstr;
2265 /* autoloaded stub? */
2266 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2267 goto retry;
2268 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2269 GvNAMELEN(gv), FALSE);
2270 if (autogv && (cv = GvCV(autogv)))
2271 goto retry;
2272 tmpstr = sv_newmortal();
2273 gv_efullname3(tmpstr, gv, Nullch);
35c1215d 2274 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
4aa0a1f7 2275 }
cea2e8a9 2276 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD
2277 }
2278
a0d0e21e 2279 /* First do some returnish stuff. */
7fc63493 2280 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
71fc2216 2281 FREETMPS;
a0d0e21e
LW
2282 cxix = dopoptosub(cxstack_ix);
2283 if (cxix < 0)
cea2e8a9 2284 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW
2285 if (cxix < cxstack_ix)
2286 dounwind(cxix);
2287 TOPBLOCK(cx);
63b28e3f 2288 if (CxREALEVAL(cx))
cea2e8a9 2289 DIE(aTHX_ "Can't goto subroutine from an eval-string");
d8b46c1b
GS
2290 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2291 /* put @_ back onto stack */
a0d0e21e 2292 AV* av = cx->blk_sub.argarray;
bfed75c6 2293
93965878 2294 items = AvFILLp(av) + 1;
a45cdc79
DM
2295 EXTEND(SP, items+1); /* @_ could have been extended. */
2296 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS
2297 SvREFCNT_dec(GvAV(PL_defgv));
2298 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2299 CLEAR_ARGARRAY(av);
d8b46c1b 2300 /* abandon @_ if it got reified */
62b1ebc2 2301 if (AvREAL(av)) {
b1464ded
DM
2302 reified = 1;
2303 SvREFCNT_dec(av);
d8b46c1b
GS
2304 av = newAV();
2305 av_extend(av, items-1);
2306 AvFLAGS(av) = AVf_REIFY;
dd2155a4 2307 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2308 }
a0d0e21e 2309 }
1fa4e549
AD
2310 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2311 AV* av;
3280af22 2312 av = GvAV(PL_defgv);
1fa4e549 2313 items = AvFILLp(av) + 1;
a45cdc79
DM
2314 EXTEND(SP, items+1); /* @_ could have been extended. */
2315 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2316 }
a45cdc79
DM
2317 mark = SP;
2318 SP += items;
6b35e009 2319 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2320 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2321 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2322 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
2323 LEAVE_SCOPE(oldsave);
2324
2325 /* Now do some callish stuff. */
2326 SAVETMPS;
5023d17a 2327 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
a0d0e21e 2328 if (CvXSUB(cv)) {
b1464ded
DM
2329 if (reified) {
2330 I32 index;
2331 for (index=0; index<items; index++)
2332 sv_2mortal(SP[-index]);
2333 }
67caa1fe 2334#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2335 if (CvOLDSTYLE(cv)) {
20ce7b12 2336 I32 (*fp3)(int,int,int);
924508f0
GS
2337 while (SP > mark) {
2338 SP[1] = SP[0];
2339 SP--;
a0d0e21e 2340 }
7766f137 2341 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2342 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2343 mark - PL_stack_base + 1,
ecfc5424 2344 items);
3280af22 2345 SP = PL_stack_base + items;
a0d0e21e 2346 }
67caa1fe
GS
2347 else
2348#endif /* PERL_XSUB_OLDSTYLE */
2349 {
1fa4e549
AD
2350 SV **newsp;
2351 I32 gimme;
2352
1fa4e549 2353 /* Push a mark for the start of arglist */
ac27b0f5 2354 PUSHMARK(mark);
a45cdc79 2355 PUTBACK;
acfe0abc 2356 (void)(*CvXSUB(cv))(aTHX_ cv);
1fa4e549 2357 /* Pop the current context like a decent sub should */
3280af22 2358 POPBLOCK(cx, PL_curpm);
1fa4e549 2359 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW
2360 }
2361 LEAVE;
f39bc417
DM
2362 assert(CxTYPE(cx) == CXt_SUB);
2363 return cx->blk_sub.retop;
a0d0e21e
LW
2364 }
2365 else {
2366 AV* padlist = CvPADLIST(cv);
6b35e009 2367 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS
2368 PL_in_eval = cx->blk_eval.old_in_eval;
2369 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH
2370 cx->cx_type = CXt_SUB;
2371 cx->blk_sub.hasargs = 0;
2372 }
a0d0e21e 2373 cx->blk_sub.cv = cv;
eb160463 2374 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
dd2155a4 2375
a0d0e21e
LW
2376 CvDEPTH(cv)++;
2377 if (CvDEPTH(cv) < 2)
2378 (void)SvREFCNT_inc(cv);
dd2155a4 2379 else {
599cee73 2380 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2381 sub_crush_depth(cv);
26019298 2382 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2383 }
dd2155a4 2384 PAD_SET_CUR(padlist, CvDEPTH(cv));
6d4ff0d2 2385 if (cx->blk_sub.hasargs)
6d4ff0d2 2386 {
dd2155a4 2387 AV* av = (AV*)PAD_SVl(0);
a0d0e21e
LW
2388 SV** ary;
2389
3280af22
NIS
2390 cx->blk_sub.savearray = GvAV(PL_defgv);
2391 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2392 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2393 cx->blk_sub.argarray = av;
a0d0e21e
LW
2394
2395 if (items >= AvMAX(av) + 1) {
2396 ary = AvALLOC(av);
2397 if (AvARRAY(av) != ary) {
2398 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
f880fe2f 2399 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2400 }
2401 if (items >= AvMAX(av) + 1) {
2402 AvMAX(av) = items - 1;
2403 Renew(ary,items+1,SV*);
2404 AvALLOC(av) = ary;
f880fe2f 2405 SvPV_set(av, (char*)ary);
a0d0e21e
LW
2406 }
2407 }
a45cdc79 2408 ++mark;
a0d0e21e 2409 Copy(mark,AvARRAY(av),items,SV*);
93965878 2410 AvFILLp(av) = items - 1;
d8b46c1b 2411 assert(!AvREAL(av));
b1464ded
DM
2412 if (reified) {
2413 /* transfer 'ownership' of refcnts to new @_ */
2414 AvREAL_on(av);
2415 AvREIFY_off(av);
2416 }
a0d0e21e
LW
2417 while (items--) {
2418 if (*mark)
2419 SvTEMP_off(*mark);
2420 mark++;
2421 }
2422 }
491527d0 2423 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a
PP
2424 /*
2425 * We do not care about using sv to call CV;
2426 * it's for informational purposes only.
2427 */
3280af22 2428 SV *sv = GvSV(PL_DBsub);
491527d0 2429 CV *gotocv;
bfed75c6 2430
f398eb67 2431 save_item(sv);
491527d0 2432 if (PERLDB_SUB_NN) {
f398eb67
NC
2433 int type = SvTYPE(sv);
2434 if (type < SVt_PVIV && type != SVt_IV)
2435 sv_upgrade(sv, SVt_PVIV);
7619c85e 2436 (void)SvIOK_on(sv);
45977657 2437 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
491527d0 2438 } else {
491527d0
GS
2439 gv_efullname3(sv, CvGV(cv), Nullch);
2440 }
2441 if ( PERLDB_GOTO
864dbfa3 2442 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2443 PUSHMARK( PL_stack_sp );
864dbfa3 2444 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2445 PL_stack_sp--;
491527d0 2446 }
1ce6579f 2447 }
a0d0e21e
LW
2448 RETURNOP(CvSTART(cv));
2449 }
2450 }
1614b0e3 2451 else {
2d8e6c8d 2452 label = SvPV(sv,n_a);
1614b0e3 2453 if (!(do_dump || *label))
cea2e8a9 2454 DIE(aTHX_ must_have_label);
1614b0e3 2455 }
a0d0e21e 2456 }
533c011a 2457 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2458 if (! do_dump)
cea2e8a9 2459 DIE(aTHX_ must_have_label);
a0d0e21e
LW
2460 }
2461 else
2462 label = cPVOP->op_pv;
2463
2464 if (label && *label) {
2465 OP *gotoprobe = 0;
3b2447bc 2466 bool leaving_eval = FALSE;
33d34e4c 2467 bool in_block = FALSE;
a4f3a277 2468 PERL_CONTEXT *last_eval_cx = 0;
a0d0e21e
LW
2469
2470 /* find label */
2471
3280af22 2472 PL_lastgotoprobe = 0;
a0d0e21e
LW
2473 *enterops = 0;
2474 for (ix = cxstack_ix; ix >= 0; ix--) {
2475 cx = &cxstack[ix];
6b35e009 2476 switch (CxTYPE(cx)) {
a0d0e21e 2477 case CXt_EVAL:
3b2447bc 2478 leaving_eval = TRUE;
971ecbe6 2479 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH
2480 gotoprobe = (last_eval_cx ?
2481 last_eval_cx->blk_eval.old_eval_root :
2482 PL_eval_root);
2483 last_eval_cx = cx;
9c5794fe
RH
2484 break;
2485 }
2486 /* else fall through */
a0d0e21e
LW
2487 case CXt_LOOP:
2488 gotoprobe = cx->blk_oldcop->op_sibling;
2489 break;
2490 case CXt_SUBST:
2491 continue;
2492 case CXt_BLOCK:
33d34e4c 2493 if (ix) {
a0d0e21e 2494 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE
2495 in_block = TRUE;
2496 } else
3280af22 2497 gotoprobe = PL_main_root;
a0d0e21e 2498 break;
b3933176
CS
2499 case CXt_SUB:
2500 if (CvDEPTH(cx->blk_sub.cv)) {
2501 gotoprobe = CvROOT(cx->blk_sub.cv);
2502 break;
2503 }
2504 /* FALL THROUGH */
7766f137 2505 case CXt_FORMAT:
0a753a76 2506 case CXt_NULL:
a651a37d 2507 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW
2508 default:
2509 if (ix)
cea2e8a9 2510 DIE(aTHX_ "panic: goto");
3280af22 2511 gotoprobe = PL_main_root;
a0d0e21e
LW
2512 break;
2513 }
2b597662
GS
2514 if (gotoprobe) {
2515 retop = dofindlabel(gotoprobe, label,
2516 enterops, enterops + GOTO_DEPTH);
2517 if (retop)
2518 break;
2519 }
3280af22 2520 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW
2521 }
2522 if (!retop)
cea2e8a9 2523 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2524
3b2447bc
RH
2525 /* if we're leaving an eval, check before we pop any frames
2526 that we're not going to punt, otherwise the error
2527 won't be caught */
2528
2529 if (leaving_eval && *enterops && enterops[1]) {
2530 I32 i;
2531 for (i = 1; enterops[i]; i++)
2532 if (enterops[i]->op_type == OP_ENTERITER)
2533 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2534 }
2535
a0d0e21e
LW
2536 /* pop unwanted frames */
2537
2538 if (ix < cxstack_ix) {
2539 I32 oldsave;
2540
2541 if (ix < 0)
2542 ix = 0;
2543 dounwind(ix);
2544 TOPBLOCK(cx);
3280af22 2545 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW
2546 LEAVE_SCOPE(oldsave);
2547 }
2548
2549 /* push wanted frames */
2550
748a9306 2551 if (*enterops && enterops[1]) {
533c011a 2552 OP *oldop = PL_op;
33d34e4c
AE
2553 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2554 for (; enterops[ix]; ix++) {
533c011a 2555 PL_op = enterops[ix];
84902520
TB
2556 /* Eventually we may want to stack the needed arguments
2557 * for each op. For now, we punt on the hard ones. */
533c011a 2558 if (PL_op->op_type == OP_ENTERITER)
894356b3 2559 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2560 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2561 }
533c011a 2562 PL_op = oldop;
a0d0e21e
LW
2563 }
2564 }
2565
2566 if (do_dump) {
a5f75d66 2567#ifdef VMS
6b88bc9c 2568 if (!retop) retop = PL_main_start;
a5f75d66 2569#endif
3280af22
NIS
2570 PL_restartop = retop;
2571 PL_do_undump = TRUE;
a0d0e21e
LW
2572
2573 my_unexec();
2574
3280af22
NIS
2575 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2576 PL_do_undump = FALSE;
a0d0e21e
LW
2577 }
2578
2579 RETURNOP(retop);
2580}
2581
2582PP(pp_exit)
2583{
39644a26 2584 dSP;
a0d0e21e
LW
2585 I32 anum;
2586
2587 if (MAXARG < 1)
2588 anum = 0;
ff0cee69 2589 else {
a0d0e21e 2590 anum = SvIVx(POPs);
d98f61e7
GS
2591#ifdef VMS
2592 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2593 anum = 0;
96e176bf 2594 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69
PP
2595#endif
2596 }
cc3604b1 2597 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2598 my_exit(anum);
3280af22 2599 PUSHs(&PL_sv_undef);
a0d0e21e
LW
2600 RETURN;
2601}
2602
2603#ifdef NOTYET
2604PP(pp_nswitch)
2605{
39644a26 2606 dSP;
65202027 2607 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW
2608 register I32 match = I_32(value);
2609
2610 if (value < 0.0) {
65202027 2611 if (((NV)match) > value)
a0d0e21e
LW
2612 --match; /* was fractional--truncate other way */
2613 }
2614 match -= cCOP->uop.scop.scop_offset;
2615 if (match < 0)
2616 match = 0;
2617 else if (match > cCOP->uop.scop.scop_max)
2618 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS
2619 PL_op = cCOP->uop.scop.scop_next[match];
2620 RETURNOP(PL_op);
a0d0e21e
LW
2621}
2622
2623PP(pp_cswitch)
2624{
39644a26 2625 dSP;
a0d0e21e
LW
2626 register I32 match;
2627
6b88bc9c
GS
2628 if (PL_multiline)
2629 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2630 else {
2d8e6c8d
GS
2631 STRLEN n_a;
2632 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW
2633 match -= cCOP->uop.scop.scop_offset;
2634 if (match < 0)
2635 match = 0;
2636 else if (match > cCOP->uop.scop.scop_max)
2637 match = cCOP->uop.scop.scop_max;
6b88bc9c 2638 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2639 }
6b88bc9c 2640 RETURNOP(PL_op);
a0d0e21e
LW
2641}
2642#endif
2643
2644/* Eval. */
2645
0824fdcb 2646STATIC void
cea2e8a9 2647S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2648{
06b5626a
AL
2649 register const char *s = SvPVX(sv);
2650 register const char *send = SvPVX(sv) + SvCUR(sv);
2651 register const char *t;
a0d0e21e
LW
2652 register I32 line = 1;
2653
2654 while (s && s < send) {
2655 SV *tmpstr = NEWSV(85,0);
2656
2657 sv_upgrade(tmpstr, SVt_PVMG);
2658 t = strchr(s, '\n');
2659 if (t)
2660 t++;
2661 else
2662 t = send;
2663
2664 sv_setpvn(tmpstr, s, t - s);
2665 av_store(array, line++, tmpstr);
2666 s = t;
2667 }
2668}
2669
14dd3ad8
GS
2670STATIC void *
2671S_docatch_body(pTHX)
2672{
cea2e8a9 2673 CALLRUNOPS(aTHX);
312caa8e
CS
2674 return NULL;
2675}
2676
0824fdcb 2677STATIC OP *
cea2e8a9 2678S_docatch(pTHX_ OP *o)
1e422769 2679{
6224f72b 2680 int ret;
06b5626a 2681 OP * const oldop = PL_op;
8bffa5f8 2682 OP *retop;
0cdb2077 2683 volatile PERL_SI *cursi = PL_curstackinfo;
db36c5a1 2684 dJMPENV;
1e422769 2685
1e422769 2686#ifdef DEBUGGING
54310121 2687 assert(CATCH_GET == TRUE);
1e422769 2688#endif
312caa8e 2689 PL_op = o;
8bffa5f8
DM
2690
2691 /* Normally, the leavetry at the end of this block of ops will
2692 * pop an op off the return stack and continue there. By setting
2693 * the op to Nullop, we force an exit from the inner runops()
2694 * loop. DAPM.
2695 */
f39bc417
DM
2696 assert(cxstack_ix >= 0);
2697 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2698 retop = cxstack[cxstack_ix].blk_eval.retop;
2699 cxstack[cxstack_ix].blk_eval.retop = Nullop;
8bffa5f8 2700
14dd3ad8 2701 JMPENV_PUSH(ret);
6224f72b 2702 switch (ret) {
312caa8e 2703 case 0:
14dd3ad8
GS
2704 redo_body:
2705 docatch_body();
312caa8e
CS
2706 break;
2707 case 3:
8bffa5f8 2708 /* die caught by an inner eval - continue inner loop */
0cdb2077 2709 if (PL_restartop && cursi == PL_curstackinfo) {
312caa8e
CS
2710 PL_op = PL_restartop;
2711 PL_restartop = 0;
2712 goto redo_body;
2713 }
8bffa5f8
DM
2714 /* a die in this eval - continue in outer loop */
2715 if (!PL_restartop)
2716 break;
312caa8e
CS
2717 /* FALL THROUGH */
2718 default:
14dd3ad8 2719 JMPENV_POP;
533c011a 2720 PL_op = oldop;
6224f72b 2721 JMPENV_JUMP(ret);
1e422769 2722 /* NOTREACHED */
1e422769 2723 }
14dd3ad8 2724 JMPENV_POP;
533c011a 2725 PL_op = oldop;
8bffa5f8 2726 return retop;
1e422769
PP
2727}
2728
c277df42 2729OP *
bfed75c6 2730Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ
2731/* sv Text to convert to OP tree. */
2732/* startop op_free() this to undo. */
2733/* code Short string id of the caller. */
2734{
2735 dSP; /* Make POPBLOCK work. */
2736 PERL_CONTEXT *cx;
2737 SV **newsp;
f987c7de 2738 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ
2739 I32 optype;
2740 OP dummy;
155aba94 2741 OP *rop;
83ee9e09
GS
2742 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2743 char *tmpbuf = tbuf;
c277df42 2744 char *safestr;
a3985cdc 2745 int runtime;
40b8d195 2746 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
c277df42
IZ
2747
2748 ENTER;
2749 lex_start(sv);
2750 SAVETMPS;
2751 /* switch to eval mode */
2752
923e4eb5 2753 if (IN_PERL_COMPILETIME) {
f4dd75d9 2754 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2755 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2756 }
83ee9e09
GS
2757 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2758 SV *sv = sv_newmortal();
2759 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2760 code, (unsigned long)++PL_evalseq,
2761 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2762 tmpbuf = SvPVX(sv);
2763 }
2764 else
2765 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
f4dd75d9 2766 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2767 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2768 SAVECOPLINE(&PL_compiling);
57843af0 2769 CopLINE_set(&PL_compiling, 1);
c277df42
IZ
2770 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2771 deleting the eval's FILEGV from the stash before gv_check() runs
2772 (i.e. before run-time proper). To work around the coredump that
2773 ensues, we always turn GvMULTI_on for any globals that were
2774 introduced within evals. See force_ident(). GSAR 96-10-12 */
2775 safestr = savepv(tmpbuf);
3280af22 2776 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2777 SAVEHINTS();
d1ca3daa 2778#ifdef OP_IN_REGISTER
6b88bc9c 2779 PL_opsave = op;
d1ca3daa 2780#else
7766f137 2781 SAVEVPTR(PL_op);
d1ca3daa 2782#endif
c277df42 2783
a3985cdc 2784 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2785 runtime = IN_PERL_RUNTIME;
a3985cdc 2786 if (runtime)
d819b83a 2787 runcv = find_runcv(NULL);
a3985cdc 2788
533c011a 2789 PL_op = &dummy;
13b51b79 2790 PL_op->op_type = OP_ENTEREVAL;
533c011a 2791 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2792 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
cc49e20b 2793 PUSHEVAL(cx, 0, Nullgv);
a3985cdc
DM
2794
2795 if (runtime)
2796 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2797 else
2798 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2799 POPBLOCK(cx,PL_curpm);
e84b9f1f 2800 POPEVAL(cx);
c277df42
IZ
2801
2802 (*startop)->op_type = OP_NULL;
22c35a8c 2803 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2804 lex_end();
f3548bdc
DM
2805 /* XXX DAPM do this properly one year */
2806 *padp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2807 LEAVE;
923e4eb5 2808 if (IN_PERL_COMPILETIME)
eb160463 2809 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
d1ca3daa 2810#ifdef OP_IN_REGISTER
6b88bc9c 2811 op = PL_opsave;
d1ca3daa 2812#endif
c277df42
IZ
2813 return rop;
2814}
2815
a3985cdc
DM
2816
2817/*
2818=for apidoc find_runcv
2819
2820Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM
2821If db_seqp is non_null, skip CVs that are in the DB package and populate
2822*db_seqp with the cop sequence number at the point that the DB:: code was
2823entered. (allows debuggers to eval in the scope of the breakpoint rather
8006bbc3 2824than in in the scope of the debugger itself).
a3985cdc
DM
2825
2826=cut
2827*/
2828
2829CV*
d819b83a 2830Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 2831{
a3985cdc 2832 PERL_SI *si;
a3985cdc 2833
d819b83a
DM
2834 if (db_seqp)
2835 *db_seqp = PL_curcop->cop_seq;
a3985cdc 2836 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 2837 I32 ix;
a3985cdc 2838 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 2839 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a
DM
2840 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2841 CV *cv = cx->blk_sub.cv;
2842 /* skip DB:: code */
2843 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2844 *db_seqp = cx->blk_oldcop->cop_seq;
2845 continue;
2846 }
2847 return cv;
2848 }
a3985cdc
DM
2849 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2850 return PL_compcv;
2851 }
2852 }
2853 return PL_main_cv;
2854}
2855
2856
2857/* Compile a require/do, an eval '', or a /(?{...})/.
2858 * In the last case, startop is non-null, and contains the address of
2859 * a pointer that should be set to the just-compiled code.
2860 * outside is the lexically enclosing CV (if any) that invoked us.
2861 */
2862
4d1ff10f 2863/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2864STATIC OP *
a3985cdc 2865S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e
LW
2866{
2867 dSP;
533c011a 2868 OP *saveop = PL_op;
a0d0e21e 2869
6dc8a9e4
IZ
2870 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2871 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2872 : EVAL_INEVAL);
a0d0e21e 2873
1ce6579f
PP
2874 PUSHMARK(SP);
2875
3280af22
NIS
2876 SAVESPTR(PL_compcv);
2877 PL_compcv = (CV*)NEWSV(1104,0);
2878 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2879 CvEVAL_on(PL_compcv);
2090ab20
JH
2880 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2881 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2882
a3985cdc 2883 CvOUTSIDE_SEQ(PL_compcv) = seq;
7dafbf52 2884 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
a3985cdc 2885
dd2155a4 2886 /* set up a scratch pad */
a0d0e21e 2887
dd2155a4 2888 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2c05e328 2889
07055b4c 2890
26d9b02f 2891 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2892
a0d0e21e
LW
2893 /* make sure we compile in the right package */
2894
ed094faf 2895 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2896 SAVESPTR(PL_curstash);
ed094faf 2897 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2898 }
3280af22
NIS
2899 SAVESPTR(PL_beginav);
2900 PL_beginav = newAV();
2901 SAVEFREESV(PL_beginav);
24944567 2902 SAVEI32(PL_error_count);
a0d0e21e
LW
2903
2904 /* try to compile it */
2905
3280af22
NIS
2906 PL_eval_root = Nullop;
2907 PL_error_count = 0;
2908 PL_curcop = &PL_compiling;
2909 PL_curcop->cop_arybase = 0;
c277df42 2910 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2911 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2912 else
38a03e6e 2913 sv_setpv(ERRSV,"");
3280af22 2914 if (yyparse() || PL_error_count || !PL_eval_root) {
0c58d367 2915 SV **newsp; /* Used by POPBLOCK. */
4d8b06f1 2916 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2917 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2918 STRLEN n_a;
bfed75c6 2919
533c011a 2920 PL_op = saveop;
3280af22
NIS
2921 if (PL_eval_root) {
2922 op_free(PL_eval_root);
2923 PL_eval_root = Nullop;
a0d0e21e 2924 }
3280af22 2925 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2926 if (!startop) {
3280af22 2927 POPBLOCK(cx,PL_curpm);
c277df42 2928 POPEVAL(cx);
c277df42 2929 }
a0d0e21e
LW
2930 lex_end();
2931 LEAVE;
7a2e2cd6 2932 if (optype == OP_REQUIRE) {
06b5626a 2933 const char* msg = SvPVx(ERRSV, n_a);
4d8b06f1
RD
2934 SV *nsv = cx->blk_eval.old_namesv;
2935 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
27bcc0a7 2936 &PL_sv_undef, 0);
5a844595
GS
2937 DIE(aTHX_ "%sCompilation failed in require",
2938 *msg ? msg : "Unknown error\n");
2939 }
2940 else if (startop) {
06b5626a 2941 const char* msg = SvPVx(ERRSV, n_a);
c277df42 2942
3280af22 2943 POPBLOCK(cx,PL_curpm);
c277df42 2944 POPEVAL(cx);
5a844595
GS
2945 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2946 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2947 }
9d7f88dd 2948 else {
06b5626a 2949 const char* msg = SvPVx(ERRSV, n_a);
9d7f88dd
SR
2950 if (!*msg) {
2951 sv_setpv(ERRSV, "Compilation error");
2952 }
2953 }
a0d0e21e
LW
2954 RETPUSHUNDEF;
2955 }
57843af0 2956 CopLINE_set(&PL_compiling, 0);
c277df42 2957 if (startop) {
3280af22 2958 *startop = PL_eval_root;
c277df42 2959 } else
3280af22 2960 SAVEFREEOP(PL_eval_root);
0c58d367
RGS
2961
2962 /* Set the context for this new optree.
2963 * If the last op is an OP_REQUIRE, force scalar context.
2964 * Otherwise, propagate the context from the eval(). */
2965 if (PL_eval_root->op_type == OP_LEAVEEVAL
2966 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2967 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2968 == OP_REQUIRE)
2969 scalar(PL_eval_root);
2970 else if (gimme & G_VOID)
3280af22 2971 scalarvoid(PL_eval_root);
54310121 2972 else if (gimme & G_ARRAY)
3280af22 2973 list(PL_eval_root);
a0d0e21e 2974 else
3280af22 2975 scalar(PL_eval_root);
a0d0e21e
LW
2976
2977 DEBUG_x(dump_eval());
2978
55497cff 2979 /* Register with debugger: */
84902520 2980 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2981 CV *cv = get_cv("DB::postponed", FALSE);
55497cff
PP
2982 if (cv) {
2983 dSP;
924508f0 2984 PUSHMARK(SP);
cc49e20b 2985 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2986 PUTBACK;
864dbfa3 2987 call_sv((SV*)cv, G_DISCARD);
55497cff
PP
2988 }
2989 }
2990
a0d0e21e
LW
2991 /* compiled okay, so do it */
2992
3280af22
NIS
2993 CvDEPTH(PL_compcv) = 1;
2994 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2995 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 2996 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 2997
3280af22 2998 RETURNOP(PL_eval_start);
a0d0e21e
LW
2999}
3000
a6c40364 3001STATIC PerlIO *
7925835c 3002S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3003{
7925835c 3004#ifndef PERL_DISABLE_PMC
b295d113
TH
3005 STRLEN namelen = strlen(name);
3006 PerlIO *fp;
3007
7894fbab 3008 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 3009 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
06b5626a 3010 const char * const pmc = SvPV_nolen(pmcsv);
b295d113 3011 Stat_t pmstat;
a6c40364
GS
3012 Stat_t pmcstat;
3013 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 3014 fp = PerlIO_open(name, mode);
a6c40364
GS
3015 }
3016 else {
b295d113 3017 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS
3018 pmstat.st_mtime < pmcstat.st_mtime)
3019 {
3020 fp = PerlIO_open(pmc, mode);
3021 }
3022 else {
3023 fp = PerlIO_open(name, mode);
3024 }
b295d113 3025 }
a6c40364
GS
3026 SvREFCNT_dec(pmcsv);
3027 }
3028 else {
3029 fp = PerlIO_open(name, mode);
b295d113 3030 }
b295d113 3031 return fp;
7925835c
RGS
3032#else
3033 return PerlIO_open(name, mode);
3034#endif /* !PERL_DISABLE_PMC */
b295d113
TH
3035}
3036
a0d0e21e
LW
3037PP(pp_require)
3038{
39644a26 3039 dSP;
c09156bb 3040 register PERL_CONTEXT *cx;
a0d0e21e
LW
3041 SV *sv;
3042 char *name;
6132ea6c 3043 STRLEN len;
9c5ffd7c 3044 char *tryname = Nullch;
46fc3d4c 3045 SV *namesv = Nullsv;
a0d0e21e 3046 SV** svp;
986b19de 3047 I32 gimme = GIMME_V;
760ac839 3048 PerlIO *tryrsfp = 0;
2d8e6c8d 3049 STRLEN n_a;
bbed91b5
KF
3050 int filter_has_file = 0;
3051 GV *filter_child_proc = 0;
3052 SV *filter_state = 0;
3053 SV *filter_sub = 0;
89ccab8c 3054 SV *hook_sv = 0;
6ec9efec
JH
3055 SV *encoding;
3056 OP *op;
a0d0e21e
LW
3057
3058 sv = POPs;
d7aa5382
JP
3059 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3060 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
9014280d 3061 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 3062 "v-string in use/require non-portable");
d7aa5382
JP
3063
3064 sv = new_version(sv);
3065 if (!sv_derived_from(PL_patchlevel, "version"))
3066 (void *)upg_version(PL_patchlevel);
3067 if ( vcmp(sv,PL_patchlevel) > 0 )
014ead4b 3068 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
d7aa5382
JP
3069 vstringify(sv), vstringify(PL_patchlevel));
3070
4305d8ab 3071 RETPUSHYES;
a0d0e21e 3072 }
6132ea6c
GS
3073 name = SvPV(sv, len);
3074 if (!(name && len > 0 && *name))
cea2e8a9 3075 DIE(aTHX_ "Null filename used");
4633a7c4 3076 TAINT_PROPER("require");
533c011a 3077 if (PL_op->op_type == OP_REQUIRE &&
27bcc0a7
RGS
3078 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3079 if (*svp != &PL_sv_undef)
4d8b06f1
RD
3080 RETPUSHYES;
3081 else
3082 DIE(aTHX_ "Compilation failed in require");
3083 }
a0d0e21e
LW
3084
3085 /* prepare to compile file */
3086
be4b629d 3087 if (path_is_absolute(name)) {
46fc3d4c 3088 tryname = name;
7925835c 3089 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
bf4acbe4 3090 }
67627c52
JH
3091#ifdef MACOS_TRADITIONAL
3092 if (!tryrsfp) {
3093 char newname[256];
3094
3095 MacPerl_CanonDir(name, newname, 1);
3096 if (path_is_absolute(newname)) {
3097 tryname = newname;
7925835c 3098 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
67627c52
JH
3099 }
3100 }
3101#endif
be4b629d 3102 if (!tryrsfp) {
3280af22 3103 AV *ar = GvAVn(PL_incgv);
a0d0e21e 3104 I32 i;
748a9306 3105#ifdef VMS
46fc3d4c
PP
3106 char *unixname;
3107 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3108#endif
3109 {
3110 namesv = NEWSV(806, 0);
3111 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF
3112 SV *dirsv = *av_fetch(ar, i, TRUE);
3113
3114 if (SvROK(dirsv)) {
3115 int count;
3116 SV *loader = dirsv;
3117
e14e2dc8
NC
3118 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3119 && !sv_isobject(loader))
3120 {
bbed91b5
KF
3121 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3122 }
3123
b900a521 3124 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3125 PTR2UV(SvRV(dirsv)), name);
bbed91b5
KF
3126 tryname = SvPVX(namesv);
3127 tryrsfp = 0;
3128
3129 ENTER;
3130 SAVETMPS;
3131 EXTEND(SP, 2);
3132
3133 PUSHMARK(SP);
3134 PUSHs(dirsv);
3135 PUSHs(sv);
3136 PUTBACK;
e982885c
NC
3137 if (sv_isobject(loader))
3138 count = call_method("INC", G_ARRAY);
3139 else
3140 count = call_sv(loader, G_ARRAY);
bbed91b5
KF
3141 SPAGAIN;
3142
3143 if (count > 0) {
3144 int i = 0;
3145 SV *arg;
3146
3147 SP -= count - 1;
3148 arg = SP[i++];
3149
3150 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3151 arg = SvRV(arg);
3152 }
3153
3154 if (SvTYPE(arg) == SVt_PVGV) {
3155 IO *io = GvIO((GV *)arg);
3156
3157 ++filter_has_file;
3158
3159 if (io) {
3160 tryrsfp = IoIFP(io);
50952442 3161 if (IoTYPE(io) == IoTYPE_PIPE) {
bbed91b5
KF
3162 /* reading from a child process doesn't
3163 nest -- when returning from reading
3164 the inner module, the outer one is
3165 unreadable (closed?) I've tried to
3166 save the gv to manage the lifespan of
3167 the pipe, but this didn't help. XXX */
3168 filter_child_proc = (GV *)arg;
520c758a 3169 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF
3170 }
3171 else {
3172 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3173 PerlIO_close(IoOFP(io));
3174 }
3175 IoIFP(io) = Nullfp;
3176 IoOFP(io) = Nullfp;
3177 }
3178 }
3179
3180 if (i < count) {
3181 arg = SP[i++];
3182 }
3183 }
3184
3185 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3186 filter_sub = arg;
520c758a 3187 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF
3188
3189 if (i < count) {
3190 filter_state = SP[i];
520c758a 3191 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF
3192 }
3193
3194 if (tryrsfp == 0) {
3195 tryrsfp = PerlIO_open("/dev/null",
3196 PERL_SCRIPT_MODE);
3197 }
3198 }
1d06aecd 3199 SP--;
bbed91b5
KF
3200 }
3201
3202 PUTBACK;
3203 FREETMPS;
3204 LEAVE;
3205
3206 if (tryrsfp) {
89ccab8c 3207 hook_sv = dirsv;
bbed91b5
KF
3208 break;
3209 }
3210
3211 filter_has_file = 0;
3212 if (filter_child_proc) {
3213 SvREFCNT_dec(filter_child_proc);
3214 filter_child_proc = 0;
3215 }
3216 if (filter_state) {
3217 SvREFCNT_dec(filter_state);
3218 filter_state = 0;
3219 }
3220 if (filter_sub) {
3221 SvREFCNT_dec(filter_sub);
3222 filter_sub = 0;
3223 }
3224 }
3225 else {
be4b629d
CN
3226 if (!path_is_absolute(name)
3227#ifdef MACOS_TRADITIONAL
3228 /* We consider paths of the form :a:b ambiguous and interpret them first
3229 as global then as local
3230 */
3231 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3232#endif
3233 ) {
bbed91b5 3234 char *dir = SvPVx(dirsv, n_a);
bf4acbe4 3235#ifdef MACOS_TRADITIONAL
67627c52
JH
3236 char buf1[256];
3237 char buf2[256];
3238
3239 MacPerl_CanonDir(name, buf2, 1);
3240 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3241#else
46fc3d4c 3242#ifdef VMS
bbed91b5
KF
3243 char *unixdir;
3244 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3245 continue;
3246 sv_setpv(namesv, unixdir);
3247 sv_catpv(namesv, unixname);
748a9306 3248#else
bbed91b5 3249 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 3250#endif
bf4acbe4 3251#endif
bbed91b5
KF
3252 TAINT_PROPER("require");
3253 tryname = SvPVX(namesv);
7925835c 3254 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
bbed91b5
KF
3255 if (tryrsfp) {
3256 if (tryname[0] == '.' && tryname[1] == '/')
3257 tryname += 2;
3258 break;
3259 }
be4b629d 3260 }
46fc3d4c 3261 }
a0d0e21e
LW
3262 }
3263 }
3264 }
f4dd75d9 3265 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3266 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3267 SvREFCNT_dec(namesv);
a0d0e21e 3268 if (!tryrsfp) {
533c011a 3269 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS
3270 char *msgstr = name;
3271 if (namesv) { /* did we lookup @INC? */
3272 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3273 SV *dirmsgsv = NEWSV(0, 0);
3274 AV *ar = GvAVn(PL_incgv);
3275 I32 i;
3276 sv_catpvn(msg, " in @INC", 8);
3277 if (instr(SvPVX(msg), ".h "))
3278 sv_catpv(msg, " (change .h to .ph maybe?)");
3279 if (instr(SvPVX(msg), ".ph "))
3280 sv_catpv(msg, " (did you run h2ph?)");
3281 sv_catpv(msg, " (@INC contains:");
3282 for (i = 0; i <= AvFILL(ar); i++) {
3283 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 3284 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS
3285 sv_catsv(msg, dirmsgsv);
3286 }
3287 sv_catpvn(msg, ")", 1);
3288 SvREFCNT_dec(dirmsgsv);
3289 msgstr = SvPV_nolen(msg);
2683423c 3290 }
ea071790 3291 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW
3292 }
3293
3294 RETPUSHUNDEF;
3295 }
d8bfb8bd 3296 else
93189314 3297 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW
3298
3299 /* Assume success here to prevent recursive requirement. */
d3a4e64e
RGS
3300 len = strlen(name);
3301 /* Check whether a hook in @INC has already filled %INC */
3302 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3303 (void)hv_store(GvHVn(PL_incgv), name, len,
3304 (hook_sv ? SvREFCNT_inc(hook_sv)
3305 : newSVpv(CopFILE(&PL_compiling), 0)),
3306 0 );
3307 }
a0d0e21e
LW
3308
3309 ENTER;
3310 SAVETMPS;
79cb57f6 3311 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS
3312 SAVEGENERICSV(PL_rsfp_filters);
3313 PL_rsfp_filters = Nullav;
e50aee73 3314
3280af22 3315 PL_rsfp = tryrsfp;
b3ac6de7 3316 SAVEHINTS();
3280af22 3317 PL_hints = 0;
7766f137 3318 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3319 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3320 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3321 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3322 PL_compiling.cop_warnings = pWARN_NONE ;
317ea90d
MS
3323 else if (PL_taint_warn)
3324 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
ac27b0f5 3325 else
d3a7d8c7 3326 PL_compiling.cop_warnings = pWARN_STD ;
ac27b0f5
NIS
3327 SAVESPTR(PL_compiling.cop_io);
3328 PL_compiling.cop_io = Nullsv;
a0d0e21e 3329
bbed91b5
KF
3330 if (filter_sub || filter_child_proc) {
3331 SV *datasv = filter_add(run_user_filter, Nullsv);
3332 IoLINES(datasv) = filter_has_file;
3333 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3334 IoTOP_GV(datasv) = (GV *)filter_state;
3335 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3336 }
3337
3338 /* switch to eval mode */
a0d0e21e 3339 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3340 PUSHEVAL(cx, name, Nullgv);
f39bc417 3341 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 3342
57843af0
GS
3343 SAVECOPLINE(&PL_compiling);
3344 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW
3345
3346 PUTBACK;
6ec9efec
JH
3347
3348 /* Store and reset encoding. */
3349 encoding = PL_encoding;
3350 PL_encoding = Nullsv;
3351
a3985cdc 3352 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
bfed75c6 3353
6ec9efec
JH
3354 /* Restore encoding. */
3355 PL_encoding = encoding;
3356
3357 return op;
a0d0e21e
LW
3358}
3359
3360PP(pp_dofile)
3361{
cea2e8a9 3362 return pp_require();
a0d0e21e
LW
3363}
3364
3365PP(pp_entereval)
3366{
39644a26 3367 dSP;
c09156bb 3368 register PERL_CONTEXT *cx;
a0d0e21e 3369 dPOPss;
3280af22 3370 I32 gimme = GIMME_V, was = PL_sub_generation;
83ee9e09
GS
3371 char tbuf[TYPE_DIGITS(long) + 12];
3372 char *tmpbuf = tbuf;
fc36a67e 3373 char *safestr;
a0d0e21e 3374 STRLEN len;
55497cff 3375 OP *ret;
a3985cdc 3376 CV* runcv;
d819b83a 3377 U32 seq;
a0d0e21e 3378
16a5162e 3379 if (!SvPV(sv,len))
a0d0e21e 3380 RETPUSHUNDEF;
748a9306 3381 TAINT_PROPER("eval");
a0d0e21e
LW
3382
3383 ENTER;
a0d0e21e 3384 lex_start(sv);
748a9306 3385 SAVETMPS;
ac27b0f5 3386
a0d0e21e
LW
3387 /* switch to eval mode */
3388
83ee9e09
GS
3389 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3390 SV *sv = sv_newmortal();
3391 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3392 (unsigned long)++PL_evalseq,
3393 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3394 tmpbuf = SvPVX(sv);
3395 }
3396 else
3397 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 3398 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3399 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3400 SAVECOPLINE(&PL_compiling);
57843af0 3401 CopLINE_set(&PL_compiling, 1);
55497cff
PP
3402 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3403 deleting the eval's FILEGV from the stash before gv_check() runs
3404 (i.e. before run-time proper). To work around the coredump that
3405 ensues, we always turn GvMULTI_on for any globals that were
3406 introduced within evals. See force_ident(). GSAR 96-10-12 */
3407 safestr = savepv(tmpbuf);
3280af22 3408 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3409 SAVEHINTS();
533c011a 3410 PL_hints = PL_op->op_targ;
7766f137 3411 SAVESPTR(PL_compiling.cop_warnings);
f0a6fc86
GS
3412 if (specialWARN(PL_curcop->cop_warnings))
3413 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3414 else {
3415 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3416 SAVEFREESV(PL_compiling.cop_warnings);
599cee73 3417 }
ac27b0f5
NIS
3418 SAVESPTR(PL_compiling.cop_io);
3419 if (specialCopIO(PL_curcop->cop_io))
3420 PL_compiling.cop_io = PL_curcop->cop_io;
3421 else {
3422 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3423 SAVEFREESV(PL_compiling.cop_io);
3424 }
d819b83a
DM
3425 /* special case: an eval '' executed within the DB package gets lexically
3426 * placed in the first non-DB CV rather than the current CV - this
3427 * allows the debugger to execute code, find lexicals etc, in the
3428 * scope of the code being debugged. Passing &seq gets find_runcv
3429 * to do the dirty work for us */
3430 runcv = find_runcv(&seq);
a0d0e21e 3431
6b35e009 3432 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3433 PUSHEVAL(cx, 0, Nullgv);
f39bc417 3434 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e
LW
3435
3436 /* prepare to compile string */
3437
3280af22 3438 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3439 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3440 PUTBACK;
d819b83a 3441 ret = doeval(gimme, NULL, runcv, seq);
eb160463 3442 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
533c011a 3443 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff
PP
3444 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3445 }
1e422769 3446 return DOCATCH(ret);
a0d0e21e
LW
3447}
3448
3449PP(pp_leaveeval)
3450{
39644a26 3451 dSP;
a0d0e21e
LW
3452 register SV **mark;
3453 SV **newsp;
3454 PMOP *newpm;
3455 I32 gimme;
c09156bb 3456 register PERL_CONTEXT *cx;
a0d0e21e 3457 OP *retop;
06b5626a 3458 const U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW
3459 I32 optype;
3460
3461 POPBLOCK(cx,newpm);
3462 POPEVAL(cx);
f39bc417 3463 retop = cx->blk_eval.retop;
a0d0e21e 3464
a1f49e72 3465 TAINT_NOT;
54310121
PP
3466 if (gimme == G_VOID)
3467 MARK = newsp;
3468 else if (gimme == G_SCALAR) {
3469 MARK = newsp + 1;
3470 if (MARK <= SP) {
3471 if (SvFLAGS(TOPs) & SVs_TEMP)
3472 *MARK = TOPs;
3473 else
3474 *MARK = sv_mortalcopy(TOPs);
3475 }
a0d0e21e 3476 else {
54310121 3477 MEXTEND(mark,0);
3280af22 3478 *MARK = &PL_sv_undef;
a0d0e21e 3479 }
a7ec2b44 3480 SP = MARK;
a0d0e21e
LW
3481 }
3482 else {
a1f49e72
CS
3483 /* in case LEAVE wipes old return values */
3484 for (mark = newsp + 1; mark <= SP; mark++) {
3485 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3486 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
3487 TAINT_NOT; /* Each item is independent */
3488 }
3489 }
a0d0e21e 3490 }
3280af22 3491 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3492
4fdae800 3493#ifdef DEBUGGING
3280af22 3494 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3495#endif
3280af22 3496 CvDEPTH(PL_compcv) = 0;
f46d017c 3497 lex_end();
4fdae800 3498
1ce6579f 3499 if (optype == OP_REQUIRE &&
924508f0 3500 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3501 {
1ce6579f 3502 /* Unassume the success we assumed earlier. */
0f79a09d
GS
3503 SV *nsv = cx->blk_eval.old_namesv;
3504 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 3505 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
f46d017c
GS
3506 /* die_where() did LEAVE, or we won't be here */
3507 }
3508 else {
3509 LEAVE;
3510 if (!(save_flags & OPf_SPECIAL))
3511 sv_setpv(ERRSV