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