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