Allow poking holes at the UTF-8 decoding strictness.

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

diff --git a/sv.c b/sv.c
index e7bd003..2790cfd 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -913,6 +913,10 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
     MAGIC*     magic;
     HV*                stash;
 
+    if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
+       sv_force_normal(sv);
+    }
+
     if (SvTYPE(sv) == mt)
        return TRUE;
 
@@ -2444,8 +2448,13 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
         if (!utf8_to_bytes((U8*)c, &len)) {
            if (fail_ok)
                return FALSE;
-           else
-               Perl_croak(aTHX_ "big byte");
+           else {
+               if (PL_op)
+                   Perl_croak(aTHX_ "Wide character in %s",
+                              PL_op_desc[PL_op->op_type]);
+               else
+                   Perl_croak(aTHX_ "Wide character");
+           }
        }
        SvCUR(sv) = len - 1;
        SvUTF8_off(sv);
@@ -2736,12 +2745,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                            if (!GvCVGEN((GV*)dstr) &&
                                (CvROOT(cv) || CvXSUB(cv)))
                            {
-                               SV *const_sv = cv_const_sv(cv);
-                               bool const_changed = TRUE;
-                               if(const_sv)
-                                   const_changed = sv_cmp(const_sv,
-                                          op_const_sv(CvSTART((CV*)sref),
-                                                      (CV*)sref));
+                               SV *const_sv;
                                /* ahem, death to those who redefine
                                 * active sort subs */
                                if (PL_curstackinfo->si_type == PERLSI_SORT &&
@@ -2749,11 +2753,20 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                                    Perl_croak(aTHX_
                                    "Can't redefine active sort subroutine %s",
                                          GvENAME((GV*)dstr));
-                               if ((const_changed && const_sv) || ckWARN(WARN_REDEFINE))
-                                   Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
-                                            "Constant subroutine %s redefined"
-                                            : "Subroutine %s redefined",
-                                            GvENAME((GV*)dstr));
+                               /* Redefining a sub - warning is mandatory if
+                                  it was a const and its value changed. */
+                               if (ckWARN(WARN_REDEFINE)
+                                   || (CvCONST(cv)
+                                       && (!CvCONST((CV*)sref)
+                                           || sv_cmp(cv_const_sv(cv),
+                                                     cv_const_sv((CV*)sref)))))
+                               {
+                                   Perl_warner(aTHX_ WARN_REDEFINE,
+                                       CvCONST(cv)
+                                       ? "Constant subroutine %s redefined"
+                                       : "Subroutine %s redefined", 
+                                       GvENAME((GV*)dstr));
+                               }
                            }
                            cv_ckproto(cv, (GV*)dstr,
                                       SvPOK(sref) ? SvPVX(sref) : Nullch);
@@ -4090,7 +4103,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
        pv2 = SvPV(sv2, cur2);
 
     /* do not utf8ize the comparands as a side-effect */
-    if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE && 0) {
+    if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
        if (SvUTF8(sv1)) {
            pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
            pv2tmp = TRUE;
@@ -6041,7 +6054,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;
@@ -6069,6 +6082,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) {
@@ -6129,6 +6145,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':
@@ -6136,17 +6161,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 */
@@ -6157,7 +6195,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++;
            }
@@ -6175,8 +6214,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);
            }
@@ -6230,7 +6269,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;
@@ -6259,8 +6299,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) {
@@ -6303,7 +6343,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;
 
@@ -6317,13 +6358,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_chk(vecstr, veclen, &ulen, 0);
                else {
                    iv = *vecstr;
                    ulen = 1;
@@ -6343,7 +6384,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;
@@ -6398,14 +6440,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_chk(vecstr, veclen, &ulen, 0);
                else {
                    uv = *vecstr;
                    ulen = 1;
@@ -6425,7 +6467,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;
@@ -6517,7 +6560,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') {
@@ -6602,8 +6646,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 */