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