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