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