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