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