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