X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_pack.c;h=486c4f7136e2312431343f4f606f89a779bbf894;hb=b4bc5691c8dfad19b52d103e3b12af9342fcea38;hp=173654e0a6ccf76e2b5e6d2066aaa7f018f21e1d;hpb=518eff30dc1178427891fea71423c788549e34aa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_pack.c b/pp_pack.c index 173654e..486c4f7 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,10 +146,13 @@ 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 + /* Returns the sizeof() struct described by pat */ -I32 +STATIC I32 S_measure_struct(pTHX_ char *pat, register char *patend) { I32 datumtype; @@ -170,12 +173,16 @@ S_measure_struct(pTHX_ char *pat, register char *patend) natint = 0; #endif if (*pat == '!') { - static const char *natstr = "sSiIlL"; + static const char *natstr = "sSiIlLxX"; if (strchr(natstr, datumtype)) { + if (datumtype == 'x' || datumtype == 'X') { + datumtype |= TYPE_IS_SHRIEKING; + } else { /* XXXX Should be redone similarly! */ #ifdef PERL_NATINT_PACK - natint = 1; + natint = 1; #endif + } pat++; } else @@ -195,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 '%': @@ -219,14 +226,33 @@ S_measure_struct(pTHX_ char *pat, register char *patend) len = 1; else if (star > 0) /* Star */ Perl_croak(aTHX_ "%s not allowed in length fields", "count *"); + /* XXXX Theoretically, we need to measure many times at different + positions, since the subexpression may contain + alignment commands, but be not of aligned length. + Need to detect this and croak(). */ size = measure_struct(beg, end); break; } + case 'X' | TYPE_IS_SHRIEKING: + /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */ + if (!len) /* Avoid division by 0 */ + len = 1; + len = total % len; /* Assumed: the start is aligned. */ + /* FALL THROUGH */ case 'X': size = -1; if (total < len) Perl_croak(aTHX_ "X outside of string"); break; + case 'x' | TYPE_IS_SHRIEKING: + if (!len) /* Avoid division by 0 */ + len = 1; + star = total % len; /* Assumed: the start is aligned. */ + if (star) /* Other portable ways? */ + len = len - star; + else + len = 0; + /* FALL THROUGH */ case 'x': case 'A': case 'Z': @@ -268,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; @@ -300,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; } @@ -317,7 +355,7 @@ S_measure_struct(pTHX_ char *pat, register char *patend) STATIC I32 S_find_count(pTHX_ char **ppat, register char *patend, int *star) { - register char *pat = *ppat; + char *pat = *ppat; I32 len; *star = 0; @@ -328,27 +366,22 @@ S_find_count(pTHX_ char **ppat, register char *patend, int *star) *star = 1; len = -1; } - else if (isDIGIT(*pat) || *pat == '[') { - bool brackets = *pat == '['; - - if (brackets) { - ++pat, len = 0; - if (!isDIGIT(*pat)) { - char *end = group_end(pat, patend, ']'); - - *ppat = end + 1; - return measure_struct(pat, end); - } - } - else - len = *pat++ - '0'; + else if (isDIGIT(*pat)) { + len = *pat++ - '0'; while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); - if (len < 0) - Perl_croak(aTHX_ "Repeat count in unpack overflows"); + if (len < 0) /* 50% chance of catching... */ + Perl_croak(aTHX_ "Repeat count in pack/unpack overflows"); } - if (brackets && *pat++ != ']') - Perl_croak(aTHX_ "No repeat count ender ] found after digits"); + } + else if (*pat == '[') { + char *end = group_end(++pat, patend, ']'); + + len = 0; + *ppat = end + 1; + if (isDIGIT(*pat)) + return find_count(&pat, end, star); + return measure_struct(pat, end); } else len = *star = -1; @@ -410,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; @@ -434,12 +473,16 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * && (datumtype != '/') ) break; if (*pat == '!') { - static const char natstr[] = "sSiIlL"; + static const char natstr[] = "sSiIlLxX"; if (strchr(natstr, datumtype)) { + if (datumtype == 'x' || datumtype == 'X') { + datumtype |= TYPE_IS_SHRIEKING; + } else { /* XXXX Should be redone similarly! */ #ifdef PERL_NATINT_PACK - natint = 1; + natint = 1; #endif + } pat++; } else @@ -457,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; @@ -500,11 +543,25 @@ Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char * Perl_croak(aTHX_ "@ outside of string"); s = strbeg + len; break; + case 'X' | TYPE_IS_SHRIEKING: + if (!len) /* Avoid division by 0 */ + len = 1; + len = (s - strbeg) % len; + /* FALL THROUGH */ case 'X': if (len > s - strbeg) Perl_croak(aTHX_ "X outside of string"); s -= len; break; + case 'x' | TYPE_IS_SHRIEKING: + if (!len) /* Avoid division by 0 */ + len = 1; + aint = (s - strbeg) % len; + if (aint) /* Other portable ways? */ + len = len - aint; + else + len = 0; + /* FALL THROUGH */ case 'x': if (len > strend - s) Perl_croak(aTHX_ "x outside of string"); @@ -570,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; } } @@ -659,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) { @@ -687,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) { @@ -713,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); @@ -754,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; } } @@ -771,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 @@ -827,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 @@ -847,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 @@ -897,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) { @@ -948,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) { @@ -970,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; @@ -987,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 @@ -1006,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 @@ -1064,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 @@ -1084,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 @@ -1143,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); { @@ -1166,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; @@ -1212,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)); @@ -1245,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) { @@ -1270,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; @@ -1282,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) { @@ -1294,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; @@ -1306,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) { @@ -1317,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 @@ -1362,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; @@ -1379,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)); @@ -1395,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; @@ -1572,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; @@ -1598,12 +1798,16 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg natint = 0; #endif if (*pat == '!') { - static const char natstr[] = "sSiIlL"; + static const char natstr[] = "sSiIlLxX"; if (strchr(natstr, datumtype)) { + if (datumtype == 'x' || datumtype == 'X') { + datumtype |= TYPE_IS_SHRIEKING; + } else { /* XXXX Should be redone similarly! */ #ifdef PERL_NATINT_PACK - natint = 1; + natint = 1; #endif + } pat++; } else @@ -1627,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 '%': @@ -1665,13 +1869,27 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg beglist = savebeglist; break; } + case 'X' | TYPE_IS_SHRIEKING: + if (!len) /* Avoid division by 0 */ + len = 1; + len = (SvCUR(cat)) % len; + /* 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'; break; + case 'x' | TYPE_IS_SHRIEKING: + if (!len) /* Avoid division by 0 */ + len = 1; + aint = (SvCUR(cat)) % len; + if (aint) /* Other portable ways? */ + len = len - aint; + else + len = 0; + /* FALL THROUGH */ case 'x': grow: while (len >= 10) { @@ -1690,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'; @@ -1729,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; @@ -1785,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; @@ -1835,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)); @@ -1844,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)); @@ -1857,28 +2075,96 @@ 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 +# if defined(VMS) && !defined(__IEEE_FP) +/* IEEE fp overflow shenanigans are unavailable on VAX and optional + * on Alpha; fake it if we don't have them. + */ + if (SvNV(fromstr) > FLT_MAX) + afloat = FLT_MAX; + else if (SvNV(fromstr) < -FLT_MAX) + afloat = -FLT_MAX; + else afloat = (float)SvNV(fromstr); +# else afloat = (float)SvNV(fromstr); +# endif +#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 +# if defined(VMS) && !defined(__IEEE_FP) +/* IEEE fp overflow shenanigans are unavailable on VAX and optional + * on Alpha; fake it if we don't have them. + */ + if (SvNV(fromstr) > DBL_MAX) + adouble = DBL_MAX; + else if (SvNV(fromstr) < -DBL_MAX) + adouble = -DBL_MAX; + else adouble = (double)SvNV(fromstr); +# else adouble = (double)SvNV(fromstr); +# endif +#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; @@ -1951,32 +2237,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)); + anv = SvNV(fromstr); - if (adouble < 0) + if (anv < 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) || anv < 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 */ @@ -2004,16 +2299,17 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg SvREFCNT_dec(norm); /* free norm */ } else if (SvNOKp(fromstr)) { - char buf[sizeof(double) * 2]; /* 8/7 <= 2 */ + char buf[sizeof(NV) * 2]; /* 8/7 <= 2 */ char *in = buf + sizeof(buf); + anv = Perl_floor(anv); do { - double next = floor(adouble / 128); - *--in = (unsigned char)(adouble - (next * 128)) | 0x80; + NV next = Perl_floor(anv / 128); + *--in = (unsigned char)(anv - (next * 128)) | 0x80; if (in <= buf) /* this cannot happen ;-) */ Perl_croak(aTHX_ "Cannot compress integer"); - adouble = next; - } while (adouble > 0); + anv = next; + } while (anv > 0); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ sv_catpvn(cat, in, (buf + sizeof(buf)) - in); } @@ -2144,7 +2440,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)) @@ -2166,7 +2462,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;