User-defined character properties were unintentionally

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

diff --git a/pp_pack.c b/pp_pack.c
index 1c5ee31..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) {
@@ -2052,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;