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