X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/db187877da40b107958f433a7167f7f85c7162d2..9d440a18ad692fca357b1109d91d51ad027aead3:/pp_pack.c diff --git a/pp_pack.c b/pp_pack.c index 8e49932..c62754f 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -1,7 +1,7 @@ /* pp_pack.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -14,6 +14,8 @@ * wooden spoon, a short two-pronged fork and some skewers were stowed; and * hidden at the bottom of the pack in a flat wooden box a dwindling treasure, * some salt. + * + * [p.653 of _The Lord of the Rings_, IV/iv: "Of Herbs and Stewed Rabbit"] */ /* This file contains pp ("push/pop") functions that @@ -26,7 +28,6 @@ * other pp*.c files for the rest of the pp_ functions. */ - #include "EXTERN.h" #define PERL_IN_PP_PACK_C #include "perl.h" @@ -69,6 +70,18 @@ typedef struct tempsym { (symptr)->previous = NULL; \ } STMT_END +typedef union { + NV nv; + U8 bytes[sizeof(NV)]; +} NV_bytes; + +#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) +typedef union { + long double ld; + U8 bytes[sizeof(long double)]; +} ld_bytes; +#endif + #if PERL_VERSION >= 9 # define PERL_PACK_CAN_BYTEORDER # define PERL_PACK_CAN_SHRIEKSIGN @@ -145,17 +158,20 @@ typedef struct tempsym { #define PUSH32(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF32(p), SIZE32) /* Only to be used inside a loop (see the break) */ -#define SHIFT_VAR(utf8, s, strend, var, datumtype) \ +#define SHIFT_BYTES(utf8, s, strend, buf, len, datumtype) \ STMT_START { \ if (utf8) { \ if (!uni_to_bytes(aTHX_ &s, strend, \ - (char *) &var, sizeof(var), datumtype)) break;\ + (char *) (buf), len, datumtype)) break; \ } else { \ - Copy(s, (char *) &var, sizeof(var), char); \ - s += sizeof(var); \ + Copy(s, (char *) (buf), len, char); \ + s += len; \ } \ } STMT_END +#define SHIFT_VAR(utf8, s, strend, var, datumtype) \ + SHIFT_BYTES(utf8, s, strend, &(var), sizeof(var), datumtype) + #define PUSH_VAR(utf8, aptr, var) \ PUSH_BYTES(utf8, aptr, &(var), sizeof(var)) @@ -178,6 +194,8 @@ S_mul128(pTHX_ SV *sv, U8 m) char *s = SvPV(sv, len); char *t; + PERL_ARGS_ASSERT_MUL128; + if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ SV * const tmpNew = newSVpvs("0000000000"); @@ -318,10 +336,17 @@ S_mul128(pTHX_ SV *sv, U8 m) # define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, i, int, char) # define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, i, int, char) # elif PTRSIZE == LONGSIZE -# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long, void) -# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long, void) -# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, long, char) -# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, long, char) +# if LONGSIZE < IVSIZE && IVSIZE == 8 +# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, 64, IV, void) +# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, 64, IV, void) +# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, 64, IV, char) +# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, 64, IV, char) +# else +# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, IV, void) +# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, IV, void) +# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, IV, char) +# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, IV, char) +# endif # elif PTRSIZE == IVSIZE # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, IV, void) # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, IV, void) @@ -381,7 +406,7 @@ STATIC const packprops_t packprops[512] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* C */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE, + /* C */ sizeof(unsigned char), #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) /* D */ LONG_DOUBLESIZE, #else @@ -532,7 +557,7 @@ STATIC const packprops_t packprops[512] = { /* w */ sizeof(char) | PACK_SIZE_UNPREDICTABLE | PACK_SIZE_CANNOT_CSUM, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* C */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE, + /* C */ sizeof(unsigned char), #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) /* D */ LONG_DOUBLESIZE, #else @@ -620,17 +645,16 @@ uni_to_byte(pTHX_ const char **s, const char *end, I32 datumtype) STRLEN retlen; UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); - /* We try to process malformed UTF-8 as much as possible (preferrably with + /* We try to process malformed UTF-8 as much as possible (preferably with warnings), but these two mean we make no progress in the string and might enter an infinite loop */ if (retlen == (STRLEN) -1 || retlen == 0) Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack", (int) TYPE_NO_MODIFIERS(datumtype)); if (val >= 0x100) { - if (ckWARN(WARN_UNPACK)) - Perl_warner(aTHX_ packWARN(WARN_UNPACK), - "Character in '%c' format wrapped in unpack", - (int) TYPE_NO_MODIFIERS(datumtype)); + Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK), + "Character in '%c' format wrapped in unpack", + (int) TYPE_NO_MODIFIERS(datumtype)); val &= 0xff; } *s += retlen; @@ -675,12 +699,12 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len } if (from > end) from = end; } - if ((bad & 2) && ckWARN(WARN_UNPACK)) - Perl_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ? + if ((bad & 2)) + Perl_ck_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ? WARN_PACK : WARN_UNPACK), - "Character(s) in '%c' format wrapped in %s", - (int) TYPE_NO_MODIFIERS(datumtype), - datumtype & TYPE_IS_PACK ? "pack" : "unpack"); + "Character(s) in '%c' format wrapped in %s", + (int) TYPE_NO_MODIFIERS(datumtype), + datumtype & TYPE_IS_PACK ? "pack" : "unpack"); } *s = from; return TRUE; @@ -706,6 +730,8 @@ STATIC char * S_bytes_to_uni(const U8 *start, STRLEN len, char *dest) { const U8 * const end = start + len; + PERL_ARGS_ASSERT_BYTES_TO_UNI; + while (start < end) { const UV uv = NATIVE_TO_ASCII(*start); if (UNI_IS_INVARIANT(uv)) @@ -785,6 +811,8 @@ S_measure_struct(pTHX_ tempsym_t* symptr) { I32 total = 0; + PERL_ARGS_ASSERT_MEASURE_STRUCT; + while (next_symbol(symptr)) { I32 len; int size; @@ -894,6 +922,8 @@ S_measure_struct(pTHX_ tempsym_t* symptr) STATIC const char * S_group_end(pTHX_ register const char *patptr, register const char *patend, char ender) { + PERL_ARGS_ASSERT_GROUP_END; + while (patptr < patend) { const char c = *patptr++; @@ -924,6 +954,9 @@ STATIC const char * S_get_num(pTHX_ register const char *patptr, I32 *lenptr ) { I32 len = *patptr++ - '0'; + + PERL_ARGS_ASSERT_GET_NUM; + while (isDIGIT(*patptr)) { if (len >= 0x7FFFFFFF/10) Perl_croak(aTHX_ "pack/unpack repeat count overflow"); @@ -942,6 +975,8 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) const char* patptr = symptr->patptr; const char* const patend = symptr->patend; + PERL_ARGS_ASSERT_NEXT_SYMBOL; + symptr->flags &= ~FLAG_SLASH; while (patptr < patend) { @@ -1025,11 +1060,11 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s", *patptr, _action( symptr ) ); - if ((code & modifier) && ckWARN(WARN_UNPACK)) { - Perl_warner(aTHX_ packWARN(WARN_UNPACK), - "Duplicate modifier '%c' after '%c' in %s", - *patptr, (int) TYPE_NO_MODIFIERS(code), - _action( symptr ) ); + if ((code & modifier)) { + Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK), + "Duplicate modifier '%c' after '%c' in %s", + *patptr, (int) TYPE_NO_MODIFIERS(code), + _action( symptr ) ); } code |= modifier; @@ -1121,6 +1156,9 @@ STATIC bool need_utf8(const char *pat, const char *patend) { bool first = TRUE; + + PERL_ARGS_ASSERT_NEED_UTF8; + while (pat < patend) { if (pat[0] == '#') { pat++; @@ -1136,6 +1174,8 @@ need_utf8(const char *pat, const char *patend) STATIC char first_symbol(const char *pat, const char *patend) { + PERL_ARGS_ASSERT_FIRST_SYMBOL; + while (pat < patend) { if (pat[0] != '#') return pat[0]; pat++; @@ -1160,6 +1200,8 @@ Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, cons { tempsym_t sym; + PERL_ARGS_ASSERT_UNPACKSTRING; + if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8; else if (need_utf8(pat, patend)) { /* We probably should try to avoid this in case a scalar context call @@ -1183,10 +1225,9 @@ STATIC I32 S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s ) { dVAR; dSP; - SV *sv; + SV *sv = NULL; const I32 start_sp_offset = SP - PL_stack_base; howlen_t howlen; - I32 checksum = 0; UV cuv = 0; NV cdouble = 0.0; @@ -1195,6 +1236,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c bool explicit_length; const bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0; bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0; + + PERL_ARGS_ASSERT_UNPACK_REC; + symptr->strbeg = s - strbeg; while (next_symbol(symptr)) { @@ -1259,6 +1303,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c symptr->previous = &savsym; symptr->level++; PUTBACK; + if (len && unpack_only_one) len = 1; while (len--) { symptr->patptr = savsym.grpbeg; if (utf8) symptr->flags |= FLAG_PARSE_UTF8; @@ -1294,7 +1339,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c sv = from <= s ? newSVuv( u8 ? (UV) utf8_length((const U8*)from, (const U8*)s) : (UV) (s-from)) : newSViv(-(u8 ? (IV) utf8_length((const U8*)s, (const U8*)from) : (IV) (from-s))); - XPUSHs(sv_2mortal(sv)); + mXPUSHs(sv); break; } #ifdef PERL_PACK_CAN_SHRIEKSIGN @@ -1444,7 +1489,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (!(symptr->flags & FLAG_WAS_UTF8)) sv_utf8_downgrade(sv, 0); } - XPUSHs(sv_2mortal(sv)); + mXPUSHs(sv); s += len; break; case 'B': @@ -1453,20 +1498,6 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (howlen == e_star || len > (strend - s) * 8) len = (strend - s) * 8; if (checksum) { - if (!PL_bitcount) { - int bits; - Newxz(PL_bitcount, 256, char); - for (bits = 1; bits < 256; bits++) { - if (bits & 1) PL_bitcount[bits]++; - if (bits & 2) PL_bitcount[bits]++; - if (bits & 4) PL_bitcount[bits]++; - if (bits & 8) PL_bitcount[bits]++; - if (bits & 16) PL_bitcount[bits]++; - if (bits & 32) PL_bitcount[bits]++; - if (bits & 64) PL_bitcount[bits]++; - if (bits & 128) PL_bitcount[bits]++; - } - } if (utf8) while (len >= 8 && s < strend) { cuv += PL_bitcount[uni_to_byte(aTHX_ &s, strend, datumtype)]; @@ -1527,13 +1558,15 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } case 'H': case 'h': { - char *str; + char *str = NULL; /* Preliminary length estimate, acceptable for utf8 too */ if (howlen == e_star || len > (strend - s) * 2) len = (strend - s) * 2; - sv = sv_2mortal(newSV(len ? len : 1)); - SvPOK_on(sv); - str = SvPVX(sv); + if (!checksum) { + sv = sv_2mortal(newSV(len ? len : 1)); + SvPOK_on(sv); + str = SvPVX(sv); + } if (datumtype == 'h') { U8 bits = 0; I32 ai32 = len; @@ -1543,7 +1576,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (s >= strend) break; bits = uni_to_byte(aTHX_ &s, strend, datumtype); } else bits = * (U8 *) s++; - *str++ = PL_hexdigit[bits & 15]; + if (!checksum) + *str++ = PL_hexdigit[bits & 15]; } } else { U8 bits = 0; @@ -1554,39 +1588,52 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (s >= strend) break; bits = uni_to_byte(aTHX_ &s, strend, datumtype); } else bits = *(U8 *) s++; - *str++ = PL_hexdigit[(bits >> 4) & 15]; + if (!checksum) + *str++ = PL_hexdigit[(bits >> 4) & 15]; } } - *str = '\0'; - SvCUR_set(sv, str - SvPVX_const(sv)); - XPUSHs(sv); + if (!checksum) { + *str = '\0'; + SvCUR_set(sv, str - SvPVX_const(sv)); + XPUSHs(sv); + } break; } + case 'C': + if (len == 0) { + if (explicit_length) + /* Switch to "character" mode */ + utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; + break; + } + /* FALL THROUGH */ case 'c': - while (len-- > 0) { - int aint = SHIFT_BYTE(utf8, s, strend, datumtype); - if (aint >= 128) /* fake up signed chars */ + while (len-- > 0 && s < strend) { + int aint; + if (utf8) + { + STRLEN retlen; + aint = utf8n_to_uvchr((U8 *) s, strend-s, &retlen, + ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); + if (retlen == (STRLEN) -1 || retlen == 0) + Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); + s += retlen; + } + else + aint = *(U8 *)(s)++; + if (aint >= 128 && datumtype != 'C') /* fake up signed chars */ aint -= 256; if (!checksum) - PUSHs(sv_2mortal(newSViv((IV)aint))); + mPUSHi(aint); else if (checksum > bits_in_uv) cdouble += (NV)aint; else cuv += aint; } break; - case 'C': case 'W': W_checksum: - if (len == 0) { - if (explicit_length && datumtype == 'C') - /* Switch to "character" mode */ - utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; - break; - } - if (datumtype == 'C' ? - (symptr->flags & FLAG_DO_UTF8) && - !(symptr->flags & FLAG_WAS_UTF8) : utf8) { + if (utf8) { while (len-- > 0 && s < strend) { STRLEN retlen; const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen, @@ -1595,7 +1642,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); s += retlen; if (!checksum) - PUSHs(sv_2mortal(newSVuv((UV) val))); + mPUSHu(val); else if (checksum > bits_in_uv) cdouble += (NV) val; else @@ -1604,7 +1651,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } else if (!checksum) while (len-- > 0) { const U8 ch = *(U8 *) s++; - PUSHs(sv_2mortal(newSVuv((UV) ch))); + mPUSHu(ch); } else if (checksum > bits_in_uv) while (len-- > 0) cdouble += (NV) *(U8 *) s++; @@ -1613,7 +1660,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c break; case 'U': if (len == 0) { - if (explicit_length) { + if (explicit_length && howlen != e_star) { /* Switch to "bytes in UTF-8" mode */ if (symptr->flags & FLAG_DO_UTF8) utf8 = 0; else @@ -1652,7 +1699,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c s += retlen; } if (!checksum) - PUSHs(sv_2mortal(newSVuv((UV) auv))); + mPUSHu(auv); else if (checksum > bits_in_uv) cdouble += (NV) auv; else @@ -1666,7 +1713,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, ashort, datumtype); DO_BO_UNPACK(ashort, s); if (!checksum) - PUSHs(sv_2mortal(newSViv((IV)ashort))); + mPUSHi(ashort); else if (checksum > bits_in_uv) cdouble += (NV)ashort; else @@ -1690,7 +1737,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c ai16 -= 65536; #endif if (!checksum) - PUSHs(sv_2mortal(newSViv((IV)ai16))); + mPUSHi(ai16); else if (checksum > bits_in_uv) cdouble += (NV)ai16; else @@ -1704,7 +1751,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, aushort, datumtype); DO_BO_UNPACK(aushort, s); if (!checksum) - PUSHs(sv_2mortal(newSVuv((UV) aushort))); + mPUSHu(aushort); else if (checksum > bits_in_uv) cdouble += (NV)aushort; else @@ -1712,7 +1759,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } break; #else - /* Fallhrough! */ + /* Fallthrough! */ #endif case 'v': case 'n': @@ -1733,7 +1780,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c au16 = vtohs(au16); #endif if (!checksum) - PUSHs(sv_2mortal(newSVuv((UV)au16))); + mPUSHu(au16); else if (checksum > bits_in_uv) cdouble += (NV) au16; else @@ -1758,7 +1805,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c ai16 = (I16) vtohs((U16) ai16); # endif /* HAS_VTOHS */ if (!checksum) - PUSHs(sv_2mortal(newSViv((IV)ai16))); + mPUSHi(ai16); else if (checksum > bits_in_uv) cdouble += (NV) ai16; else @@ -1773,7 +1820,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, aint, datumtype); DO_BO_UNPACK(aint, i); if (!checksum) - PUSHs(sv_2mortal(newSViv((IV)aint))); + mPUSHi(aint); else if (checksum > bits_in_uv) cdouble += (NV)aint; else @@ -1787,7 +1834,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, auint, datumtype); DO_BO_UNPACK(auint, i); if (!checksum) - PUSHs(sv_2mortal(newSVuv((UV)auint))); + mPUSHu(auint); else if (checksum > bits_in_uv) cdouble += (NV)auint; else @@ -1808,7 +1855,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c Perl_croak(aTHX_ "'j' not supported on this platform"); #endif if (!checksum) - PUSHs(sv_2mortal(newSViv(aiv))); + mPUSHi(aiv); else if (checksum > bits_in_uv) cdouble += (NV)aiv; else @@ -1829,7 +1876,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c Perl_croak(aTHX_ "'J' not supported on this platform"); #endif if (!checksum) - PUSHs(sv_2mortal(newSVuv(auv))); + mPUSHu(auv); else if (checksum > bits_in_uv) cdouble += (NV)auv; else @@ -1843,7 +1890,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, along, datumtype); DO_BO_UNPACK(along, l); if (!checksum) - PUSHs(sv_2mortal(newSViv((IV)along))); + mPUSHi(along); else if (checksum > bits_in_uv) cdouble += (NV)along; else @@ -1865,7 +1912,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (ai32 > 2147483647) ai32 -= 4294967296; #endif if (!checksum) - PUSHs(sv_2mortal(newSViv((IV)ai32))); + mPUSHi(ai32); else if (checksum > bits_in_uv) cdouble += (NV)ai32; else @@ -1879,7 +1926,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, aulong, datumtype); DO_BO_UNPACK(aulong, l); if (!checksum) - PUSHs(sv_2mortal(newSVuv((UV)aulong))); + mPUSHu(aulong); else if (checksum > bits_in_uv) cdouble += (NV)aulong; else @@ -1908,7 +1955,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c au32 = vtohl(au32); #endif if (!checksum) - PUSHs(sv_2mortal(newSVuv((UV)au32))); + mPUSHu(au32); else if (checksum > bits_in_uv) cdouble += (NV)au32; else @@ -1933,7 +1980,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c ai32 = (I32)vtohl((U32)ai32); # endif if (!checksum) - PUSHs(sv_2mortal(newSViv((IV)ai32))); + mPUSHi(ai32); else if (checksum > bits_in_uv) cdouble += (NV)ai32; else @@ -1947,7 +1994,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, aptr, datumtype); DO_BO_UNPACK_PC(aptr); /* newSVpv generates undef if aptr is NULL */ - PUSHs(sv_2mortal(newSVpv(aptr, 0))); + mPUSHs(newSVpv(aptr, 0)); } break; case 'w': @@ -1962,7 +2009,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c /* UTF8_IS_XXXXX not right here - using constant 0x80 */ if (ch < 0x80) { bytes = 0; - PUSHs(sv_2mortal(newSVuv(auv))); + mPUSHu(auv); len--; auv = 0; continue; @@ -1983,7 +2030,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c while (*t == '0') t++; sv_chop(sv, t); - PUSHs(sv_2mortal(sv)); + mPUSHs(sv); len--; auv = 0; } @@ -2001,7 +2048,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, aptr, datumtype); DO_BO_UNPACK_PC(aptr); /* newSVpvn generates undef if aptr is NULL */ - PUSHs(sv_2mortal(newSVpvn(aptr, len))); + PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP)); } break; #ifdef HAS_QUAD @@ -2011,8 +2058,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, aquad, datumtype); DO_BO_UNPACK(aquad, 64); if (!checksum) - PUSHs(sv_2mortal(aquad >= IV_MIN && aquad <= IV_MAX ? - newSViv((IV)aquad) : newSVnv((NV)aquad))); + mPUSHs(aquad >= IV_MIN && aquad <= IV_MAX ? + newSViv((IV)aquad) : newSVnv((NV)aquad)); else if (checksum > bits_in_uv) cdouble += (NV)aquad; else @@ -2025,8 +2072,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, auquad, datumtype); DO_BO_UNPACK(auquad, 64); if (!checksum) - PUSHs(sv_2mortal(auquad <= UV_MAX ? - newSVuv((UV)auquad):newSVnv((NV)auquad))); + mPUSHs(auquad <= UV_MAX ? + newSVuv((UV)auquad) : newSVnv((NV)auquad)); else if (checksum > bits_in_uv) cdouble += (NV)auquad; else @@ -2041,7 +2088,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, afloat, datumtype); DO_BO_UNPACK_N(afloat, float); if (!checksum) - PUSHs(sv_2mortal(newSVnv((NV)afloat))); + mPUSHn(afloat); else cdouble += afloat; } @@ -2052,53 +2099,37 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c SHIFT_VAR(utf8, s, strend, adouble, datumtype); DO_BO_UNPACK_N(adouble, double); if (!checksum) - PUSHs(sv_2mortal(newSVnv((NV)adouble))); + mPUSHn(adouble); else cdouble += adouble; } break; case 'F': while (len-- > 0) { - NV anv; - SHIFT_VAR(utf8, s, strend, anv, datumtype); - DO_BO_UNPACK_N(anv, NV); + NV_bytes anv; + SHIFT_BYTES(utf8, s, strend, anv.bytes, sizeof(anv.bytes), datumtype); + DO_BO_UNPACK_N(anv.nv, NV); if (!checksum) - PUSHs(sv_2mortal(newSVnv(anv))); + mPUSHn(anv.nv); else - cdouble += anv; + cdouble += anv.nv; } break; #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) case 'D': while (len-- > 0) { - long double aldouble; - SHIFT_VAR(utf8, s, strend, aldouble, datumtype); - DO_BO_UNPACK_N(aldouble, long double); + ld_bytes aldouble; + SHIFT_BYTES(utf8, s, strend, aldouble.bytes, sizeof(aldouble.bytes), datumtype); + DO_BO_UNPACK_N(aldouble.ld, long double); if (!checksum) - PUSHs(sv_2mortal(newSVnv((NV)aldouble))); + mPUSHn(aldouble.ld); else - cdouble += aldouble; + cdouble += aldouble.ld; } break; #endif case 'u': - /* MKS: - * Initialise the decode mapping. By using a table driven - * algorithm, the code will be character-set independent - * (and just as fast as doing character arithmetic) - */ - if (PL_uudmap[(U8)'M'] == 0) { - size_t i; - - for (i = 0; i < sizeof(PL_uuemap); ++i) - PL_uudmap[(U8)PL_uuemap[i]] = i; - /* - * Because ' ' and '`' map to the same value, - * we need to decode them both the same. - */ - PL_uudmap[(U8)' '] = 0; - } - { + if (!checksum) { const STRLEN l = (STRLEN) (strend - s) * 3 / 4; sv = sv_2mortal(newSV(l)); if (l) SvPOK_on(sv); @@ -2116,7 +2147,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c 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); + if (!checksum) + sv_catpvn(sv, hunk, (len > 3) ? 3 : len); len -= 3; } if (s < strend) { @@ -2157,7 +2189,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c 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); + if (!checksum) + sv_catpvn(sv, hunk, (len > 3) ? 3 : len); len -= 3; } if (*s == '\n') @@ -2167,7 +2200,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c s += 2; } } - XPUSHs(sv); + if (!checksum) + XPUSHs(sv); break; } @@ -2194,7 +2228,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } sv = newSVuv(cuv); } - XPUSHs(sv_2mortal(sv)); + mXPUSHs(sv); checksum = 0; } @@ -2285,6 +2319,8 @@ S_is_an_int(pTHX_ const char *s, STRLEN l) bool skip = 1; bool ignore = 0; + PERL_ARGS_ASSERT_IS_AN_INT; + while (*s) { switch (*s) { case ' ': @@ -2333,6 +2369,8 @@ S_div128(pTHX_ SV *pnum, bool *done) char *t = s; int m = 0; + PERL_ARGS_ASSERT_DIV128; + *done = 1; while (*t) { const int i = m * 10 + (*t - '0'); @@ -2362,6 +2400,8 @@ Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, register SV ** dVAR; tempsym_t sym; + PERL_ARGS_ASSERT_PACKLIST; + TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK); /* We're going to do changes through SvPVX(cat). Make sure it's valid. @@ -2415,7 +2455,7 @@ marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) { if (m != marks + sym_ptr->level+1) { Safefree(marks); Safefree(to_start); - Perl_croak(aTHX_ "Assertion: marks beyond string end"); + Perl_croak(aTHX_ "panic: marks beyond string end"); } for (group=sym_ptr; group; group = group->previous) group->strbeg = marks[group->level] - to_start; @@ -2446,6 +2486,9 @@ S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) { const STRLEN cur = SvCUR(sv); const STRLEN len = SvLEN(sv); STRLEN extend; + + PERL_ARGS_ASSERT_SV_EXP_GROW; + if (len - cur > needed) return SvPVX(sv); extend = needed > len ? needed : len; return SvGROW(sv, len+extend+1); @@ -2462,6 +2505,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0; bool warn_utf8 = ckWARN(WARN_UTF8); + PERL_ARGS_ASSERT_PACK_REC; + if (symptr->level == 0 && found && symptr->code == 'U') { marked_upgrade(aTHX_ cat, symptr); symptr->flags |= FLAG_DO_UTF8; @@ -2517,9 +2562,9 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) by copying it to a temporary. */ STRLEN len; const char *const pv = SvPV_const(*beglist, len); - SV *const temp = sv_2mortal(newSVpvn(pv, len)); - if (SvUTF8(*beglist)) - SvUTF8_on(temp); + SV *const temp + = newSVpvn_flags(pv, len, + SVs_TEMP | SvUTF8(*beglist)); *beglist = temp; } count = DO_UTF8(*beglist) ? @@ -2744,7 +2789,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) GROWING(0, cat, start, cur, len); if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen, datumtype | TYPE_IS_PACK)) - Perl_croak(aTHX_ "Perl bug: predicted utf8 length not available"); + Perl_croak(aTHX_ "panic: predicted utf8 length not available"); cur += fromlen; len -= fromlen; } else if (utf8) { @@ -2783,6 +2828,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) } memset(cur, datumtype == 'A' ? ' ' : '\0', len); cur += len; + SvTAINT(cat); break; } case 'B': @@ -2934,10 +2980,9 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) IV aiv; fromstr = NEXTFROM; aiv = SvIV(fromstr); - if ((-128 > aiv || aiv > 127) && - ckWARN(WARN_PACK)) - Perl_warner(aTHX_ packWARN(WARN_PACK), - "Character in 'c' format wrapped in pack"); + if ((-128 > aiv || aiv > 127)) + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'c' format wrapped in pack"); PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff)); } break; @@ -2946,16 +2991,14 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; break; } - GROWING(0, cat, start, cur, len); while (len-- > 0) { IV aiv; fromstr = NEXTFROM; aiv = SvIV(fromstr); - if ((0 > aiv || aiv > 0xff) && - ckWARN(WARN_PACK)) - Perl_warner(aTHX_ packWARN(WARN_PACK), - "Character in 'C' format wrapped in pack"); - *cur++ = (char)(aiv & 0xff); + if ((0 > aiv || aiv > 0xff)) + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'C' format wrapped in pack"); + PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff)); } break; case 'W': { @@ -2996,9 +3039,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) end = start+SvLEN(cat)-UTF8_MAXLEN; goto W_utf8; } - if (ckWARN(WARN_PACK)) - Perl_warner(aTHX_ packWARN(WARN_PACK), - "Character in 'W' format wrapped in pack"); + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'W' format wrapped in pack"); auv &= 0xff; } if (cur >= end) { @@ -3072,11 +3114,14 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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. */ +{ +extern const float _float_constants[]; if (anv > FLT_MAX) afloat = _float_constants[0]; /* single prec. inf. */ else if (anv < -FLT_MAX) afloat = _float_constants[0]; /* single prec. inf. */ else afloat = (float) anv; +} #else /* __VOS__ */ # if defined(VMS) && !defined(__IEEE_FP) /* IEEE fp overflow shenanigans are unavailable on VAX and optional @@ -3108,11 +3153,14 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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. */ +{ +extern const double _double_constants[]; if (anv > DBL_MAX) adouble = _double_constants[0]; /* double prec. inf. */ else if (anv < -DBL_MAX) adouble = _double_constants[0]; /* double prec. inf. */ else adouble = (double) anv; +} #else /* __VOS__ */ # if defined(VMS) && !defined(__IEEE_FP) /* IEEE fp overflow shenanigans are unavailable on VAX and optional @@ -3132,26 +3180,36 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) } break; case 'F': { - NV anv; + NV_bytes anv; Zero(&anv, 1, NV); /* can be long double with unused bits */ while (len-- > 0) { fromstr = NEXTFROM; - anv = SvNV(fromstr); +#ifdef __GNUC__ + /* to work round a gcc/x86 bug; don't use SvNV */ + anv.nv = sv_2nv(fromstr); +#else + anv.nv = SvNV(fromstr); +#endif DO_BO_PACK_N(anv, NV); - PUSH_VAR(utf8, cur, anv); + PUSH_BYTES(utf8, cur, anv.bytes, sizeof(anv.bytes)); } break; } #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) case 'D': { - long double aldouble; + ld_bytes aldouble; /* long doubles can have unused bits, which may be nonzero */ Zero(&aldouble, 1, long double); while (len-- > 0) { fromstr = NEXTFROM; - aldouble = (long double)SvNV(fromstr); +# ifdef __GNUC__ + /* to work round a gcc/x86 bug; don't use SvNV */ + aldouble.ld = (long double)sv_2nv(fromstr); +# else + aldouble.ld = (long double)SvNV(fromstr); +# endif DO_BO_PACK_N(aldouble, long double); - PUSH_VAR(utf8, cur, aldouble); + PUSH_BYTES(utf8, cur, aldouble.bytes, sizeof(aldouble.bytes)); } break; } @@ -3305,7 +3363,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) goto w_string; else if (SvNOKp(fromstr)) { /* 10**NV_MAX_10_EXP is the largest power of 10 - so 10**(NV_MAX_10_EXP+1) is definately unrepresentable + so 10**(NV_MAX_10_EXP+1) is definitely unrepresentable given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x: x = (NV_MAX_10_EXP+1) * log (10) / log (128) And with that many bytes only Inf can overflow. @@ -3479,9 +3537,9 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) * gone. */ if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) && - !SvREADONLY(fromstr))) && ckWARN(WARN_PACK)) { - Perl_warner(aTHX_ packWARN(WARN_PACK), - "Attempt to pack pointer to temporary value"); + !SvREADONLY(fromstr)))) { + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Attempt to pack pointer to temporary value"); } if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV_nomg_const_nolen(fromstr); @@ -3500,9 +3558,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (len <= 2) len = 45; else len = len / 3 * 3; if (len >= 64) { - if (ckWARN(WARN_PACK)) - Perl_warner(aTHX_ packWARN(WARN_PACK), - "Field too wide in 'u' format in pack"); + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Field too wide in 'u' format in pack"); len = 63; } aptr = SvPV_const(fromstr, fromlen); @@ -3527,7 +3584,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 'u' | TYPE_IS_PACK)) { *cur = '\0'; SvCUR_set(cat, cur - start); - Perl_croak(aTHX_ "Assertion: string is shorter than advertised"); + Perl_croak(aTHX_ "panic: string is shorter than advertised"); } end = doencodes(hunk, buffer, todo); } else { @@ -3560,7 +3617,7 @@ PP(pp_pack) register const char *patend = pat + fromlen; MARK++; - sv_setpvn(cat, "", 0); + sv_setpvs(cat, ""); SvUTF8_off(cat); packlist(cat, pat, patend, MARK, SP + 1);