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