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