This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Update Changes.
[perl5.git] / pp_pack.c
diff --git a/pp_pack.c b/pp_pack.c
index b653362..4cf3b93 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -104,8 +104,8 @@ S_mul128(pTHX_ SV *sv, U8 m)
     t--;
   while (t > s) {
     i = ((*t - '0') << 7) + m;
-    *(t--) = '0' + (i % 10);
-    m = i / 10;
+    *(t--) = '0' + (char)(i % 10);
+    m = (char)(i / 10);
   }
   return (sv);
 }
@@ -202,7 +202,7 @@ S_measure_struct(pTHX_ char *pat, register char *patend)
        case 'U':                       /* XXXX Is it correct? */
        case 'w':
        case 'u':
-           buf[0] = datumtype;
+           buf[0] = (char)datumtype;
            buf[1] = 0;
            Perl_croak(aTHX_ "%s not allowed in length fields", buf);
        case ',': /* grandfather in commas but with a warning */
@@ -458,7 +458,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
     long double aldouble;
 #endif
-    bool do_utf8 = flags & UNPACK_DO_UTF8;
+    bool do_utf8 = (flags & UNPACK_DO_UTF8) != 0;
 
     while ((pat = next_symbol(pat, patend)) < patend) {
        datumtype = *pat++ & 0xFF;
@@ -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);
            {
@@ -1275,7 +1299,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
 
                        sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
                        while (s < strend) {
-                           sv = mul128(sv, *s & 0x7f);
+                           sv = mul128(sv, (U8)(*s & 0x7f));
                            if (!(*s++ & 0x80)) {
                                bytes = 0;
                                break;
@@ -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) {
@@ -1517,16 +1553,17 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                        d = PL_uudmap[*(U8*)s++] & 077;
                    else
                        d = 0;
-                   hunk[0] = (a << 2) | (b >> 4);
-                   hunk[1] = (b << 4) | (c >> 2);
-                   hunk[2] = (c << 6) | d;
+                   hunk[0] = (char)((a << 2) | (b >> 4));
+                   hunk[1] = (char)((b << 4) | (c >> 2));
+                   hunk[2] = (char)((c << 6) | d);
                    sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
                    len -= 3;
                }
                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;
@@ -1839,7 +1876,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
            /* FALL THROUGH */
        case 'X':
          shrink:
-           if (SvCUR(cat) < len)
+           if ((I32)SvCUR(cat) < len)
                Perl_croak(aTHX_ "X outside of string");
            SvCUR(cat) -= len;
            *SvEND(cat) = '\0';
@@ -1871,7 +1908,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                if (datumtype == 'Z')
                    ++len;
            }
-           if (fromlen >= len) {
+           if ((I32)fromlen >= len) {
                sv_catpvn(cat, aptr, len);
                if (datumtype == 'Z')
                    *(SvEND(cat)-1) = '\0';
@@ -1910,7 +1947,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                SvCUR(cat) += (len+7)/8;
                SvGROW(cat, SvCUR(cat) + 1);
                aptr = SvPVX(cat) + aint;
-               if (len > fromlen)
+               if (len > (I32)fromlen)
                    len = fromlen;
                aint = len;
                items = 0;
@@ -1966,7 +2003,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                SvCUR(cat) += (len+1)/2;
                SvGROW(cat, SvCUR(cat) + 1);
                aptr = SvPVX(cat) + aint;
-               if (len > fromlen)
+               if (len > (I32)fromlen)
                    len = fromlen;
                aint = len;
                items = 0;
@@ -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,12 +2244,12 @@ 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);
 
                    do {
-                       *--in = (auv & 0x7f) | 0x80;
+                       *--in = (char)((auv & 0x7f) | 0x80);
                        auv >>= 7;
                    } while (auv);
                    buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
@@ -2371,7 +2440,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
            while (fromlen > 0) {
                I32 todo;
 
-               if (fromlen > len)
+               if ((I32)fromlen > len)
                    todo = len;
                else
                    todo = fromlen;
Unnamed repository; edit this file 'description' to name the repository.