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