EBCDIC sanity - phase I
[p5sagit/p5-mst-13.2.git] / pp_ctl.c
index 33f91ee..8985cca 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1,6 +1,6 @@
 /*    pp_ctl.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -47,7 +47,7 @@ static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
 
 PP(pp_wantarray)
 {
-    djSP;
+    dSP;
     I32 cxix;
     EXTEND(SP, 1);
 
@@ -80,7 +80,7 @@ PP(pp_regcreset)
 
 PP(pp_regcomp)
 {
-    djSP;
+    dSP;
     register PMOP *pm = (PMOP*)cLOGOP->op_other;
     register char *t;
     SV *tmpstr;
@@ -115,9 +115,16 @@ PP(pp_regcomp)
 
            pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
            if (DO_UTF8(tmpstr))
-               pm->op_pmdynflags |= PMdf_UTF8;
+               pm->op_pmdynflags |= PMdf_DYN_UTF8;
+           else {
+               pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
+               if (pm->op_pmdynflags & PMdf_UTF8)
+                   t = (char*)bytes_to_utf8((U8*)t, &len);
+           }
            pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
-           PL_reginterp_cnt = 0;               /* XXXX Be extra paranoid - needed
+           if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
+               Safefree(t);
+           PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
                                           inside tie/overload accessors.  */
        }
     }
@@ -149,7 +156,7 @@ PP(pp_regcomp)
 
 PP(pp_substcont)
 {
-    djSP;
+    dSP;
     register PMOP *pm = (PMOP*) cLOGOP->op_other;
     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
     register SV *dstr = cx->sb_dstr;
@@ -176,8 +183,8 @@ PP(pp_substcont)
                                      : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
        {
            SV *targ = cx->sb_targ;
-           sv_catpvn(dstr, s, cx->sb_strend - s);
 
+           sv_catpvn(dstr, s, cx->sb_strend - s);
            cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 
            (void)SvOOK_off(targ);
@@ -185,13 +192,15 @@ PP(pp_substcont)
            SvPVX(targ) = SvPVX(dstr);
            SvCUR_set(targ, SvCUR(dstr));
            SvLEN_set(targ, SvLEN(dstr));
+           if (DO_UTF8(dstr))
+               SvUTF8_on(targ);
            SvPVX(dstr) = 0;
            sv_free(dstr);
 
            TAINT_IF(cx->sb_rxtainted & 1);
            PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
 
-           (void)SvPOK_only(targ);
+           (void)SvPOK_only_UTF8(targ);
            TAINT_IF(cx->sb_rxtainted);
            SvSETMAGIC(targ);
            SvTAINT(targ);
@@ -209,8 +218,24 @@ PP(pp_substcont)
        cx->sb_strend = s + (cx->sb_strend - m);
     }
     cx->sb_m = m = rx->startp[0] + orig;
-    sv_catpvn(dstr, s, m-s);
+    if (m > s)
+       sv_catpvn(dstr, s, m-s);
     cx->sb_s = rx->endp[0] + orig;
+    { /* Update the pos() information. */
+       SV *sv = cx->sb_targ;
+       MAGIC *mg;
+       I32 i;
+       if (SvTYPE(sv) < SVt_PVMG)
+           (void)SvUPGRADE(sv, SVt_PVMG);
+       if (!(mg = mg_find(sv, 'g'))) {
+           sv_magic(sv, Nullsv, 'g', Nullch, 0);
+           mg = mg_find(sv, 'g');
+       }
+       i = m - orig;
+       if (DO_UTF8(sv))
+           sv_pos_b2u(sv, &i);
+       mg->mg_len = i;
+    }
     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
     rxres_save(&cx->sb_rxres, rx);
     RETURNOP(pm->op_pmreplstart);
@@ -279,7 +304,7 @@ Perl_rxres_free(pTHX_ void **rsp)
 
 PP(pp_formline)
 {
-    djSP; dMARK; dORIGMARK;
+    dSP; dMARK; dORIGMARK;
     register SV *tmpForm = *++MARK;
     register U16 *fpc;
     register char *t;
@@ -342,6 +367,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;
            }
            if (arg >= 0)
                PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
@@ -524,7 +550,7 @@ PP(pp_formline)
            s = item;
            if (item_is_utf) {
                while (arg--) {
-                   if (*s & 0x80) {
+                   if (UTF8_IS_CONTINUED(*s)) {
                        switch (UTF8SKIP(s)) {
                        case 7: *t++ = *s++;
                        case 6: *t++ = *s++;
@@ -620,6 +646,43 @@ PP(pp_formline)
            t += fieldsize;
            break;
 
+       case FF_0DECIMAL:
+           /* If the field is marked with ^ and the value is undefined,
+              blank it out. */
+           arg = *fpc++;
+           if ((arg & 512) && !SvOK(sv)) {
+               arg = fieldsize;
+               while (arg--)
+                   *t++ = ' ';
+               break;
+           }
+           gotsome = TRUE;
+           value = SvNV(sv);
+           /* Formats aren't yet marked for locales, so assume "yes". */
+           {
+               STORE_NUMERIC_STANDARD_SET_LOCAL();
+#if defined(USE_LONG_DOUBLE)
+               if (arg & 256) {
+                   sprintf(t, "%#0*.*" PERL_PRIfldbl,
+                           (int) fieldsize, (int) arg & 255, value);
+/* is this legal? I don't have long doubles */
+               } else {
+                   sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
+               }
+#else
+               if (arg & 256) {
+                   sprintf(t, "%#0*.*f",
+                           (int) fieldsize, (int) arg & 255, value);
+               } else {
+                   sprintf(t, "%0*.0f",
+                           (int) fieldsize, value);
+               }
+#endif
+               RESTORE_NUMERIC_STANDARD();
+           }
+           t += fieldsize;
+           break;
+       
        case FF_NEWLINE:
            f++;
            while (t-- > linemark && *t == ' ') ;
@@ -687,7 +750,7 @@ PP(pp_formline)
 
 PP(pp_grepstart)
 {
-    djSP;
+    dSP;
     SV *src;
 
     if (PL_stack_base + *PL_markstack_ptr == SP) {
@@ -724,12 +787,12 @@ PP(pp_mapstart)
 
 PP(pp_mapwhile)
 {
-    djSP;
+    dSP;
     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
     I32 count;
     I32 shift;
     SV** src;
-    SV** dst; 
+    SV** dst;
 
     /* first, move source pointer to the next item in the source list */
     ++PL_markstack_ptr[-1];
@@ -761,7 +824,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);
@@ -771,9 +834,9 @@ PP(pp_mapwhile)
                *dst-- = *src--;
        }
        /* copy the new items down to the destination list */
-       dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; 
+       dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
        while (items--)
-           *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); 
+           *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
     }
     LEAVE;                                     /* exit inner scope */
 
@@ -812,7 +875,7 @@ PP(pp_mapwhile)
 
 PP(pp_sort)
 {
-    djSP; dMARK; dORIGMARK;
+    dSP; dMARK; dORIGMARK;
     register SV **up;
     SV **myorigmark = ORIGMARK;
     register I32 max;
@@ -997,7 +1060,7 @@ PP(pp_range)
 
 PP(pp_flip)
 {
-    djSP;
+    dSP;
 
     if (GIMME == G_ARRAY) {
        RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
@@ -1036,7 +1099,7 @@ PP(pp_flip)
 
 PP(pp_flop)
 {
-    djSP;
+    dSP;
 
     if (GIMME == G_ARRAY) {
        dPOPPOPssrl;
@@ -1107,7 +1170,6 @@ PP(pp_flop)
 STATIC I32
 S_dopoptolabel(pTHX_ char *label)
 {
-    dTHR;
     register I32 i;
     register PERL_CONTEXT *cx;
 
@@ -1116,27 +1178,27 @@ S_dopoptolabel(pTHX_ char *label)
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_SUB:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_FORMAT:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_EVAL:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_NULL:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
                        PL_op_name[PL_op->op_type]);
            return -1;
        case CXt_LOOP:
@@ -1163,7 +1225,6 @@ Perl_dowantarray(pTHX)
 I32
 Perl_block_gimme(pTHX)
 {
-    dTHR;
     I32 cxix;
 
     cxix = dopoptosub(cxstack_ix);
@@ -1184,17 +1245,29 @@ Perl_block_gimme(pTHX)
     }
 }
 
+I32
+Perl_is_lvalue_sub(pTHX)
+{
+    I32 cxix;
+
+    cxix = dopoptosub(cxstack_ix);
+    assert(cxix >= 0);  /* We should only be called from inside subs */
+
+    if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
+       return cxstack[cxix].blk_sub.lval;
+    else
+       return 0;
+}
+
 STATIC I32
 S_dopoptosub(pTHX_ I32 startingblock)
 {
-    dTHR;
     return dopoptosub_at(cxstack, startingblock);
 }
 
 STATIC I32
 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
 {
-    dTHR;
     I32 i;
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
@@ -1215,7 +1288,6 @@ S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
 STATIC I32
 S_dopoptoeval(pTHX_ I32 startingblock)
 {
-    dTHR;
     I32 i;
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
@@ -1234,7 +1306,6 @@ S_dopoptoeval(pTHX_ I32 startingblock)
 STATIC I32
 S_dopoptoloop(pTHX_ I32 startingblock)
 {
-    dTHR;
     I32 i;
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
@@ -1242,27 +1313,27 @@ S_dopoptoloop(pTHX_ I32 startingblock)
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_SUB:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_FORMAT:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_EVAL:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_NULL:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
                        PL_op_name[PL_op->op_type]);
            return -1;
        case CXt_LOOP:
@@ -1276,7 +1347,6 @@ S_dopoptoloop(pTHX_ I32 startingblock)
 void
 Perl_dounwind(pTHX_ I32 cxix)
 {
-    dTHR;
     register PERL_CONTEXT *cx;
     I32 optype;
 
@@ -1322,7 +1392,6 @@ Perl_dounwind(pTHX_ I32 cxix)
 STATIC void
 S_free_closures(pTHX)
 {
-    dTHR;
     SV **svp = AvARRAY(PL_comppad_name);
     I32 ix;
     for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
@@ -1391,8 +1460,13 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
                    }
                }
            }
-           else
+           else {
                sv_setpvn(ERRSV, message, msglen);
+               if (PL_hints & HINT_UTF8)
+                   SvUTF8_on(ERRSV);
+               else
+                   SvUTF8_off(ERRSV);
+           }
        }
        else
            message = SvPVx(ERRSV, msglen);
@@ -1460,7 +1534,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
 
 PP(pp_xor)
 {
-    djSP; dPOPTOPssrl;
+    dSP; dPOPTOPssrl;
     if (SvTRUE(left) != SvTRUE(right))
        RETSETYES;
     else
@@ -1469,7 +1543,7 @@ PP(pp_xor)
 
 PP(pp_andassign)
 {
-    djSP;
+    dSP;
     if (!SvTRUE(TOPs))
        RETURN;
     else
@@ -1478,7 +1552,7 @@ PP(pp_andassign)
 
 PP(pp_orassign)
 {
-    djSP;
+    dSP;
     if (SvTRUE(TOPs))
        RETURN;
     else
@@ -1487,7 +1561,7 @@ PP(pp_orassign)
        
 PP(pp_caller)
 {
-    djSP;
+    dSP;
     register I32 cxix = dopoptosub(cxstack_ix);
     register PERL_CONTEXT *cx;
     register PERL_CONTEXT *ccstack = cxstack;
@@ -1615,10 +1689,10 @@ PP(pp_caller)
        SV * mask ;
        SV * old_warnings = cx->blk_oldcop->cop_warnings ;
 
-       if  (old_warnings == pWARN_NONE || 
+       if  (old_warnings == pWARN_NONE ||
                (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
-        else if (old_warnings == pWARN_ALL || 
+        else if (old_warnings == pWARN_ALL ||
                  (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
             mask = newSVpvn(WARN_ALLstring, WARNsize) ;
         else
@@ -1630,7 +1704,7 @@ PP(pp_caller)
 
 PP(pp_reset)
 {
-    djSP;
+    dSP;
     char *tmps;
     STRLEN n_a;
 
@@ -1657,7 +1731,7 @@ PP(pp_dbstate)
 
     if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
     {
-       djSP;
+       dSP;
        register CV *cv;
        register PERL_CONTEXT *cx;
        I32 gimme = G_ARRAY;
@@ -1669,7 +1743,8 @@ PP(pp_dbstate)
        if (!cv)
            DIE(aTHX_ "No DB::DB routine defined");
 
-       if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
+       if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
+           /* don't do recursive DB::DB call */
            return NORMAL;
 
        ENTER;
@@ -1701,7 +1776,7 @@ PP(pp_scope)
 
 PP(pp_enteriter)
 {
-    djSP; dMARK;
+    dSP; dMARK;
     register PERL_CONTEXT *cx;
     I32 gimme = GIMME_V;
     SV **svp;
@@ -1715,7 +1790,6 @@ PP(pp_enteriter)
 
 #ifdef USE_THREADS
     if (PL_op->op_flags & OPf_SPECIAL) {
-       dTHR;
        svp = &THREADSV(PL_op->op_targ);        /* per-thread variable */
        SAVEGENERICSV(*svp);
        *svp = NEWSV(0,0);
@@ -1723,9 +1797,11 @@ PP(pp_enteriter)
     else
 #endif /* USE_THREADS */
     if (PL_op->op_targ) {
+#ifndef USE_ITHREADS
        svp = &PL_curpad[PL_op->op_targ];               /* "my" variable */
        SAVESPTR(*svp);
-#ifdef USE_ITHREADS
+#else
+       SAVEPADSV(PL_op->op_targ);
        iterdata = (void*)PL_op->op_targ;
        cxtype |= CXp_PADVAR;
 #endif
@@ -1779,7 +1855,7 @@ PP(pp_enteriter)
 
 PP(pp_enterloop)
 {
-    djSP;
+    dSP;
     register PERL_CONTEXT *cx;
     I32 gimme = GIMME_V;
 
@@ -1795,7 +1871,7 @@ PP(pp_enterloop)
 
 PP(pp_leaveloop)
 {
-    djSP;
+    dSP;
     register PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
@@ -1835,7 +1911,7 @@ PP(pp_leaveloop)
 
 PP(pp_return)
 {
-    djSP; dMARK;
+    dSP; dMARK;
     I32 cxix;
     register PERL_CONTEXT *cx;
     bool popsub2 = FALSE;
@@ -1946,7 +2022,7 @@ PP(pp_return)
 
 PP(pp_last)
 {
-    djSP;
+    dSP;
     I32 cxix;
     register PERL_CONTEXT *cx;
     I32 pop2 = 0;
@@ -2103,7 +2179,6 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
     }
     *ops = 0;
     if (o->op_flags & OPf_KIDS) {
-       dTHR;
        /* First try all the kids at this level, since that's likeliest. */
        for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
            if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
@@ -2134,7 +2209,7 @@ PP(pp_dump)
 
 PP(pp_goto)
 {
-    djSP;
+    dSP;
     OP *retop = 0;
     I32 ix;
     register PERL_CONTEXT *cx;
@@ -2185,7 +2260,7 @@ PP(pp_goto)
            if (cxix < cxstack_ix)
                dounwind(cxix);
            TOPBLOCK(cx);
-           if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) 
+           if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
                DIE(aTHX_ "Can't goto subroutine from an eval-string");
            mark = PL_stack_sp;
            if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
@@ -2253,7 +2328,7 @@ PP(pp_goto)
 
                    PL_stack_sp--;              /* There is no cv arg. */
                    /* Push a mark for the start of arglist */
-                   PUSHMARK(mark); 
+                   PUSHMARK(mark);
                    (void)(*CvXSUB(cv))(aTHXo_ cv);
                    /* Pop the current context like a decent sub should */
                    POPBLOCK(cx, PL_curpm);
@@ -2327,14 +2402,14 @@ PP(pp_goto)
 #ifdef USE_THREADS
                if (!cx->blk_sub.hasargs) {
                    AV* av = (AV*)PL_curpad[0];
-                   
+               
                    items = AvFILLp(av) + 1;
                    if (items) {
                        /* Mark is at the end of the stack. */
                        EXTEND(SP, items);
                        Copy(AvARRAY(av), SP + 1, items, SV*);
                        SP += items;
-                       PUTBACK ;                   
+                       PUTBACK ;               
                    }
                }
 #endif /* USE_THREADS */               
@@ -2384,7 +2459,7 @@ PP(pp_goto)
                     */
                    SV *sv = GvSV(PL_DBsub);
                    CV *gotocv;
-                   
+               
                    if (PERLDB_SUB_NN) {
                        SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
                    } else {
@@ -2511,7 +2586,7 @@ PP(pp_goto)
 
 PP(pp_exit)
 {
-    djSP;
+    dSP;
     I32 anum;
 
     if (MAXARG < 1)
@@ -2532,7 +2607,7 @@ PP(pp_exit)
 #ifdef NOTYET
 PP(pp_nswitch)
 {
-    djSP;
+    dSP;
     NV value = SvNVx(GvSV(cCOP->cop_gv));
     register I32 match = I_32(value);
 
@@ -2551,7 +2626,7 @@ PP(pp_nswitch)
 
 PP(pp_cswitch)
 {
-    djSP;
+    dSP;
     register I32 match;
 
     if (PL_multiline)
@@ -2614,7 +2689,6 @@ S_docatch_body(pTHX)
 STATIC OP *
 S_docatch(pTHX_ OP *o)
 {
-    dTHR;
     int ret;
     OP *oldop = PL_op;
     volatile PERL_SI *cursi = PL_curstackinfo;
@@ -2707,12 +2781,12 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
 #else
     SAVEVPTR(PL_op);
 #endif
-    PL_hints = 0;
+    PL_hints &= HINT_UTF8;
 
     PL_op = &dummy;
     PL_op->op_type = OP_ENTEREVAL;
     PL_op->op_flags = 0;                       /* Avoid uninit warning. */
-    PUSHBLOCK(cx, CXt_EVAL, SP);
+    PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
     PUSHEVAL(cx, 0, Nullgv);
     rop = doeval(G_SCALAR, startop);
     POPBLOCK(cx,PL_curpm);
@@ -2951,7 +3025,7 @@ S_doopen_pmc(pTHX_ const char *name, const char *mode)
 
 PP(pp_require)
 {
-    djSP;
+    dSP;
     register PERL_CONTEXT *cx;
     SV *sv;
     char *name;
@@ -2975,13 +3049,13 @@ PP(pp_require)
            U8 *s = (U8*)SvPVX(sv);
            U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
            if (s < end) {
-               rev = utf8_to_uv_chk(s, end - s, &len, 0);
+               rev = utf8n_to_uvchr(s, end - s, &len, 0);
                s += len;
                if (s < end) {
-                   ver = utf8_to_uv_chk(s, end - s, &len, 0);
+                   ver = utf8n_to_uvchr(s, end - s, &len, 0);
                    s += len;
                    if (s < end)
-                       sver = utf8_to_uv_chk(s, end - s, &len, 0);
+                       sver = utf8n_to_uvchr(s, end - s, &len, 0);
                }
            }
            if (PERL_REVISION < rev
@@ -3037,22 +3111,27 @@ PP(pp_require)
 
     /* prepare to compile file */
 
+#ifdef MACOS_TRADITIONAL
     if (PERL_FILE_IS_ABSOLUTE(name)
-       || (*name == '.' && (name[1] == '/' ||
-                            (name[1] == '.' && name[2] == '/'))))
+       || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
     {
        tryname = name;
        tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
-#ifdef MACOS_TRADITIONAL
        /* We consider paths of the form :a:b ambiguous and interpret them first
           as global then as local
        */
-       if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
+       if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
            goto trylocal;
     }
-    else 
+    else
 trylocal: {
 #else
+    if (PERL_FILE_IS_ABSOLUTE(name)
+       || (*name == '.' && (name[1] == '/' ||
+                            (name[1] == '.' && name[2] == '/'))))
+    {
+       tryname = name;
+       tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
     }
     else {
 #endif
@@ -3088,7 +3167,10 @@ trylocal: {
                    PUSHs(dirsv);
                    PUSHs(sv);
                    PUTBACK;
-                   count = call_sv(loader, G_ARRAY);
+                   if (sv_isobject(loader))
+                       count = call_method("INC", G_ARRAY);
+                   else
+                       count = call_sv(loader, G_ARRAY);
                    SPAGAIN;
 
                    if (count > 0) {
@@ -3259,8 +3341,10 @@ trylocal: {
         PL_compiling.cop_warnings = pWARN_ALL ;
     else if (PL_dowarn & G_WARN_ALL_OFF)
         PL_compiling.cop_warnings = pWARN_NONE ;
-    else 
+    else
         PL_compiling.cop_warnings = pWARN_STD ;
+    SAVESPTR(PL_compiling.cop_io);
+    PL_compiling.cop_io = Nullsv;
 
     if (filter_sub || filter_child_proc) {
        SV *datasv = filter_add(run_user_filter, Nullsv);
@@ -3297,7 +3381,7 @@ PP(pp_dofile)
 
 PP(pp_entereval)
 {
-    djSP;
+    dSP;
     register PERL_CONTEXT *cx;
     dPOPss;
     I32 gimme = GIMME_V, was = PL_sub_generation;
@@ -3314,7 +3398,7 @@ PP(pp_entereval)
     ENTER;
     lex_start(sv);
     SAVETMPS;
+
     /* switch to eval mode */
 
     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
@@ -3346,6 +3430,13 @@ PP(pp_entereval)
         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
         SAVEFREESV(PL_compiling.cop_warnings);
     }
+    SAVESPTR(PL_compiling.cop_io);
+    if (specialCopIO(PL_curcop->cop_io))
+        PL_compiling.cop_io = PL_curcop->cop_io;
+    else {
+        PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
+        SAVEFREESV(PL_compiling.cop_io);
+    }
 
     push_return(PL_op->op_next);
     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
@@ -3374,7 +3465,7 @@ PP(pp_entereval)
 
 PP(pp_leaveeval)
 {
-    djSP;
+    dSP;
     register SV **mark;
     SV **newsp;
     PMOP *newpm;
@@ -3445,7 +3536,7 @@ PP(pp_leaveeval)
 
 PP(pp_entertry)
 {
-    djSP;
+    dSP;
     register PERL_CONTEXT *cx;
     I32 gimme = GIMME_V;
 
@@ -3465,7 +3556,7 @@ PP(pp_entertry)
 
 PP(pp_leavetry)
 {
-    djSP;
+    dSP;
     register SV **mark;
     SV **newsp;
     PMOP *newpm;
@@ -3529,7 +3620,7 @@ S_doparseform(pTHX_ SV *sv)
 
     if (len == 0)
        Perl_croak(aTHX_ "Null picture in formline");
-    
+
     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
     fpc = fops;
 
@@ -3557,7 +3648,7 @@ S_doparseform(pTHX_ SV *sv)
        case ' ': case '\t':
            skipspaces++;
            continue;
-           
+       
        case '\n': case 0:
            arg = s - base;
            skipspaces++;
@@ -3632,6 +3723,24 @@ S_doparseform(pTHX_ SV *sv)
                }
                *fpc++ = s - base;              /* fieldsize for FETCH */
                *fpc++ = FF_DECIMAL;
+                *fpc++ = arg;
+            }
+            else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
+                arg = ischop ? 512 : 0;
+               base = s - 1;
+                s++;                                /* skip the '0' first */
+                while (*s == '#')
+                    s++;
+                if (*s == '.') {
+                    char *f;
+                    s++;
+                    f = s;
+                    while (*s == '#')
+                        s++;
+                    arg |= 256 + (s - f);
+                }
+                *fpc++ = s - base;                /* fieldsize for FETCH */
+                *fpc++ = FF_0DECIMAL;
                *fpc++ = arg;
            }
            else {
@@ -3695,7 +3804,7 @@ S_doparseform(pTHX_ SV *sv)
  * Research Group at University of California, Berkeley.
  *
  * See also: "Optimistic Merge Sort" (SODA '92)
- *      
+ *
  * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
  *
  * The code can be distributed under the same terms as Perl itself.
@@ -4065,7 +4174,6 @@ S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
 static I32
 sortcv(pTHXo_ SV *a, SV *b)
 {
-    dTHR;
     I32 oldsaveix = PL_savestack_ix;
     I32 oldscopeix = PL_scopestack_ix;
     I32 result;
@@ -4089,7 +4197,6 @@ sortcv(pTHXo_ SV *a, SV *b)
 static I32
 sortcv_stacked(pTHXo_ SV *a, SV *b)
 {
-    dTHR;
     I32 oldsaveix = PL_savestack_ix;
     I32 oldscopeix = PL_scopestack_ix;
     I32 result;
@@ -4295,7 +4402,7 @@ run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
     }
 
     if (filter_sub && len >= 0) {
-       djSP;
+       dSP;
        int count;
 
        ENTER;