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