solve one taint problem

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

diff --git a/pp_pack.c b/pp_pack.c
index b653362..63e9d4b 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -720,6 +720,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -748,6 +750,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -770,7 +774,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            if (checksum) {
                while (len-- > 0 && s < strend) {
                    STRLEN alen;
-                   auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, 0));
+                   auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
                    along = alen;
                    s += along;
                    if (checksum > bits_in_uv)
@@ -780,11 +784,13 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0 && s < strend) {
                    STRLEN alen;
-                   auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, 0));
+                   auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
                    along = alen;
                    s += along;
                    sv = NEWSV(37, 0);
@@ -833,6 +839,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
 #if SHORTSIZE != SIZE16
@@ -909,6 +917,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
 #if SHORTSIZE != SIZE16
@@ -958,6 +968,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1009,6 +1021,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1042,6 +1056,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1068,6 +1084,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1120,6 +1138,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
 #if LONGSIZE != SIZE32
@@ -1198,6 +1218,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
 #if LONGSIZE != SIZE32
@@ -1252,6 +1274,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            }
            break;
        case 'w':
+            if (len && (flags & UNPACK_ONLY_ONE))
+                len = 1;
            EXTEND(SP, len);
            EXTEND_MORTAL(len);
            {
@@ -1325,6 +1349,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
             else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                 EXTEND(SP, len);
                 EXTEND_MORTAL(len);
                 while (len-- > 0) {
@@ -1358,6 +1384,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
             else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                 EXTEND(SP, len);
                 EXTEND_MORTAL(len);
                 while (len-- > 0) {
@@ -1390,6 +1418,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1413,6 +1443,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1436,6 +1468,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1460,6 +1494,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
            }
            else {
+                if (len && (flags & UNPACK_ONLY_ONE))
+                    len = 1;
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0) {
@@ -1525,8 +1561,9 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                }
                if (*s == '\n')
                    s++;
-               else if (s[1] == '\n')          /* possible checksum byte */
-                   s += 2;
+               else    /* possible checksum byte */
+                   if (s + 1 < strend && s[1] == '\n')
+                       s += 2;
            }
            XPUSHs(sv_2mortal(sv));
            break;
@@ -2038,8 +2075,12 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                fromstr = NEXTFROM;
                auint = UNI_TO_NATIVE(SvUV(fromstr));
                SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
-               SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
-                              - SvPVX(cat));
+               SvCUR_set(cat,
+                         (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
+                                                    auint,
+                                                    ckWARN(WARN_UTF8) ?
+                                                    0 : UNICODE_ALLOW_ANY)
+                         - SvPVX(cat));
            }
            *SvEND(cat) = '\0';
            break;
@@ -2047,14 +2088,42 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
        case 'f':
            while (len-- > 0) {
                fromstr = NEXTFROM;
+#ifdef __VOS__
+/* VOS does not automatically map a floating-point overflow
+   during conversion from double to float into infinity, so we
+   do it by hand.  This code should either be generalized for
+   any OS that needs it, or removed if and when VOS implements
+   posix-976 (suggestion to support mapping to infinity).
+   Paul.Green@stratus.com 02-04-02.  */
+               if (SvNV(fromstr) > FLT_MAX)
+                    afloat = _float_constants[0];   /* single prec. inf. */
+               else if (SvNV(fromstr) < -FLT_MAX)
+                    afloat = _float_constants[0];   /* single prec. inf. */
+               else afloat = (float)SvNV(fromstr);
+#else
                afloat = (float)SvNV(fromstr);
+#endif
                sv_catpvn(cat, (char *)&afloat, sizeof (float));
            }
            break;
        case 'd':
            while (len-- > 0) {
                fromstr = NEXTFROM;
+#ifdef __VOS__
+/* VOS does not automatically map a floating-point overflow
+   during conversion from long double to double into infinity,
+   so we do it by hand.  This code should either be generalized
+   for any OS that needs it, or removed if and when VOS
+   implements posix-976 (suggestion to support mapping to
+   infinity).  Paul.Green@stratus.com 02-04-02.  */
+               if (SvNV(fromstr) > DBL_MAX)
+                    adouble = _double_constants[0];   /* double prec. inf. */
+               else if (SvNV(fromstr) < -DBL_MAX)
+                    adouble = _double_constants[0];   /* double prec. inf. */
+               else adouble = (double)SvNV(fromstr);
+#else
                adouble = (double)SvNV(fromstr);
+#endif
                sv_catpvn(cat, (char *)&adouble, sizeof (double));
            }
            break;
@@ -2175,7 +2244,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    against UV_MAX_P1.  */
                if (SvIOK(fromstr) || adouble < UV_MAX_P1)
                {
-                   char   buf[1 + sizeof(UV)];
+                   char   buf[(sizeof(UV)*8)/7+1];
                    char  *in = buf + sizeof(buf);
                    UV     auv = SvUV(fromstr);