Upgrade to Tie::File 0.93, from mjd.

[perl5.git] / pp_pack.c

diff --git a/pp_pack.c b/pp_pack.c
index 1f483fc..452a2b0 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -146,6 +146,7 @@ S_group_end(pTHX_ register char *pat, register char *patend, char ender)
            pat = group_end(pat, patend, ']') + 1;
     }
     Perl_croak(aTHX_ "No group ending character `%c' found", ender);
+    return 0;
 }
 
 #define TYPE_IS_SHRIEKING      0x100
@@ -206,7 +207,7 @@ S_measure_struct(pTHX_ char *pat, register char *patend)
            Perl_croak(aTHX_ "%s not allowed in length fields", buf);
        case ',': /* grandfather in commas but with a warning */
            if (commas++ == 0 && ckWARN(WARN_UNPACK))
-               Perl_warner(aTHX_ WARN_UNPACK,
+               Perl_warner(aTHX_ packWARN(WARN_UNPACK),
                            "Invalid type in unpack: '%c'", (int)datumtype);
            /* FALL THROUGH */
        case '%':
@@ -499,7 +500,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
            Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
        case ',': /* grandfather in commas but with a warning */
            if (commas++ == 0 && ckWARN(WARN_UNPACK))
-               Perl_warner(aTHX_ WARN_UNPACK,
+               Perl_warner(aTHX_ packWARN(WARN_UNPACK),
                            "Invalid type in unpack: '%c'", (int)datumtype);
            break;
        case '%':
@@ -769,7 +770,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)
@@ -783,7 +784,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *
                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);
@@ -1524,8 +1525,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;
@@ -1793,7 +1795,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
            Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
        case ',': /* grandfather in commas but with a warning */
            if (commas++ == 0 && ckWARN(WARN_PACK))
-               Perl_warner(aTHX_ WARN_PACK,
+               Perl_warner(aTHX_ packWARN(WARN_PACK),
                            "Invalid type in pack: '%c'", (int)datumtype);
            break;
        case '%':
@@ -2015,7 +2017,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    aint = SvIV(fromstr);
                    if ((aint < 0 || aint > 255) &&
                        ckWARN(WARN_PACK))
-                       Perl_warner(aTHX_ WARN_PACK,
+                       Perl_warner(aTHX_ packWARN(WARN_PACK),
                                    "Character in \"C\" format wrapped");
                    achar = aint & 255;
                    sv_catpvn(cat, &achar, sizeof(char));
@@ -2024,7 +2026,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    aint = SvIV(fromstr);
                    if ((aint < -128 || aint > 127) &&
                        ckWARN(WARN_PACK))
-                       Perl_warner(aTHX_ WARN_PACK,
+                       Perl_warner(aTHX_ packWARN(WARN_PACK),
                                    "Character in \"c\" format wrapped");
                    achar = aint & 255;
                    sv_catpvn(cat, &achar, sizeof(char));
@@ -2037,8 +2039,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;
@@ -2162,26 +2168,21 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
        case 'w':
             while (len-- > 0) {
                fromstr = NEXTFROM;
-               adouble = Perl_floor(SvNV(fromstr));
+               adouble = SvNV(fromstr);
 
                if (adouble < 0)
                    Perl_croak(aTHX_ "Cannot compress negative numbers");
 
-               if (
-#if UVSIZE > 4 && UVSIZE >= NVSIZE
-                   adouble <= 0xffffffff
-#else
-#   ifdef CXUX_BROKEN_CONSTANT_CONVERT
-                   adouble <= UV_MAX_cxux
-#   else
-                   adouble <= UV_MAX
-#   endif
-#endif
-                   )
+                /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
+                   which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
+                   any negative IVs will have already been got by the croak()
+                   above. IOK is untrue for fractions, so we test them
+                   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 = U_V(adouble);
+                   UV     auv = SvUV(fromstr);
 
                    do {
                        *--in = (auv & 0x7f) | 0x80;
@@ -2215,6 +2216,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                    char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
                    char  *in = buf + sizeof(buf);
 
+                    adouble = Perl_floor(adouble);
                    do {
                        double next = floor(adouble / 128);
                        *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
@@ -2352,7 +2354,7 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                                                || (SvPADTMP(fromstr)
                                                    && !SvREADONLY(fromstr))))
                    {
-                       Perl_warner(aTHX_ WARN_PACK,
+                       Perl_warner(aTHX_ packWARN(WARN_PACK),
                                "Attempt to pack pointer to temporary value");
                    }
                    if (SvPOK(fromstr) || SvNIOK(fromstr))