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