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