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