This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
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
PP
42 switch (cxstack[cxix].blk_gimme) {
43 case G_ARRAY:
a0d0e21e 44 RETPUSHYES;
54310121 45 case G_SCALAR:
a0d0e21e 46 RETPUSHNO;
54310121
PP
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
PP
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
PP
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
PP
303 }
304}
305
306void
864dbfa3 307Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4
PP
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
PP
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
PP
330 }
331}
332
333void
864dbfa3 334Perl_rxres_free(pTHX_ void **rsp)
c90c0ff4
PP
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
PP
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
LW
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
LW
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
LW
692 case FF_LINESNGL:
693 chopspace = 0;
694 oneline = TRUE;
695 goto ff_line;
a0d0e21e 696 case FF_LINEGLOB:
a1b95068
LW
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
LW
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
LW
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
LW
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
LW
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
URCI
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
1597 gimme = (I32)cx->blk_gimme;
1598 if (gimme == G_VOID)
3280af22 1599 PUSHs(&PL_sv_undef);
54310121
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
2063 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2064 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
2065 TAINT_NOT; /* Each item is independent */
2066 }
f86702cc
PP
2067 }
2068 SP = newsp;
2069 PUTBACK;
2070
5dd42e15
DM
2071 LEAVE;
2072 cxstack_ix--;
f86702cc
PP
2073 /* Stack values are safe: */
2074 switch (pop2) {
2075 case CXt_LOOP:
a8bba7fa 2076 POPLOOP(cx); /* release loop vars ... */
4fdae800 2077 LEAVE;
f86702cc
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
NP
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
NP
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
PP
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
PP
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
PP
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
PP
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