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