X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_pack.c;h=4cf3b93c27a07dd53ba98ed5b774b7a15534990d;hb=a4c53327465447bb63099eecea56701314399b0a;hp=5d620eed46266a0382476409f24b7a1d9ce70df8;hpb=62f955573e85dc949b6e396624a9434d6c330a5f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_pack.c b/pp_pack.c index 5d620ee..4cf3b93 100644 --- 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); } @@ -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 @@ -201,12 +202,12 @@ 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 */ 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 '%': @@ -293,6 +294,12 @@ S_measure_struct(pTHX_ char *pat, register char *patend) case 'I': size = sizeof(unsigned int); break; + case 'j': + size = IVSIZE; + break; + case 'J': + size = UVSIZE; + break; case 'l': #if LONGSIZE == SIZE32 size = SIZE32; @@ -325,13 +332,19 @@ S_measure_struct(pTHX_ char *pat, register char *patend) break; #endif case 'f': - case 'F': size = sizeof(float); break; case 'd': - case 'D': size = sizeof(double); break; + case 'F': + size = NVSIZE; + break; +#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) + case 'D': + size = LONG_DOUBLESIZE; + break; +#endif } total += len * size; } @@ -430,16 +443,22 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * float afloat; double adouble; I32 checksum = 0; - UV culong = 0; + UV cuv = 0; NV cdouble = 0.0; - const int bits_in_uv = 8 * sizeof(culong); + const int bits_in_uv = 8 * sizeof(cuv); int commas = 0; int star; /* 1 if count is *, -1 if no count given, -2 for / */ #ifdef PERL_NATINT_PACK int natint; /* native integer */ int unatint; /* unsigned native integer */ #endif - bool do_utf8 = flags & UNPACK_DO_UTF8; + IV aiv; + UV auv; + NV anv; +#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) + long double aldouble; +#endif + bool do_utf8 = (flags & UNPACK_DO_UTF8) != 0; while ((pat = next_symbol(pat, patend)) < patend) { datumtype = *pat++ & 0xFF; @@ -481,14 +500,14 @@ 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 '%': if (len == 1 && pat[-1] != '1' && pat[-1] != ']') len = 16; /* len is not specified */ checksum = len; - culong = 0; + cuv = 0; cdouble = 0; continue; break; @@ -608,20 +627,20 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * } } while (len >= 8) { - culong += PL_bitcount[*(unsigned char*)s++]; + cuv += PL_bitcount[*(unsigned char*)s++]; len -= 8; } if (len) { bits = *s; if (datumtype == 'b') { while (len-- > 0) { - if (bits & 1) culong++; + if (bits & 1) cuv++; bits >>= 1; } } else { while (len-- > 0) { - if (bits & 128) culong++; + if (bits & 128) cuv++; bits <<= 1; } } @@ -697,10 +716,12 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aint; else - culong += aint; + cuv += aint; } } else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { @@ -725,10 +746,12 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * uchar_checksum: while (len-- > 0) { auint = *s++ & 255; - culong += auint; + cuv += auint; } } else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { @@ -751,21 +774,23 @@ 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) cdouble += (NV)auint; else - culong += auint; + cuv += auint; } } 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); @@ -792,7 +817,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)ashort; else - culong += ashort; + cuv += ashort; } } @@ -809,11 +834,13 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)ashort; else - culong += ashort; + cuv += ashort; } } } else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; EXTEND(SP, len); EXTEND_MORTAL(len); #if SHORTSIZE != SIZE16 @@ -865,7 +892,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aushort; else - culong += aushort; + cuv += aushort; } } else @@ -885,11 +912,13 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aushort; else - culong += aushort; + cuv += aushort; } } } else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; EXTEND(SP, len); EXTEND_MORTAL(len); #if SHORTSIZE != SIZE16 @@ -935,10 +964,12 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aint; else - culong += aint; + cuv += aint; } } else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { @@ -986,10 +1017,12 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)auint; else - culong += auint; + cuv += auint; } } else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { @@ -1008,6 +1041,62 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * } } break; + case 'j': + along = (strend - s) / IVSIZE; + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &aiv, 1, IV); + s += IVSIZE; + if (checksum > bits_in_uv) + cdouble += (NV)aiv; + else + cuv += aiv; + } + } + else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + Copy(s, &aiv, 1, IV); + s += IVSIZE; + sv = NEWSV(40, 0); + sv_setiv(sv, aiv); + PUSHs(sv_2mortal(sv)); + } + } + break; + case 'J': + along = (strend - s) / UVSIZE; + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &auv, 1, UV); + s += UVSIZE; + if (checksum > bits_in_uv) + cdouble += (NV)auv; + else + cuv += auv; + } + } + else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + Copy(s, &auv, 1, UV); + s += UVSIZE; + sv = NEWSV(41, 0); + sv_setuv(sv, auv); + PUSHs(sv_2mortal(sv)); + } + } + break; case 'l': #if LONGSIZE == SIZE32 along = (strend - s) / SIZE32; @@ -1025,7 +1114,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)along; else - culong += along; + cuv += along; } } else @@ -1044,11 +1133,13 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)along; else - culong += along; + cuv += along; } } } else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; EXTEND(SP, len); EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 @@ -1102,7 +1193,7 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aulong; else - culong += aulong; + cuv += aulong; } } else @@ -1122,11 +1213,13 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aulong; else - culong += aulong; + cuv += aulong; } } } else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; EXTEND(SP, len); EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 @@ -1181,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); { @@ -1204,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; @@ -1250,22 +1345,24 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)aquad; else - culong += aquad; + cuv += aquad; } } else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { if (s + sizeof(Quad_t) > strend) aquad = 0; else { - Copy(s, &aquad, 1, Quad_t); - s += sizeof(Quad_t); + Copy(s, &aquad, 1, Quad_t); + s += sizeof(Quad_t); } sv = NEWSV(42, 0); if (aquad >= IV_MIN && aquad <= IV_MAX) - sv_setiv(sv, (IV)aquad); + sv_setiv(sv, (IV)aquad); else sv_setnv(sv, (NV)aquad); PUSHs(sv_2mortal(sv)); @@ -1283,10 +1380,12 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum > bits_in_uv) cdouble += (NV)auquad; else - culong += auquad; + cuv += auquad; } } else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { @@ -1308,7 +1407,6 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * #endif /* float and double added gnb@melba.bby.oz.au 22/11/89 */ case 'f': - case 'F': along = (strend - s) / sizeof(float); if (len > along) len = along; @@ -1320,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) { @@ -1332,7 +1432,6 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * } break; case 'd': - case 'D': along = (strend - s) / sizeof(double); if (len > along) len = along; @@ -1344,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) { @@ -1355,6 +1456,58 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * } } break; + case 'F': + along = (strend - s) / NVSIZE; + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &anv, 1, NV); + s += NVSIZE; + cdouble += anv; + } + } + else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + Copy(s, &anv, 1, NV); + s += NVSIZE; + sv = NEWSV(48, 0); + sv_setnv(sv, anv); + PUSHs(sv_2mortal(sv)); + } + } + break; +#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) + case 'D': + along = (strend - s) / LONG_DOUBLESIZE; + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &aldouble, 1, long double); + s += LONG_DOUBLESIZE; + cdouble += aldouble; + } + } + else { + if (len && (flags & UNPACK_ONLY_ONE)) + len = 1; + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0) { + Copy(s, &aldouble, 1, long double); + s += LONG_DOUBLESIZE; + sv = NEWSV(48, 0); + sv_setnv(sv, (NV)aldouble); + PUSHs(sv_2mortal(sv)); + } + } + break; +#endif case 'u': /* MKS: * Initialise the decode mapping. By using a table driven @@ -1400,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; @@ -1417,7 +1571,8 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * if (checksum) { sv = NEWSV(42, 0); if (strchr("fFdD", datumtype) || - (checksum > bits_in_uv && strchr("csSiIlLnNUvVqQ", datumtype)) ) { + (checksum > bits_in_uv && + strchr("csSiIlLnNUvVqQjJ", datumtype)) ) { NV trouble; adouble = (NV) (1 << (checksum & 15)); @@ -1433,9 +1588,10 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * else { if (checksum < bits_in_uv) { UV mask = ((UV)1 << checksum) - 1; - culong &= mask; + + cuv &= mask; } - sv_setuv(sv, (UV)culong); + sv_setuv(sv, cuv); } XPUSHs(sv_2mortal(sv)); checksum = 0; @@ -1610,6 +1766,12 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg unsigned int auint; I32 along; U32 aulong; + IV aiv; + UV auv; + NV anv; +#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) + long double aldouble; +#endif #ifdef HAS_QUAD Quad_t aquad; Uquad_t auquad; @@ -1669,7 +1831,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 '%': @@ -1714,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'; @@ -1746,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'; @@ -1785,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; @@ -1841,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; @@ -1891,7 +2053,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)); @@ -1900,7 +2062,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)); @@ -1913,28 +2075,74 @@ 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; /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ case 'f': - 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': - 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; + case 'F': + while (len-- > 0) { + fromstr = NEXTFROM; + anv = SvNV(fromstr); + sv_catpvn(cat, (char *)&anv, NVSIZE); + } + break; +#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) + case 'D': + while (len-- > 0) { + fromstr = NEXTFROM; + aldouble = (long double)SvNV(fromstr); + sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE); + } + break; +#endif case 'n': while (len-- > 0) { fromstr = NEXTFROM; @@ -2007,32 +2215,41 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg sv_catpvn(cat, (char*)&auint, sizeof(unsigned int)); } break; + case 'j': + while (len-- > 0) { + fromstr = NEXTFROM; + aiv = SvIV(fromstr); + sv_catpvn(cat, (char*)&aiv, IVSIZE); + } + break; + case 'J': + while (len-- > 0) { + fromstr = NEXTFROM; + auv = SvUV(fromstr); + sv_catpvn(cat, (char*)&auv, UVSIZE); + } + break; 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; + *--in = (char)((auv & 0x7f) | 0x80); auv >>= 7; } while (auv); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ @@ -2063,6 +2280,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; @@ -2200,7 +2418,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)) @@ -2222,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;