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