Update Changes.

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

diff --git a/sv.c b/sv.c
index 148c762..acb0b82 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1497,6 +1497,9 @@ Perl_sv_2iv(pTHX_ register SV *sv)
              return SvIV(tmpstr);
          return PTR2IV(SvRV(sv));
        }
+       if (SvREADONLY(sv) && SvFAKE(sv)) {
+           sv_force_normal(sv);
+       }
        if (SvREADONLY(sv) && !SvOK(sv)) {
            dTHR;
            if (ckWARN(WARN_UNINITIALIZED))
@@ -2567,7 +2570,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
            SvIVX(dstr) = SvIVX(sstr);
            if (SvIsUV(sstr))
                SvIsUV_on(dstr);
-           SvTAINT(dstr);
+           if (SvTAINTED(sstr))
+               SvTAINT(dstr);
            return;
        }
        goto undef_sstr;
@@ -2587,7 +2591,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
            }
            SvNVX(dstr) = SvNVX(sstr);
            (void)SvNOK_only(dstr);
-           SvTAINT(dstr);
+           if (SvTAINTED(sstr))
+               SvTAINT(dstr);
            return;
        }
        goto undef_sstr;
@@ -2656,7 +2661,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
            GvINTRO_off(dstr);          /* one-shot flag */
            gp_free((GV*)dstr);
            GvGP(dstr) = gp_ref(GvGP(sstr));
-           SvTAINT(dstr);
+           if (SvTAINTED(sstr))
+               SvTAINT(dstr);
            if (GvIMPORTED(dstr) != GVf_IMPORTED
                && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
            {
@@ -2764,7 +2770,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                                    Perl_warner(aTHX_ WARN_REDEFINE,
                                        CvCONST(cv)
                                        ? "Constant subroutine %s redefined"
-                                       : "Subroutine %s redefined", 
+                                       : "Subroutine %s redefined",
                                        GvENAME((GV*)dstr));
                                }
                            }
@@ -2813,7 +2819,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                    SvREFCNT_dec(dref);
                if (intro)
                    SAVEFREESV(sref);
-               SvTAINT(dstr);
+               if (SvTAINTED(sstr))
+                   SvTAINT(dstr);
                return;
            }
            if (SvPVX(dstr)) {
@@ -2922,7 +2929,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
        else
            (void)SvOK_off(dstr);
     }
-    SvTAINT(dstr);
+    if (SvTAINTED(sstr))
+       SvTAINT(dstr);
 }
 
 /*
@@ -2953,8 +2961,11 @@ void
 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
 {
     register char *dptr;
-    assert(len >= 0);  /* STRLEN is probably unsigned, so this may
-                         elicit a warning, but it won't hurt. */
+    {
+        /* len is STRLEN which is unsigned, need to copy to signed */
+       IV iv = len;
+       assert(iv >= 0);
+    }
     SV_CHECK_THINKFIRST(sv);
     if (!ptr) {
        (void)SvOK_off(sv);
@@ -3986,26 +3997,20 @@ UTF8 bytes as a single character.
 STRLEN
 Perl_sv_len_utf8(pTHX_ register SV *sv)
 {
-    U8 *s;
-    U8 *send;
-    STRLEN len;
-
     if (!sv)
        return 0;
 
 #ifdef NOTYET
     if (SvGMAGICAL(sv))
-       len = mg_length(sv);
+       return mg_length(sv);
     else
 #endif
-       s = (U8*)SvPV(sv, len);
-    send = s + len;
-    len = 0;
-    while (s < send) {
-       s += UTF8SKIP(s);
-       len++;
+    {
+       STRLEN len;
+       U8 *s = (U8*)SvPV(sv, len);
+
+       return Perl_utf8_length(aTHX_ s, s + len);
     }
-    return len;
 }
 
 void
@@ -5132,7 +5137,7 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash)
                }
                if (GvHV(gv) && !HvNAME(GvHV(gv))) {
                    hv_clear(GvHV(gv));
-#if !defined( VMS) && !defined(EPOC)  /* VMS has no environ array */
+#ifdef USE_ENVIRON_ARRAY
                    if (gv == PL_envgv)
                        environ[0] = Nullch;
 #endif
@@ -6054,7 +6059,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        bool has_precis = FALSE;
        STRLEN precis = 0;
        bool is_utf = FALSE;
-
+       
        char esignbuf[4];
        U8 utf8buf[UTF8_MAXLEN];
        STRLEN esignlen = 0;
@@ -6082,6 +6087,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        STRLEN gap;
        char *dotstr = ".";
        STRLEN dotstrlen = 1;
+       I32 epix = 0; /* explicit parameter index */
+       I32 ewix = 0; /* explicit width index */
+       bool asterisk = FALSE;
 
        for (q = p; q < patend && *q != '%'; ++q) ;
        if (q > p) {
@@ -6142,6 +6150,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
        /* WIDTH */
 
+    scanwidth:
+
+       if (*q == '*') {
+           if (asterisk)
+               goto unknown;
+           asterisk = TRUE;
+           q++;
+       }
+
        switch (*q) {
        case '1': case '2': case '3':
        case '4': case '5': case '6':
@@ -6149,17 +6166,30 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            width = 0;
            while (isDIGIT(*q))
                width = width * 10 + (*q++ - '0');
-           break;
+           if (*q == '$') {
+               if (asterisk && ewix == 0) {
+                   ewix  = width;
+                   width = 0;
+                   q++;
+                   goto scanwidth;
+               } else if (epix == 0) {
+                   epix  = width;
+                   width = 0;
+                   q++;
+                   goto scanwidth;
+               } else
+                   goto unknown;
+           }
+       }
 
-       case '*':
+       if (asterisk) {
            if (args)
                i = va_arg(*args, int);
            else
-               i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+               i = (ewix ? ewix <= svmax : svix < svmax) ?
+                   SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
            left |= (i < 0);
            width = (i < 0) ? -i : i;
-           q++;
-           break;
        }
 
        /* PRECISION */
@@ -6170,7 +6200,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                if (args)
                    i = va_arg(*args, int);
                else
-                   i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+                   i = (ewix ? ewix <= svmax : svix < svmax)
+                       ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
                precis = (i < 0) ? 0 : i;
                q++;
            }
@@ -6188,8 +6219,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                vecstr = (U8*)SvPVx(vecsv,veclen);
                utf = DO_UTF8(vecsv);
            }
-           else if (svix < svmax) {
-               vecsv = svargs[svix++];
+           else if (epix ? epix <= svmax : svix < svmax) {
+               vecsv = svargs[epix ? epix-1 : svix++];
                vecstr = (U8*)SvPVx(vecsv,veclen);
                utf = DO_UTF8(vecsv);
            }
@@ -6243,7 +6274,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            if (args)
                uv = va_arg(*args, int);
            else
-               uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+               uv = (epix ? epix <= svmax : svix < svmax) ?
+                   SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
            if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
                eptr = (char*)utf8buf;
                elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
@@ -6272,8 +6304,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                    elen = sizeof nullstr - 1;
                }
            }
-           else if (svix < svmax) {
-               argsv = svargs[svix++];
+           else if (epix ? epix <= svmax : svix < svmax) {
+               argsv = svargs[epix ? epix-1 : svix++];
                eptr = SvPVx(argsv, elen);
                if (DO_UTF8(argsv)) {
                    if (has_precis && precis < elen) {
@@ -6316,7 +6348,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            if (args)
                uv = PTR2UV(va_arg(*args, void*));
            else
-               uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
+               uv = (epix ? epix <= svmax : svix < svmax) ?
+                   PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
            base = 16;
            goto integer;
 
@@ -6330,13 +6363,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        case 'd':
        case 'i':
            if (vectorize) {
-               I32 ulen;
+               STRLEN ulen;
                if (!veclen) {
                    vectorize = FALSE;
                    break;
                }
                if (utf)
-                   iv = (IV)utf8_to_uv_chk(vecstr, &ulen, 0);
+                   iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
                else {
                    iv = *vecstr;
                    ulen = 1;
@@ -6356,7 +6389,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                }
            }
            else {
-               iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+               iv = (epix ? epix <= svmax : svix < svmax) ?
+                   SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
                switch (intsize) {
                case 'h':       iv = (short)iv; break;
                default:        break;
@@ -6411,14 +6445,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
        uns_integer:
            if (vectorize) {
-               I32 ulen;
+               STRLEN ulen;
        vector:
                if (!veclen) {
                    vectorize = FALSE;
                    break;
                }
                if (utf)
-                   uv = utf8_to_uv_chk(vecstr, &ulen, 0);
+                   uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
                else {
                    uv = *vecstr;
                    ulen = 1;
@@ -6438,7 +6472,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                }
            }
            else {
-               uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
+               uv = (epix ? epix <= svmax : svix < svmax) ?
+                   SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
                switch (intsize) {
                case 'h':       uv = (unsigned short)uv; break;
                default:        break;
@@ -6530,7 +6565,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            if (args)
                nv = va_arg(*args, NV);
            else
-               nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
+               nv = (epix ? epix <= svmax : svix < svmax) ?
+                   SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
 
            need = 0;
            if (c != 'e' && c != 'E') {
@@ -6585,15 +6621,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                *--eptr = '#';
            *--eptr = '%';
 
-           {
-               STORE_NUMERIC_STANDARD_SET_LOCAL();
-#ifdef USE_LOCALE_NUMERIC
-               if (!was_standard && maybe_tainted)
-                   *maybe_tainted = TRUE;
-#endif
-               (void)sprintf(PL_efloatbuf, eptr, nv);
-               RESTORE_NUMERIC_STANDARD();
-           }
+           (void)sprintf(PL_efloatbuf, eptr, nv);
 
            eptr = PL_efloatbuf;
            elen = strlen(PL_efloatbuf);
@@ -6615,8 +6643,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 #endif
                }
            }
-           else if (svix < svmax)
-               sv_setuv_mg(svargs[svix++], (UV)i);
+           else if (epix ? epix <= svmax : svix < svmax)
+               sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
            continue;   /* not "break" */
 
            /* UNKNOWN */
@@ -7801,6 +7829,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
     if (!specialWARN(PL_compiling.cop_warnings))
        PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
+    if (!specialCopIO(PL_compiling.cop_io))
+       PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
     PL_curcop          = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
 
     /* pseudo environmental stuff */