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
Fixes to Pod errors found by podchecker.
[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
c127bd3a
SF		 1774 if (CvXSUB(cv)) {
1775 CvDEPTH(cv)++;
1776 PUSHMARK(SP);
1777 (void)(*CvXSUB(cv))(aTHX_ cv);
1778 CvDEPTH(cv)--;
1779 FREETMPS;
1780 LEAVE;
1781 return NORMAL;
1782 }
1783 else {
1784 PUSHBLOCK(cx, CXt_SUB, SP);
1785 PUSHSUB_DB(cx);
1786 cx->blk_sub.retop = PL_op->op_next;
1787 CvDEPTH(cv)++;
1788 SAVECOMPPAD();
1789 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1790 RETURNOP(CvSTART(cv));
1791 }
a0d0e21e
LW		 1792 }
1793 else
1794 return NORMAL;
1795}
1796
1797PP(pp_scope)
1798{
1799 return NORMAL;
1800}
1801
1802PP(pp_enteriter)
1803{
27da23d5 1804 dVAR; dSP; dMARK;
c09156bb 1805 register PERL_CONTEXT *cx;
f54cb97a 1806 const I32 gimme = GIMME_V;
a0d0e21e 1807 SV **svp;
7766f137
GS		 1808 U32 cxtype = CXt_LOOP;
1809#ifdef USE_ITHREADS
1810 void *iterdata;
1811#endif
a0d0e21e 1812
4633a7c4
LW		 1813 ENTER;
1814 SAVETMPS;
1815
533c011a 1816 if (PL_op->op_targ) {
14f338dc
DM		 1817 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1818 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1819 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1820 SVs_PADSTALE, SVs_PADSTALE);
1821 }
c3564e5c 1822#ifndef USE_ITHREADS
dd2155a4 1823 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
54b9620d 1824 SAVESPTR(*svp);
c3564e5c
GS		 1825#else
1826 SAVEPADSV(PL_op->op_targ);
cbfa9890 1827 iterdata = INT2PTR(void*, PL_op->op_targ);
7766f137
GS		 1828 cxtype |= CXp_PADVAR;
1829#endif
54b9620d
MB		 1830 }
1831 else {
7766f137
GS		 1832 GV *gv = (GV*)POPs;
1833 svp = &GvSV(gv); /* symbol table variable */
0214ae40
GS		 1834 SAVEGENERICSV(*svp);
1835 *svp = NEWSV(0,0);
7766f137
GS		 1836#ifdef USE_ITHREADS
1837 iterdata = (void*)gv;
1838#endif
54b9620d 1839 }
4633a7c4 1840
a0d0e21e
LW		 1841 ENTER;
1842
7766f137
GS		 1843 PUSHBLOCK(cx, cxtype, SP);
1844#ifdef USE_ITHREADS
1845 PUSHLOOP(cx, iterdata, MARK);
1846#else
a0d0e21e 1847 PUSHLOOP(cx, svp, MARK);
7766f137 1848#endif
533c011a 1849 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1850 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1851 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1852 dPOPss;
4fe3f0fa 1853 SV *right = (SV*)cx->blk_loop.iterary;
984a4bea
RD		 1854 SvGETMAGIC(sv);
1855 SvGETMAGIC(right);
4fe3f0fa
MHM		 1856 if (RANGE_IS_NUMERIC(sv,right)) {
1857 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1858 (SvOK(right) && SvNV(right) >= IV_MAX))
076d9a11
MHM		 1859 DIE(aTHX_ "Range iterator outside integer range");
1860 cx->blk_loop.iterix = SvIV(sv);
4fe3f0fa 1861 cx->blk_loop.itermax = SvIV(right);
d4665a05
DM		 1862#ifdef DEBUGGING
1863 /* for correct -Dstv display */
1864 cx->blk_oldsp = sp - PL_stack_base;
1865#endif
89ea2908 1866 }
3f63a782 1867 else {
89ea2908 1868 cx->blk_loop.iterlval = newSVsv(sv);
13c5b33c 1869 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
10516c54 1870 (void) SvPV_nolen_const(right);
3f63a782 1871 }
89ea2908 1872 }
ef3e5ea9 1873 else if (PL_op->op_private & OPpITER_REVERSED) {
e682d7b7 1874 cx->blk_loop.itermax = -1;
ef3e5ea9
NC		 1875 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1876
1877 }
89ea2908 1878 }
4633a7c4 1879 else {
3280af22
NIS		 1880 cx->blk_loop.iterary = PL_curstack;
1881 AvFILLp(PL_curstack) = SP - PL_stack_base;
ef3e5ea9
NC		 1882 if (PL_op->op_private & OPpITER_REVERSED) {
1883 cx->blk_loop.itermax = MARK - PL_stack_base;
1884 cx->blk_loop.iterix = cx->blk_oldsp;
1885 }
1886 else {
1887 cx->blk_loop.iterix = MARK - PL_stack_base;
1888 }
4633a7c4 1889 }
a0d0e21e
LW		 1890
1891 RETURN;
1892}
1893
1894PP(pp_enterloop)
1895{
27da23d5 1896 dVAR; dSP;
c09156bb 1897 register PERL_CONTEXT *cx;
f54cb97a 1898 const I32 gimme = GIMME_V;
a0d0e21e
LW		 1899
1900 ENTER;
1901 SAVETMPS;
1902 ENTER;
1903
1904 PUSHBLOCK(cx, CXt_LOOP, SP);
1905 PUSHLOOP(cx, 0, SP);
1906
1907 RETURN;
1908}
1909
1910PP(pp_leaveloop)
1911{
27da23d5 1912 dVAR; dSP;
c09156bb 1913 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1914 I32 gimme;
1915 SV **newsp;
1916 PMOP *newpm;
1917 SV **mark;
1918
1919 POPBLOCK(cx,newpm);
3a1b2b9e 1920 assert(CxTYPE(cx) == CXt_LOOP);
4fdae800 1921 mark = newsp;
a8bba7fa 1922 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1923
a1f49e72 1924 TAINT_NOT;
54310121 1925 if (gimme == G_VOID)
1926 ; /* do nothing */
1927 else if (gimme == G_SCALAR) {
1928 if (mark < SP)
1929 *++newsp = sv_mortalcopy(*SP);
1930 else
3280af22 1931 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1932 }
1933 else {
a1f49e72 1934 while (mark < SP) {
a0d0e21e 1935 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1936 TAINT_NOT; /* Each item is independent */
1937 }
a0d0e21e 1938 }
f86702cc 1939 SP = newsp;
1940 PUTBACK;
1941
a8bba7fa 1942 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1943 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1944
a0d0e21e
LW		 1945 LEAVE;
1946 LEAVE;
1947
f86702cc 1948 return NORMAL;
a0d0e21e
LW		 1949}
1950
1951PP(pp_return)
1952{
27da23d5 1953 dVAR; dSP; dMARK;
a0d0e21e 1954 I32 cxix;
c09156bb 1955 register PERL_CONTEXT *cx;
f86702cc 1956 bool popsub2 = FALSE;
b45de488 1957 bool clear_errsv = FALSE;
a0d0e21e
LW		 1958 I32 gimme;
1959 SV **newsp;
1960 PMOP *newpm;
1961 I32 optype = 0;
b0d9ce38 1962 SV *sv;
f39bc417 1963 OP *retop;
a0d0e21e 1964
3280af22 1965 if (PL_curstackinfo->si_type == PERLSI_SORT) {
7766f137
GS		 1966 if (cxstack_ix == PL_sortcxix
1967 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1968 {
3280af22
NIS		 1969 if (cxstack_ix > PL_sortcxix)
1970 dounwind(PL_sortcxix);
1971 AvARRAY(PL_curstack)[1] = *SP;
1972 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1973 return 0;
1974 }
1975 }
1976
1977 cxix = dopoptosub(cxstack_ix);
1978 if (cxix < 0)
cea2e8a9 1979 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW		 1980 if (cxix < cxstack_ix)
1981 dounwind(cxix);
1982
1983 POPBLOCK(cx,newpm);
6b35e009 1984 switch (CxTYPE(cx)) {
a0d0e21e 1985 case CXt_SUB:
f86702cc 1986 popsub2 = TRUE;
f39bc417 1987 retop = cx->blk_sub.retop;
5dd42e15 1988 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW		 1989 break;
1990 case CXt_EVAL:
b45de488
GS		 1991 if (!(PL_in_eval & EVAL_KEEPERR))
1992 clear_errsv = TRUE;
a0d0e21e 1993 POPEVAL(cx);
f39bc417 1994 retop = cx->blk_eval.retop;
1d76a5c3
GS		 1995 if (CxTRYBLOCK(cx))
1996 break;
067f92a0 1997 lex_end();
748a9306
LW		 1998 if (optype == OP_REQUIRE &&
1999 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2000 {
54310121 2001 /* Unassume the success we assumed earlier. */
901017d6 2002 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 2003 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 2004 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
748a9306 2005 }
a0d0e21e 2006 break;
7766f137
GS		 2007 case CXt_FORMAT:
2008 POPFORMAT(cx);
f39bc417 2009 retop = cx->blk_sub.retop;
7766f137 2010 break;
a0d0e21e 2011 default:
cea2e8a9 2012 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 2013 }
2014
a1f49e72 2015 TAINT_NOT;
a0d0e21e 2016 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 2017 if (MARK < SP) {
2018 if (popsub2) {
a8bba7fa 2019 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ		 2020 if (SvTEMP(TOPs)) {
2021 *++newsp = SvREFCNT_inc(*SP);
2022 FREETMPS;
2023 sv_2mortal(*newsp);
959e3673
GS		 2024 }
2025 else {
2026 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 2027 FREETMPS;
959e3673
GS		 2028 *++newsp = sv_mortalcopy(sv);
2029 SvREFCNT_dec(sv);
a29cdaf0 2030 }
959e3673
GS		 2031 }
2032 else
a29cdaf0 2033 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS		 2034 }
2035 else
a29cdaf0 2036 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 2037 }
2038 else
3280af22 2039 *++newsp = &PL_sv_undef;
a0d0e21e 2040 }
54310121 2041 else if (gimme == G_ARRAY) {
a1f49e72 2042 while (++MARK <= SP) {
f86702cc 2043 *++newsp = (popsub2 && SvTEMP(*MARK))
2044 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2045 TAINT_NOT; /* Each item is independent */
2046 }
a0d0e21e 2047 }
3280af22 2048 PL_stack_sp = newsp;
a0d0e21e 2049
5dd42e15 2050 LEAVE;
f86702cc 2051 /* Stack values are safe: */
2052 if (popsub2) {
5dd42e15 2053 cxstack_ix--;
b0d9ce38 2054 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2055 }
b0d9ce38
GS		 2056 else
2057 sv = Nullsv;
3280af22 2058 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2059
b0d9ce38 2060 LEAVESUB(sv);
b45de488 2061 if (clear_errsv)
c69006e4 2062 sv_setpvn(ERRSV,"",0);
f39bc417 2063 return retop;
a0d0e21e
LW		 2064}
2065
2066PP(pp_last)
2067{
27da23d5 2068 dVAR; dSP;
a0d0e21e 2069 I32 cxix;
c09156bb 2070 register PERL_CONTEXT *cx;
f86702cc 2071 I32 pop2 = 0;
a0d0e21e 2072 I32 gimme;
8772537c 2073 I32 optype;
a0d0e21e
LW		 2074 OP *nextop;
2075 SV **newsp;
2076 PMOP *newpm;
a8bba7fa 2077 SV **mark;
b0d9ce38 2078 SV *sv = Nullsv;
9d4ba2ae 2079
a0d0e21e 2080
533c011a 2081 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2082 cxix = dopoptoloop(cxstack_ix);
2083 if (cxix < 0)
a651a37d 2084 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 2085 }
2086 else {
2087 cxix = dopoptolabel(cPVOP->op_pv);
2088 if (cxix < 0)
cea2e8a9 2089 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2090 }
2091 if (cxix < cxstack_ix)
2092 dounwind(cxix);
2093
2094 POPBLOCK(cx,newpm);
5dd42e15 2095 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2096 mark = newsp;
6b35e009 2097 switch (CxTYPE(cx)) {
a0d0e21e 2098 case CXt_LOOP:
f86702cc 2099 pop2 = CXt_LOOP;
a8bba7fa
GS		 2100 newsp = PL_stack_base + cx->blk_loop.resetsp;
2101 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 2102 break;
f86702cc 2103 case CXt_SUB:
f86702cc 2104 pop2 = CXt_SUB;
f39bc417 2105 nextop = cx->blk_sub.retop;
a0d0e21e 2106 break;
f86702cc 2107 case CXt_EVAL:
2108 POPEVAL(cx);
f39bc417 2109 nextop = cx->blk_eval.retop;
a0d0e21e 2110 break;
7766f137
GS		 2111 case CXt_FORMAT:
2112 POPFORMAT(cx);
f39bc417 2113 nextop = cx->blk_sub.retop;
7766f137 2114 break;
a0d0e21e 2115 default:
cea2e8a9 2116 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 2117 }
2118
a1f49e72 2119 TAINT_NOT;
a0d0e21e 2120 if (gimme == G_SCALAR) {
f86702cc 2121 if (MARK < SP)
2122 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2123 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2124 else
3280af22 2125 *++newsp = &PL_sv_undef;
a0d0e21e 2126 }
54310121 2127 else if (gimme == G_ARRAY) {
a1f49e72 2128 while (++MARK <= SP) {
f86702cc 2129 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2130 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2131 TAINT_NOT; /* Each item is independent */
2132 }
f86702cc 2133 }
2134 SP = newsp;
2135 PUTBACK;
2136
5dd42e15
DM		 2137 LEAVE;
2138 cxstack_ix--;
f86702cc 2139 /* Stack values are safe: */
2140 switch (pop2) {
2141 case CXt_LOOP:
a8bba7fa 2142 POPLOOP(cx); /* release loop vars ... */
4fdae800 2143 LEAVE;
f86702cc 2144 break;
2145 case CXt_SUB:
b0d9ce38 2146 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2147 break;
a0d0e21e 2148 }
3280af22 2149 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2150
b0d9ce38 2151 LEAVESUB(sv);
9d4ba2ae
AL		 2152 PERL_UNUSED_VAR(optype);
2153 PERL_UNUSED_VAR(gimme);
f86702cc 2154 return nextop;
a0d0e21e
LW		 2155}
2156
2157PP(pp_next)
2158{
27da23d5 2159 dVAR;
a0d0e21e 2160 I32 cxix;
c09156bb 2161 register PERL_CONTEXT *cx;
85538317 2162 I32 inner;
a0d0e21e 2163
533c011a 2164 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2165 cxix = dopoptoloop(cxstack_ix);
2166 if (cxix < 0)
a651a37d 2167 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 2168 }
2169 else {
2170 cxix = dopoptolabel(cPVOP->op_pv);
2171 if (cxix < 0)
cea2e8a9 2172 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2173 }
2174 if (cxix < cxstack_ix)
2175 dounwind(cxix);
2176
85538317
GS		 2177 /* clear off anything above the scope we're re-entering, but
2178 * save the rest until after a possible continue block */
2179 inner = PL_scopestack_ix;
1ba6ee2b 2180 TOPBLOCK(cx);
85538317
GS		 2181 if (PL_scopestack_ix < inner)
2182 leave_scope(PL_scopestack[PL_scopestack_ix]);
3a1b2b9e 2183 PL_curcop = cx->blk_oldcop;
1ba6ee2b 2184 return cx->blk_loop.next_op;
a0d0e21e
LW		 2185}
2186
2187PP(pp_redo)
2188{
27da23d5 2189 dVAR;
a0d0e21e 2190 I32 cxix;
c09156bb 2191 register PERL_CONTEXT *cx;
a0d0e21e 2192 I32 oldsave;
a034e688 2193 OP* redo_op;
a0d0e21e 2194
533c011a 2195 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2196 cxix = dopoptoloop(cxstack_ix);
2197 if (cxix < 0)
a651a37d 2198 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 2199 }
2200 else {
2201 cxix = dopoptolabel(cPVOP->op_pv);
2202 if (cxix < 0)
cea2e8a9 2203 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2204 }
2205 if (cxix < cxstack_ix)
2206 dounwind(cxix);
2207
a034e688
DM		 2208 redo_op = cxstack[cxix].blk_loop.redo_op;
2209 if (redo_op->op_type == OP_ENTER) {
2210 /* pop one less context to avoid $x being freed in while (my $x..) */
2211 cxstack_ix++;
2212 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2213 redo_op = redo_op->op_next;
2214 }
2215
a0d0e21e 2216 TOPBLOCK(cx);
3280af22 2217 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2218 LEAVE_SCOPE(oldsave);
936c78b5 2219 FREETMPS;
3a1b2b9e 2220 PL_curcop = cx->blk_oldcop;
a034e688 2221 return redo_op;
a0d0e21e
LW		 2222}
2223
0824fdcb 2224STATIC OP *
bfed75c6 2225S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2226{
a0d0e21e 2227 OP **ops = opstack;
bfed75c6 2228 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2229
fc36a67e 2230 if (ops >= oplimit)
cea2e8a9 2231 Perl_croak(aTHX_ too_deep);
11343788
MB		 2232 if (o->op_type == OP_LEAVE ||
2233 o->op_type == OP_SCOPE ||
2234 o->op_type == OP_LEAVELOOP ||
33d34e4c 2235 o->op_type == OP_LEAVESUB ||
11343788 2236 o->op_type == OP_LEAVETRY)
fc36a67e 2237 {
5dc0d613 2238 *ops++ = cUNOPo->op_first;
fc36a67e 2239 if (ops >= oplimit)
cea2e8a9 2240 Perl_croak(aTHX_ too_deep);
fc36a67e 2241 }
c4aa4e48 2242 *ops = 0;
11343788 2243 if (o->op_flags & OPf_KIDS) {
aec46f14 2244 OP *kid;
a0d0e21e 2245 /* First try all the kids at this level, since that's likeliest. */
11343788 2246 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 2247 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2248 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 2249 return kid;
2250 }
11343788 2251 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2252 if (kid == PL_lastgotoprobe)
a0d0e21e 2253 continue;
ed8d0fe2
SM		 2254 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2255 if (ops == opstack)
2256 *ops++ = kid;
2257 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2258 ops[-1]->op_type == OP_DBSTATE)
2259 ops[-1] = kid;
2260 else
2261 *ops++ = kid;
2262 }
155aba94 2263 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2264 return o;
a0d0e21e
LW		 2265 }
2266 }
c4aa4e48 2267 *ops = 0;
a0d0e21e
LW		 2268 return 0;
2269}
2270
2271PP(pp_dump)
2272{
cea2e8a9 2273 return pp_goto();
a0d0e21e
LW		 2274 /*NOTREACHED*/
2275}
2276
2277PP(pp_goto)
2278{
27da23d5 2279 dVAR; dSP;
a0d0e21e
LW		 2280 OP *retop = 0;
2281 I32 ix;
c09156bb 2282 register PERL_CONTEXT *cx;
fc36a67e 2283#define GOTO_DEPTH 64
2284 OP *enterops[GOTO_DEPTH];
bfed75c6
AL		 2285 const char *label = 0;
2286 const bool do_dump = (PL_op->op_type == OP_DUMP);
2287 static const char must_have_label[] = "goto must have label";
a0d0e21e 2288
533c011a 2289 if (PL_op->op_flags & OPf_STACKED) {
9d4ba2ae 2290 SV * const sv = POPs;
a0d0e21e
LW		 2291
2292 /* This egregious kludge implements goto &subroutine */
2293 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2294 I32 cxix;
c09156bb 2295 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2296 CV* cv = (CV*)SvRV(sv);
2297 SV** mark;
2298 I32 items = 0;
2299 I32 oldsave;
b1464ded 2300 bool reified = 0;
a0d0e21e 2301
e8f7dd13 2302 retry:
4aa0a1f7 2303 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2304 const GV * const gv = CvGV(cv);
e8f7dd13 2305 if (gv) {
7fc63493 2306 GV *autogv;
e8f7dd13
GS		 2307 SV *tmpstr;
2308 /* autoloaded stub? */
2309 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2310 goto retry;
2311 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2312 GvNAMELEN(gv), FALSE);
2313 if (autogv && (cv = GvCV(autogv)))
2314 goto retry;
2315 tmpstr = sv_newmortal();
2316 gv_efullname3(tmpstr, gv, Nullch);
35c1215d 2317 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
4aa0a1f7 2318 }
cea2e8a9 2319 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2320 }
2321
a0d0e21e 2322 /* First do some returnish stuff. */
7fc63493 2323 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
71fc2216 2324 FREETMPS;
a0d0e21e
LW		 2325 cxix = dopoptosub(cxstack_ix);
2326 if (cxix < 0)
cea2e8a9 2327 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2328 if (cxix < cxstack_ix)
2329 dounwind(cxix);
2330 TOPBLOCK(cx);
2d43a17f 2331 SPAGAIN;
564abe23 2332 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2d43a17f 2333 if (CxTYPE(cx) == CXt_EVAL) {
c74ace89
DM		 2334 if (CxREALEVAL(cx))
2335 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2336 else
2337 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2d43a17f 2338 }
d8b46c1b
GS		 2339 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2340 /* put @_ back onto stack */
a0d0e21e 2341 AV* av = cx->blk_sub.argarray;
bfed75c6 2342
93965878 2343 items = AvFILLp(av) + 1;
a45cdc79
DM		 2344 EXTEND(SP, items+1); /* @_ could have been extended. */
2345 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS		 2346 SvREFCNT_dec(GvAV(PL_defgv));
2347 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2348 CLEAR_ARGARRAY(av);
d8b46c1b 2349 /* abandon @_ if it got reified */
62b1ebc2 2350 if (AvREAL(av)) {
b1464ded
DM		 2351 reified = 1;
2352 SvREFCNT_dec(av);
d8b46c1b
GS		 2353 av = newAV();
2354 av_extend(av, items-1);
11ca45c0 2355 AvREIFY_only(av);
dd2155a4 2356 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2357 }
a0d0e21e 2358 }
1fa4e549 2359 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
890ce7af 2360 AV* const av = GvAV(PL_defgv);
1fa4e549 2361 items = AvFILLp(av) + 1;
a45cdc79
DM		 2362 EXTEND(SP, items+1); /* @_ could have been extended. */
2363 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2364 }
a45cdc79
DM		 2365 mark = SP;
2366 SP += items;
6b35e009 2367 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2368 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2369 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2370 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2371 LEAVE_SCOPE(oldsave);
2372
2373 /* Now do some callish stuff. */
2374 SAVETMPS;
5023d17a 2375 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
a0d0e21e 2376 if (CvXSUB(cv)) {
5eff7df7 2377 OP* retop = cx->blk_sub.retop;
b1464ded
DM		 2378 if (reified) {
2379 I32 index;
2380 for (index=0; index<items; index++)
2381 sv_2mortal(SP[-index]);
2382 }
67caa1fe 2383#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2384 if (CvOLDSTYLE(cv)) {
20ce7b12 2385 I32 (*fp3)(int,int,int);
924508f0
GS		 2386 while (SP > mark) {
2387 SP[1] = SP[0];
2388 SP--;
a0d0e21e 2389 }
7766f137 2390 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2391 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2392 mark - PL_stack_base + 1,
ecfc5424 2393 items);
3280af22 2394 SP = PL_stack_base + items;
a0d0e21e 2395 }
67caa1fe
GS		 2396 else
2397#endif /* PERL_XSUB_OLDSTYLE */
2398 {
1fa4e549
AD		 2399 SV **newsp;
2400 I32 gimme;
2401
5eff7df7
DM		 2402 /* XS subs don't have a CxSUB, so pop it */
2403 POPBLOCK(cx, PL_curpm);
1fa4e549 2404 /* Push a mark for the start of arglist */
ac27b0f5 2405 PUSHMARK(mark);
a45cdc79 2406 PUTBACK;
acfe0abc 2407 (void)(*CvXSUB(cv))(aTHX_ cv);
1b6737cc
AL		 2408 /* Put these at the bottom since the vars are set but not used */
2409 PERL_UNUSED_VAR(newsp);
2410 PERL_UNUSED_VAR(gimme);
a0d0e21e
LW		 2411 }
2412 LEAVE;
5eff7df7 2413 return retop;
a0d0e21e
LW		 2414 }
2415 else {
2416 AV* padlist = CvPADLIST(cv);
6b35e009 2417 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2418 PL_in_eval = cx->blk_eval.old_in_eval;
2419 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2420 cx->cx_type = CXt_SUB;
2421 cx->blk_sub.hasargs = 0;
2422 }
a0d0e21e 2423 cx->blk_sub.cv = cv;
eb160463 2424 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
dd2155a4 2425
a0d0e21e
LW		 2426 CvDEPTH(cv)++;
2427 if (CvDEPTH(cv) < 2)
2428 (void)SvREFCNT_inc(cv);
dd2155a4 2429 else {
599cee73 2430 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2431 sub_crush_depth(cv);
26019298 2432 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2433 }
fd617465
DM		 2434 SAVECOMPPAD();
2435 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
6d4ff0d2 2436 if (cx->blk_sub.hasargs)
6d4ff0d2 2437 {
dd2155a4 2438 AV* av = (AV*)PAD_SVl(0);
a0d0e21e
LW		 2439 SV** ary;
2440
3280af22
NIS		 2441 cx->blk_sub.savearray = GvAV(PL_defgv);
2442 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2443 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2444 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2445
2446 if (items >= AvMAX(av) + 1) {
2447 ary = AvALLOC(av);
2448 if (AvARRAY(av) != ary) {
2449 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
f880fe2f 2450 SvPV_set(av, (char*)ary);
a0d0e21e
LW		 2451 }
2452 if (items >= AvMAX(av) + 1) {
2453 AvMAX(av) = items - 1;
2454 Renew(ary,items+1,SV*);
2455 AvALLOC(av) = ary;
f880fe2f 2456 SvPV_set(av, (char*)ary);
a0d0e21e
LW		 2457 }
2458 }
a45cdc79 2459 ++mark;
a0d0e21e 2460 Copy(mark,AvARRAY(av),items,SV*);
93965878 2461 AvFILLp(av) = items - 1;
d8b46c1b 2462 assert(!AvREAL(av));
b1464ded
DM		 2463 if (reified) {
2464 /* transfer 'ownership' of refcnts to new @_ */
2465 AvREAL_on(av);
2466 AvREIFY_off(av);
2467 }
a0d0e21e
LW		 2468 while (items--) {
2469 if (*mark)
2470 SvTEMP_off(*mark);
2471 mark++;
2472 }
2473 }
491527d0 2474 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2475 /*
2476 * We do not care about using sv to call CV;
2477 * it's for informational purposes only.
2478 */
890ce7af 2479 SV * const sv = GvSV(PL_DBsub);
491527d0 2480 CV *gotocv;
bfed75c6 2481
f398eb67 2482 save_item(sv);
491527d0 2483 if (PERLDB_SUB_NN) {
890ce7af 2484 const int type = SvTYPE(sv);
f398eb67
NC		 2485 if (type < SVt_PVIV && type != SVt_IV)
2486 sv_upgrade(sv, SVt_PVIV);
7619c85e 2487 (void)SvIOK_on(sv);
45977657 2488 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
491527d0 2489 } else {
491527d0
GS		 2490 gv_efullname3(sv, CvGV(cv), Nullch);
2491 }
2492 if ( PERLDB_GOTO
864dbfa3 2493 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2494 PUSHMARK( PL_stack_sp );
864dbfa3 2495 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2496 PL_stack_sp--;
491527d0 2497 }
1ce6579f 2498 }
a0d0e21e
LW		 2499 RETURNOP(CvSTART(cv));
2500 }
2501 }
1614b0e3 2502 else {
0510663f 2503 label = SvPV_nolen_const(sv);
1614b0e3 2504 if (!(do_dump || *label))
cea2e8a9 2505 DIE(aTHX_ must_have_label);
1614b0e3 2506 }
a0d0e21e 2507 }
533c011a 2508 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2509 if (! do_dump)
cea2e8a9 2510 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2511 }
2512 else
2513 label = cPVOP->op_pv;
2514
2515 if (label && *label) {
2516 OP *gotoprobe = 0;
3b2447bc 2517 bool leaving_eval = FALSE;
33d34e4c 2518 bool in_block = FALSE;
a4f3a277 2519 PERL_CONTEXT *last_eval_cx = 0;
a0d0e21e
LW		 2520
2521 /* find label */
2522
3280af22 2523 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2524 *enterops = 0;
2525 for (ix = cxstack_ix; ix >= 0; ix--) {
2526 cx = &cxstack[ix];
6b35e009 2527 switch (CxTYPE(cx)) {
a0d0e21e 2528 case CXt_EVAL:
3b2447bc 2529 leaving_eval = TRUE;
971ecbe6 2530 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH		 2531 gotoprobe = (last_eval_cx ?
2532 last_eval_cx->blk_eval.old_eval_root :
2533 PL_eval_root);
2534 last_eval_cx = cx;
9c5794fe
RH		 2535 break;
2536 }
2537 /* else fall through */
a0d0e21e
LW		 2538 case CXt_LOOP:
2539 gotoprobe = cx->blk_oldcop->op_sibling;
2540 break;
2541 case CXt_SUBST:
2542 continue;
2543 case CXt_BLOCK:
33d34e4c 2544 if (ix) {
a0d0e21e 2545 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE		 2546 in_block = TRUE;
2547 } else
3280af22 2548 gotoprobe = PL_main_root;
a0d0e21e 2549 break;
b3933176
CS		 2550 case CXt_SUB:
2551 if (CvDEPTH(cx->blk_sub.cv)) {
2552 gotoprobe = CvROOT(cx->blk_sub.cv);
2553 break;
2554 }
2555 /* FALL THROUGH */
7766f137 2556 case CXt_FORMAT:
0a753a76 2557 case CXt_NULL:
a651a37d 2558 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 2559 default:
2560 if (ix)
cea2e8a9 2561 DIE(aTHX_ "panic: goto");
3280af22 2562 gotoprobe = PL_main_root;
a0d0e21e
LW		 2563 break;
2564 }
2b597662
GS		 2565 if (gotoprobe) {
2566 retop = dofindlabel(gotoprobe, label,
2567 enterops, enterops + GOTO_DEPTH);
2568 if (retop)
2569 break;
2570 }
3280af22 2571 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2572 }
2573 if (!retop)
cea2e8a9 2574 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2575
3b2447bc
RH		 2576 /* if we're leaving an eval, check before we pop any frames
2577 that we're not going to punt, otherwise the error
2578 won't be caught */
2579
2580 if (leaving_eval && *enterops && enterops[1]) {
2581 I32 i;
2582 for (i = 1; enterops[i]; i++)
2583 if (enterops[i]->op_type == OP_ENTERITER)
2584 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2585 }
2586
a0d0e21e
LW		 2587 /* pop unwanted frames */
2588
2589 if (ix < cxstack_ix) {
2590 I32 oldsave;
2591
2592 if (ix < 0)
2593 ix = 0;
2594 dounwind(ix);
2595 TOPBLOCK(cx);
3280af22 2596 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2597 LEAVE_SCOPE(oldsave);
2598 }
2599
2600 /* push wanted frames */
2601
748a9306 2602 if (*enterops && enterops[1]) {
533c011a 2603 OP *oldop = PL_op;
33d34e4c
AE		 2604 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2605 for (; enterops[ix]; ix++) {
533c011a 2606 PL_op = enterops[ix];
84902520
TB		 2607 /* Eventually we may want to stack the needed arguments
2608 * for each op. For now, we punt on the hard ones. */
533c011a 2609 if (PL_op->op_type == OP_ENTERITER)
894356b3 2610 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2611 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2612 }
533c011a 2613 PL_op = oldop;
a0d0e21e
LW		 2614 }
2615 }
2616
2617 if (do_dump) {
a5f75d66 2618#ifdef VMS
6b88bc9c 2619 if (!retop) retop = PL_main_start;
a5f75d66 2620#endif
3280af22
NIS		 2621 PL_restartop = retop;
2622 PL_do_undump = TRUE;
a0d0e21e
LW		 2623
2624 my_unexec();
2625
3280af22
NIS		 2626 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2627 PL_do_undump = FALSE;
a0d0e21e
LW		 2628 }
2629
2630 RETURNOP(retop);
2631}
2632
2633PP(pp_exit)
2634{
39644a26 2635 dSP;
a0d0e21e
LW		 2636 I32 anum;
2637
2638 if (MAXARG < 1)
2639 anum = 0;
ff0cee69 2640 else {
a0d0e21e 2641 anum = SvIVx(POPs);
d98f61e7
GS		 2642#ifdef VMS
2643 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2644 anum = 0;
96e176bf 2645 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69 2646#endif
2647 }
cc3604b1 2648 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2649 my_exit(anum);
3280af22 2650 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2651 RETURN;
2652}
2653
2654#ifdef NOTYET
2655PP(pp_nswitch)
2656{
39644a26 2657 dSP;
f54cb97a 2658 const NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2659 register I32 match = I_32(value);
2660
2661 if (value < 0.0) {
65202027 2662 if (((NV)match) > value)
a0d0e21e
LW		 2663 --match; /* was fractional--truncate other way */
2664 }
2665 match -= cCOP->uop.scop.scop_offset;
2666 if (match < 0)
2667 match = 0;
2668 else if (match > cCOP->uop.scop.scop_max)
2669 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2670 PL_op = cCOP->uop.scop.scop_next[match];
2671 RETURNOP(PL_op);
a0d0e21e
LW		 2672}
2673
2674PP(pp_cswitch)
2675{
39644a26 2676 dSP;
a0d0e21e
LW		 2677 register I32 match;
2678
6b88bc9c
GS		 2679 if (PL_multiline)
2680 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2681 else {
0510663f 2682 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
a0d0e21e
LW		 2683 match -= cCOP->uop.scop.scop_offset;
2684 if (match < 0)
2685 match = 0;
2686 else if (match > cCOP->uop.scop.scop_max)
2687 match = cCOP->uop.scop.scop_max;
6b88bc9c 2688 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2689 }
6b88bc9c 2690 RETURNOP(PL_op);
a0d0e21e
LW		 2691}
2692#endif
2693
2694/* Eval. */
2695
0824fdcb 2696STATIC void
cea2e8a9 2697S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2698{
504618e9 2699 const char *s = SvPVX_const(sv);
890ce7af 2700 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 2701 I32 line = 1;
a0d0e21e
LW		 2702
2703 while (s && s < send) {
f54cb97a 2704 const char *t;
890ce7af 2705 SV * const tmpstr = NEWSV(85,0);
a0d0e21e
LW		 2706
2707 sv_upgrade(tmpstr, SVt_PVMG);
2708 t = strchr(s, '\n');
2709 if (t)
2710 t++;
2711 else
2712 t = send;
2713
2714 sv_setpvn(tmpstr, s, t - s);
2715 av_store(array, line++, tmpstr);
2716 s = t;
2717 }
2718}
2719
901017d6 2720STATIC void
14dd3ad8
GS		 2721S_docatch_body(pTHX)
2722{
cea2e8a9 2723 CALLRUNOPS(aTHX);
901017d6 2724 return;
312caa8e
CS		 2725}
2726
0824fdcb 2727STATIC OP *
cea2e8a9 2728S_docatch(pTHX_ OP *o)
1e422769 2729{
6224f72b 2730 int ret;
06b5626a 2731 OP * const oldop = PL_op;
db36c5a1 2732 dJMPENV;
1e422769 2733
1e422769 2734#ifdef DEBUGGING
54310121 2735 assert(CATCH_GET == TRUE);
1e422769 2736#endif
312caa8e 2737 PL_op = o;
8bffa5f8 2738
14dd3ad8 2739 JMPENV_PUSH(ret);
6224f72b 2740 switch (ret) {
312caa8e 2741 case 0:
abd70938
DM		 2742 assert(cxstack_ix >= 0);
2743 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2744 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8
GS		 2745 redo_body:
2746 docatch_body();
312caa8e
CS		 2747 break;
2748 case 3:
8bffa5f8 2749 /* die caught by an inner eval - continue inner loop */
abd70938
DM		 2750
2751 /* NB XXX we rely on the old popped CxEVAL still being at the top
2752 * of the stack; the way die_where() currently works, this
2753 * assumption is valid. In theory The cur_top_env value should be
2754 * returned in another global, the way retop (aka PL_restartop)
2755 * is. */
2756 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2757
2758 if (PL_restartop
2759 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2760 {
312caa8e
CS		 2761 PL_op = PL_restartop;
2762 PL_restartop = 0;
2763 goto redo_body;
2764 }
2765 /* FALL THROUGH */
2766 default:
14dd3ad8 2767 JMPENV_POP;
533c011a 2768 PL_op = oldop;
6224f72b 2769 JMPENV_JUMP(ret);
1e422769 2770 /* NOTREACHED */
1e422769 2771 }
14dd3ad8 2772 JMPENV_POP;
533c011a 2773 PL_op = oldop;
745cf2ff 2774 return Nullop;
1e422769 2775}
2776
c277df42 2777OP *
bfed75c6 2778Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ		 2779/* sv Text to convert to OP tree. */
2780/* startop op_free() this to undo. */
2781/* code Short string id of the caller. */
2782{
27da23d5 2783 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ		 2784 PERL_CONTEXT *cx;
2785 SV **newsp;
b094c71d 2786 I32 gimme = G_VOID;
c277df42
IZ		 2787 I32 optype;
2788 OP dummy;
155aba94 2789 OP *rop;
83ee9e09
GS		 2790 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2791 char *tmpbuf = tbuf;
c277df42 2792 char *safestr;
a3985cdc 2793 int runtime;
40b8d195 2794 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
c277df42
IZ		 2795
2796 ENTER;
2797 lex_start(sv);
2798 SAVETMPS;
2799 /* switch to eval mode */
2800
923e4eb5 2801 if (IN_PERL_COMPILETIME) {
f4dd75d9 2802 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2803 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2804 }
83ee9e09 2805 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
9d4ba2ae 2806 SV * const sv = sv_newmortal();
83ee9e09
GS		 2807 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2808 code, (unsigned long)++PL_evalseq,
2809 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2810 tmpbuf = SvPVX(sv);
2811 }
2812 else
2813 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
f4dd75d9 2814 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2815 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2816 SAVECOPLINE(&PL_compiling);
57843af0 2817 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2818 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2819 deleting the eval's FILEGV from the stash before gv_check() runs
2820 (i.e. before run-time proper). To work around the coredump that
2821 ensues, we always turn GvMULTI_on for any globals that were
2822 introduced within evals. See force_ident(). GSAR 96-10-12 */
2823 safestr = savepv(tmpbuf);
3280af22 2824 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2825 SAVEHINTS();
d1ca3daa 2826#ifdef OP_IN_REGISTER
6b88bc9c 2827 PL_opsave = op;
d1ca3daa 2828#else
7766f137 2829 SAVEVPTR(PL_op);
d1ca3daa 2830#endif
c277df42 2831
a3985cdc 2832 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2833 runtime = IN_PERL_RUNTIME;
a3985cdc 2834 if (runtime)
d819b83a 2835 runcv = find_runcv(NULL);
a3985cdc 2836
533c011a 2837 PL_op = &dummy;
13b51b79 2838 PL_op->op_type = OP_ENTEREVAL;
533c011a 2839 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2840 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
cc49e20b 2841 PUSHEVAL(cx, 0, Nullgv);
a3985cdc
DM		 2842
2843 if (runtime)
2844 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2845 else
2846 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2847 POPBLOCK(cx,PL_curpm);
e84b9f1f 2848 POPEVAL(cx);
c277df42
IZ		 2849
2850 (*startop)->op_type = OP_NULL;
22c35a8c 2851 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2852 lex_end();
f3548bdc
DM		 2853 /* XXX DAPM do this properly one year */
2854 *padp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2855 LEAVE;
923e4eb5 2856 if (IN_PERL_COMPILETIME)
eb160463 2857 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
d1ca3daa 2858#ifdef OP_IN_REGISTER
6b88bc9c 2859 op = PL_opsave;
d1ca3daa 2860#endif
9d4ba2ae
AL		 2861 PERL_UNUSED_VAR(newsp);
2862 PERL_UNUSED_VAR(optype);
2863
c277df42
IZ		 2864 return rop;
2865}
2866
a3985cdc
DM		 2867
2868/*
2869=for apidoc find_runcv
2870
2871Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM		 2872If db_seqp is non_null, skip CVs that are in the DB package and populate
2873*db_seqp with the cop sequence number at the point that the DB:: code was
2874entered. (allows debuggers to eval in the scope of the breakpoint rather
cf525c36 2875than in the scope of the debugger itself).
a3985cdc
DM		 2876
2877=cut
2878*/
2879
2880CV*
d819b83a 2881Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 2882{
a3985cdc 2883 PERL_SI *si;
a3985cdc 2884
d819b83a
DM		 2885 if (db_seqp)
2886 *db_seqp = PL_curcop->cop_seq;
a3985cdc 2887 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 2888 I32 ix;
a3985cdc 2889 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 2890 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a 2891 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1b6737cc 2892 CV * const cv = cx->blk_sub.cv;
d819b83a
DM		 2893 /* skip DB:: code */
2894 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2895 *db_seqp = cx->blk_oldcop->cop_seq;
2896 continue;
2897 }
2898 return cv;
2899 }
a3985cdc
DM		 2900 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2901 return PL_compcv;
2902 }
2903 }
2904 return PL_main_cv;
2905}
2906
2907
2908/* Compile a require/do, an eval '', or a /(?{...})/.
2909 * In the last case, startop is non-null, and contains the address of
2910 * a pointer that should be set to the just-compiled code.
2911 * outside is the lexically enclosing CV (if any) that invoked us.
2912 */
2913
4d1ff10f 2914/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2915STATIC OP *
a3985cdc 2916S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 2917{
27da23d5 2918 dVAR; dSP;
46c461b5 2919 OP * const saveop = PL_op;
a0d0e21e 2920
6dc8a9e4
IZ		 2921 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2922 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2923 : EVAL_INEVAL);
a0d0e21e 2924
1ce6579f 2925 PUSHMARK(SP);
2926
3280af22
NIS		 2927 SAVESPTR(PL_compcv);
2928 PL_compcv = (CV*)NEWSV(1104,0);
2929 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2930 CvEVAL_on(PL_compcv);
2090ab20
JH		 2931 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2932 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2933
a3985cdc 2934 CvOUTSIDE_SEQ(PL_compcv) = seq;
7dafbf52 2935 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
a3985cdc 2936
dd2155a4 2937 /* set up a scratch pad */
a0d0e21e 2938
dd2155a4 2939 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2c05e328 2940
07055b4c 2941
26d9b02f 2942 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2943
a0d0e21e
LW		 2944 /* make sure we compile in the right package */
2945
ed094faf 2946 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2947 SAVESPTR(PL_curstash);
ed094faf 2948 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2949 }
3280af22
NIS		 2950 SAVESPTR(PL_beginav);
2951 PL_beginav = newAV();
2952 SAVEFREESV(PL_beginav);
24944567 2953 SAVEI32(PL_error_count);
a0d0e21e
LW		 2954
2955 /* try to compile it */
2956
3280af22
NIS		 2957 PL_eval_root = Nullop;
2958 PL_error_count = 0;
2959 PL_curcop = &PL_compiling;
2960 PL_curcop->cop_arybase = 0;
c277df42 2961 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2962 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2963 else
c69006e4 2964 sv_setpvn(ERRSV,"",0);
3280af22 2965 if (yyparse() || PL_error_count || !PL_eval_root) {
0c58d367 2966 SV **newsp; /* Used by POPBLOCK. */
9d4ba2ae 2967 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2968 I32 optype = 0; /* Might be reset by POPEVAL. */
9d4ba2ae 2969 const char *msg;
bfed75c6 2970
533c011a 2971 PL_op = saveop;
3280af22
NIS		 2972 if (PL_eval_root) {
2973 op_free(PL_eval_root);
2974 PL_eval_root = Nullop;
a0d0e21e 2975 }
3280af22 2976 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2977 if (!startop) {
3280af22 2978 POPBLOCK(cx,PL_curpm);
c277df42 2979 POPEVAL(cx);
c277df42 2980 }
a0d0e21e
LW		 2981 lex_end();
2982 LEAVE;
9d4ba2ae
AL		 2983
2984 msg = SvPVx_nolen_const(ERRSV);
7a2e2cd6 2985 if (optype == OP_REQUIRE) {
b464bac0 2986 const SV * const nsv = cx->blk_eval.old_namesv;
504618e9 2987 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 2988 &PL_sv_undef, 0);
5a844595
GS		 2989 DIE(aTHX_ "%sCompilation failed in require",
2990 *msg ? msg : "Unknown error\n");
2991 }
2992 else if (startop) {
3280af22 2993 POPBLOCK(cx,PL_curpm);
c277df42 2994 POPEVAL(cx);
5a844595
GS		 2995 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2996 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2997 }
9d7f88dd 2998 else {
9d7f88dd
SR		 2999 if (!*msg) {
3000 sv_setpv(ERRSV, "Compilation error");
3001 }
3002 }
9d4ba2ae 3003 PERL_UNUSED_VAR(newsp);
a0d0e21e
LW		 3004 RETPUSHUNDEF;
3005 }
57843af0 3006 CopLINE_set(&PL_compiling, 0);
c277df42 3007 if (startop) {
3280af22 3008 *startop = PL_eval_root;
c277df42 3009 } else
3280af22 3010 SAVEFREEOP(PL_eval_root);
0c58d367
RGS		 3011
3012 /* Set the context for this new optree.
3013 * If the last op is an OP_REQUIRE, force scalar context.
3014 * Otherwise, propagate the context from the eval(). */
3015 if (PL_eval_root->op_type == OP_LEAVEEVAL
3016 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3017 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3018 == OP_REQUIRE)
3019 scalar(PL_eval_root);
3020 else if (gimme & G_VOID)
3280af22 3021 scalarvoid(PL_eval_root);
54310121 3022 else if (gimme & G_ARRAY)
3280af22 3023 list(PL_eval_root);
a0d0e21e 3024 else
3280af22 3025 scalar(PL_eval_root);
a0d0e21e
LW		 3026
3027 DEBUG_x(dump_eval());
3028
55497cff 3029 /* Register with debugger: */
84902520 3030 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
890ce7af 3031 CV * const cv = get_cv("DB::postponed", FALSE);
55497cff 3032 if (cv) {
3033 dSP;
924508f0 3034 PUSHMARK(SP);
cc49e20b 3035 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 3036 PUTBACK;
864dbfa3 3037 call_sv((SV*)cv, G_DISCARD);
55497cff 3038 }
3039 }
3040
a0d0e21e
LW		 3041 /* compiled okay, so do it */
3042
3280af22
NIS		 3043 CvDEPTH(PL_compcv) = 1;
3044 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 3045 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 3046 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 3047
3280af22 3048 RETURNOP(PL_eval_start);
a0d0e21e
LW		 3049}
3050
a6c40364 3051STATIC PerlIO *
7925835c 3052S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3053{
7925835c 3054#ifndef PERL_DISABLE_PMC
f54cb97a 3055 const STRLEN namelen = strlen(name);
b295d113
TH		 3056 PerlIO *fp;
3057
7894fbab 3058 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
9d4ba2ae 3059 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
349d4f2f 3060 const char * const pmc = SvPV_nolen_const(pmcsv);
a6c40364
GS		 3061 Stat_t pmcstat;
3062 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 3063 fp = PerlIO_open(name, mode);
a6c40364
GS		 3064 }
3065 else {
9d4ba2ae 3066 Stat_t pmstat;
b295d113 3067 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 3068 pmstat.st_mtime < pmcstat.st_mtime)
3069 {
3070 fp = PerlIO_open(pmc, mode);
3071 }
3072 else {
3073 fp = PerlIO_open(name, mode);
3074 }
b295d113 3075 }
a6c40364
GS		 3076 SvREFCNT_dec(pmcsv);
3077 }
3078 else {
3079 fp = PerlIO_open(name, mode);
b295d113 3080 }
b295d113 3081 return fp;
7925835c
RGS		 3082#else
3083 return PerlIO_open(name, mode);
3084#endif /* !PERL_DISABLE_PMC */
b295d113
TH		 3085}
3086
a0d0e21e
LW		 3087PP(pp_require)
3088{
27da23d5 3089 dVAR; dSP;
c09156bb 3090 register PERL_CONTEXT *cx;
a0d0e21e 3091 SV *sv;
5c144d81 3092 const char *name;
6132ea6c 3093 STRLEN len;
5c144d81 3094 const char *tryname = Nullch;
46fc3d4c 3095 SV *namesv = Nullsv;
a0d0e21e 3096 SV** svp;
f54cb97a 3097 const I32 gimme = GIMME_V;
760ac839 3098 PerlIO *tryrsfp = 0;
bbed91b5
KF		 3099 int filter_has_file = 0;
3100 GV *filter_child_proc = 0;
3101 SV *filter_state = 0;
3102 SV *filter_sub = 0;
89ccab8c 3103 SV *hook_sv = 0;
6ec9efec
JH		 3104 SV *encoding;
3105 OP *op;
a0d0e21e
LW		 3106
3107 sv = POPs;
d7aa5382
JP		 3108 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3109 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
9014280d 3110 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 3111 "v-string in use/require non-portable");
d7aa5382
JP		 3112
3113 sv = new_version(sv);
3114 if (!sv_derived_from(PL_patchlevel, "version"))
3115 (void *)upg_version(PL_patchlevel);
149c1637 3116 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
468aa647
RGS		 3117 if ( vcmp(sv,PL_patchlevel) < 0 )
3118 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3119 vnormal(sv), vnormal(PL_patchlevel));
3120 }
3121 else {
3122 if ( vcmp(sv,PL_patchlevel) > 0 )
3123 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3124 vnormal(sv), vnormal(PL_patchlevel));
3125 }
d7aa5382 3126
4305d8ab 3127 RETPUSHYES;
a0d0e21e 3128 }
5c144d81 3129 name = SvPV_const(sv, len);
6132ea6c 3130 if (!(name && len > 0 && *name))
cea2e8a9 3131 DIE(aTHX_ "Null filename used");
4633a7c4 3132 TAINT_PROPER("require");
533c011a 3133 if (PL_op->op_type == OP_REQUIRE &&
27bcc0a7
RGS		 3134 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3135 if (*svp != &PL_sv_undef)
4d8b06f1
RD		 3136 RETPUSHYES;
3137 else
3138 DIE(aTHX_ "Compilation failed in require");
3139 }
a0d0e21e
LW		 3140
3141 /* prepare to compile file */
3142
be4b629d 3143 if (path_is_absolute(name)) {
46fc3d4c 3144 tryname = name;
7925835c 3145 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
bf4acbe4 3146 }
67627c52
JH		 3147#ifdef MACOS_TRADITIONAL
3148 if (!tryrsfp) {
3149 char newname[256];
3150
3151 MacPerl_CanonDir(name, newname, 1);
3152 if (path_is_absolute(newname)) {
3153 tryname = newname;
7925835c 3154 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
67627c52
JH		 3155 }
3156 }
3157#endif
be4b629d 3158 if (!tryrsfp) {
3280af22 3159 AV *ar = GvAVn(PL_incgv);
a0d0e21e 3160 I32 i;
748a9306 3161#ifdef VMS
46fc3d4c 3162 char *unixname;
b8ffc8df 3163 if ((unixname = tounixspec(name, Nullch)) != Nullch)
46fc3d4c 3164#endif
3165 {
3166 namesv = NEWSV(806, 0);
3167 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF		 3168 SV *dirsv = *av_fetch(ar, i, TRUE);
3169
3170 if (SvROK(dirsv)) {
3171 int count;
3172 SV *loader = dirsv;
3173
e14e2dc8
NC		 3174 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3175 && !sv_isobject(loader))
3176 {
bbed91b5
KF		 3177 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3178 }
3179
b900a521 3180 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3181 PTR2UV(SvRV(dirsv)), name);
349d4f2f 3182 tryname = SvPVX_const(namesv);
bbed91b5
KF		 3183 tryrsfp = 0;
3184
3185 ENTER;
3186 SAVETMPS;
3187 EXTEND(SP, 2);
3188
3189 PUSHMARK(SP);
3190 PUSHs(dirsv);
3191 PUSHs(sv);
3192 PUTBACK;
e982885c
NC		 3193 if (sv_isobject(loader))
3194 count = call_method("INC", G_ARRAY);
3195 else
3196 count = call_sv(loader, G_ARRAY);
bbed91b5
KF		 3197 SPAGAIN;
3198
3199 if (count > 0) {
3200 int i = 0;
3201 SV *arg;
3202
3203 SP -= count - 1;
3204 arg = SP[i++];
3205
3206 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3207 arg = SvRV(arg);
3208 }
3209
3210 if (SvTYPE(arg) == SVt_PVGV) {
3211 IO *io = GvIO((GV *)arg);
3212
3213 ++filter_has_file;
3214
3215 if (io) {
3216 tryrsfp = IoIFP(io);
50952442 3217 if (IoTYPE(io) == IoTYPE_PIPE) {
bbed91b5
KF		 3218 /* reading from a child process doesn't
3219 nest -- when returning from reading
3220 the inner module, the outer one is
3221 unreadable (closed?) I've tried to
3222 save the gv to manage the lifespan of
3223 the pipe, but this didn't help. XXX */
3224 filter_child_proc = (GV *)arg;
520c758a 3225 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF		 3226 }
3227 else {
3228 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3229 PerlIO_close(IoOFP(io));
3230 }
3231 IoIFP(io) = Nullfp;
3232 IoOFP(io) = Nullfp;
3233 }
3234 }
3235
3236 if (i < count) {
3237 arg = SP[i++];
3238 }
3239 }
3240
3241 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3242 filter_sub = arg;
520c758a 3243 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 3244
3245 if (i < count) {
3246 filter_state = SP[i];
520c758a 3247 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF		 3248 }
3249
3250 if (tryrsfp == 0) {
3251 tryrsfp = PerlIO_open("/dev/null",
3252 PERL_SCRIPT_MODE);
3253 }
3254 }
1d06aecd 3255 SP--;
bbed91b5
KF		 3256 }
3257
3258 PUTBACK;
3259 FREETMPS;
3260 LEAVE;
3261
3262 if (tryrsfp) {
89ccab8c 3263 hook_sv = dirsv;
bbed91b5
KF		 3264 break;
3265 }
3266
3267 filter_has_file = 0;
3268 if (filter_child_proc) {
3269 SvREFCNT_dec(filter_child_proc);
3270 filter_child_proc = 0;
3271 }
3272 if (filter_state) {
3273 SvREFCNT_dec(filter_state);
3274 filter_state = 0;
3275 }
3276 if (filter_sub) {
3277 SvREFCNT_dec(filter_sub);
3278 filter_sub = 0;
3279 }
3280 }
3281 else {
be4b629d
CN		 3282 if (!path_is_absolute(name)
3283#ifdef MACOS_TRADITIONAL
3284 /* We consider paths of the form :a:b ambiguous and interpret them first
3285 as global then as local
3286 */
3287 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3288#endif
3289 ) {
0510663f 3290 const char *dir = SvPVx_nolen_const(dirsv);
bf4acbe4 3291#ifdef MACOS_TRADITIONAL
67627c52
JH		 3292 char buf1[256];
3293 char buf2[256];
3294
3295 MacPerl_CanonDir(name, buf2, 1);
3296 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3297#else
27da23d5 3298# ifdef VMS
bbed91b5 3299 char *unixdir;
b8ffc8df 3300 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
bbed91b5
KF		 3301 continue;
3302 sv_setpv(namesv, unixdir);
3303 sv_catpv(namesv, unixname);
27da23d5
JH		 3304# else
3305# ifdef SYMBIAN
3306 if (PL_origfilename[0] &&
3307 PL_origfilename[1] == ':' &&
3308 !(dir[0] && dir[1] == ':'))
3309 Perl_sv_setpvf(aTHX_ namesv,
3310 "%c:%s\\%s",
3311 PL_origfilename[0],
3312 dir, name);
3313 else
3314 Perl_sv_setpvf(aTHX_ namesv,
3315 "%s\\%s",
3316 dir, name);
3317# else
bbed91b5 3318 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
27da23d5
JH		 3319# endif
3320# endif
bf4acbe4 3321#endif
bbed91b5 3322 TAINT_PROPER("require");
349d4f2f 3323 tryname = SvPVX_const(namesv);
7925835c 3324 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
bbed91b5
KF		 3325 if (tryrsfp) {
3326 if (tryname[0] == '.' && tryname[1] == '/')
3327 tryname += 2;
3328 break;
3329 }
be4b629d 3330 }
46fc3d4c 3331 }
a0d0e21e
LW		 3332 }
3333 }
3334 }
f4dd75d9 3335 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3336 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3337 SvREFCNT_dec(namesv);
a0d0e21e 3338 if (!tryrsfp) {
533c011a 3339 if (PL_op->op_type == OP_REQUIRE) {
5c144d81 3340 const char *msgstr = name;
e31de809 3341 if(errno == EMFILE) {
ec889f3a 3342 SV *msg = sv_2mortal(newSVpv(msgstr,0));
e31de809
SP		 3343 sv_catpv(msg, ": ");
3344 sv_catpv(msg, Strerror(errno));
349d4f2f 3345 msgstr = SvPV_nolen_const(msg);
e31de809
SP		 3346 } else {
3347 if (namesv) { /* did we lookup @INC? */
3348 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3349 SV *dirmsgsv = NEWSV(0, 0);
3350 AV *ar = GvAVn(PL_incgv);
3351 I32 i;
3352 sv_catpvn(msg, " in @INC", 8);
3353 if (instr(SvPVX_const(msg), ".h "))
3354 sv_catpv(msg, " (change .h to .ph maybe?)");
3355 if (instr(SvPVX_const(msg), ".ph "))
3356 sv_catpv(msg, " (did you run h2ph?)");
3357 sv_catpv(msg, " (@INC contains:");
3358 for (i = 0; i <= AvFILL(ar); i++) {
3359 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3360 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3361 sv_catsv(msg, dirmsgsv);
3362 }
3363 sv_catpvn(msg, ")", 1);
3364 SvREFCNT_dec(dirmsgsv);
3365 msgstr = SvPV_nolen_const(msg);
3366 }
2683423c 3367 }
ea071790 3368 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 3369 }
3370
3371 RETPUSHUNDEF;
3372 }
d8bfb8bd 3373 else
93189314 3374 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW		 3375
3376 /* Assume success here to prevent recursive requirement. */
d3a4e64e
RGS		 3377 len = strlen(name);
3378 /* Check whether a hook in @INC has already filled %INC */
3379 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3380 (void)hv_store(GvHVn(PL_incgv), name, len,
3381 (hook_sv ? SvREFCNT_inc(hook_sv)
3382 : newSVpv(CopFILE(&PL_compiling), 0)),
3383 0 );
3384 }
a0d0e21e
LW		 3385
3386 ENTER;
3387 SAVETMPS;
79cb57f6 3388 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 3389 SAVEGENERICSV(PL_rsfp_filters);
3390 PL_rsfp_filters = Nullav;
e50aee73 3391
3280af22 3392 PL_rsfp = tryrsfp;
b3ac6de7 3393 SAVEHINTS();
3280af22 3394 PL_hints = 0;
7766f137 3395 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3396 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3397 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3398 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3399 PL_compiling.cop_warnings = pWARN_NONE ;
317ea90d
MS		 3400 else if (PL_taint_warn)
3401 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
ac27b0f5 3402 else
d3a7d8c7 3403 PL_compiling.cop_warnings = pWARN_STD ;
ac27b0f5
NIS		 3404 SAVESPTR(PL_compiling.cop_io);
3405 PL_compiling.cop_io = Nullsv;
a0d0e21e 3406
bbed91b5 3407 if (filter_sub || filter_child_proc) {
890ce7af 3408 SV * const datasv = filter_add(run_user_filter, Nullsv);
bbed91b5
KF		 3409 IoLINES(datasv) = filter_has_file;
3410 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3411 IoTOP_GV(datasv) = (GV *)filter_state;
3412 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3413 }
3414
3415 /* switch to eval mode */
a0d0e21e 3416 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3417 PUSHEVAL(cx, name, Nullgv);
f39bc417 3418 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 3419
57843af0
GS		 3420 SAVECOPLINE(&PL_compiling);
3421 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3422
3423 PUTBACK;
6ec9efec
JH		 3424
3425 /* Store and reset encoding. */
3426 encoding = PL_encoding;
3427 PL_encoding = Nullsv;
3428
a3985cdc 3429 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
bfed75c6 3430
6ec9efec
JH		 3431 /* Restore encoding. */
3432 PL_encoding = encoding;
3433
3434 return op;
a0d0e21e
LW		 3435}
3436
3437PP(pp_dofile)
3438{
cea2e8a9 3439 return pp_require();
a0d0e21e
LW		 3440}
3441
3442PP(pp_entereval)
3443{
27da23d5 3444 dVAR; dSP;
c09156bb 3445 register PERL_CONTEXT *cx;
a0d0e21e 3446 dPOPss;
890ce7af
AL		 3447 const I32 gimme = GIMME_V;
3448 const I32 was = PL_sub_generation;
83ee9e09
GS		 3449 char tbuf[TYPE_DIGITS(long) + 12];
3450 char *tmpbuf = tbuf;
fc36a67e 3451 char *safestr;
a0d0e21e 3452 STRLEN len;
55497cff 3453 OP *ret;
a3985cdc 3454 CV* runcv;
d819b83a 3455 U32 seq;
a0d0e21e 3456
5c144d81 3457 if (!SvPV_const(sv,len))
a0d0e21e 3458 RETPUSHUNDEF;
748a9306 3459 TAINT_PROPER("eval");
a0d0e21e
LW		 3460
3461 ENTER;
a0d0e21e 3462 lex_start(sv);
748a9306 3463 SAVETMPS;
ac27b0f5 3464
a0d0e21e
LW		 3465 /* switch to eval mode */
3466
83ee9e09 3467 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
890ce7af 3468 SV * const sv = sv_newmortal();
83ee9e09
GS		 3469 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3470 (unsigned long)++PL_evalseq,
3471 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3472 tmpbuf = SvPVX(sv);
3473 }
3474 else
3475 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 3476 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3477 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3478 SAVECOPLINE(&PL_compiling);
57843af0 3479 CopLINE_set(&PL_compiling, 1);
55497cff 3480 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3481 deleting the eval's FILEGV from the stash before gv_check() runs
3482 (i.e. before run-time proper). To work around the coredump that
3483 ensues, we always turn GvMULTI_on for any globals that were
3484 introduced within evals. See force_ident(). GSAR 96-10-12 */
3485 safestr = savepv(tmpbuf);
3280af22 3486 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3487 SAVEHINTS();
533c011a 3488 PL_hints = PL_op->op_targ;
7766f137 3489 SAVESPTR(PL_compiling.cop_warnings);
f0a6fc86
GS		 3490 if (specialWARN(PL_curcop-&