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