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
Remove no 6 from the todo list
[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 1128
5b295bef
RD		 1129 SvGETMAGIC(left);
1130 SvGETMAGIC(right);
a0d0e21e 1131
8e9bbdb9 1132 if (RANGE_IS_NUMERIC(left,right)) {
901017d6
AL		 1133 register IV i, j;
1134 IV max;
4fe3f0fa
MHM		 1135 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1136 (SvOK(right) && SvNV(right) > IV_MAX))
d470f89e 1137 DIE(aTHX_ "Range iterator outside integer range");
a0d0e21e
LW		 1138 i = SvIV(left);
1139 max = SvIV(right);
bbce6d69 1140 if (max >= i) {
c1ab3db2
AK		 1141 j = max - i + 1;
1142 EXTEND_MORTAL(j);
1143 EXTEND(SP, j);
bbce6d69 1144 }
c1ab3db2
AK		 1145 else
1146 j = 0;
1147 while (j--) {
901017d6 1148 SV * const sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW		 1149 PUSHs(sv);
1150 }
1151 }
1152 else {
1153 SV *final = sv_mortalcopy(right);
13c5b33c 1154 STRLEN len;
349d4f2f 1155 const char *tmps = SvPV_const(final, len);
a0d0e21e 1156
901017d6 1157 SV *sv = sv_mortalcopy(left);
13c5b33c 1158 SvPV_force_nolen(sv);
89ea2908 1159 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1160 XPUSHs(sv);
b15aece3 1161 if (strEQ(SvPVX_const(sv),tmps))
89ea2908 1162 break;
a0d0e21e
LW		 1163 sv = sv_2mortal(newSVsv(sv));
1164 sv_inc(sv);
1165 }
a0d0e21e
LW		 1166 }
1167 }
1168 else {
1169 dTOPss;
901017d6 1170 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
4e3399f9 1171 int flop = 0;
a0d0e21e 1172 sv_inc(targ);
4e3399f9
YST		 1173
1174 if (PL_op->op_private & OPpFLIP_LINENUM) {
1175 if (GvIO(PL_last_in_gv)) {
1176 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1177 }
1178 else {
901017d6 1179 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
4e3399f9
YST		 1180 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1181 }
1182 }
1183 else {
1184 flop = SvTRUE(sv);
1185 }
1186
1187 if (flop) {
a0d0e21e 1188 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
901017d6 1189 sv_catpvn(targ, "E0", 2);
a0d0e21e
LW		 1190 }
1191 SETs(targ);
1192 }
1193
1194 RETURN;
1195}
1196
1197/* Control. */
1198
27da23d5 1199static const char * const context_name[] = {
515afda2
NC		 1200 "pseudo-block",
1201 "subroutine",
1202 "eval",
1203 "loop",
1204 "substitution",
1205 "block",
1206 "format"
1207};
1208
76e3520e 1209STATIC I32
06b5626a 1210S_dopoptolabel(pTHX_ const char *label)
a0d0e21e
LW		 1211{
1212 register I32 i;
a0d0e21e
LW		 1213
1214 for (i = cxstack_ix; i >= 0; i--) {
901017d6 1215 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1216 switch (CxTYPE(cx)) {
a0d0e21e 1217 case CXt_SUBST:
a0d0e21e 1218 case CXt_SUB:
7766f137 1219 case CXt_FORMAT:
a0d0e21e 1220 case CXt_EVAL:
0a753a76 1221 case CXt_NULL:
e476b1b5 1222 if (ckWARN(WARN_EXITING))
515afda2
NC		 1223 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1224 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1225 if (CxTYPE(cx) == CXt_NULL)
1226 return -1;
1227 break;
a0d0e21e 1228 case CXt_LOOP:
901017d6 1229 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
cea2e8a9 1230 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
68dc0745 1231 (long)i, cx->blk_loop.label));
a0d0e21e
LW		 1232 continue;
1233 }
cea2e8a9 1234 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW		 1235 return i;
1236 }
1237 }
1238 return i;
1239}
1240
e50aee73 1241I32
864dbfa3 1242Perl_dowantarray(pTHX)
e50aee73 1243{
f54cb97a 1244 const I32 gimme = block_gimme();
54310121 1245 return (gimme == G_VOID) ? G_SCALAR : gimme;
1246}
1247
1248I32
864dbfa3 1249Perl_block_gimme(pTHX)
54310121 1250{
06b5626a 1251 const I32 cxix = dopoptosub(cxstack_ix);
e50aee73 1252 if (cxix < 0)
46fc3d4c 1253 return G_VOID;
e50aee73 1254
54310121 1255 switch (cxstack[cxix].blk_gimme) {
d2719217
GS		 1256 case G_VOID:
1257 return G_VOID;
54310121 1258 case G_SCALAR:
e50aee73 1259 return G_SCALAR;
54310121 1260 case G_ARRAY:
1261 return G_ARRAY;
1262 default:
cea2e8a9 1263 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS		 1264 /* NOTREACHED */
1265 return 0;
54310121 1266 }
e50aee73
AD		 1267}
1268
78f9721b
SM		 1269I32
1270Perl_is_lvalue_sub(pTHX)
1271{
06b5626a 1272 const I32 cxix = dopoptosub(cxstack_ix);
78f9721b
SM		 1273 assert(cxix >= 0); /* We should only be called from inside subs */
1274
1275 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1276 return cxstack[cxix].blk_sub.lval;
1277 else
1278 return 0;
1279}
1280
76e3520e 1281STATIC I32
cea2e8a9 1282S_dopoptosub(pTHX_ I32 startingblock)
a0d0e21e 1283{
2c375eb9
GS		 1284 return dopoptosub_at(cxstack, startingblock);
1285}
1286
1287STATIC I32
901017d6 1288S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9 1289{
a0d0e21e 1290 I32 i;
a0d0e21e 1291 for (i = startingblock; i >= 0; i--) {
901017d6 1292 register const PERL_CONTEXT * const cx = &cxstk[i];
6b35e009 1293 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1294 default:
1295 continue;
1296 case CXt_EVAL:
1297 case CXt_SUB:
7766f137 1298 case CXt_FORMAT:
cea2e8a9 1299 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW		 1300 return i;
1301 }
1302 }
1303 return i;
1304}
1305
76e3520e 1306STATIC I32
cea2e8a9 1307S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e
LW		 1308{
1309 I32 i;
a0d0e21e 1310 for (i = startingblock; i >= 0; i--) {
06b5626a 1311 register const PERL_CONTEXT *cx = &cxstack[i];
6b35e009 1312 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1313 default:
1314 continue;
1315 case CXt_EVAL:
cea2e8a9 1316 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW		 1317 return i;
1318 }
1319 }
1320 return i;
1321}
1322
76e3520e 1323STATIC I32
cea2e8a9 1324S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e
LW		 1325{
1326 I32 i;
a0d0e21e 1327 for (i = startingblock; i >= 0; i--) {
901017d6 1328 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1329 switch (CxTYPE(cx)) {
a0d0e21e 1330 case CXt_SUBST:
a0d0e21e 1331 case CXt_SUB:
7766f137 1332 case CXt_FORMAT:
a0d0e21e 1333 case CXt_EVAL:
0a753a76 1334 case CXt_NULL:
e476b1b5 1335 if (ckWARN(WARN_EXITING))
515afda2
NC		 1336 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1337 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1338 if ((CxTYPE(cx)) == CXt_NULL)
1339 return -1;
1340 break;
a0d0e21e 1341 case CXt_LOOP:
cea2e8a9 1342 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW		 1343 return i;
1344 }
1345 }
1346 return i;
1347}
1348
1349void
864dbfa3 1350Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1351{
a0d0e21e
LW		 1352 I32 optype;
1353
1354 while (cxstack_ix > cxix) {
b0d9ce38 1355 SV *sv;
06b5626a 1356 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c90c0ff4 1357 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1358 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1359 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1360 switch (CxTYPE(cx)) {
c90c0ff4 1361 case CXt_SUBST:
1362 POPSUBST(cx);
1363 continue; /* not break */
a0d0e21e 1364 case CXt_SUB:
b0d9ce38
GS		 1365 POPSUB(cx,sv);
1366 LEAVESUB(sv);
a0d0e21e
LW		 1367 break;
1368 case CXt_EVAL:
1369 POPEVAL(cx);
1370 break;
1371 case CXt_LOOP:
1372 POPLOOP(cx);
1373 break;
0a753a76 1374 case CXt_NULL:
a0d0e21e 1375 break;
7766f137
GS		 1376 case CXt_FORMAT:
1377 POPFORMAT(cx);
1378 break;
a0d0e21e 1379 }
c90c0ff4 1380 cxstack_ix--;
a0d0e21e 1381 }
1b6737cc 1382 PERL_UNUSED_VAR(optype);
a0d0e21e
LW		 1383}
1384
5a844595
GS		 1385void
1386Perl_qerror(pTHX_ SV *err)
1387{
1388 if (PL_in_eval)
1389 sv_catsv(ERRSV, err);
1390 else if (PL_errors)
1391 sv_catsv(PL_errors, err);
1392 else
894356b3 1393 Perl_warn(aTHX_ "%"SVf, err);
5a844595
GS		 1394 ++PL_error_count;
1395}
1396
a0d0e21e 1397OP *
35a4481c 1398Perl_die_where(pTHX_ const char *message, STRLEN msglen)
a0d0e21e 1399{
27da23d5 1400 dVAR;
87582a92 1401
3280af22 1402 if (PL_in_eval) {
a0d0e21e 1403 I32 cxix;
a0d0e21e 1404 I32 gimme;
a0d0e21e 1405
4e6ea2c3 1406 if (message) {
faef0170 1407 if (PL_in_eval & EVAL_KEEPERR) {
bfed75c6 1408 static const char prefix[] = "\t(in cleanup) ";
2d03de9c 1409 SV * const err = ERRSV;
06b5626a 1410 const char *e = Nullch;
98eae8f5 1411 if (!SvPOK(err))
c69006e4 1412 sv_setpvn(err,"",0);
98eae8f5 1413 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
0510663f 1414 STRLEN len;
349d4f2f 1415 e = SvPV_const(err, len);
0510663f 1416 e += len - msglen;
98eae8f5
GS		 1417 if (*e != *message || strNE(e,message))
1418 e = Nullch;
1419 }
1420 if (!e) {
1421 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1422 sv_catpvn(err, prefix, sizeof(prefix)-1);
1423 sv_catpvn(err, message, msglen);
e476b1b5 1424 if (ckWARN(WARN_MISC)) {
504618e9 1425 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
b15aece3 1426 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
4e6ea2c3 1427 }
4633a7c4 1428 }
4633a7c4 1429 }
1aa99e6b 1430 else {
06bf62c7 1431 sv_setpvn(ERRSV, message, msglen);
1aa99e6b 1432 }
4633a7c4 1433 }
4e6ea2c3 1434
5a844595
GS		 1435 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1436 && PL_curstackinfo->si_prev)
1437 {
bac4b2ad 1438 dounwind(-1);
d3acc0f7 1439 POPSTACK;
bac4b2ad 1440 }
e336de0d 1441
a0d0e21e
LW		 1442 if (cxix >= 0) {
1443 I32 optype;
35a4481c 1444 register PERL_CONTEXT *cx;
901017d6 1445 SV **newsp;
a0d0e21e
LW		 1446
1447 if (cxix < cxstack_ix)
1448 dounwind(cxix);
1449
3280af22 1450 POPBLOCK(cx,PL_curpm);
6b35e009 1451 if (CxTYPE(cx) != CXt_EVAL) {
16869676 1452 if (!message)
349d4f2f 1453 message = SvPVx_const(ERRSV, msglen);
bf49b057
GS		 1454 PerlIO_write(Perl_error_log, "panic: die ", 11);
1455 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW		 1456 my_exit(1);
1457 }
1458 POPEVAL(cx);
1459
1460 if (gimme == G_SCALAR)
3280af22
NIS		 1461 *++newsp = &PL_sv_undef;
1462 PL_stack_sp = newsp;
a0d0e21e
LW		 1463
1464 LEAVE;
748a9306 1465
7fb6a879
GS		 1466 /* LEAVE could clobber PL_curcop (see save_re_context())
1467 * XXX it might be better to find a way to avoid messing with
1468 * PL_curcop in save_re_context() instead, but this is a more
1469 * minimal fix --GSAR */
1470 PL_curcop = cx->blk_oldcop;
1471
7a2e2cd6 1472 if (optype == OP_REQUIRE) {
0510663f 1473 const char* msg = SvPVx_nolen_const(ERRSV);
901017d6 1474 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 1475 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 1476 &PL_sv_undef, 0);
5a844595
GS		 1477 DIE(aTHX_ "%sCompilation failed in require",
1478 *msg ? msg : "Unknown error\n");
7a2e2cd6 1479 }
f39bc417
DM		 1480 assert(CxTYPE(cx) == CXt_EVAL);
1481 return cx->blk_eval.retop;
a0d0e21e
LW		 1482 }
1483 }
9cc2fdd3 1484 if (!message)
349d4f2f 1485 message = SvPVx_const(ERRSV, msglen);
87582a92 1486
7ff03255 1487 write_to_stderr(message, msglen);
f86702cc 1488 my_failure_exit();
1489 /* NOTREACHED */
a0d0e21e
LW		 1490 return 0;
1491}
1492
1493PP(pp_xor)
1494{
39644a26 1495 dSP; dPOPTOPssrl;
a0d0e21e
LW		 1496 if (SvTRUE(left) != SvTRUE(right))
1497 RETSETYES;
1498 else
1499 RETSETNO;
1500}
1501
1502PP(pp_andassign)
1503{
39644a26 1504 dSP;
a0d0e21e
LW		 1505 if (!SvTRUE(TOPs))
1506 RETURN;
1507 else
1508 RETURNOP(cLOGOP->op_other);
1509}
1510
1511PP(pp_orassign)
1512{
39644a26 1513 dSP;
a0d0e21e
LW		 1514 if (SvTRUE(TOPs))
1515 RETURN;
1516 else
1517 RETURNOP(cLOGOP->op_other);
1518}
c963b151
BD		 1519
1520PP(pp_dorassign)
1521{
1522 dSP;
1523 register SV* sv;
1524
1525 sv = TOPs;
1526 if (!sv || !SvANY(sv)) {
1527 RETURNOP(cLOGOP->op_other);
1528 }
1529
1530 switch (SvTYPE(sv)) {
1531 case SVt_PVAV:
1532 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1533 RETURN;
1534 break;
1535 case SVt_PVHV:
1536 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1537 RETURN;
1538 break;
1539 case SVt_PVCV:
1540 if (CvROOT(sv) || CvXSUB(sv))
1541 RETURN;
1542 break;
1543 default:
5b295bef 1544 SvGETMAGIC(sv);
c963b151
BD		 1545 if (SvOK(sv))
1546 RETURN;
1547 }
1548
1549 RETURNOP(cLOGOP->op_other);
1550}
1551
a0d0e21e
LW		 1552PP(pp_caller)
1553{
39644a26 1554 dSP;
a0d0e21e 1555 register I32 cxix = dopoptosub(cxstack_ix);
901017d6
AL		 1556 register const PERL_CONTEXT *cx;
1557 register const PERL_CONTEXT *ccstack = cxstack;
1558 const PERL_SI *top_si = PL_curstackinfo;
54310121 1559 I32 gimme;
06b5626a 1560 const char *stashname;
a0d0e21e
LW		 1561 I32 count = 0;
1562
1563 if (MAXARG)
1564 count = POPi;
27d41816 1565
a0d0e21e 1566 for (;;) {
2c375eb9
GS		 1567 /* we may be in a higher stacklevel, so dig down deeper */
1568 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1569 top_si = top_si->si_prev;
1570 ccstack = top_si->si_cxstack;
1571 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1572 }
a0d0e21e 1573 if (cxix < 0) {
27d41816
DM		 1574 if (GIMME != G_ARRAY) {
1575 EXTEND(SP, 1);
a0d0e21e 1576 RETPUSHUNDEF;
27d41816 1577 }
a0d0e21e
LW		 1578 RETURN;
1579 }
f2a7f298
DG		 1580 /* caller() should not report the automatic calls to &DB::sub */
1581 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
3280af22 1582 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1583 count++;
1584 if (!count--)
1585 break;
2c375eb9 1586 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1587 }
2c375eb9
GS		 1588
1589 cx = &ccstack[cxix];
7766f137 1590 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
f54cb97a 1591 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2c375eb9 1592 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1593 field below is defined for any cx. */
f2a7f298
DG		 1594 /* caller() should not report the automatic calls to &DB::sub */
1595 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1596 cx = &ccstack[dbcxix];
06a5b730 1597 }
1598
ed094faf 1599 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1600 if (GIMME != G_ARRAY) {
27d41816 1601 EXTEND(SP, 1);
ed094faf 1602 if (!stashname)
3280af22 1603 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1604 else {
1605 dTARGET;
ed094faf 1606 sv_setpv(TARG, stashname);
49d8d3a1
MB		 1607 PUSHs(TARG);
1608 }
a0d0e21e
LW		 1609 RETURN;
1610 }
a0d0e21e 1611
27d41816
DM		 1612 EXTEND(SP, 10);
1613
ed094faf 1614 if (!stashname)
3280af22 1615 PUSHs(&PL_sv_undef);
49d8d3a1 1616 else
ed094faf 1617 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
248c2a4d 1618 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
57843af0 1619 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW		 1620 if (!MAXARG)
1621 RETURN;
7766f137 1622 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
07b8c804 1623 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
7766f137 1624 /* So is ccstack[dbcxix]. */
07b8c804 1625 if (isGV(cvgv)) {
f54cb97a 1626 SV * const sv = NEWSV(49, 0);
07b8c804
RGS		 1627 gv_efullname3(sv, cvgv, Nullch);
1628 PUSHs(sv_2mortal(sv));
1629 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1630 }
1631 else {
1632 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
72699b0f 1633 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
07b8c804 1634 }
a0d0e21e
LW		 1635 }
1636 else {
79cb57f6 1637 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
a0d0e21e
LW		 1638 PUSHs(sv_2mortal(newSViv(0)));
1639 }
54310121 1640 gimme = (I32)cx->blk_gimme;
1641 if (gimme == G_VOID)
3280af22 1642 PUSHs(&PL_sv_undef);
54310121 1643 else
1644 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1645 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1646 /* eval STRING */
06a5b730 1647 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1648 PUSHs(cx->blk_eval.cur_text);
3280af22 1649 PUSHs(&PL_sv_no);
0f79a09d 1650 }
811a4de9 1651 /* require */
0f79a09d
GS		 1652 else if (cx->blk_eval.old_namesv) {
1653 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
3280af22 1654 PUSHs(&PL_sv_yes);
06a5b730 1655 }
811a4de9
GS		 1656 /* eval BLOCK (try blocks have old_namesv == 0) */
1657 else {
1658 PUSHs(&PL_sv_undef);
1659 PUSHs(&PL_sv_undef);
1660 }
4633a7c4 1661 }
a682de96
GS		 1662 else {
1663 PUSHs(&PL_sv_undef);
1664 PUSHs(&PL_sv_undef);
1665 }
1666 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1667 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1668 {
66a1b24b
AL		 1669 AV * const ary = cx->blk_sub.argarray;
1670 const int off = AvARRAY(ary) - AvALLOC(ary);
a0d0e21e 1671
3280af22 1672 if (!PL_dbargs) {
a0d0e21e 1673 GV* tmpgv;
3280af22 1674 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1675 SVt_PVAV)));
a5f75d66 1676 GvMULTI_on(tmpgv);
3ddcf04c 1677 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
a0d0e21e
LW		 1678 }
1679
3280af22
NIS		 1680 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1681 av_extend(PL_dbargs, AvFILLp(ary) + off);
1682 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1683 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1684 }
f3aa04c2
GS		 1685 /* XXX only hints propagated via op_private are currently
1686 * visible (others are not easily accessible, since they
1687 * use the global PL_hints) */
1688 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1689 HINT_PRIVATE_MASK)));
e476b1b5
GS		 1690 {
1691 SV * mask ;
1692 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba 1693
ac27b0f5 1694 if (old_warnings == pWARN_NONE ||
114bafba 1695 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1696 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
ac27b0f5 1697 else if (old_warnings == pWARN_ALL ||
75b6c4ca
RGS		 1698 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1699 /* Get the bit mask for $warnings::Bits{all}, because
1700 * it could have been extended by warnings::register */
1701 SV **bits_all;
1702 HV *bits = get_hv("warnings::Bits", FALSE);
1703 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1704 mask = newSVsv(*bits_all);
1705 }
1706 else {
1707 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1708 }
1709 }
e476b1b5
GS		 1710 else
1711 mask = newSVsv(old_warnings);
1712 PUSHs(sv_2mortal(mask));
1713 }
a0d0e21e
LW		 1714 RETURN;
1715}
1716
a0d0e21e
LW		 1717PP(pp_reset)
1718{
39644a26 1719 dSP;
bfed75c6 1720 const char *tmps;
a0d0e21e
LW		 1721
1722 if (MAXARG < 1)
1723 tmps = "";
1724 else
e62f0680 1725 tmps = POPpconstx;
11faa288 1726 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1727 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1728 RETURN;
1729}
1730
1731PP(pp_lineseq)
1732{
1733 return NORMAL;
1734}
1735
dd2155a4
DM		 1736/* like pp_nextstate, but used instead when the debugger is active */
1737
a0d0e21e
LW		 1738PP(pp_dbstate)
1739{
27da23d5 1740 dVAR;
533c011a 1741 PL_curcop = (COP*)PL_op;
a0d0e21e 1742 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1743 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1744 FREETMPS;
1745
5df8de69
DM		 1746 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1747 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1748 {
39644a26 1749 dSP;
a0d0e21e 1750 register CV *cv;
c09156bb 1751 register PERL_CONTEXT *cx;
f54cb97a 1752 const I32 gimme = G_ARRAY;
eb160463 1753 U8 hasargs;
a0d0e21e
LW		 1754 GV *gv;
1755
3280af22 1756 gv = PL_DBgv;
a0d0e21e 1757 cv = GvCV(gv);
a0d0e21e 1758 if (!cv)
cea2e8a9 1759 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1760
aea4f609
DM		 1761 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1762 /* don't do recursive DB::DB call */
a0d0e21e 1763 return NORMAL;
748a9306 1764
4633a7c4
LW		 1765 ENTER;
1766 SAVETMPS;
1767
3280af22 1768 SAVEI32(PL_debug);
55497cff 1769 SAVESTACK_POS();
3280af22 1770 PL_debug = 0;
748a9306 1771 hasargs = 0;
924508f0 1772 SPAGAIN;
748a9306 1773
924508f0 1774 PUSHBLOCK(cx, CXt_SUB, SP);
ee98a1d6 1775 PUSHSUB_DB(cx);
f39bc417 1776 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 1777 CvDEPTH(cv)++;
fd617465
DM		 1778 SAVECOMPPAD();
1779 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
a0d0e21e
LW		 1780 RETURNOP(CvSTART(cv));
1781 }
1782 else
1783 return NORMAL;
1784}
1785
1786PP(pp_scope)
1787{
1788 return NORMAL;
1789}
1790
1791PP(pp_enteriter)
1792{
27da23d5 1793 dVAR; dSP; dMARK;
c09156bb 1794 register PERL_CONTEXT *cx;
f54cb97a 1795 const I32 gimme = GIMME_V;
a0d0e21e 1796 SV **svp;
7766f137
GS		 1797 U32 cxtype = CXt_LOOP;
1798#ifdef USE_ITHREADS
1799 void *iterdata;
1800#endif
a0d0e21e 1801
4633a7c4
LW		 1802 ENTER;
1803 SAVETMPS;
1804
533c011a 1805 if (PL_op->op_targ) {
14f338dc
DM		 1806 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1807 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1808 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1809 SVs_PADSTALE, SVs_PADSTALE);
1810 }
c3564e5c 1811#ifndef USE_ITHREADS
dd2155a4 1812 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
54b9620d 1813 SAVESPTR(*svp);
c3564e5c
GS		 1814#else
1815 SAVEPADSV(PL_op->op_targ);
cbfa9890 1816 iterdata = INT2PTR(void*, PL_op->op_targ);
7766f137
GS		 1817 cxtype |= CXp_PADVAR;
1818#endif
54b9620d
MB		 1819 }
1820 else {
7766f137
GS		 1821 GV *gv = (GV*)POPs;
1822 svp = &GvSV(gv); /* symbol table variable */
0214ae40
GS		 1823 SAVEGENERICSV(*svp);
1824 *svp = NEWSV(0,0);
7766f137
GS		 1825#ifdef USE_ITHREADS
1826 iterdata = (void*)gv;
1827#endif
54b9620d 1828 }
4633a7c4 1829
a0d0e21e
LW		 1830 ENTER;
1831
7766f137
GS		 1832 PUSHBLOCK(cx, cxtype, SP);
1833#ifdef USE_ITHREADS
1834 PUSHLOOP(cx, iterdata, MARK);
1835#else
a0d0e21e 1836 PUSHLOOP(cx, svp, MARK);
7766f137 1837#endif
533c011a 1838 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1839 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1840 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1841 dPOPss;
4fe3f0fa 1842 SV *right = (SV*)cx->blk_loop.iterary;
984a4bea
RD		 1843 SvGETMAGIC(sv);
1844 SvGETMAGIC(right);
4fe3f0fa
MHM		 1845 if (RANGE_IS_NUMERIC(sv,right)) {
1846 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1847 (SvOK(right) && SvNV(right) >= IV_MAX))
076d9a11
MHM		 1848 DIE(aTHX_ "Range iterator outside integer range");
1849 cx->blk_loop.iterix = SvIV(sv);
4fe3f0fa 1850 cx->blk_loop.itermax = SvIV(right);
d4665a05
DM		 1851#ifdef DEBUGGING
1852 /* for correct -Dstv display */
1853 cx->blk_oldsp = sp - PL_stack_base;
1854#endif
89ea2908 1855 }
3f63a782 1856 else {
89ea2908 1857 cx->blk_loop.iterlval = newSVsv(sv);
13c5b33c 1858 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
10516c54 1859 (void) SvPV_nolen_const(right);
3f63a782 1860 }
89ea2908 1861 }
ef3e5ea9 1862 else if (PL_op->op_private & OPpITER_REVERSED) {
e682d7b7 1863 cx->blk_loop.itermax = -1;
ef3e5ea9
NC		 1864 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1865
1866 }
89ea2908 1867 }
4633a7c4 1868 else {
3280af22
NIS		 1869 cx->blk_loop.iterary = PL_curstack;
1870 AvFILLp(PL_curstack) = SP - PL_stack_base;
ef3e5ea9
NC		 1871 if (PL_op->op_private & OPpITER_REVERSED) {
1872 cx->blk_loop.itermax = MARK - PL_stack_base;
1873 cx->blk_loop.iterix = cx->blk_oldsp;
1874 }
1875 else {
1876 cx->blk_loop.iterix = MARK - PL_stack_base;
1877 }
4633a7c4 1878 }
a0d0e21e
LW		 1879
1880 RETURN;
1881}
1882
1883PP(pp_enterloop)
1884{
27da23d5 1885 dVAR; dSP;
c09156bb 1886 register PERL_CONTEXT *cx;
f54cb97a 1887 const I32 gimme = GIMME_V;
a0d0e21e
LW		 1888
1889 ENTER;
1890 SAVETMPS;
1891 ENTER;
1892
1893 PUSHBLOCK(cx, CXt_LOOP, SP);
1894 PUSHLOOP(cx, 0, SP);
1895
1896 RETURN;
1897}
1898
1899PP(pp_leaveloop)
1900{
27da23d5 1901 dVAR; dSP;
c09156bb 1902 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1903 I32 gimme;
1904 SV **newsp;
1905 PMOP *newpm;
1906 SV **mark;
1907
1908 POPBLOCK(cx,newpm);
3a1b2b9e 1909 assert(CxTYPE(cx) == CXt_LOOP);
4fdae800 1910 mark = newsp;
a8bba7fa 1911 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1912
a1f49e72 1913 TAINT_NOT;
54310121 1914 if (gimme == G_VOID)
1915 ; /* do nothing */
1916 else if (gimme == G_SCALAR) {
1917 if (mark < SP)
1918 *++newsp = sv_mortalcopy(*SP);
1919 else
3280af22 1920 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1921 }
1922 else {
a1f49e72 1923 while (mark < SP) {
a0d0e21e 1924 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1925 TAINT_NOT; /* Each item is independent */
1926 }
a0d0e21e 1927 }
f86702cc 1928 SP = newsp;
1929 PUTBACK;
1930
a8bba7fa 1931 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1932 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1933
a0d0e21e
LW		 1934 LEAVE;
1935 LEAVE;
1936
f86702cc 1937 return NORMAL;
a0d0e21e
LW		 1938}
1939
1940PP(pp_return)
1941{
27da23d5 1942 dVAR; dSP; dMARK;
a0d0e21e 1943 I32 cxix;
c09156bb 1944 register PERL_CONTEXT *cx;
f86702cc 1945 bool popsub2 = FALSE;
b45de488 1946 bool clear_errsv = FALSE;
a0d0e21e
LW		 1947 I32 gimme;
1948 SV **newsp;
1949 PMOP *newpm;
1950 I32 optype = 0;
b0d9ce38 1951 SV *sv;
f39bc417 1952 OP *retop;
a0d0e21e 1953
3280af22 1954 if (PL_curstackinfo->si_type == PERLSI_SORT) {
7766f137
GS		 1955 if (cxstack_ix == PL_sortcxix
1956 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1957 {
3280af22
NIS		 1958 if (cxstack_ix > PL_sortcxix)
1959 dounwind(PL_sortcxix);
1960 AvARRAY(PL_curstack)[1] = *SP;
1961 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1962 return 0;
1963 }
1964 }
1965
1966 cxix = dopoptosub(cxstack_ix);
1967 if (cxix < 0)
cea2e8a9 1968 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW		 1969 if (cxix < cxstack_ix)
1970 dounwind(cxix);
1971
1972 POPBLOCK(cx,newpm);
6b35e009 1973 switch (CxTYPE(cx)) {
a0d0e21e 1974 case CXt_SUB:
f86702cc 1975 popsub2 = TRUE;
f39bc417 1976 retop = cx->blk_sub.retop;
5dd42e15 1977 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW		 1978 break;
1979 case CXt_EVAL:
b45de488
GS		 1980 if (!(PL_in_eval & EVAL_KEEPERR))
1981 clear_errsv = TRUE;
a0d0e21e 1982 POPEVAL(cx);
f39bc417 1983 retop = cx->blk_eval.retop;
1d76a5c3
GS		 1984 if (CxTRYBLOCK(cx))
1985 break;
067f92a0 1986 lex_end();
748a9306
LW		 1987 if (optype == OP_REQUIRE &&
1988 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1989 {
54310121 1990 /* Unassume the success we assumed earlier. */
901017d6 1991 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 1992 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 1993 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
748a9306 1994 }
a0d0e21e 1995 break;
7766f137
GS		 1996 case CXt_FORMAT:
1997 POPFORMAT(cx);
f39bc417 1998 retop = cx->blk_sub.retop;
7766f137 1999 break;
a0d0e21e 2000 default:
cea2e8a9 2001 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 2002 }
2003
a1f49e72 2004 TAINT_NOT;
a0d0e21e 2005 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 2006 if (MARK < SP) {
2007 if (popsub2) {
a8bba7fa 2008 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ		 2009 if (SvTEMP(TOPs)) {
2010 *++newsp = SvREFCNT_inc(*SP);
2011 FREETMPS;
2012 sv_2mortal(*newsp);
959e3673
GS		 2013 }
2014 else {
2015 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 2016 FREETMPS;
959e3673
GS		 2017 *++newsp = sv_mortalcopy(sv);
2018 SvREFCNT_dec(sv);
a29cdaf0 2019 }
959e3673
GS		 2020 }
2021 else
a29cdaf0 2022 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS		 2023 }
2024 else
a29cdaf0 2025 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 2026 }
2027 else
3280af22 2028 *++newsp = &PL_sv_undef;
a0d0e21e 2029 }
54310121 2030 else if (gimme == G_ARRAY) {
a1f49e72 2031 while (++MARK <= SP) {
f86702cc 2032 *++newsp = (popsub2 && SvTEMP(*MARK))
2033 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2034 TAINT_NOT; /* Each item is independent */
2035 }
a0d0e21e 2036 }
3280af22 2037 PL_stack_sp = newsp;
a0d0e21e 2038
5dd42e15 2039 LEAVE;
f86702cc 2040 /* Stack values are safe: */
2041 if (popsub2) {
5dd42e15 2042 cxstack_ix--;
b0d9ce38 2043 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2044 }
b0d9ce38
GS		 2045 else
2046 sv = Nullsv;
3280af22 2047 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2048
b0d9ce38 2049 LEAVESUB(sv);
b45de488 2050 if (clear_errsv)
c69006e4 2051 sv_setpvn(ERRSV,"",0);
f39bc417 2052 return retop;
a0d0e21e
LW		 2053}
2054
2055PP(pp_last)
2056{
27da23d5 2057 dVAR; dSP;
a0d0e21e 2058 I32 cxix;
c09156bb 2059 register PERL_CONTEXT *cx;
f86702cc 2060 I32 pop2 = 0;
a0d0e21e 2061 I32 gimme;
8772537c 2062 I32 optype;
a0d0e21e
LW		 2063 OP *nextop;
2064 SV **newsp;
2065 PMOP *newpm;
a8bba7fa 2066 SV **mark;
b0d9ce38 2067 SV *sv = Nullsv;
9d4ba2ae 2068
a0d0e21e 2069
533c011a 2070 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2071 cxix = dopoptoloop(cxstack_ix);
2072 if (cxix < 0)
a651a37d 2073 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 2074 }
2075 else {
2076 cxix = dopoptolabel(cPVOP->op_pv);
2077 if (cxix < 0)
cea2e8a9 2078 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2079 }
2080 if (cxix < cxstack_ix)
2081 dounwind(cxix);
2082
2083 POPBLOCK(cx,newpm);
5dd42e15 2084 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2085 mark = newsp;
6b35e009 2086 switch (CxTYPE(cx)) {
a0d0e21e 2087 case CXt_LOOP:
f86702cc 2088 pop2 = CXt_LOOP;
a8bba7fa
GS		 2089 newsp = PL_stack_base + cx->blk_loop.resetsp;
2090 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 2091 break;
f86702cc 2092 case CXt_SUB:
f86702cc 2093 pop2 = CXt_SUB;
f39bc417 2094 nextop = cx->blk_sub.retop;
a0d0e21e 2095 break;
f86702cc 2096 case CXt_EVAL:
2097 POPEVAL(cx);
f39bc417 2098 nextop = cx->blk_eval.retop;
a0d0e21e 2099 break;
7766f137
GS		 2100 case CXt_FORMAT:
2101 POPFORMAT(cx);
f39bc417 2102 nextop = cx->blk_sub.retop;
7766f137 2103 break;
a0d0e21e 2104 default:
cea2e8a9 2105 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 2106 }
2107
a1f49e72 2108 TAINT_NOT;
a0d0e21e 2109 if (gimme == G_SCALAR) {
f86702cc 2110 if (MARK < SP)
2111 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2112 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2113 else
3280af22 2114 *++newsp = &PL_sv_undef;
a0d0e21e 2115 }
54310121 2116 else if (gimme == G_ARRAY) {
a1f49e72 2117 while (++MARK <= SP) {
f86702cc 2118 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2119 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2120 TAINT_NOT; /* Each item is independent */
2121 }
f86702cc 2122 }
2123 SP = newsp;
2124 PUTBACK;
2125
5dd42e15
DM		 2126 LEAVE;
2127 cxstack_ix--;
f86702cc 2128 /* Stack values are safe: */
2129 switch (pop2) {
2130 case CXt_LOOP:
a8bba7fa 2131 POPLOOP(cx); /* release loop vars ... */
4fdae800 2132 LEAVE;
f86702cc 2133 break;
2134 case CXt_SUB:
b0d9ce38 2135 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2136 break;
a0d0e21e 2137 }
3280af22 2138 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2139
b0d9ce38 2140 LEAVESUB(sv);
9d4ba2ae
AL		 2141 PERL_UNUSED_VAR(optype);
2142 PERL_UNUSED_VAR(gimme);
f86702cc 2143 return nextop;
a0d0e21e
LW		 2144}
2145
2146PP(pp_next)
2147{
27da23d5 2148 dVAR;
a0d0e21e 2149 I32 cxix;
c09156bb 2150 register PERL_CONTEXT *cx;
85538317 2151 I32 inner;
a0d0e21e 2152
533c011a 2153 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2154 cxix = dopoptoloop(cxstack_ix);
2155 if (cxix < 0)
a651a37d 2156 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 2157 }
2158 else {
2159 cxix = dopoptolabel(cPVOP->op_pv);
2160 if (cxix < 0)
cea2e8a9 2161 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2162 }
2163 if (cxix < cxstack_ix)
2164 dounwind(cxix);
2165
85538317
GS		 2166 /* clear off anything above the scope we're re-entering, but
2167 * save the rest until after a possible continue block */
2168 inner = PL_scopestack_ix;
1ba6ee2b 2169 TOPBLOCK(cx);
85538317
GS		 2170 if (PL_scopestack_ix < inner)
2171 leave_scope(PL_scopestack[PL_scopestack_ix]);
3a1b2b9e 2172 PL_curcop = cx->blk_oldcop;
1ba6ee2b 2173 return cx->blk_loop.next_op;
a0d0e21e
LW		 2174}
2175
2176PP(pp_redo)
2177{
27da23d5 2178 dVAR;
a0d0e21e 2179 I32 cxix;
c09156bb 2180 register PERL_CONTEXT *cx;
a0d0e21e 2181 I32 oldsave;
a034e688 2182 OP* redo_op;
a0d0e21e 2183
533c011a 2184 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2185 cxix = dopoptoloop(cxstack_ix);
2186 if (cxix < 0)
a651a37d 2187 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 2188 }
2189 else {
2190 cxix = dopoptolabel(cPVOP->op_pv);
2191 if (cxix < 0)
cea2e8a9 2192 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2193 }
2194 if (cxix < cxstack_ix)
2195 dounwind(cxix);
2196
a034e688
DM		 2197 redo_op = cxstack[cxix].blk_loop.redo_op;
2198 if (redo_op->op_type == OP_ENTER) {
2199 /* pop one less context to avoid $x being freed in while (my $x..) */
2200 cxstack_ix++;
2201 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2202 redo_op = redo_op->op_next;
2203 }
2204
a0d0e21e 2205 TOPBLOCK(cx);
3280af22 2206 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2207 LEAVE_SCOPE(oldsave);
936c78b5 2208 FREETMPS;
3a1b2b9e 2209 PL_curcop = cx->blk_oldcop;
a034e688 2210 return redo_op;
a0d0e21e
LW		 2211}
2212
0824fdcb 2213STATIC OP *
bfed75c6 2214S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2215{
a0d0e21e 2216 OP **ops = opstack;
bfed75c6 2217 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2218
fc36a67e 2219 if (ops >= oplimit)
cea2e8a9 2220 Perl_croak(aTHX_ too_deep);
11343788
MB		 2221 if (o->op_type == OP_LEAVE ||
2222 o->op_type == OP_SCOPE ||
2223 o->op_type == OP_LEAVELOOP ||
33d34e4c 2224 o->op_type == OP_LEAVESUB ||
11343788 2225 o->op_type == OP_LEAVETRY)
fc36a67e 2226 {
5dc0d613 2227 *ops++ = cUNOPo->op_first;
fc36a67e 2228 if (ops >= oplimit)
cea2e8a9 2229 Perl_croak(aTHX_ too_deep);
fc36a67e 2230 }
c4aa4e48 2231 *ops = 0;
11343788 2232 if (o->op_flags & OPf_KIDS) {
aec46f14 2233 OP *kid;
a0d0e21e 2234 /* First try all the kids at this level, since that's likeliest. */
11343788 2235 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 2236 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2237 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 2238 return kid;
2239 }
11343788 2240 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2241 if (kid == PL_lastgotoprobe)
a0d0e21e 2242 continue;
ed8d0fe2
SM		 2243 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2244 if (ops == opstack)
2245 *ops++ = kid;
2246 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2247 ops[-1]->op_type == OP_DBSTATE)
2248 ops[-1] = kid;
2249 else
2250 *ops++ = kid;
2251 }
155aba94 2252 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2253 return o;
a0d0e21e
LW		 2254 }
2255 }
c4aa4e48 2256 *ops = 0;
a0d0e21e
LW		 2257 return 0;
2258}
2259
2260PP(pp_dump)
2261{
cea2e8a9 2262 return pp_goto();
a0d0e21e
LW		 2263 /*NOTREACHED*/
2264}
2265
2266PP(pp_goto)
2267{
27da23d5 2268 dVAR; dSP;
a0d0e21e
LW		 2269 OP *retop = 0;
2270 I32 ix;
c09156bb 2271 register PERL_CONTEXT *cx;
fc36a67e 2272#define GOTO_DEPTH 64
2273 OP *enterops[GOTO_DEPTH];
bfed75c6
AL		 2274 const char *label = 0;
2275 const bool do_dump = (PL_op->op_type == OP_DUMP);
2276 static const char must_have_label[] = "goto must have label";
a0d0e21e 2277
533c011a 2278 if (PL_op->op_flags & OPf_STACKED) {
9d4ba2ae 2279 SV * const sv = POPs;
a0d0e21e
LW		 2280
2281 /* This egregious kludge implements goto &subroutine */
2282 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2283 I32 cxix;
c09156bb 2284 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2285 CV* cv = (CV*)SvRV(sv);
2286 SV** mark;
2287 I32 items = 0;
2288 I32 oldsave;
b1464ded 2289 bool reified = 0;
a0d0e21e 2290
e8f7dd13 2291 retry:
4aa0a1f7 2292 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2293 const GV * const gv = CvGV(cv);
e8f7dd13 2294 if (gv) {
7fc63493 2295 GV *autogv;
e8f7dd13
GS		 2296 SV *tmpstr;
2297 /* autoloaded stub? */
2298 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2299 goto retry;
2300 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2301 GvNAMELEN(gv), FALSE);
2302 if (autogv && (cv = GvCV(autogv)))
2303 goto retry;
2304 tmpstr = sv_newmortal();
2305 gv_efullname3(tmpstr, gv, Nullch);
35c1215d 2306 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
4aa0a1f7 2307 }
cea2e8a9 2308 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2309 }
2310
a0d0e21e 2311 /* First do some returnish stuff. */
7fc63493 2312 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
71fc2216 2313 FREETMPS;
a0d0e21e
LW		 2314 cxix = dopoptosub(cxstack_ix);
2315 if (cxix < 0)
cea2e8a9 2316 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2317 if (cxix < cxstack_ix)
2318 dounwind(cxix);
2319 TOPBLOCK(cx);
2d43a17f 2320 SPAGAIN;
564abe23 2321 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2d43a17f 2322 if (CxTYPE(cx) == CXt_EVAL) {
c74ace89
DM		 2323 if (CxREALEVAL(cx))
2324 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2325 else
2326 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2d43a17f 2327 }
d8b46c1b
GS		 2328 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2329 /* put @_ back onto stack */
a0d0e21e 2330 AV* av = cx->blk_sub.argarray;
bfed75c6 2331
93965878 2332 items = AvFILLp(av) + 1;
a45cdc79
DM		 2333 EXTEND(SP, items+1); /* @_ could have been extended. */
2334 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS		 2335 SvREFCNT_dec(GvAV(PL_defgv));
2336 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2337 CLEAR_ARGARRAY(av);
d8b46c1b 2338 /* abandon @_ if it got reified */
62b1ebc2 2339 if (AvREAL(av)) {
b1464ded
DM		 2340 reified = 1;
2341 SvREFCNT_dec(av);
d8b46c1b
GS		 2342 av = newAV();
2343 av_extend(av, items-1);
11ca45c0 2344 AvREIFY_only(av);
dd2155a4 2345 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2346 }
a0d0e21e 2347 }
1fa4e549 2348 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
890ce7af 2349 AV* const av = GvAV(PL_defgv);
1fa4e549 2350 items = AvFILLp(av) + 1;
a45cdc79
DM		 2351 EXTEND(SP, items+1); /* @_ could have been extended. */
2352 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2353 }
a45cdc79
DM		 2354 mark = SP;
2355 SP += items;
6b35e009 2356 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2357 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2358 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2359 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2360 LEAVE_SCOPE(oldsave);
2361
2362 /* Now do some callish stuff. */
2363 SAVETMPS;
5023d17a 2364 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
a0d0e21e 2365 if (CvXSUB(cv)) {
5eff7df7 2366 OP* retop = cx->blk_sub.retop;
b1464ded
DM		 2367 if (reified) {
2368 I32 index;
2369 for (index=0; index<items; index++)
2370 sv_2mortal(SP[-index]);
2371 }
67caa1fe 2372#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2373 if (CvOLDSTYLE(cv)) {
20ce7b12 2374 I32 (*fp3)(int,int,int);
924508f0
GS		 2375 while (SP > mark) {
2376 SP[1] = SP[0];
2377 SP--;
a0d0e21e 2378 }
7766f137 2379 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2380 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2381 mark - PL_stack_base + 1,
ecfc5424 2382 items);
3280af22 2383 SP = PL_stack_base + items;
a0d0e21e 2384 }
67caa1fe
GS		 2385 else
2386#endif /* PERL_XSUB_OLDSTYLE */
2387 {
1fa4e549
AD		 2388 SV **newsp;
2389 I32 gimme;
2390
5eff7df7
DM		 2391 /* XS subs don't have a CxSUB, so pop it */
2392 POPBLOCK(cx, PL_curpm);
1fa4e549 2393 /* Push a mark for the start of arglist */
ac27b0f5 2394 PUSHMARK(mark);
a45cdc79 2395 PUTBACK;
acfe0abc 2396 (void)(*CvXSUB(cv))(aTHX_ cv);
1b6737cc
AL		 2397 /* Put these at the bottom since the vars are set but not used */
2398 PERL_UNUSED_VAR(newsp);
2399 PERL_UNUSED_VAR(gimme);
a0d0e21e
LW		 2400 }
2401 LEAVE;
5eff7df7 2402 return retop;
a0d0e21e
LW		 2403 }
2404 else {
2405 AV* padlist = CvPADLIST(cv);
6b35e009 2406 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2407 PL_in_eval = cx->blk_eval.old_in_eval;
2408 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2409 cx->cx_type = CXt_SUB;
2410 cx->blk_sub.hasargs = 0;
2411 }
a0d0e21e 2412 cx->blk_sub.cv = cv;
eb160463 2413 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
dd2155a4 2414
a0d0e21e
LW		 2415 CvDEPTH(cv)++;
2416 if (CvDEPTH(cv) < 2)
2417 (void)SvREFCNT_inc(cv);
dd2155a4 2418 else {
599cee73 2419 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2420 sub_crush_depth(cv);
26019298 2421 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2422 }
fd617465
DM		 2423 SAVECOMPPAD();
2424 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
6d4ff0d2 2425 if (cx->blk_sub.hasargs)
6d4ff0d2 2426 {
dd2155a4 2427 AV* av = (AV*)PAD_SVl(0);
a0d0e21e
LW		 2428 SV** ary;
2429
3280af22
NIS		 2430 cx->blk_sub.savearray = GvAV(PL_defgv);
2431 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2432 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2433 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2434
2435 if (items >= AvMAX(av) + 1) {
2436 ary = AvALLOC(av);
2437 if (AvARRAY(av) != ary) {
2438 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
f880fe2f 2439 SvPV_set(av, (char*)ary);
a0d0e21e
LW		 2440 }
2441 if (items >= AvMAX(av) + 1) {
2442 AvMAX(av) = items - 1;
2443 Renew(ary,items+1,SV*);
2444 AvALLOC(av) = ary;
f880fe2f 2445 SvPV_set(av, (char*)ary);
a0d0e21e
LW		 2446 }
2447 }
a45cdc79 2448 ++mark;
a0d0e21e 2449 Copy(mark,AvARRAY(av),items,SV*);
93965878 2450 AvFILLp(av) = items - 1;
d8b46c1b 2451 assert(!AvREAL(av));
b1464ded
DM		 2452 if (reified) {
2453 /* transfer 'ownership' of refcnts to new @_ */
2454 AvREAL_on(av);
2455 AvREIFY_off(av);
2456 }
a0d0e21e
LW		 2457 while (items--) {
2458 if (*mark)
2459 SvTEMP_off(*mark);
2460 mark++;
2461 }
2462 }
491527d0 2463 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2464 /*
2465 * We do not care about using sv to call CV;
2466 * it's for informational purposes only.
2467 */
890ce7af 2468 SV * const sv = GvSV(PL_DBsub);
491527d0 2469 CV *gotocv;
bfed75c6 2470
f398eb67 2471 save_item(sv);
491527d0 2472 if (PERLDB_SUB_NN) {
890ce7af 2473 const int type = SvTYPE(sv);
f398eb67
NC		 2474 if (type < SVt_PVIV && type != SVt_IV)
2475 sv_upgrade(sv, SVt_PVIV);
7619c85e 2476 (void)SvIOK_on(sv);
45977657 2477 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
491527d0 2478 } else {
491527d0
GS		 2479 gv_efullname3(sv, CvGV(cv), Nullch);
2480 }
2481 if ( PERLDB_GOTO
864dbfa3 2482 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2483 PUSHMARK( PL_stack_sp );
864dbfa3 2484 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2485 PL_stack_sp--;
491527d0 2486 }
1ce6579f 2487 }
a0d0e21e
LW		 2488 RETURNOP(CvSTART(cv));
2489 }
2490 }
1614b0e3 2491 else {
0510663f 2492 label = SvPV_nolen_const(sv);
1614b0e3 2493 if (!(do_dump || *label))
cea2e8a9 2494 DIE(aTHX_ must_have_label);
1614b0e3 2495 }
a0d0e21e 2496 }
533c011a 2497 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2498 if (! do_dump)
cea2e8a9 2499 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2500 }
2501 else
2502 label = cPVOP->op_pv;
2503
2504 if (label && *label) {
2505 OP *gotoprobe = 0;
3b2447bc 2506 bool leaving_eval = FALSE;
33d34e4c 2507 bool in_block = FALSE;
a4f3a277 2508 PERL_CONTEXT *last_eval_cx = 0;
a0d0e21e
LW		 2509
2510 /* find label */
2511
3280af22 2512 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2513 *enterops = 0;
2514 for (ix = cxstack_ix; ix >= 0; ix--) {
2515 cx = &cxstack[ix];
6b35e009 2516 switch (CxTYPE(cx)) {
a0d0e21e 2517 case CXt_EVAL:
3b2447bc 2518 leaving_eval = TRUE;
971ecbe6 2519 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH		 2520 gotoprobe = (last_eval_cx ?
2521 last_eval_cx->blk_eval.old_eval_root :
2522 PL_eval_root);
2523 last_eval_cx = cx;
9c5794fe
RH		 2524 break;
2525 }
2526 /* else fall through */
a0d0e21e
LW		 2527 case CXt_LOOP:
2528 gotoprobe = cx->blk_oldcop->op_sibling;
2529 break;
2530 case CXt_SUBST:
2531 continue;
2532 case CXt_BLOCK:
33d34e4c 2533 if (ix) {
a0d0e21e 2534 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE		 2535 in_block = TRUE;
2536 } else
3280af22 2537 gotoprobe = PL_main_root;
a0d0e21e 2538 break;
b3933176
CS		 2539 case CXt_SUB:
2540 if (CvDEPTH(cx->blk_sub.cv)) {
2541 gotoprobe = CvROOT(cx->blk_sub.cv);
2542 break;
2543 }
2544 /* FALL THROUGH */
7766f137 2545 case CXt_FORMAT:
0a753a76 2546 case CXt_NULL:
a651a37d 2547 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 2548 default:
2549 if (ix)
cea2e8a9 2550 DIE(aTHX_ "panic: goto");
3280af22 2551 gotoprobe = PL_main_root;
a0d0e21e
LW		 2552 break;
2553 }
2b597662
GS		 2554 if (gotoprobe) {
2555 retop = dofindlabel(gotoprobe, label,
2556 enterops, enterops + GOTO_DEPTH);
2557 if (retop)
2558 break;
2559 }
3280af22 2560 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2561 }
2562 if (!retop)
cea2e8a9 2563 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2564
3b2447bc
RH		 2565 /* if we're leaving an eval, check before we pop any frames
2566 that we're not going to punt, otherwise the error
2567 won't be caught */
2568
2569 if (leaving_eval && *enterops && enterops[1]) {
2570 I32 i;
2571 for (i = 1; enterops[i]; i++)
2572 if (enterops[i]->op_type == OP_ENTERITER)
2573 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2574 }
2575
a0d0e21e
LW		 2576 /* pop unwanted frames */
2577
2578 if (ix < cxstack_ix) {
2579 I32 oldsave;
2580
2581 if (ix < 0)
2582 ix = 0;
2583 dounwind(ix);
2584 TOPBLOCK(cx);
3280af22 2585 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2586 LEAVE_SCOPE(oldsave);
2587 }
2588
2589 /* push wanted frames */
2590
748a9306 2591 if (*enterops && enterops[1]) {
533c011a 2592 OP *oldop = PL_op;
33d34e4c
AE		 2593 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2594 for (; enterops[ix]; ix++) {
533c011a 2595 PL_op = enterops[ix];
84902520
TB		 2596 /* Eventually we may want to stack the needed arguments
2597 * for each op. For now, we punt on the hard ones. */
533c011a 2598 if (PL_op->op_type == OP_ENTERITER)
894356b3 2599 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2600 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2601 }
533c011a 2602 PL_op = oldop;
a0d0e21e
LW		 2603 }
2604 }
2605
2606 if (do_dump) {
a5f75d66 2607#ifdef VMS
6b88bc9c 2608 if (!retop) retop = PL_main_start;
a5f75d66 2609#endif
3280af22
NIS		 2610 PL_restartop = retop;
2611 PL_do_undump = TRUE;
a0d0e21e
LW		 2612
2613 my_unexec();
2614
3280af22
NIS		 2615 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2616 PL_do_undump = FALSE;
a0d0e21e
LW		 2617 }
2618
2619 RETURNOP(retop);
2620}
2621
2622PP(pp_exit)
2623{
39644a26 2624 dSP;
a0d0e21e
LW		 2625 I32 anum;
2626
2627 if (MAXARG < 1)
2628 anum = 0;
ff0cee69 2629 else {
a0d0e21e 2630 anum = SvIVx(POPs);
d98f61e7
GS		 2631#ifdef VMS
2632 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2633 anum = 0;
96e176bf 2634 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69 2635#endif
2636 }
cc3604b1 2637 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2638 my_exit(anum);
3280af22 2639 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2640 RETURN;
2641}
2642
2643#ifdef NOTYET
2644PP(pp_nswitch)
2645{
39644a26 2646 dSP;
f54cb97a 2647 const NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2648 register I32 match = I_32(value);
2649
2650 if (value < 0.0) {
65202027 2651 if (((NV)match) > value)
a0d0e21e
LW		 2652 --match; /* was fractional--truncate other way */
2653 }
2654 match -= cCOP->uop.scop.scop_offset;
2655 if (match < 0)
2656 match = 0;
2657 else if (match > cCOP->uop.scop.scop_max)
2658 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2659 PL_op = cCOP->uop.scop.scop_next[match];
2660 RETURNOP(PL_op);
a0d0e21e
LW		 2661}
2662
2663PP(pp_cswitch)
2664{
39644a26 2665 dSP;
a0d0e21e
LW		 2666 register I32 match;
2667
6b88bc9c
GS		 2668 if (PL_multiline)
2669 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2670 else {
0510663f 2671 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
a0d0e21e
LW		 2672 match -= cCOP->uop.scop.scop_offset;
2673 if (match < 0)
2674 match = 0;
2675 else if (match > cCOP->uop.scop.scop_max)
2676 match = cCOP->uop.scop.scop_max;
6b88bc9c 2677 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2678 }
6b88bc9c 2679 RETURNOP(PL_op);
a0d0e21e
LW		 2680}
2681#endif
2682
2683/* Eval. */
2684
0824fdcb 2685STATIC void
cea2e8a9 2686S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2687{
504618e9 2688 const char *s = SvPVX_const(sv);
890ce7af 2689 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 2690 I32 line = 1;
a0d0e21e
LW		 2691
2692 while (s && s < send) {
f54cb97a 2693 const char *t;
890ce7af 2694 SV * const tmpstr = NEWSV(85,0);
a0d0e21e
LW		 2695
2696 sv_upgrade(tmpstr, SVt_PVMG);
2697 t = strchr(s, '\n');
2698 if (t)
2699 t++;
2700 else
2701 t = send;
2702
2703 sv_setpvn(tmpstr, s, t - s);
2704 av_store(array, line++, tmpstr);
2705 s = t;
2706 }
2707}
2708
901017d6 2709STATIC void
14dd3ad8
GS		 2710S_docatch_body(pTHX)
2711{
cea2e8a9 2712 CALLRUNOPS(aTHX);
901017d6 2713 return;
312caa8e
CS		 2714}
2715
0824fdcb 2716STATIC OP *
cea2e8a9 2717S_docatch(pTHX_ OP *o)
1e422769 2718{
6224f72b 2719 int ret;
06b5626a 2720 OP * const oldop = PL_op;
db36c5a1 2721 dJMPENV;
1e422769 2722
1e422769 2723#ifdef DEBUGGING
54310121 2724 assert(CATCH_GET == TRUE);
1e422769 2725#endif
312caa8e 2726 PL_op = o;
8bffa5f8 2727
14dd3ad8 2728 JMPENV_PUSH(ret);
6224f72b 2729 switch (ret) {
312caa8e 2730 case 0:
abd70938
DM		 2731 assert(cxstack_ix >= 0);
2732 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2733 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8
GS		 2734 redo_body:
2735 docatch_body();
312caa8e
CS		 2736 break;
2737 case 3:
8bffa5f8 2738 /* die caught by an inner eval - continue inner loop */
abd70938
DM		 2739
2740 /* NB XXX we rely on the old popped CxEVAL still being at the top
2741 * of the stack; the way die_where() currently works, this
2742 * assumption is valid. In theory The cur_top_env value should be
2743 * returned in another global, the way retop (aka PL_restartop)
2744 * is. */
2745 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2746
2747 if (PL_restartop
2748 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2749 {
312caa8e
CS		 2750 PL_op = PL_restartop;
2751 PL_restartop = 0;
2752 goto redo_body;
2753 }
2754 /* FALL THROUGH */
2755 default:
14dd3ad8 2756 JMPENV_POP;
533c011a 2757 PL_op = oldop;
6224f72b 2758 JMPENV_JUMP(ret);
1e422769 2759 /* NOTREACHED */
1e422769 2760 }
14dd3ad8 2761 JMPENV_POP;
533c011a 2762 PL_op = oldop;
745cf2ff 2763 return Nullop;
1e422769 2764}
2765
c277df42 2766OP *
bfed75c6 2767Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ		 2768/* sv Text to convert to OP tree. */
2769/* startop op_free() this to undo. */
2770/* code Short string id of the caller. */
2771{
27da23d5 2772 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ		 2773 PERL_CONTEXT *cx;
2774 SV **newsp;
b094c71d 2775 I32 gimme = G_VOID;
c277df42
IZ		 2776 I32 optype;
2777 OP dummy;
155aba94 2778 OP *rop;
83ee9e09
GS		 2779 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2780 char *tmpbuf = tbuf;
c277df42 2781 char *safestr;
a3985cdc 2782 int runtime;
40b8d195 2783 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
c277df42
IZ		 2784
2785 ENTER;
2786 lex_start(sv);
2787 SAVETMPS;
2788 /* switch to eval mode */
2789
923e4eb5 2790 if (IN_PERL_COMPILETIME) {
f4dd75d9 2791 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2792 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2793 }
83ee9e09 2794 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
9d4ba2ae 2795 SV * const sv = sv_newmortal();
83ee9e09
GS		 2796 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2797 code, (unsigned long)++PL_evalseq,
2798 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2799 tmpbuf = SvPVX(sv);
2800 }
2801 else
2802 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
f4dd75d9 2803 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2804 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2805 SAVECOPLINE(&PL_compiling);
57843af0 2806 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2807 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2808 deleting the eval's FILEGV from the stash before gv_check() runs
2809 (i.e. before run-time proper). To work around the coredump that
2810 ensues, we always turn GvMULTI_on for any globals that were
2811 introduced within evals. See force_ident(). GSAR 96-10-12 */
2812 safestr = savepv(tmpbuf);
3280af22 2813 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2814 SAVEHINTS();
d1ca3daa 2815#ifdef OP_IN_REGISTER
6b88bc9c 2816 PL_opsave = op;
d1ca3daa 2817#else
7766f137 2818 SAVEVPTR(PL_op);
d1ca3daa 2819#endif
c277df42 2820
a3985cdc 2821 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2822 runtime = IN_PERL_RUNTIME;
a3985cdc 2823 if (runtime)
d819b83a 2824 runcv = find_runcv(NULL);
a3985cdc 2825
533c011a 2826 PL_op = &dummy;
13b51b79 2827 PL_op->op_type = OP_ENTEREVAL;
533c011a 2828 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2829 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
cc49e20b 2830 PUSHEVAL(cx, 0, Nullgv);
a3985cdc
DM		 2831
2832 if (runtime)
2833 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2834 else
2835 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2836 POPBLOCK(cx,PL_curpm);
e84b9f1f 2837 POPEVAL(cx);
c277df42
IZ		 2838
2839 (*startop)->op_type = OP_NULL;
22c35a8c 2840 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2841 lex_end();
f3548bdc
DM		 2842 /* XXX DAPM do this properly one year */
2843 *padp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2844 LEAVE;
923e4eb5 2845 if (IN_PERL_COMPILETIME)
eb160463 2846 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
d1ca3daa 2847#ifdef OP_IN_REGISTER
6b88bc9c 2848 op = PL_opsave;
d1ca3daa 2849#endif
9d4ba2ae
AL		 2850 PERL_UNUSED_VAR(newsp);
2851 PERL_UNUSED_VAR(optype);
2852
c277df42
IZ		 2853 return rop;
2854}
2855
a3985cdc
DM		 2856
2857/*
2858=for apidoc find_runcv
2859
2860Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM		 2861If db_seqp is non_null, skip CVs that are in the DB package and populate
2862*db_seqp with the cop sequence number at the point that the DB:: code was
2863entered. (allows debuggers to eval in the scope of the breakpoint rather
cf525c36 2864than in the scope of the debugger itself).
a3985cdc
DM		 2865
2866=cut
2867*/
2868
2869CV*
d819b83a 2870Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 2871{
a3985cdc 2872 PERL_SI *si;
a3985cdc 2873
d819b83a
DM		 2874 if (db_seqp)
2875 *db_seqp = PL_curcop->cop_seq;
a3985cdc 2876 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 2877 I32 ix;
a3985cdc 2878 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 2879 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a 2880 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1b6737cc 2881 CV * const cv = cx->blk_sub.cv;
d819b83a
DM		 2882 /* skip DB:: code */
2883 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2884 *db_seqp = cx->blk_oldcop->cop_seq;
2885 continue;
2886 }
2887 return cv;
2888 }
a3985cdc
DM		 2889 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2890 return PL_compcv;
2891 }
2892 }
2893 return PL_main_cv;
2894}
2895
2896
2897/* Compile a require/do, an eval '', or a /(?{...})/.
2898 * In the last case, startop is non-null, and contains the address of
2899 * a pointer that should be set to the just-compiled code.
2900 * outside is the lexically enclosing CV (if any) that invoked us.
2901 */
2902
4d1ff10f 2903/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2904STATIC OP *
a3985cdc 2905S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 2906{
27da23d5 2907 dVAR; dSP;
46c461b5 2908 OP * const saveop = PL_op;
a0d0e21e 2909
6dc8a9e4
IZ		 2910 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2911 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2912 : EVAL_INEVAL);
a0d0e21e 2913
1ce6579f 2914 PUSHMARK(SP);
2915
3280af22
NIS		 2916 SAVESPTR(PL_compcv);
2917 PL_compcv = (CV*)NEWSV(1104,0);
2918 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2919 CvEVAL_on(PL_compcv);
2090ab20
JH		 2920 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2921 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2922
a3985cdc 2923 CvOUTSIDE_SEQ(PL_compcv) = seq;
7dafbf52 2924 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
a3985cdc 2925
dd2155a4 2926 /* set up a scratch pad */
a0d0e21e 2927
dd2155a4 2928 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2c05e328 2929
07055b4c 2930
26d9b02f 2931 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2932
a0d0e21e
LW		 2933 /* make sure we compile in the right package */
2934
ed094faf 2935 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2936 SAVESPTR(PL_curstash);
ed094faf 2937 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2938 }
3280af22
NIS		 2939 SAVESPTR(PL_beginav);
2940 PL_beginav = newAV();
2941 SAVEFREESV(PL_beginav);
24944567 2942 SAVEI32(PL_error_count);
a0d0e21e
LW		 2943
2944 /* try to compile it */
2945
3280af22
NIS		 2946 PL_eval_root = Nullop;
2947 PL_error_count = 0;
2948 PL_curcop = &PL_compiling;
2949 PL_curcop->cop_arybase = 0;
c277df42 2950 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2951 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2952 else
c69006e4 2953 sv_setpvn(ERRSV,"",0);
3280af22 2954 if (yyparse() || PL_error_count || !PL_eval_root) {
0c58d367 2955 SV **newsp; /* Used by POPBLOCK. */
9d4ba2ae 2956 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2957 I32 optype = 0; /* Might be reset by POPEVAL. */
9d4ba2ae 2958 const char *msg;
bfed75c6 2959
533c011a 2960 PL_op = saveop;
3280af22
NIS		 2961 if (PL_eval_root) {
2962 op_free(PL_eval_root);
2963 PL_eval_root = Nullop;
a0d0e21e 2964 }
3280af22 2965 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2966 if (!startop) {
3280af22 2967 POPBLOCK(cx,PL_curpm);
c277df42 2968 POPEVAL(cx);
c277df42 2969 }
a0d0e21e
LW		 2970 lex_end();
2971 LEAVE;
9d4ba2ae
AL		 2972
2973 msg = SvPVx_nolen_const(ERRSV);
7a2e2cd6 2974 if (optype == OP_REQUIRE) {
b464bac0 2975 const SV * const nsv = cx->blk_eval.old_namesv;
504618e9 2976 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 2977 &PL_sv_undef, 0);
5a844595
GS		 2978 DIE(aTHX_ "%sCompilation failed in require",
2979 *msg ? msg : "Unknown error\n");
2980 }
2981 else if (startop) {
3280af22 2982 POPBLOCK(cx,PL_curpm);
c277df42 2983 POPEVAL(cx);
5a844595
GS		 2984 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2985 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2986 }
9d7f88dd 2987 else {
9d7f88dd
SR		 2988 if (!*msg) {
2989 sv_setpv(ERRSV, "Compilation error");
2990 }
2991 }
9d4ba2ae 2992 PERL_UNUSED_VAR(newsp);
a0d0e21e
LW		 2993 RETPUSHUNDEF;
2994 }
57843af0 2995 CopLINE_set(&PL_compiling, 0);
c277df42 2996 if (startop) {
3280af22 2997 *startop = PL_eval_root;
c277df42 2998 } else
3280af22 2999 SAVEFREEOP(PL_eval_root);
0c58d367
RGS		 3000
3001 /* Set the context for this new optree.
3002 * If the last op is an OP_REQUIRE, force scalar context.
3003 * Otherwise, propagate the context from the eval(). */
3004 if (PL_eval_root->op_type == OP_LEAVEEVAL
3005 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3006 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3007 == OP_REQUIRE)
3008 scalar(PL_eval_root);
3009 else if (gimme & G_VOID)
3280af22 3010 scalarvoid(PL_eval_root);
54310121 3011 else if (gimme & G_ARRAY)
3280af22 3012 list(PL_eval_root);
a0d0e21e 3013 else
3280af22 3014 scalar(PL_eval_root);
a0d0e21e
LW		 3015
3016 DEBUG_x(dump_eval());
3017
55497cff 3018 /* Register with debugger: */
84902520 3019 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
890ce7af 3020 CV * const cv = get_cv("DB::postponed", FALSE);
55497cff 3021 if (cv) {
3022 dSP;
924508f0 3023 PUSHMARK(SP);
cc49e20b 3024 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 3025 PUTBACK;
864dbfa3 3026 call_sv((SV*)cv, G_DISCARD);
55497cff 3027 }
3028 }
3029
a0d0e21e
LW		 3030 /* compiled okay, so do it */
3031
3280af22
NIS		 3032 CvDEPTH(PL_compcv) = 1;
3033 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 3034 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 3035 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 3036
3280af22 3037 RETURNOP(PL_eval_start);
a0d0e21e
LW		 3038}
3039
a6c40364 3040STATIC PerlIO *
7925835c 3041S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3042{
7925835c 3043#ifndef PERL_DISABLE_PMC
f54cb97a 3044 const STRLEN namelen = strlen(name);
b295d113
TH		 3045 PerlIO *fp;
3046
7894fbab 3047 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
9d4ba2ae 3048 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
349d4f2f 3049 const char * const pmc = SvPV_nolen_const(pmcsv);
a6c40364
GS		 3050 Stat_t pmcstat;
3051 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 3052 fp = PerlIO_open(name, mode);
a6c40364
GS		 3053 }
3054 else {
9d4ba2ae 3055 Stat_t pmstat;
b295d113 3056 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 3057 pmstat.st_mtime < pmcstat.st_mtime)
3058 {
3059 fp = PerlIO_open(pmc, mode);
3060 }
3061 else {
3062 fp = PerlIO_open(name, mode);
3063 }
b295d113 3064 }
a6c40364
GS		 3065 SvREFCNT_dec(pmcsv);
3066 }
3067 else {
3068 fp = PerlIO_open(name, mode);
b295d113 3069 }
b295d113 3070 return fp;
7925835c
RGS		 3071#else
3072 return PerlIO_open(name, mode);
3073#endif /* !PERL_DISABLE_PMC */
b295d113
TH		 3074}
3075
a0d0e21e
LW		 3076PP(pp_require)
3077{
27da23d5 3078 dVAR; dSP;
c09156bb 3079 register PERL_CONTEXT *cx;
a0d0e21e 3080 SV *sv;
5c144d81 3081 const char *name;
6132ea6c 3082 STRLEN len;
5c144d81 3083 const char *tryname = Nullch;
46fc3d4c 3084 SV *namesv = Nullsv;
a0d0e21e 3085 SV** svp;
f54cb97a 3086 const I32 gimme = GIMME_V;
760ac839 3087 PerlIO *tryrsfp = 0;
bbed91b5
KF		 3088 int filter_has_file = 0;
3089 GV *filter_child_proc = 0;
3090 SV *filter_state = 0;
3091 SV *filter_sub = 0;
89ccab8c 3092 SV *hook_sv = 0;
6ec9efec
JH		 3093 SV *encoding;
3094 OP *op;
a0d0e21e
LW		 3095
3096 sv = POPs;
d7aa5382
JP		 3097 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3098 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
9014280d 3099 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 3100 "v-string in use/require non-portable");
d7aa5382
JP		 3101
3102 sv = new_version(sv);
3103 if (!sv_derived_from(PL_patchlevel, "version"))
3104 (void *)upg_version(PL_patchlevel);
3105 if ( vcmp(sv,PL_patchlevel) > 0 )
9137345a
JP		 3106 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3107 vnormal(sv), vnormal(PL_patchlevel));
d7aa5382 3108
4305d8ab 3109 RETPUSHYES;
a0d0e21e 3110 }
5c144d81 3111 name = SvPV_const(sv, len);
6132ea6c 3112 if (!(name && len > 0 && *name))
cea2e8a9 3113 DIE(aTHX_ "Null filename used");
4633a7c4 3114 TAINT_PROPER("require");
533c011a 3115 if (PL_op->op_type == OP_REQUIRE &&
27bcc0a7
RGS		 3116 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3117 if (*svp != &PL_sv_undef)
4d8b06f1
RD		 3118 RETPUSHYES;
3119 else
3120 DIE(aTHX_ "Compilation failed in require");
3121 }
a0d0e21e
LW		 3122
3123 /* prepare to compile file */
3124
be4b629d 3125 if (path_is_absolute(name)) {
46fc3d4c 3126 tryname = name;
7925835c 3127 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
bf4acbe4 3128 }
67627c52
JH		 3129#ifdef MACOS_TRADITIONAL
3130 if (!tryrsfp) {
3131 char newname[256];
3132
3133 MacPerl_CanonDir(name, newname, 1);
3134 if (path_is_absolute(newname)) {
3135 tryname = newname;
7925835c 3136 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
67627c52
JH		 3137 }
3138 }
3139#endif
be4b629d 3140 if (!tryrsfp) {
3280af22 3141 AV *ar = GvAVn(PL_incgv);
a0d0e21e 3142 I32 i;
748a9306 3143#ifdef VMS
46fc3d4c 3144 char *unixname;
b8ffc8df 3145 if ((unixname = tounixspec(name, Nullch)) != Nullch)
46fc3d4c 3146#endif
3147 {
3148 namesv = NEWSV(806, 0);
3149 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF		 3150 SV *dirsv = *av_fetch(ar, i, TRUE);
3151
3152 if (SvROK(dirsv)) {
3153 int count;
3154 SV *loader = dirsv;
3155
e14e2dc8
NC		 3156 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3157 && !sv_isobject(loader))
3158 {
bbed91b5
KF		 3159 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3160 }
3161
b900a521 3162 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3163 PTR2UV(SvRV(dirsv)), name);
349d4f2f 3164 tryname = SvPVX_const(namesv);
bbed91b5
KF		 3165 tryrsfp = 0;
3166
3167 ENTER;
3168 SAVETMPS;
3169 EXTEND(SP, 2);
3170
3171 PUSHMARK(SP);
3172 PUSHs(dirsv);
3173 PUSHs(sv);
3174 PUTBACK;
e982885c
NC		 3175 if (sv_isobject(loader))
3176 count = call_method("INC", G_ARRAY);
3177 else
3178 count = call_sv(loader, G_ARRAY);
bbed91b5
KF		 3179 SPAGAIN;
3180
3181 if (count > 0) {
3182 int i = 0;
3183 SV *arg;
3184
3185 SP -= count - 1;
3186 arg = SP[i++];
3187
3188 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3189 arg = SvRV(arg);
3190 }
3191
3192 if (SvTYPE(arg) == SVt_PVGV) {
3193 IO *io = GvIO((GV *)arg);
3194
3195 ++filter_has_file;
3196
3197 if (io) {
3198 tryrsfp = IoIFP(io);
50952442 3199 if (IoTYPE(io) == IoTYPE_PIPE) {
bbed91b5
KF		 3200 /* reading from a child process doesn't
3201 nest -- when returning from reading
3202 the inner module, the outer one is
3203 unreadable (closed?) I've tried to
3204 save the gv to manage the lifespan of
3205 the pipe, but this didn't help. XXX */
3206 filter_child_proc = (GV *)arg;
520c758a 3207 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF		 3208 }
3209 else {
3210 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3211 PerlIO_close(IoOFP(io));
3212 }
3213 IoIFP(io) = Nullfp;
3214 IoOFP(io) = Nullfp;
3215 }
3216 }
3217
3218 if (i < count) {
3219 arg = SP[i++];
3220 }
3221 }
3222
3223 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3224 filter_sub = arg;
520c758a 3225 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 3226
3227 if (i < count) {
3228 filter_state = SP[i];
520c758a 3229 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF		 3230 }
3231
3232 if (tryrsfp == 0) {
3233 tryrsfp = PerlIO_open("/dev/null",
3234 PERL_SCRIPT_MODE);
3235 }
3236 }
1d06aecd 3237 SP--;
bbed91b5
KF		 3238 }
3239
3240 PUTBACK;
3241 FREETMPS;
3242 LEAVE;
3243
3244 if (tryrsfp) {
89ccab8c 3245 hook_sv = dirsv;
bbed91b5
KF		 3246 break;
3247 }
3248
3249 filter_has_file = 0;
3250 if (filter_child_proc) {
3251 SvREFCNT_dec(filter_child_proc);
3252 filter_child_proc = 0;
3253 }
3254 if (filter_state) {
3255 SvREFCNT_dec(filter_state);
3256 filter_state = 0;
3257 }
3258 if (filter_sub) {
3259 SvREFCNT_dec(filter_sub);
3260 filter_sub = 0;
3261 }
3262 }
3263 else {
be4b629d
CN		 3264 if (!path_is_absolute(name)
3265#ifdef MACOS_TRADITIONAL
3266 /* We consider paths of the form :a:b ambiguous and interpret them first
3267 as global then as local
3268 */
3269 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3270#endif
3271 ) {
0510663f 3272 const char *dir = SvPVx_nolen_const(dirsv);
bf4acbe4 3273#ifdef MACOS_TRADITIONAL
67627c52
JH		 3274 char buf1[256];
3275 char buf2[256];
3276
3277 MacPerl_CanonDir(name, buf2, 1);
3278 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3279#else
27da23d5 3280# ifdef VMS
bbed91b5 3281 char *unixdir;
b8ffc8df 3282 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
bbed91b5
KF		 3283 continue;
3284 sv_setpv(namesv, unixdir);
3285 sv_catpv(namesv, unixname);
27da23d5
JH		 3286# else
3287# ifdef SYMBIAN
3288 if (PL_origfilename[0] &&
3289 PL_origfilename[1] == ':' &&
3290 !(dir[0] && dir[1] == ':'))
3291 Perl_sv_setpvf(aTHX_ namesv,
3292 "%c:%s\\%s",
3293 PL_origfilename[0],
3294 dir, name);
3295 else
3296 Perl_sv_setpvf(aTHX_ namesv,
3297 "%s\\%s",
3298 dir, name);
3299# else
bbed91b5 3300 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
27da23d5
JH		 3301# endif
3302# endif
bf4acbe4 3303#endif
bbed91b5 3304 TAINT_PROPER("require");
349d4f2f 3305 tryname = SvPVX_const(namesv);
7925835c 3306 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
bbed91b5
KF		 3307 if (tryrsfp) {
3308 if (tryname[0] == '.' && tryname[1] == '/')
3309 tryname += 2;
3310 break;
3311 }
be4b629d 3312 }
46fc3d4c 3313 }
a0d0e21e
LW		 3314 }
3315 }
3316 }
f4dd75d9 3317 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3318 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3319 SvREFCNT_dec(namesv);
a0d0e21e 3320 if (!tryrsfp) {
533c011a 3321 if (PL_op->op_type == OP_REQUIRE) {
5c144d81 3322 const char *msgstr = name;
ec889f3a
GS		 3323 if (namesv) { /* did we lookup @INC? */
3324 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3325 SV *dirmsgsv = NEWSV(0, 0);
3326 AV *ar = GvAVn(PL_incgv);
3327 I32 i;
3328 sv_catpvn(msg, " in @INC", 8);
b15aece3 3329 if (instr(SvPVX_const(msg), ".h "))
ec889f3a 3330 sv_catpv(msg, " (change .h to .ph maybe?)");
b15aece3 3331 if (instr(SvPVX_const(msg), ".ph "))
ec889f3a
GS		 3332 sv_catpv(msg, " (did you run h2ph?)");
3333 sv_catpv(msg, " (@INC contains:");
3334 for (i = 0; i <= AvFILL(ar); i++) {
0510663f 3335 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
cea2e8a9 3336 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS		 3337 sv_catsv(msg, dirmsgsv);
3338 }
3339 sv_catpvn(msg, ")", 1);
3340 SvREFCNT_dec(dirmsgsv);
349d4f2f 3341 msgstr = SvPV_nolen_const(msg);
2683423c 3342 }
ea071790 3343 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 3344 }
3345
3346 RETPUSHUNDEF;
3347 }
d8bfb8bd 3348 else
93189314 3349 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW		 3350
3351 /* Assume success here to prevent recursive requirement. */
d3a4e64e
RGS		 3352 len = strlen(name);
3353 /* Check whether a hook in @INC has already filled %INC */
3354 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3355 (void)hv_store(GvHVn(PL_incgv), name, len,
3356 (hook_sv ? SvREFCNT_inc(hook_sv)
3357 : newSVpv(CopFILE(&PL_compiling), 0)),
3358 0 );
3359 }
a0d0e21e
LW		 3360
3361 ENTER;
3362 SAVETMPS;
79cb57f6 3363 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 3364 SAVEGENERICSV(PL_rsfp_filters);
3365 PL_rsfp_filters = Nullav;
e50aee73 3366
3280af22 3367 PL_rsfp = tryrsfp;
b3ac6de7 3368 SAVEHINTS();
3280af22 3369 PL_hints = 0;
7766f137 3370 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3371 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3372 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3373 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3374 PL_compiling.cop_warnings = pWARN_NONE ;
317ea90d
MS		 3375 else if (PL_taint_warn)
3376 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
ac27b0f5 3377 else
d3a7d8c7 3378 PL_compiling.cop_warnings = pWARN_STD ;
ac27b0f5
NIS		 3379 SAVESPTR(PL_compiling.cop_io);
3380 PL_compiling.cop_io = Nullsv;
a0d0e21e 3381
bbed91b5 3382 if (filter_sub || filter_child_proc) {
890ce7af 3383 SV * const datasv = filter_add(run_user_filter, Nullsv);
bbed91b5
KF		 3384 IoLINES(datasv) = filter_has_file;
3385 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3386 IoTOP_GV(datasv) = (GV *)filter_state;
3387 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3388 }
3389
3390 /* switch to eval mode */
a0d0e21e 3391 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3392 PUSHEVAL(cx, name, Nullgv);
f39bc417 3393 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 3394
57843af0
GS		 3395 SAVECOPLINE(&PL_compiling);
3396 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3397
3398 PUTBACK;
6ec9efec
JH		 3399
3400 /* Store and reset encoding. */
3401 encoding = PL_encoding;
3402 PL_encoding = Nullsv;
3403
a3985cdc 3404 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
bfed75c6 3405
6ec9efec
JH		 3406 /* Restore encoding. */
3407 PL_encoding = encoding;
3408
3409 return op;
a0d0e21e
LW		 3410}
3411
3412PP(pp_dofile)
3413{
cea2e8a9 3414 return pp_require();
a0d0e21e
LW		 3415}
3416
3417PP(pp_entereval)
3418{
27da23d5 3419 dVAR; dSP;
c09156bb 3420 register PERL_CONTEXT *cx;
a0d0e21e 3421 dPOPss;
890ce7af
AL		 3422 const I32 gimme = GIMME_V;
3423 const I32 was = PL_sub_generation;
83ee9e09
GS		 3424 char tbuf[TYPE_DIGITS(long) + 12];
3425 char *tmpbuf = tbuf;
fc36a67e 3426 char *safestr;
a0d0e21e 3427 STRLEN len;
55497cff 3428 OP *ret;
a3985cdc 3429 CV* runcv;
d819b83a 3430 U32 seq;
a0d0e21e 3431
5c144d81 3432 if (!SvPV_const(sv,len))
a0d0e21e 3433 RETPUSHUNDEF;
748a9306 3434 TAINT_PROPER("eval");
a0d0e21e
LW		 3435
3436 ENTER;
a0d0e21e 3437 lex_start(sv);
748a9306 3438 SAVETMPS;
ac27b0f5 3439
a0d0e21e
LW		 3440 /* switch to eval mode */
3441
83ee9e09 3442 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
890ce7af 3443 SV * const sv = sv_newmortal();
83ee9e09
GS		 3444 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3445 (unsigned long)++PL_evalseq,
3446 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3447 tmpbuf = SvPVX(sv);
3448 }
3449 else
3450 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 3451 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3452 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3453 SAVECOPLINE(&PL_compiling);
57843af0 3454 CopLINE_set(&PL_compiling, 1);
55497cff 3455 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3456 deleting the eval's FILEGV from the stash before gv_check() runs
3457 (i.e. before run-time proper). To work around the coredump that
3458 ensues, we always turn GvMULTI_on for any globals that were
3459 introduced within evals. See force_ident(). GSAR 96-10-12 */
3460 safestr = savepv(tmpbuf);
3280af22 3461 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3462 SAVEHINTS();
533c011a 3463 PL_hints = PL_op->op_targ;
7766f137 3464 SAVESPTR(PL_compiling.cop_warnings);
f0a6fc86
GS		 3465 if (specialWARN(PL_curcop->cop_warnings))
3466 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3467 else {
3468 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3469 SAVEFREESV(PL_compiling.cop_warnings);
599cee73 3470 }
ac27b0f5
NIS		 3471 SAVESPTR(PL_compiling.cop_io);
3472 if (specialCopIO(PL_curcop->cop_io))
3473 PL_compiling.cop_io = PL_curcop->cop_io;
3474 else {
3475 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3476 SAVEFREESV(PL_compiling.cop_io);
3477 }
d819b83a
DM		 3478 /* special case: an eval '' executed within the DB package gets lexically
3479 * placed in the first non-DB CV rather than the current CV - this
3480 * allows the debugger to execute code, find lexicals etc, in the
3481 * scope of the code being debugged. Passing &seq gets find_runcv