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