PerlIO #include and #ifdef re-work.

[p5sagit/p5-mst-13.2.git] / pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index c949e78..fce163f 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -211,6 +211,21 @@ PP(pp_substcont)
     cx->sb_m = m = rx->startp[0] + orig;
     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)
+           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);
@@ -342,6 +357,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);
@@ -620,6 +636,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 == ' ') ;
@@ -1005,10 +1058,17 @@ PP(pp_flip)
     else {
        dTOPss;
        SV *targ = PAD_SV(PL_op->op_targ);
-
-       if ((PL_op->op_private & OPpFLIP_LINENUM)
-         ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
-         : SvTRUE(sv) ) {
+       int flip;
+
+       if (PL_op->op_private & OPpFLIP_LINENUM) {
+           struct io *gp_io;
+           flip = PL_last_in_gv
+               && (gp_io = GvIOp(PL_last_in_gv))
+               && SvIV(sv) == (IV)IoLINES(gp_io);
+       } 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);
@@ -1417,6 +1477,12 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
 
            LEAVE;
 
+           /* LEAVE could clobber PL_curcop (see save_re_context())
+            * XXX it might be better to find a way to avoid messing with
+            * PL_curcop in save_re_context() instead, but this is a more
+            * minimal fix --GSAR */
+           PL_curcop = cx->blk_oldcop;
+
            if (optype == OP_REQUIRE) {
                char* msg = SvPVx(ERRSV, n_a);
                DIE(aTHX_ "%sCompilation failed in require",
@@ -2958,17 +3024,17 @@ PP(pp_require)
     if (SvNIOKp(sv)) {
        if (SvPOK(sv) && SvNOK(sv)) {           /* require v5.6.1 */
            UV rev = 0, ver = 0, sver = 0;
-           I32 len;
+           STRLEN len;
            U8 *s = (U8*)SvPVX(sv);
            U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
            if (s < end) {
-               rev = utf8_to_uv_chk(s, &len, 0);
+               rev = utf8_to_uv(s, end - s, &len, 0);
                s += len;
                if (s < end) {
-                   ver = utf8_to_uv_chk(s, &len, 0);
+                   ver = utf8_to_uv(s, end - s, &len, 0);
                    s += len;
                    if (s < end)
-                       sver = utf8_to_uv_chk(s, &len, 0);
+                       sver = utf8_to_uv(s, end - s, &len, 0);
                }
            }
            if (PERL_REVISION < rev
@@ -3619,6 +3685,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 {