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