Re: [perl #34493] h2ph `extern inline' problems
[p5sagit/p5-mst-13.2.git] / pp_ctl.c
index ec21e69..7ba6d0a 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1,7 +1,7 @@
 /*    pp_ctl.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  * And whither then?  I cannot say.
  */
 
+/* This file contains control-oriented pp ("push/pop") functions that
+ * execute the opcodes that make up a perl program. A typical pp function
+ * expects to find its arguments on the stack, and usually pushes its
+ * results onto the stack, hence the 'pp' terminology. Each OP structure
+ * contains a pointer to the relevant pp_foo() function.
+ *
+ * Control-oriented means things like pp_enteriter() and pp_next(), which
+ * alter the flow of control of the program.
+ */
+
+
 #include "EXTERN.h"
 #define PERL_IN_PP_CTL_C
 #include "perl.h"
@@ -71,14 +82,41 @@ PP(pp_regcomp)
     SV *tmpstr;
     STRLEN len;
     MAGIC *mg = Null(MAGIC*);
-    
-    tmpstr = POPs;
 
     /* prevent recompiling under /o and ithreads. */
 #if defined(USE_ITHREADS)
-    if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
-        RETURN;
+    if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
+       if (PL_op->op_flags & OPf_STACKED) {
+           dMARK;
+           SP = MARK;
+       }
+       else
+           (void)POPs;
+       RETURN;
+    }
 #endif
+    if (PL_op->op_flags & OPf_STACKED) {
+       /* multiple args; concatentate them */
+       dMARK; dORIGMARK;
+       tmpstr = PAD_SV(ARGTARG);
+       sv_setpvn(tmpstr, "", 0);
+       while (++MARK <= SP) {
+           if (PL_amagic_generation) {
+               SV *sv;
+               if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
+                   (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
+               {
+                  sv_setsv(tmpstr, sv);
+                  continue;
+               }
+           }
+           sv_catsv(tmpstr, *MARK);
+       }
+       SvSETMAGIC(tmpstr);
+       SP = ORIGMARK;
+    }
+    else
+       tmpstr = POPs;
 
     if (SvROK(tmpstr)) {
        SV *sv = SvRV(tmpstr);
@@ -161,7 +199,7 @@ PP(pp_substcont)
     SV *nsv = Nullsv;
     REGEXP *old = PM_GETRE(pm);
     if(old != rx) {
-       if(old) 
+       if(old)
            ReREFCNT_dec(old);
        PM_SETRE(pm,rx);
     }
@@ -187,10 +225,13 @@ PP(pp_substcont)
        {
            SV *targ = cx->sb_targ;
 
-           if (DO_UTF8(dstr) && !SvUTF8(targ))
-               sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
-           else
-               sv_catpvn(dstr, s, cx->sb_strend - s);
+           assert(cx->sb_strend >= s);
+           if(cx->sb_strend > s) {
+                if (DO_UTF8(dstr) && !SvUTF8(targ))
+                     sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
+                else
+                     sv_catpvn(dstr, s, cx->sb_strend - s);
+           }
            cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 
 #ifdef PERL_COPY_ON_WRITE
@@ -199,7 +240,7 @@ PP(pp_substcont)
            } else
 #endif
            {
-               (void)SvOOK_off(targ);
+               SvOOK_off(targ);
                if (SvLEN(targ))
                    Safefree(SvPVX(targ));
            }
@@ -235,7 +276,7 @@ PP(pp_substcont)
     }
     cx->sb_m = m = rx->startp[0] + orig;
     if (m > s) {
-       if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) 
+       if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
            sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
        else
            sv_catpvn(dstr, s, m-s);
@@ -365,12 +406,13 @@ PP(pp_formline)
     NV value;
     bool gotsome = FALSE;
     STRLEN len;
-    STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
+    STRLEN fudge = SvPOK(tmpForm)
+                       ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
     bool item_is_utf8 = FALSE;
     bool targ_is_utf8 = FALSE;
     SV * nsv = Nullsv;
     OP * parseres = 0;
-    char *fmt;
+    const char *fmt;
     bool oneline;
 
     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
@@ -397,7 +439,7 @@ PP(pp_formline)
 
     for (;;) {
        DEBUG_f( {
-           char *name = "???";
+           const char *name = "???";
            arg = -1;
            switch (*fpc) {
            case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
@@ -417,7 +459,7 @@ PP(pp_formline)
            case FF_MORE:       name = "MORE";          break;
            case FF_LINEMARK:   name = "LINEMARK";      break;
            case FF_END:        name = "END";           break;
-            case FF_0DECIMAL:  name = "0DECIMAL";      break;
+           case FF_0DECIMAL:   name = "0DECIMAL";      break;
            case FF_LINESNGL:   name = "LINESNGL";      break;
            }
            if (arg >= 0)
@@ -696,7 +738,7 @@ PP(pp_formline)
            item = s = SvPV(sv, len);
            itemsize = len;
            if ((item_is_utf8 = DO_UTF8(sv)))
-               itemsize = sv_len_utf8(sv);         
+               itemsize = sv_len_utf8(sv);
            if (itemsize) {
                bool chopped = FALSE;
                gotsome = TRUE;
@@ -762,7 +804,7 @@ PP(pp_formline)
            gotsome = TRUE;
            value = SvNV(sv);
            /* overflow evidence */
-           if (num_overflow(value, fieldsize, arg)) { 
+           if (num_overflow(value, fieldsize, arg)) {
                arg = fieldsize;
                while (arg--)
                    *t++ = '#';
@@ -928,7 +970,7 @@ PP(pp_mapwhile)
             * irrelevant.  --jhi */
             if (shift < count)
                 shift = count; /* Avoid shifting too often --Ben Tilly */
-       
+
            EXTEND(SP,shift);
            src = SP;
            dst = (SP += shift);
@@ -943,7 +985,7 @@ PP(pp_mapwhile)
            while (items-- > 0)
                *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
        }
-       else { 
+       else {
            /* scalar context: we don't care about which values map returns
             * (we use undef here). And so we certainly don't want to do mortal
             * copies of meaningless values. */
@@ -1019,9 +1061,9 @@ PP(pp_flip)
     else {
        dTOPss;
        SV *targ = PAD_SV(PL_op->op_targ);
-       int flip = 0;
+       int flip = 0;
 
-       if (PL_op->op_private & OPpFLIP_LINENUM) {
+       if (PL_op->op_private & OPpFLIP_LINENUM) {
            if (GvIO(PL_last_in_gv)) {
                flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
            }
@@ -1029,10 +1071,10 @@ PP(pp_flip)
                GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
                if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
            }
-       } else {
-           flip = SvTRUE(sv);
-       }
-       if (flip) {
+       } else {
+           flip = SvTRUE(sv);
+       }
+       if (flip) {
            sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
            if (PL_op->op_flags & OPf_SPECIAL) {
                sv_setiv(targ, 1);
@@ -1142,7 +1184,7 @@ PP(pp_flop)
 
 /* Control. */
 
-static char *context_name[] = {
+static const char *context_name[] = {
     "pseudo-block",
     "subroutine",
     "eval",
@@ -1350,19 +1392,18 @@ Perl_qerror(pTHX_ SV *err)
 }
 
 OP *
-Perl_die_where(pTHX_ char *message, STRLEN msglen)
+Perl_die_where(pTHX_ const char *message, STRLEN msglen)
 {
     STRLEN n_a;
 
     if (PL_in_eval) {
        I32 cxix;
-       register PERL_CONTEXT *cx;
        I32 gimme;
        SV **newsp;
 
        if (message) {
            if (PL_in_eval & EVAL_KEEPERR) {
-               static char prefix[] = "\t(in cleanup) ";
+                static const char prefix[] = "\t(in cleanup) ";
                SV *err = ERRSV;
                char *e = Nullch;
                if (!SvPOK(err))
@@ -1397,6 +1438,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
 
        if (cxix >= 0) {
            I32 optype;
+           register PERL_CONTEXT *cx;
 
            if (cxix < cxstack_ix)
                dounwind(cxix);
@@ -1424,14 +1466,15 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
            PL_curcop = cx->blk_oldcop;
 
            if (optype == OP_REQUIRE) {
-               char* msg = SvPVx(ERRSV, n_a);
-               SV *nsv = cx->blk_eval.old_namesv;
-               (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
+                const char* msg = SvPVx(ERRSV, n_a);
+                SV *nsv = cx->blk_eval.old_namesv;
+                (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
                                &PL_sv_undef, 0);
                DIE(aTHX_ "%sCompilation failed in require",
                    *msg ? msg : "Unknown error\n");
            }
-           return pop_return();
+           assert(CxTYPE(cx) == CXt_EVAL);
+           return cx->blk_eval.retop;
        }
     }
     if (!message)
@@ -1671,7 +1714,7 @@ PP(pp_caller)
 PP(pp_reset)
 {
     dSP;
-    char *tmps;
+    const char *tmps;
     STRLEN n_a;
 
     if (MAXARG < 1)
@@ -1725,9 +1768,9 @@ PP(pp_dbstate)
        hasargs = 0;
        SPAGAIN;
 
-       push_return(PL_op->op_next);
        PUSHBLOCK(cx, CXt_SUB, SP);
        PUSHSUB_DB(cx);
+       cx->blk_sub.retop = PL_op->op_next;
        CvDEPTH(cv)++;
        PAD_SET_CUR(CvPADLIST(cv),1);
        RETURNOP(CvSTART(cv));
@@ -1807,11 +1850,22 @@ PP(pp_enteriter)
                (void) SvPV(right,n_a);
            }
        }
+       else if (PL_op->op_private & OPpITER_REVERSED) {
+           cx->blk_loop.itermax = -1;
+           cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
+
+       }
     }
     else {
        cx->blk_loop.iterary = PL_curstack;
        AvFILLp(PL_curstack) = SP - PL_stack_base;
-       cx->blk_loop.iterix = MARK - PL_stack_base;
+       if (PL_op->op_private & OPpITER_REVERSED) {
+           cx->blk_loop.itermax = MARK - PL_stack_base;
+           cx->blk_loop.iterix = cx->blk_oldsp;
+       }
+       else {
+           cx->blk_loop.iterix = MARK - PL_stack_base;
+       }
     }
 
     RETURN;
@@ -1885,6 +1939,7 @@ PP(pp_return)
     PMOP *newpm;
     I32 optype = 0;
     SV *sv;
+    OP *retop;
 
     if (PL_curstackinfo->si_type == PERLSI_SORT) {
        if (cxstack_ix == PL_sortcxix
@@ -1908,12 +1963,14 @@ PP(pp_return)
     switch (CxTYPE(cx)) {
     case CXt_SUB:
        popsub2 = TRUE;
+       retop = cx->blk_sub.retop;
        cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
        break;
     case CXt_EVAL:
        if (!(PL_in_eval & EVAL_KEEPERR))
            clear_errsv = TRUE;
        POPEVAL(cx);
+       retop = cx->blk_eval.retop;
        if (CxTRYBLOCK(cx))
            break;
        lex_end();
@@ -1928,6 +1985,7 @@ PP(pp_return)
        break;
     case CXt_FORMAT:
        POPFORMAT(cx);
+       retop = cx->blk_sub.retop;
        break;
     default:
        DIE(aTHX_ "panic: return");
@@ -1981,7 +2039,7 @@ PP(pp_return)
     LEAVESUB(sv);
     if (clear_errsv)
        sv_setpv(ERRSV,"");
-    return pop_return();
+    return retop;
 }
 
 PP(pp_last)
@@ -2022,15 +2080,15 @@ PP(pp_last)
        break;
     case CXt_SUB:
        pop2 = CXt_SUB;
-       nextop = pop_return();
+       nextop = cx->blk_sub.retop;
        break;
     case CXt_EVAL:
        POPEVAL(cx);
-       nextop = pop_return();
+       nextop = cx->blk_eval.retop;
        break;
     case CXt_FORMAT:
        POPFORMAT(cx);
-       nextop = pop_return();
+       nextop = cx->blk_sub.retop;
        break;
     default:
        DIE(aTHX_ "panic: last");
@@ -2127,11 +2185,11 @@ PP(pp_redo)
 }
 
 STATIC OP *
-S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
+S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
 {
     OP *kid = Nullop;
     OP **ops = opstack;
-    static char too_deep[] = "Target of goto is too deeply nested";
+    static const char too_deep[] = "Target of goto is too deeply nested";
 
     if (ops >= oplimit)
        Perl_croak(aTHX_ too_deep);
@@ -2187,12 +2245,10 @@ PP(pp_goto)
     register PERL_CONTEXT *cx;
 #define GOTO_DEPTH 64
     OP *enterops[GOTO_DEPTH];
-    char *label;
-    int do_dump = (PL_op->op_type == OP_DUMP);
-    static char must_have_label[] = "goto must have label";
-    AV *oldav = Nullav;
+    const char *label = 0;
+    const bool do_dump = (PL_op->op_type == OP_DUMP);
+    static const char must_have_label[] = "goto must have label";
 
-    label = 0;
     if (PL_op->op_flags & OPf_STACKED) {
        SV *sv = POPs;
        STRLEN n_a;
@@ -2205,12 +2261,13 @@ PP(pp_goto)
            SV** mark;
            I32 items = 0;
            I32 oldsave;
+           bool reified = 0;
 
        retry:
            if (!CvROOT(cv) && !CvXSUB(cv)) {
-               GV *gv = CvGV(cv);
-               GV *autogv;
+               const GV * const gv = CvGV(cv);
                if (gv) {
+                   GV *autogv;
                    SV *tmpstr;
                    /* autoloaded stub? */
                    if (cv != GvCV(gv) && (cv = GvCV(gv)))
@@ -2227,7 +2284,7 @@ PP(pp_goto)
            }
 
            /* First do some returnish stuff. */
-           SvREFCNT_inc(cv); /* avoid premature free during unwind */
+           (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
            FREETMPS;
            cxix = dopoptosub(cxstack_ix);
            if (cxix < 0)
@@ -2237,38 +2294,35 @@ PP(pp_goto)
            TOPBLOCK(cx);
            if (CxREALEVAL(cx))
                DIE(aTHX_ "Can't goto subroutine from an eval-string");
-           mark = PL_stack_sp;
            if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
                /* put @_ back onto stack */
                AV* av = cx->blk_sub.argarray;
-               
+
                items = AvFILLp(av) + 1;
-               PL_stack_sp++;
-               EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
-               Copy(AvARRAY(av), PL_stack_sp, items, SV*);
-               PL_stack_sp += items;
+               EXTEND(SP, items+1); /* @_ could have been extended. */
+               Copy(AvARRAY(av), SP + 1, items, SV*);
                SvREFCNT_dec(GvAV(PL_defgv));
                GvAV(PL_defgv) = cx->blk_sub.savearray;
+               CLEAR_ARGARRAY(av);
                /* abandon @_ if it got reified */
                if (AvREAL(av)) {
-                   oldav = av; /* delay until return */
+                   reified = 1;
+                   SvREFCNT_dec(av);
                    av = newAV();
                    av_extend(av, items-1);
                    AvFLAGS(av) = AVf_REIFY;
                    PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
                }
-               else
-                   CLEAR_ARGARRAY(av);
            }
            else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
                AV* av;
                av = GvAV(PL_defgv);
                items = AvFILLp(av) + 1;
-               PL_stack_sp++;
-               EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
-               Copy(AvARRAY(av), PL_stack_sp, items, SV*);
-               PL_stack_sp += items;
+               EXTEND(SP, items+1); /* @_ could have been extended. */
+               Copy(AvARRAY(av), SP + 1, items, SV*);
            }
+           mark = SP;
+           SP += items;
            if (CxTYPE(cx) == CXt_SUB &&
                !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
                SvREFCNT_dec(cx->blk_sub.cv);
@@ -2277,11 +2331,13 @@ PP(pp_goto)
 
            /* Now do some callish stuff. */
            SAVETMPS;
-           /* For reified @_, delay freeing till return from new sub */
-           if (oldav)
-               SAVEFREESV((SV*)oldav);
            SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
            if (CvXSUB(cv)) {
+               if (reified) {
+                   I32 index;
+                   for (index=0; index<items; index++)
+                       sv_2mortal(SP[-index]);
+               }
 #ifdef PERL_XSUB_OLDSTYLE
                if (CvOLDSTYLE(cv)) {
                    I32 (*fp3)(int,int,int);
@@ -2301,16 +2357,17 @@ PP(pp_goto)
                    SV **newsp;
                    I32 gimme;
 
-                   PL_stack_sp--;              /* There is no cv arg. */
                    /* Push a mark for the start of arglist */
                    PUSHMARK(mark);
+                   PUTBACK;
                    (void)(*CvXSUB(cv))(aTHX_ cv);
                    /* Pop the current context like a decent sub should */
                    POPBLOCK(cx, PL_curpm);
                    /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
                }
                LEAVE;
-               return pop_return();
+               assert(CxTYPE(cx) == CXt_SUB);
+               return cx->blk_sub.retop;
            }
            else {
                AV* padlist = CvPADLIST(cv);
@@ -2329,7 +2386,7 @@ PP(pp_goto)
                else {
                    if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
                        sub_crush_depth(cv);
-                   pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
+                   pad_push(padlist, CvDEPTH(cv));
                }
                PAD_SET_CUR(padlist, CvDEPTH(cv));
                if (cx->blk_sub.hasargs)
@@ -2341,7 +2398,6 @@ PP(pp_goto)
                    GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
                    CX_CURPAD_SAVE(cx->blk_sub);
                    cx->blk_sub.argarray = av;
-                   ++mark;
 
                    if (items >= AvMAX(av) + 1) {
                        ary = AvALLOC(av);
@@ -2356,9 +2412,15 @@ PP(pp_goto)
                            SvPVX(av) = (char*)ary;
                        }
                    }
+                   ++mark;
                    Copy(mark,AvARRAY(av),items,SV*);
                    AvFILLp(av) = items - 1;
                    assert(!AvREAL(av));
+                   if (reified) {
+                       /* transfer 'ownership' of refcnts to new @_ */
+                       AvREAL_on(av);
+                       AvREIFY_off(av);
+                   }
                    while (items--) {
                        if (*mark)
                            SvTEMP_off(*mark);
@@ -2372,7 +2434,7 @@ PP(pp_goto)
                     */
                    SV *sv = GvSV(PL_DBsub);
                    CV *gotocv;
-               
+
                    if (PERLDB_SUB_NN) {
                        (void)SvUPGRADE(sv, SVt_PVIV);
                        (void)SvIOK_on(sv);
@@ -2611,14 +2673,6 @@ S_save_lines(pTHX_ AV *array, SV *sv)
     }
 }
 
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_docatch_body(pTHX_ va_list args)
-{
-    return docatch_body();
-}
-#endif
-
 STATIC void *
 S_docatch_body(pTHX)
 {
@@ -2645,21 +2699,16 @@ S_docatch(pTHX_ OP *o)
      * the op to Nullop, we force an exit from the inner runops()
      * loop. DAPM.
      */
-    retop = pop_return();
-    push_return(Nullop);
+    assert(cxstack_ix >= 0);
+    assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
+    retop = cxstack[cxstack_ix].blk_eval.retop;
+    cxstack[cxstack_ix].blk_eval.retop = Nullop;
 
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- redo_body:
-    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
-#else
     JMPENV_PUSH(ret);
-#endif
     switch (ret) {
     case 0:
-#ifndef PERL_FLEXIBLE_EXCEPTIONS
  redo_body:
        docatch_body();
-#endif
        break;
     case 3:
        /* die caught by an inner eval - continue inner loop */
@@ -2684,7 +2733,7 @@ S_docatch(pTHX_ OP *o)
 }
 
 OP *
-Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
+Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
 /* sv Text to convert to OP tree. */
 /* startop op_free() this to undo. */
 /* code Short string id of the caller. */
@@ -2778,7 +2827,7 @@ Locate the CV corresponding to the currently executing sub or eval.
 If db_seqp is non_null, skip CVs that are in the DB package and populate
 *db_seqp with the cop sequence number at the point that the DB:: code was
 entered. (allows debuggers to eval in the scope of the breakpoint rather
-than in in the scope of the debuger itself).
+than in in the scope of the debugger itself).
 
 =cut
 */
@@ -2874,7 +2923,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
        I32 optype = 0;                 /* Might be reset by POPEVAL. */
        STRLEN n_a;
-       
+
        PL_op = saveop;
        if (PL_eval_root) {
            op_free(PL_eval_root);
@@ -2884,7 +2933,6 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
        if (!startop) {
            POPBLOCK(cx,PL_curpm);
            POPEVAL(cx);
-           pop_return();
        }
        lex_end();
        LEAVE;
@@ -3015,66 +3063,19 @@ PP(pp_require)
     OP *op;
 
     sv = POPs;
-    if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
-       if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
-           UV rev = 0, ver = 0, sver = 0;
-           STRLEN len;
-           U8 *s = (U8*)SvPVX(sv);
-           U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
-           if (s < end) {
-               rev = utf8n_to_uvchr(s, end - s, &len, 0);
-               s += len;
-               if (s < end) {
-                   ver = utf8n_to_uvchr(s, end - s, &len, 0);
-                   s += len;
-                   if (s < end)
-                       sver = utf8n_to_uvchr(s, end - s, &len, 0);
-               }
-           }
-           if (PERL_REVISION < rev
-               || (PERL_REVISION == rev
-                   && (PERL_VERSION < ver
-                       || (PERL_VERSION == ver
-                           && PERL_SUBVERSION < sver))))
-           {
-               DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
-                   "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
-                   PERL_VERSION, PERL_SUBVERSION);
-           }
-           if (ckWARN(WARN_PORTABLE))
+    if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
+       if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
                Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
                         "v-string in use/require non-portable");
+
+       sv = new_version(sv);
+       if (!sv_derived_from(PL_patchlevel, "version"))
+           (void *)upg_version(PL_patchlevel);
+       if ( vcmp(sv,PL_patchlevel) > 0 )
+           DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
+               vstringify(sv), vstringify(PL_patchlevel));
+
            RETPUSHYES;
-       }
-       else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
-           if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
-               + ((NV)PERL_SUBVERSION/(NV)1000000)
-               + 0.00000099 < SvNV(sv))
-           {
-               NV nrev = SvNV(sv);
-               UV rev = (UV)nrev;
-               NV nver = (nrev - rev) * 1000;
-               UV ver = (UV)(nver + 0.0009);
-               NV nsver = (nver - ver) * 1000;
-               UV sver = (UV)(nsver + 0.0009);
-
-               /* help out with the "use 5.6" confusion */
-               if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
-                   DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
-                       " (did you mean v%"UVuf".%03"UVuf"?)--"
-                       "this is only v%d.%d.%d, stopped",
-                       rev, ver, sver, rev, ver/100,
-                       PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
-               }
-               else {
-                   DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
-                       "this is only v%d.%d.%d, stopped",
-                       rev, ver, sver, PERL_REVISION, PERL_VERSION,
-                       PERL_SUBVERSION);
-               }
-           }
-           RETPUSHYES;
-       }
     }
     name = SvPV(sv, len);
     if (!(name && len > 0 && *name))
@@ -3342,9 +3343,9 @@ PP(pp_require)
     }
 
     /* switch to eval mode */
-    push_return(PL_op->op_next);
     PUSHBLOCK(cx, CXt_EVAL, SP);
     PUSHEVAL(cx, name, Nullgv);
+    cx->blk_eval.retop = PL_op->op_next;
 
     SAVECOPLINE(&PL_compiling);
     CopLINE_set(&PL_compiling, 0);
@@ -3356,7 +3357,7 @@ PP(pp_require)
     PL_encoding = Nullsv;
 
     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
-    
+
     /* Restore encoding. */
     PL_encoding = encoding;
 
@@ -3435,9 +3436,9 @@ PP(pp_entereval)
      * to do the dirty work for us */
     runcv = find_runcv(&seq);
 
-    push_return(PL_op->op_next);
     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
     PUSHEVAL(cx, 0, Nullgv);
+    cx->blk_eval.retop = PL_op->op_next;
 
     /* prepare to compile string */
 
@@ -3466,7 +3467,7 @@ PP(pp_leaveeval)
 
     POPBLOCK(cx,newpm);
     POPEVAL(cx);
-    retop = pop_return();
+    retop = cx->blk_eval.retop;
 
     TAINT_NOT;
     if (gimme == G_VOID)
@@ -3529,9 +3530,9 @@ PP(pp_entertry)
     ENTER;
     SAVETMPS;
 
-    push_return(cLOGOP->op_other->op_next);
     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
     PUSHEVAL(cx, 0, 0);
+    cx->blk_eval.retop = cLOGOP->op_other->op_next;
 
     PL_in_eval = EVAL_INEVAL;
     sv_setpv(ERRSV,"");
@@ -3552,7 +3553,7 @@ PP(pp_leavetry)
 
     POPBLOCK(cx,newpm);
     POPEVAL(cx);
-    retop = pop_return();
+    retop = cx->blk_eval.retop;
 
     TAINT_NOT;
     if (gimme == G_VOID)
@@ -3803,7 +3804,7 @@ S_doparseform(pTHX_ SV *sv)
     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
     SvCOMPILED_on(sv);
 
-    if (unchopnum && repeat) 
+    if (unchopnum && repeat)
         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
     return 0;
 }
@@ -3924,3 +3925,13 @@ S_path_is_absolute(pTHX_ char *name)
     else
        return FALSE;
 }
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * vim: shiftwidth=4:
+*/