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