X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/76f68e9bb86f29e34e2aeb5c177571288f05b7ca..97651d61d67d90d9b6e1cbef032da8bee3f503cc:/pp_pack.c diff --git a/pp_pack.c b/pp_pack.c index dbbb34e..40db6ef 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -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 @@ -68,9 +70,16 @@ typedef struct tempsym { (symptr)->previous = NULL; \ } STMT_END -#if PERL_VERSION >= 9 -# define PERL_PACK_CAN_BYTEORDER -# define PERL_PACK_CAN_SHRIEKSIGN +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 #ifndef CHAR_BIT @@ -120,43 +129,50 @@ typedef struct tempsym { # define OFF32(p) ((char *) (p)) #endif -/* Only to be used inside a loop (see the break) */ -#define SHIFT16(utf8, s, strend, p, datumtype) STMT_START { \ - if (utf8) { \ - if (!uni_to_bytes(aTHX_ &(s), strend, OFF16(p), SIZE16, datumtype)) break; \ - } else { \ - Copy(s, OFF16(p), SIZE16, char); \ - (s) += SIZE16; \ - } \ -} STMT_END +#define PUSH16(utf8, cur, p, needs_swap) \ + PUSH_BYTES(utf8, cur, OFF16(p), SIZE16, needs_swap) +#define PUSH32(utf8, cur, p, needs_swap) \ + PUSH_BYTES(utf8, cur, OFF32(p), SIZE32, needs_swap) -/* Only to be used inside a loop (see the break) */ -#define SHIFT32(utf8, s, strend, p, datumtype) STMT_START { \ - if (utf8) { \ - if (!uni_to_bytes(aTHX_ &(s), strend, OFF32(p), SIZE32, datumtype)) break; \ - } else { \ - Copy(s, OFF32(p), SIZE32, char); \ - (s) += SIZE32; \ - } \ -} STMT_END - -#define PUSH16(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF16(p), SIZE16) -#define PUSH32(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF32(p), SIZE32) +#if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */ +# define NEEDS_SWAP(d) (TYPE_ENDIANNESS(d) == TYPE_IS_LITTLE_ENDIAN) +#elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */ +# define NEEDS_SWAP(d) (TYPE_ENDIANNESS(d) == TYPE_IS_BIG_ENDIAN) +#else +# error "Unsupported byteorder" + /* Need to add code here to re-instate mixed endian support. + NEEDS_SWAP would need to hold a flag indicating which action to + take, and S_reverse_copy and the code in uni_to_bytes would need + logic adding to deal with any mixed-endian transformations needed. + */ +#endif /* 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, needs_swap) \ STMT_START { \ - if (utf8) { \ + if (UNLIKELY(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); \ + if (UNLIKELY(needs_swap)) \ + S_reverse_copy(s, (char *) (buf), len); \ + else \ + Copy(s, (char *) (buf), len, char); \ + s += len; \ } \ } STMT_END -#define PUSH_VAR(utf8, aptr, var) \ - PUSH_BYTES(utf8, aptr, &(var), sizeof(var)) +#define SHIFT16(utf8, s, strend, p, datumtype, needs_swap) \ + SHIFT_BYTES(utf8, s, strend, OFF16(p), SIZE16, datumtype, needs_swap) + +#define SHIFT32(utf8, s, strend, p, datumtype, needs_swap) \ + SHIFT_BYTES(utf8, s, strend, OFF32(p), SIZE32, datumtype, needs_swap) + +#define SHIFT_VAR(utf8, s, strend, var, datumtype, needs_swap) \ + SHIFT_BYTES(utf8, s, strend, &(var), sizeof(var), datumtype, needs_swap) + +#define PUSH_VAR(utf8, aptr, var, needs_swap) \ + PUSH_BYTES(utf8, aptr, &(var), sizeof(var), needs_swap) /* Avoid stack overflow due to pathological templates. 100 should be plenty. */ #define MAX_SUB_TEMPLATE_LEVEL 100 @@ -220,400 +236,24 @@ S_mul128(pTHX_ SV *sv, U8 m) #define TYPE_MODIFIERS(t) ((t) & ~0xFF) #define TYPE_NO_MODIFIERS(t) ((t) & 0xFF) -#ifdef PERL_PACK_CAN_SHRIEKSIGN -# define SHRIEKING_ALLOWED_TYPES "sSiIlLxXnNvV@." -#else -# define SHRIEKING_ALLOWED_TYPES "sSiIlLxX" -#endif - -#ifndef PERL_PACK_CAN_BYTEORDER -/* Put "can't" first because it is shorter */ -# define TYPE_ENDIANNESS(t) 0 -# define TYPE_NO_ENDIANNESS(t) (t) - -# define ENDIANNESS_ALLOWED_TYPES "" - -# define DO_BO_UNPACK(var, type) -# define DO_BO_PACK(var, type) -# define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast) -# define DO_BO_PACK_PTR(var, type, pre_cast, post_cast) -# define DO_BO_UNPACK_N(var, type) -# define DO_BO_PACK_N(var, type) -# define DO_BO_UNPACK_P(var) -# define DO_BO_PACK_P(var) -# define DO_BO_UNPACK_PC(var) -# define DO_BO_PACK_PC(var) - -#else /* PERL_PACK_CAN_BYTEORDER */ - # define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK) # define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK) # define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP(" -# define DO_BO_UNPACK(var, type) \ - STMT_START { \ - switch (TYPE_ENDIANNESS(datumtype)) { \ - case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \ - case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \ - default: break; \ - } \ - } STMT_END - -# define DO_BO_PACK(var, type) \ - STMT_START { \ - switch (TYPE_ENDIANNESS(datumtype)) { \ - case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \ - case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \ - default: break; \ - } \ - } STMT_END - -# define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast) \ - STMT_START { \ - switch (TYPE_ENDIANNESS(datumtype)) { \ - case TYPE_IS_BIG_ENDIAN: \ - var = (post_cast*) my_betoh ## type ((pre_cast) var); \ - break; \ - case TYPE_IS_LITTLE_ENDIAN: \ - var = (post_cast *) my_letoh ## type ((pre_cast) var); \ - break; \ - default: \ - break; \ - } \ - } STMT_END - -# define DO_BO_PACK_PTR(var, type, pre_cast, post_cast) \ - STMT_START { \ - switch (TYPE_ENDIANNESS(datumtype)) { \ - case TYPE_IS_BIG_ENDIAN: \ - var = (post_cast *) my_htobe ## type ((pre_cast) var); \ - break; \ - case TYPE_IS_LITTLE_ENDIAN: \ - var = (post_cast *) my_htole ## type ((pre_cast) var); \ - break; \ - default: \ - break; \ - } \ - } STMT_END - -# define BO_CANT_DOIT(action, type) \ - STMT_START { \ - switch (TYPE_ENDIANNESS(datumtype)) { \ - case TYPE_IS_BIG_ENDIAN: \ - Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \ - "platform", #action, #type); \ - break; \ - case TYPE_IS_LITTLE_ENDIAN: \ - Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \ - "platform", #action, #type); \ - break; \ - default: \ - break; \ - } \ - } STMT_END - -# if PTRSIZE == INTSIZE -# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, i, int, void) -# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, i, int, void) -# 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) -# 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) -# 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) -# else -# define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer) -# define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer) -# define DO_BO_UNPACK_PC(var) BO_CANT_DOIT(unpack, pointer) -# define DO_BO_PACK_PC(var) BO_CANT_DOIT(pack, pointer) -# endif - -# if defined(my_htolen) && defined(my_letohn) && \ - defined(my_htoben) && defined(my_betohn) -# define DO_BO_UNPACK_N(var, type) \ - STMT_START { \ - switch (TYPE_ENDIANNESS(datumtype)) { \ - case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\ - case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\ - default: break; \ - } \ - } STMT_END - -# define DO_BO_PACK_N(var, type) \ - STMT_START { \ - switch (TYPE_ENDIANNESS(datumtype)) { \ - case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\ - case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\ - default: break; \ - } \ - } STMT_END -# else -# define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type) -# define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type) -# endif - -#endif /* PERL_PACK_CAN_BYTEORDER */ - #define PACK_SIZE_CANNOT_CSUM 0x80 #define PACK_SIZE_UNPREDICTABLE 0x40 /* Not a fixed size element */ #define PACK_SIZE_MASK 0x3F -/* These tables are regenerated by genpacksizetables.pl (and then hand pasted - in). You're unlikely ever to need to regenerate them. */ +#include "packsizetables.c" -#if TYPE_IS_SHRIEKING != 0x100 - ++++shriek offset should be 256 -#endif - -typedef U8 packprops_t; -#if 'J'-'I' == 1 -/* ASCII */ -STATIC const packprops_t packprops[512] = { - /* normal */ - 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, 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), -#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) - /* D */ LONG_DOUBLESIZE, -#else - 0, -#endif - 0, - /* F */ NVSIZE, - 0, 0, - /* I */ sizeof(unsigned int), - /* J */ UVSIZE, - 0, - /* L */ SIZE32, - 0, - /* N */ SIZE32, - 0, 0, -#if defined(HAS_QUAD) - /* Q */ sizeof(Uquad_t), -#else - 0, -#endif - 0, - /* S */ SIZE16, - 0, - /* U */ sizeof(char) | PACK_SIZE_UNPREDICTABLE, - /* V */ SIZE32, - /* W */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* c */ sizeof(char), - /* d */ sizeof(double), - 0, - /* f */ sizeof(float), - 0, 0, - /* i */ sizeof(int), - /* j */ IVSIZE, - 0, - /* l */ SIZE32, - 0, - /* n */ SIZE16, - 0, - /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM, -#if defined(HAS_QUAD) - /* q */ sizeof(Quad_t), -#else - 0, -#endif - 0, - /* s */ SIZE16, - 0, 0, - /* v */ SIZE16, - /* 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, 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, 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, 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, 0, 0, 0, - /* shrieking */ - 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, 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, 0, 0, 0, - /* I */ sizeof(unsigned int), - 0, 0, - /* L */ sizeof(unsigned long), - 0, -#if defined(PERL_PACK_CAN_SHRIEKSIGN) - /* N */ SIZE32, -#else - 0, -#endif - 0, 0, 0, 0, - /* S */ sizeof(unsigned short), - 0, 0, -#if defined(PERL_PACK_CAN_SHRIEKSIGN) - /* V */ SIZE32, -#else - 0, -#endif - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, - /* i */ sizeof(int), - 0, 0, - /* l */ sizeof(long), - 0, -#if defined(PERL_PACK_CAN_SHRIEKSIGN) - /* n */ SIZE16, -#else - 0, -#endif - 0, 0, 0, 0, - /* s */ sizeof(short), - 0, 0, -#if defined(PERL_PACK_CAN_SHRIEKSIGN) - /* v */ SIZE16, -#else - 0, -#endif - 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, 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, 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, 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 -}; -#else -/* EBCDIC (or bust) */ -STATIC const packprops_t packprops[512] = { - /* normal */ - 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, 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, 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, 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(char), - /* d */ sizeof(double), - 0, - /* f */ sizeof(float), - 0, 0, - /* i */ sizeof(int), - 0, 0, 0, 0, 0, 0, 0, - /* j */ IVSIZE, - 0, - /* l */ SIZE32, - 0, - /* n */ SIZE16, - 0, - /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM, -#if defined(HAS_QUAD) - /* q */ sizeof(Quad_t), -#else - 0, -#endif - 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* s */ SIZE16, - 0, 0, - /* v */ SIZE16, - /* 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), -#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) - /* D */ LONG_DOUBLESIZE, -#else - 0, -#endif - 0, - /* F */ NVSIZE, - 0, 0, - /* I */ sizeof(unsigned int), - 0, 0, 0, 0, 0, 0, 0, - /* J */ UVSIZE, - 0, - /* L */ SIZE32, - 0, - /* N */ SIZE32, - 0, 0, -#if defined(HAS_QUAD) - /* Q */ sizeof(Uquad_t), -#else - 0, -#endif - 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* S */ SIZE16, - 0, - /* U */ sizeof(char) | PACK_SIZE_UNPREDICTABLE, - /* V */ SIZE32, - /* W */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE, - 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, - /* shrieking */ - 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, 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, 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, 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, - /* i */ sizeof(int), - 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* l */ sizeof(long), - 0, -#if defined(PERL_PACK_CAN_SHRIEKSIGN) - /* n */ SIZE16, -#else - 0, -#endif - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* s */ sizeof(short), - 0, 0, -#if defined(PERL_PACK_CAN_SHRIEKSIGN) - /* v */ SIZE16, -#else - 0, -#endif - 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, - /* I */ sizeof(unsigned int), - 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* L */ sizeof(unsigned long), - 0, -#if defined(PERL_PACK_CAN_SHRIEKSIGN) - /* N */ SIZE32, -#else - 0, -#endif - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - /* S */ sizeof(unsigned short), - 0, 0, -#if defined(PERL_PACK_CAN_SHRIEKSIGN) - /* V */ SIZE32, -#else - 0, -#endif - 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 -}; -#endif +static void +S_reverse_copy(const char *src, char *dest, STRLEN len) +{ + dest += len; + while (len--) + *--dest = *src++; +} STATIC U8 uni_to_byte(pTHX_ const char **s, const char *end, I32 datumtype) @@ -621,17 +261,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; @@ -651,6 +290,11 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len int bad = 0; const U32 flags = ckWARN(WARN_UTF8) ? UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY | UTF8_ALLOW_ANY); + const bool needs_swap = NEEDS_SWAP(datumtype); + + if (UNLIKELY(needs_swap)) + buf += buf_len; + for (;buf_len > 0; buf_len--) { if (from >= end) return FALSE; val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags); @@ -662,7 +306,10 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len bad |= 2; val &= 0xff; } - *(U8 *)buf++ = (U8)val; + if (UNLIKELY(needs_swap)) + *(U8 *)--buf = (U8)val; + else + *(U8 *)buf++ = (U8)val; } /* We have enough characters for the buffer. Did we have problems ? */ if (bad) { @@ -672,16 +319,16 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len const int flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) { if (ptr >= end) break; - utf8n_to_uvuni((U8 *) ptr, end-ptr, &retlen, flags); + utf8n_to_uvchr((U8 *) ptr, end-ptr, &retlen, flags); } 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; @@ -690,7 +337,6 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len STATIC bool next_uni_uu(pTHX_ const char **s, const char *end, I32 *out) { - dVAR; STRLEN retlen; const UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY); if (val >= 0x100 || !ISUUCHAR(val) || @@ -704,30 +350,33 @@ next_uni_uu(pTHX_ const char **s, const char *end, I32 *out) } STATIC char * -S_bytes_to_uni(const U8 *start, STRLEN len, char *dest) { - const U8 * const end = start + len; - +S_bytes_to_uni(const U8 *start, STRLEN len, char *dest, const bool needs_swap) { PERL_ARGS_ASSERT_BYTES_TO_UNI; - while (start < end) { - const UV uv = NATIVE_TO_ASCII(*start); - if (UNI_IS_INVARIANT(uv)) - *dest++ = (char)(U8)UTF_TO_NATIVE(uv); - else { - *dest++ = (char)(U8)UTF8_EIGHT_BIT_HI(uv); - *dest++ = (char)(U8)UTF8_EIGHT_BIT_LO(uv); - } - start++; + if (UNLIKELY(needs_swap)) { + const U8 *p = start + len; + while (p-- > start) { + append_utf8_from_native_byte(*p, (U8 **) & dest); + } + } else { + const U8 * const end = start + len; + while (start < end) { + append_utf8_from_native_byte(*start, (U8 **) & dest); + start++; + } } return dest; } -#define PUSH_BYTES(utf8, cur, buf, len) \ +#define PUSH_BYTES(utf8, cur, buf, len, needs_swap) \ STMT_START { \ - if (utf8) \ - (cur) = bytes_to_uni((U8 *) buf, len, (cur)); \ + if (UNLIKELY(utf8)) \ + (cur) = S_bytes_to_uni((U8 *) buf, len, (cur), needs_swap); \ else { \ - Copy(buf, cur, len, char); \ + if (UNLIKELY(needs_swap)) \ + S_reverse_copy((char *)(buf), cur, len); \ + else \ + Copy(buf, cur, len, char); \ (cur) += (len); \ } \ } STMT_END @@ -753,14 +402,14 @@ STMT_START { \ (start) = sv_exp_grow(cat, gl); \ (cur) = (start) + SvCUR(cat); \ } \ - PUSH_BYTES(utf8, cur, buf, glen); \ + PUSH_BYTES(utf8, cur, buf, glen, 0); \ } STMT_END #define PUSH_BYTE(utf8, s, byte) \ STMT_START { \ if (utf8) { \ const U8 au8 = (byte); \ - (s) = bytes_to_uni(&au8, 1, (s)); \ + (s) = S_bytes_to_uni(&au8, 1, (s), 0); \ } else *(U8 *)(s)++ = (byte); \ } STMT_END @@ -798,7 +447,7 @@ S_measure_struct(pTHX_ tempsym_t* symptr) case e_star: Perl_croak(aTHX_ "Within []-length '*' not allowed in %s", _action( symptr ) ); - break; + default: /* e_no_len and e_number */ len = symptr->length; @@ -814,10 +463,8 @@ S_measure_struct(pTHX_ tempsym_t* symptr) Perl_croak(aTHX_ "Invalid type '%c' in %s", (int)TYPE_NO_MODIFIERS(symptr->code), _action( symptr ) ); -#ifdef PERL_PACK_CAN_SHRIEKSIGN case '.' | TYPE_IS_SHRIEKING: case '@' | TYPE_IS_SHRIEKING: -#endif case '@': case '.': case '/': @@ -849,7 +496,7 @@ S_measure_struct(pTHX_ tempsym_t* symptr) if (!len) /* Avoid division by 0 */ len = 1; len = total % len; /* Assumed: the start is aligned. */ - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'X': size = -1; if (total < len) @@ -863,7 +510,7 @@ S_measure_struct(pTHX_ tempsym_t* symptr) len = len - star; else len = 0; - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'x': case 'A': case 'Z': @@ -897,7 +544,7 @@ S_measure_struct(pTHX_ tempsym_t* symptr) * returns char pointer to char after match, or NULL */ STATIC const char * -S_group_end(pTHX_ register const char *patptr, register const char *patend, char ender) +S_group_end(pTHX_ const char *patptr, const char *patend, char ender) { PERL_ARGS_ASSERT_GROUP_END; @@ -919,7 +566,7 @@ S_group_end(pTHX_ register const char *patptr, register const char *patend, char } Perl_croak(aTHX_ "No group ending character '%c' found in template", ender); - return 0; + NOT_REACHED; /* NOTREACHED */ } @@ -928,7 +575,7 @@ S_group_end(pTHX_ register const char *patptr, register const char *patend, char * Advances char pointer to 1st non-digit char and returns number */ STATIC const char * -S_get_num(pTHX_ register const char *patptr, I32 *lenptr ) +S_get_num(pTHX_ const char *patptr, I32 *lenptr ) { I32 len = *patptr++ - '0'; @@ -1004,9 +651,8 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) switch (*patptr) { case '!': modifier = TYPE_IS_SHRIEKING; - allowed = SHRIEKING_ALLOWED_TYPES; + allowed = "sSiIlLxXnNvV@."; break; -#ifdef PERL_PACK_CAN_BYTEORDER case '>': modifier = TYPE_IS_BIG_ENDIAN; allowed = ENDIANNESS_ALLOWED_TYPES; @@ -1015,7 +661,6 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) modifier = TYPE_IS_LITTLE_ENDIAN; allowed = ENDIANNESS_ALLOWED_TYPES; break; -#endif /* PERL_PACK_CAN_BYTEORDER */ default: allowed = ""; modifier = 0; @@ -1037,11 +682,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; @@ -1164,11 +809,26 @@ first_symbol(const char *pat, const char *patend) { } /* + +=head1 Pack and Unpack + =for apidoc unpackstring -The engine implementing unpack() Perl function. C puts the -extracted list items on the stack and returns the number of elements. -Issue C before and C after the call to this function. +The engine implementing the unpack() Perl function. + +Using the template pat..patend, this function unpacks the string +s..strend into a number of mortal SVs, which it pushes onto the perl +argument (@_) stack (so you will need to issue a C before and +C after the call to this function). It returns the number of +pushed elements. + +The strend and patend pointers should point to the byte following the last +character of each string. + +Although this function returns its values on the perl argument stack, it +doesn't take any parameters from that stack (and thus in particular +there's no need to do a PUSHMARK before calling it, unlike L for +example). =cut */ @@ -1201,8 +861,8 @@ Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, cons 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; + dSP; + SV *sv = NULL; const I32 start_sp_offset = SP - PL_stack_base; howlen_t howlen; I32 checksum = 0; @@ -1222,6 +882,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c packprops_t props; I32 len; I32 datumtype = symptr->code; + bool needs_swap; /* do first one only unless in list context / is implemented by unpacking the count, then popping it from the stack, so must check that we're not in the middle of a / */ @@ -1259,6 +920,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } } + needs_swap = NEEDS_SWAP(datumtype); + switch(TYPE_NO_ENDIANNESS(datumtype)) { default: Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) ); @@ -1270,7 +933,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c cuv = 0; cdouble = 0; continue; - break; + case '(': { tempsym_t savsym = *symptr; @@ -1294,17 +957,11 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c *symptr = savsym; break; } -#ifdef PERL_PACK_CAN_SHRIEKSIGN case '.' | TYPE_IS_SHRIEKING: -#endif case '.': { const char *from; SV *sv; -#ifdef PERL_PACK_CAN_SHRIEKSIGN const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING); -#else /* PERL_PACK_CAN_SHRIEKSIGN */ - const bool u8 = utf8; -#endif if (howlen == e_star) from = strbeg; else if (len <= 0) from = s; else { @@ -1319,16 +976,10 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c mXPUSHs(sv); break; } -#ifdef PERL_PACK_CAN_SHRIEKSIGN case '@' | TYPE_IS_SHRIEKING: -#endif case '@': s = strbeg + symptr->strbeg; -#ifdef PERL_PACK_CAN_SHRIEKSIGN if (utf8 && !(datumtype & TYPE_IS_SHRIEKING)) -#else /* PERL_PACK_CAN_SHRIEKSIGN */ - if (utf8) -#endif { while (len > 0) { if (s >= strend) @@ -1364,7 +1015,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c break; } len = (s - strbeg) % len; - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'X': if (utf8) { while (len > 0) { @@ -1391,7 +1042,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (ai32 == 0) break; len -= ai32; } - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'x': if (utf8) { while (len>0) { @@ -1408,7 +1059,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c break; case '/': Perl_croak(aTHX_ "'/' must follow a numeric type in unpack"); - break; + case 'A': case 'Z': case 'a': @@ -1447,7 +1098,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) { for (ptr = s+len-1; ptr >= s; ptr--) if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) && - !is_utf8_space((U8 *) ptr)) break; + !isSPACE_utf8(ptr)) break; if (ptr >= s) ptr += UTF8SKIP(ptr); else ptr++; if (ptr > s+len) @@ -1475,20 +1126,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)]; @@ -1549,13 +1186,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; @@ -1565,7 +1204,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; @@ -1576,12 +1216,15 @@ 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': @@ -1591,7 +1234,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; break; } - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'c': while (len-- > 0 && s < strend) { int aint; @@ -1645,7 +1288,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 @@ -1675,10 +1318,10 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c len = UTF8SKIP(result); if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) &result[1], len-1, 'U')) break; - auv = utf8n_to_uvuni(result, len, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV); + auv = utf8n_to_uvchr(result, len, &retlen, UTF8_ALLOW_DEFAULT); s = ptr; } else { - auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV); + auv = utf8n_to_uvchr((U8*)s, strend - s, &retlen, UTF8_ALLOW_DEFAULT); if (retlen == (STRLEN) -1 || retlen == 0) Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); s += retlen; @@ -1695,8 +1338,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if SHORTSIZE != SIZE16 while (len-- > 0) { short ashort; - SHIFT_VAR(utf8, s, strend, ashort, datumtype); - DO_BO_UNPACK(ashort, s); + SHIFT_VAR(utf8, s, strend, ashort, datumtype, needs_swap); if (!checksum) mPUSHi(ashort); else if (checksum > bits_in_uv) @@ -1706,7 +1348,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } break; #else - /* Fallthrough! */ + /* FALLTHROUGH */ #endif case 's': while (len-- > 0) { @@ -1715,8 +1357,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if U16SIZE > SIZE16 ai16 = 0; #endif - SHIFT16(utf8, s, strend, &ai16, datumtype); - DO_BO_UNPACK(ai16, 16); + SHIFT16(utf8, s, strend, &ai16, datumtype, needs_swap); #if U16SIZE > SIZE16 if (ai16 > 32767) ai16 -= 65536; @@ -1733,8 +1374,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if SHORTSIZE != SIZE16 while (len-- > 0) { unsigned short aushort; - SHIFT_VAR(utf8, s, strend, aushort, datumtype); - DO_BO_UNPACK(aushort, s); + SHIFT_VAR(utf8, s, strend, aushort, datumtype, needs_swap, + needs_swap); if (!checksum) mPUSHu(aushort); else if (checksum > bits_in_uv) @@ -1744,7 +1385,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': @@ -1754,16 +1395,11 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if U16SIZE > SIZE16 au16 = 0; #endif - SHIFT16(utf8, s, strend, &au16, datumtype); - DO_BO_UNPACK(au16, 16); -#ifdef HAS_NTOHS + SHIFT16(utf8, s, strend, &au16, datumtype, needs_swap); if (datumtype == 'n') au16 = PerlSock_ntohs(au16); -#endif -#ifdef HAS_VTOHS if (datumtype == 'v') au16 = vtohs(au16); -#endif if (!checksum) mPUSHu(au16); else if (checksum > bits_in_uv) @@ -1772,7 +1408,6 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c cuv += au16; } break; -#ifdef PERL_PACK_CAN_SHRIEKSIGN case 'v' | TYPE_IS_SHRIEKING: case 'n' | TYPE_IS_SHRIEKING: while (len-- > 0) { @@ -1780,15 +1415,13 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c # if U16SIZE > SIZE16 ai16 = 0; # endif - SHIFT16(utf8, s, strend, &ai16, datumtype); -# ifdef HAS_NTOHS + SHIFT16(utf8, s, strend, &ai16, datumtype, needs_swap); + /* There should never be any byte-swapping here. */ + assert(!TYPE_ENDIANNESS(datumtype)); if (datumtype == ('n' | TYPE_IS_SHRIEKING)) ai16 = (I16) PerlSock_ntohs((U16) ai16); -# endif /* HAS_NTOHS */ -# ifdef HAS_VTOHS if (datumtype == ('v' | TYPE_IS_SHRIEKING)) ai16 = (I16) vtohs((U16) ai16); -# endif /* HAS_VTOHS */ if (!checksum) mPUSHi(ai16); else if (checksum > bits_in_uv) @@ -1797,13 +1430,11 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c cuv += ai16; } break; -#endif /* PERL_PACK_CAN_SHRIEKSIGN */ case 'i': case 'i' | TYPE_IS_SHRIEKING: while (len-- > 0) { int aint; - SHIFT_VAR(utf8, s, strend, aint, datumtype); - DO_BO_UNPACK(aint, i); + SHIFT_VAR(utf8, s, strend, aint, datumtype, needs_swap); if (!checksum) mPUSHi(aint); else if (checksum > bits_in_uv) @@ -1816,8 +1447,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'I' | TYPE_IS_SHRIEKING: while (len-- > 0) { unsigned int auint; - SHIFT_VAR(utf8, s, strend, auint, datumtype); - DO_BO_UNPACK(auint, i); + SHIFT_VAR(utf8, s, strend, auint, datumtype, needs_swap); if (!checksum) mPUSHu(auint); else if (checksum > bits_in_uv) @@ -1829,16 +1459,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'j': while (len-- > 0) { IV aiv; - SHIFT_VAR(utf8, s, strend, aiv, datumtype); -#if IVSIZE == INTSIZE - DO_BO_UNPACK(aiv, i); -#elif IVSIZE == LONGSIZE - DO_BO_UNPACK(aiv, l); -#elif defined(HAS_QUAD) && IVSIZE == U64SIZE - DO_BO_UNPACK(aiv, 64); -#else - Perl_croak(aTHX_ "'j' not supported on this platform"); -#endif + SHIFT_VAR(utf8, s, strend, aiv, datumtype, needs_swap); if (!checksum) mPUSHi(aiv); else if (checksum > bits_in_uv) @@ -1850,16 +1471,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'J': while (len-- > 0) { UV auv; - SHIFT_VAR(utf8, s, strend, auv, datumtype); -#if IVSIZE == INTSIZE - DO_BO_UNPACK(auv, i); -#elif IVSIZE == LONGSIZE - DO_BO_UNPACK(auv, l); -#elif defined(HAS_QUAD) && IVSIZE == U64SIZE - DO_BO_UNPACK(auv, 64); -#else - Perl_croak(aTHX_ "'J' not supported on this platform"); -#endif + SHIFT_VAR(utf8, s, strend, auv, datumtype, needs_swap); if (!checksum) mPUSHu(auv); else if (checksum > bits_in_uv) @@ -1872,8 +1484,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if LONGSIZE != SIZE32 while (len-- > 0) { long along; - SHIFT_VAR(utf8, s, strend, along, datumtype); - DO_BO_UNPACK(along, l); + SHIFT_VAR(utf8, s, strend, along, datumtype, needs_swap); if (!checksum) mPUSHi(along); else if (checksum > bits_in_uv) @@ -1883,7 +1494,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } break; #else - /* Fallthrough! */ + /* FALLTHROUGH */ #endif case 'l': while (len-- > 0) { @@ -1891,8 +1502,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if U32SIZE > SIZE32 ai32 = 0; #endif - SHIFT32(utf8, s, strend, &ai32, datumtype); - DO_BO_UNPACK(ai32, 32); + SHIFT32(utf8, s, strend, &ai32, datumtype, needs_swap); #if U32SIZE > SIZE32 if (ai32 > 2147483647) ai32 -= 4294967296; #endif @@ -1908,8 +1518,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if LONGSIZE != SIZE32 while (len-- > 0) { unsigned long aulong; - SHIFT_VAR(utf8, s, strend, aulong, datumtype); - DO_BO_UNPACK(aulong, l); + SHIFT_VAR(utf8, s, strend, aulong, datumtype, needs_swap); if (!checksum) mPUSHu(aulong); else if (checksum > bits_in_uv) @@ -1919,7 +1528,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } break; #else - /* Fall through! */ + /* FALLTHROUGH */ #endif case 'V': case 'N': @@ -1929,16 +1538,11 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if U32SIZE > SIZE32 au32 = 0; #endif - SHIFT32(utf8, s, strend, &au32, datumtype); - DO_BO_UNPACK(au32, 32); -#ifdef HAS_NTOHL + SHIFT32(utf8, s, strend, &au32, datumtype, needs_swap); if (datumtype == 'N') au32 = PerlSock_ntohl(au32); -#endif -#ifdef HAS_VTOHL if (datumtype == 'V') au32 = vtohl(au32); -#endif if (!checksum) mPUSHu(au32); else if (checksum > bits_in_uv) @@ -1947,23 +1551,20 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c cuv += au32; } break; -#ifdef PERL_PACK_CAN_SHRIEKSIGN case 'V' | TYPE_IS_SHRIEKING: case 'N' | TYPE_IS_SHRIEKING: while (len-- > 0) { I32 ai32; -# if U32SIZE > SIZE32 +#if U32SIZE > SIZE32 ai32 = 0; -# endif - SHIFT32(utf8, s, strend, &ai32, datumtype); -# ifdef HAS_NTOHL +#endif + SHIFT32(utf8, s, strend, &ai32, datumtype, needs_swap); + /* There should never be any byte swapping here. */ + assert(!TYPE_ENDIANNESS(datumtype)); if (datumtype == ('N' | TYPE_IS_SHRIEKING)) ai32 = (I32)PerlSock_ntohl((U32)ai32); -# endif -# ifdef HAS_VTOHL if (datumtype == ('V' | TYPE_IS_SHRIEKING)) ai32 = (I32)vtohl((U32)ai32); -# endif if (!checksum) mPUSHi(ai32); else if (checksum > bits_in_uv) @@ -1972,12 +1573,10 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c cuv += ai32; } break; -#endif /* PERL_PACK_CAN_SHRIEKSIGN */ case 'p': while (len-- > 0) { const char *aptr; - SHIFT_VAR(utf8, s, strend, aptr, datumtype); - DO_BO_UNPACK_PC(aptr); + SHIFT_VAR(utf8, s, strend, aptr, datumtype, needs_swap); /* newSVpv generates undef if aptr is NULL */ mPUSHs(newSVpv(aptr, 0)); } @@ -2030,21 +1629,18 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c EXTEND(SP, 1); if (s + sizeof(char*) <= strend) { char *aptr; - SHIFT_VAR(utf8, s, strend, aptr, datumtype); - DO_BO_UNPACK_PC(aptr); + SHIFT_VAR(utf8, s, strend, aptr, datumtype, needs_swap); /* newSVpvn generates undef if aptr is NULL */ PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP)); } break; -#ifdef HAS_QUAD +#if defined(HAS_QUAD) && IVSIZE >= 8 case 'q': while (len-- > 0) { Quad_t aquad; - SHIFT_VAR(utf8, s, strend, aquad, datumtype); - DO_BO_UNPACK(aquad, 64); + SHIFT_VAR(utf8, s, strend, aquad, datumtype, needs_swap); if (!checksum) - mPUSHs(aquad >= IV_MIN && aquad <= IV_MAX ? - newSViv((IV)aquad) : newSVnv((NV)aquad)); + mPUSHs(newSViv((IV)aquad)); else if (checksum > bits_in_uv) cdouble += (NV)aquad; else @@ -2054,24 +1650,21 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'Q': while (len-- > 0) { Uquad_t auquad; - SHIFT_VAR(utf8, s, strend, auquad, datumtype); - DO_BO_UNPACK(auquad, 64); + SHIFT_VAR(utf8, s, strend, auquad, datumtype, needs_swap); if (!checksum) - mPUSHs(auquad <= UV_MAX ? - newSVuv((UV)auquad) : newSVnv((NV)auquad)); + mPUSHs(newSVuv((UV)auquad)); else if (checksum > bits_in_uv) cdouble += (NV)auquad; else cuv += auquad; } break; -#endif /* HAS_QUAD */ +#endif /* float and double added gnb@melba.bby.oz.au 22/11/89 */ case 'f': while (len-- > 0) { float afloat; - SHIFT_VAR(utf8, s, strend, afloat, datumtype); - DO_BO_UNPACK_N(afloat, float); + SHIFT_VAR(utf8, s, strend, afloat, datumtype, needs_swap); if (!checksum) mPUSHn(afloat); else @@ -2081,8 +1674,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'd': while (len-- > 0) { double adouble; - SHIFT_VAR(utf8, s, strend, adouble, datumtype); - DO_BO_UNPACK_N(adouble, double); + SHIFT_VAR(utf8, s, strend, adouble, datumtype, needs_swap); if (!checksum) mPUSHn(adouble); else @@ -2091,30 +1683,42 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c 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, needs_swap); if (!checksum) - mPUSHn(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, needs_swap); + /* The most common long double format, the x86 80-bit + * extended precision, has either 2 or 6 unused bytes, + * which may contain garbage, which may contain + * unintentional data. While we do zero the bytes of + * the long double data in pack(), here in unpack() we + * don't, because it's really hard to envision that + * reading the long double off aldouble would be + * affected by the unused bytes. + * + * Note that trying to unpack 'long doubles' of 'long + * doubles' packed in another system is in the general + * case doomed without having more detail. */ if (!checksum) - mPUSHn(aldouble); + mPUSHn(aldouble.ld); else - cdouble += aldouble; + cdouble += aldouble.ld; } break; #endif case 'u': - { + if (!checksum) { const STRLEN l = (STRLEN) (strend - s) * 3 / 4; sv = sv_2mortal(newSV(l)); if (l) SvPOK_on(sv); @@ -2132,7 +1736,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) { @@ -2173,7 +1778,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') @@ -2183,7 +1789,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; } @@ -2216,7 +1823,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (symptr->flags & FLAG_SLASH){ if (SP - PL_stack_base - start_sp_offset <= 0) - Perl_croak(aTHX_ "'/' must follow a numeric type in unpack"); + break; if( next_symbol(symptr) ){ if( symptr->howlen == e_number ) Perl_croak(aTHX_ "Count after length/code in unpack" ); @@ -2246,7 +1853,6 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c PP(pp_unpack) { - dVAR; dSP; dPOPPOPssrl; I32 gimme = GIMME_V; @@ -2377,9 +1983,8 @@ The engine implementing pack() Perl function. */ void -Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist ) +Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist ) { - dVAR; tempsym_t sym; PERL_ARGS_ASSERT_PACKLIST; @@ -2408,7 +2013,7 @@ marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) { from_start = SvPVX_const(sv); from_end = from_start + SvCUR(sv); for (from_ptr = from_start; from_ptr < from_end; from_ptr++) - if (!NATIVE_IS_INVARIANT(*from_ptr)) break; + if (!NATIVE_BYTE_IS_INVARIANT(*from_ptr)) break; if (from_ptr == from_end) { /* Simple case: no character needs to be changed */ SvUTF8_on(sv); @@ -2437,7 +2042,8 @@ 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, m=%p, marks=%p, " + "level=%d", m, marks, sym_ptr->level); } for (group=sym_ptr; group; group = group->previous) group->strbeg = marks[group->level] - to_start; @@ -2476,16 +2082,33 @@ S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) { return SvGROW(sv, len+extend+1); } +static void +S_sv_check_infnan(pTHX_ SV *sv, I32 datumtype) +{ + SvGETMAGIC(sv); + if (UNLIKELY(isinfnansv(sv))) { + const I32 c = TYPE_NO_MODIFIERS(datumtype); + const NV nv = SvNV_nomg(sv); + if (c == 'w') + Perl_croak(aTHX_ "Cannot compress %"NVgf" in pack", nv); + else + Perl_croak(aTHX_ "Cannot pack %"NVgf" with '%c'", nv, (int) c); + } +} + +#define SvIV_no_inf(sv,d) (S_sv_check_infnan(aTHX_ sv,d), SvIV_nomg(sv)) +#define SvUV_no_inf(sv,d) (S_sv_check_infnan(aTHX_ sv,d), SvUV_nomg(sv)) + STATIC SV ** S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) { - dVAR; tempsym_t lookahead; I32 items = endlist - beglist; bool found = next_symbol(symptr); bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0; bool warn_utf8 = ckWARN(WARN_UTF8); + char* from; PERL_ARGS_ASSERT_PACK_REC; @@ -2505,8 +2128,10 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) howlen_t howlen = symptr->howlen; char *start = SvPVX(cat); char *cur = start + SvCUR(cat); + bool needs_swap; #define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no) +#define PEEKFROM (lengthcode ? lengthcode : items > 0 ? *beglist : &PL_sv_no) switch (howlen) { case e_star: @@ -2539,18 +2164,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (lookahead.howlen == e_number) count = lookahead.length; else { if (items > 0) { - if (SvGAMAGIC(*beglist)) { - /* Avoid reading the active data more than once - by copying it to a temporary. */ - STRLEN len; - const char *const pv = SvPV_const(*beglist, len); - SV *const temp - = newSVpvn_flags(pv, len, - SVs_TEMP | SvUTF8(*beglist)); - *beglist = temp; - } - count = DO_UTF8(*beglist) ? - sv_len_utf8(*beglist) : sv_len(*beglist); + count = sv_len_utf8(*beglist); } else count = 0; if (lookahead.code == 'Z') count++; @@ -2565,20 +2179,19 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) lengthcode = sv_2mortal(newSViv(count)); } + needs_swap = NEEDS_SWAP(datumtype); + /* Code inside the switch must take care to properly update cat (CUR length and '\0' termination) if it updated *cur and doesn't simply leave using break */ - switch(TYPE_NO_ENDIANNESS(datumtype)) { + switch (TYPE_NO_ENDIANNESS(datumtype)) { default: Perl_croak(aTHX_ "Invalid type '%c' in pack", (int) TYPE_NO_MODIFIERS(datumtype)); case '%': Perl_croak(aTHX_ "'%%' may not be used in pack"); - { - char *from; -#ifdef PERL_PACK_CAN_SHRIEKSIGN + case '.' | TYPE_IS_SHRIEKING: -#endif case '.': if (howlen == e_star) from = start; else if (len == 0) from = cur; @@ -2589,19 +2202,13 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) from = group ? start + group->strbeg : start; } fromstr = NEXTFROM; - len = SvIV(fromstr); + len = SvIV_no_inf(fromstr, datumtype); goto resize; -#ifdef PERL_PACK_CAN_SHRIEKSIGN case '@' | TYPE_IS_SHRIEKING: -#endif case '@': from = start + symptr->strbeg; resize: -#ifdef PERL_PACK_CAN_SHRIEKSIGN if (utf8 && !(datumtype & TYPE_IS_SHRIEKING)) -#else /* PERL_PACK_CAN_SHRIEKSIGN */ - if (utf8) -#endif if (len >= 0) { while (len && from < cur) { from += UTF8SKIP(from); @@ -2632,7 +2239,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) goto shrink; } break; - } + case '(': { tempsym_t savsym = *symptr; U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags); @@ -2678,7 +2285,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) break; } len = (cur-start) % len; - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'X': if (utf8) { if (len < 1) goto no_change; @@ -2720,7 +2327,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (ai32 == 0) goto no_change; len -= ai32; } - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'x': goto grow; case 'A': @@ -2771,7 +2378,9 @@ 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, " + "for '%c', aptr=%p end=%p cur=%p, fromlen=%"UVuf, + (int)datumtype, aptr, end, cur, (UV)fromlen); cur += fromlen; len -= fromlen; } else if (utf8) { @@ -2810,6 +2419,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': @@ -2960,11 +2570,10 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) while (len-- > 0) { 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"); + aiv = SvIV_no_inf(fromstr, datumtype); + 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; @@ -2976,11 +2585,10 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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"); + aiv = SvIV_no_inf(fromstr, datumtype); + 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; @@ -2993,7 +2601,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) while (len-- > 0) { UV auv; fromstr = NEXTFROM; - auv = SvUV(fromstr); + auv = SvUV_no_inf(fromstr, datumtype); if (in_bytes) auv = auv % 0x100; if (utf8) { W_utf8: @@ -3004,8 +2612,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) GROWING(0, cat, start, cur, len+UTF8_MAXLEN); end = start+SvLEN(cat)-UTF8_MAXLEN; } - cur = (char *) uvuni_to_utf8_flags((U8 *) cur, - NATIVE_TO_UNI(auv), + cur = (char *) uvchr_to_utf8_flags((U8 *) cur, + auv, warn_utf8 ? 0 : UNICODE_ALLOW_ANY); } else { @@ -3022,9 +2630,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) { @@ -3056,10 +2663,10 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) while (len-- > 0) { UV auv; fromstr = NEXTFROM; - auv = SvUV(fromstr); + auv = SvUV_no_inf(fromstr, datumtype); if (utf8) { U8 buffer[UTF8_MAXLEN], *endb; - endb = uvuni_to_utf8_flags(buffer, auv, + endb = uvchr_to_utf8_flags(buffer, auv, warn_utf8 ? 0 : UNICODE_ALLOW_ANY); if (cur+(endb-buffer)*UTF8_EXPAND >= end) { @@ -3069,7 +2676,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) len+(endb-buffer)*UTF8_EXPAND); end = start+SvLEN(cat); } - cur = bytes_to_uni(buffer, endb-buffer, cur); + cur = S_bytes_to_uni(buffer, endb-buffer, cur, 0); } else { if (cur >= end) { *cur = '\0'; @@ -3077,7 +2684,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) GROWING(0, cat, start, cur, len+UTF8_MAXLEN); end = start+SvLEN(cat)-UTF8_MAXLEN; } - cur = (char *) uvuni_to_utf8_flags((U8 *) cur, auv, + cur = (char *) uvchr_to_utf8_flags((U8 *) cur, auv, warn_utf8 ? 0 : UNICODE_ALLOW_ANY); } @@ -3091,23 +2698,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) NV anv; fromstr = NEXTFROM; anv = SvNV(fromstr); -#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. */ -{ -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) +# 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. */ @@ -3119,9 +2710,7 @@ extern const float _float_constants[]; # else afloat = (float)anv; # endif -#endif /* __VOS__ */ - DO_BO_PACK_N(afloat, float); - PUSH_VAR(utf8, cur, afloat); + PUSH_VAR(utf8, cur, afloat, needs_swap); } break; case 'd': @@ -3130,23 +2719,7 @@ extern const float _float_constants[]; NV anv; fromstr = NEXTFROM; anv = SvNV(fromstr); -#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. */ -{ -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) +# 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. */ @@ -3158,62 +2731,61 @@ extern const double _double_constants[]; # else adouble = (double)anv; # endif -#endif /* __VOS__ */ - DO_BO_PACK_N(adouble, double); - PUSH_VAR(utf8, cur, adouble); + PUSH_VAR(utf8, cur, adouble, needs_swap); } 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); - DO_BO_PACK_N(anv, NV); - PUSH_VAR(utf8, cur, anv); +#ifdef __GNUC__ + /* to work round a gcc/x86 bug; don't use SvNV */ + anv.nv = sv_2nv(fromstr); +#else + anv.nv = SvNV(fromstr); +#endif + PUSH_BYTES(utf8, cur, anv.bytes, sizeof(anv.bytes), needs_swap); } 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); - DO_BO_PACK_N(aldouble, long double); - PUSH_VAR(utf8, cur, aldouble); +# 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 + PUSH_BYTES(utf8, cur, aldouble.bytes, sizeof(aldouble.bytes), + needs_swap); } break; } #endif -#ifdef PERL_PACK_CAN_SHRIEKSIGN case 'n' | TYPE_IS_SHRIEKING: -#endif case 'n': while (len-- > 0) { I16 ai16; fromstr = NEXTFROM; - ai16 = (I16)SvIV(fromstr); -#ifdef HAS_HTONS + ai16 = (I16)SvIV_no_inf(fromstr, datumtype); ai16 = PerlSock_htons(ai16); -#endif - PUSH16(utf8, cur, &ai16); + PUSH16(utf8, cur, &ai16, FALSE); } break; -#ifdef PERL_PACK_CAN_SHRIEKSIGN case 'v' | TYPE_IS_SHRIEKING: -#endif case 'v': while (len-- > 0) { I16 ai16; fromstr = NEXTFROM; - ai16 = (I16)SvIV(fromstr); -#ifdef HAS_HTOVS + ai16 = (I16)SvIV_no_inf(fromstr, datumtype); ai16 = htovs(ai16); -#endif - PUSH16(utf8, cur, &ai16); + PUSH16(utf8, cur, &ai16, FALSE); } break; case 'S' | TYPE_IS_SHRIEKING: @@ -3221,21 +2793,19 @@ extern const double _double_constants[]; while (len-- > 0) { unsigned short aushort; fromstr = NEXTFROM; - aushort = SvUV(fromstr); - DO_BO_PACK(aushort, s); - PUSH_VAR(utf8, cur, aushort); + aushort = SvUV_no_inf(fromstr, datumtype); + PUSH_VAR(utf8, cur, aushort, needs_swap); } break; #else - /* Fall through! */ + /* FALLTHROUGH */ #endif case 'S': while (len-- > 0) { U16 au16; fromstr = NEXTFROM; - au16 = (U16)SvUV(fromstr); - DO_BO_PACK(au16, 16); - PUSH16(utf8, cur, &au16); + au16 = (U16)SvUV_no_inf(fromstr, datumtype); + PUSH16(utf8, cur, &au16, needs_swap); } break; case 's' | TYPE_IS_SHRIEKING: @@ -3243,21 +2813,19 @@ extern const double _double_constants[]; while (len-- > 0) { short ashort; fromstr = NEXTFROM; - ashort = SvIV(fromstr); - DO_BO_PACK(ashort, s); - PUSH_VAR(utf8, cur, ashort); + ashort = SvIV_no_inf(fromstr, datumtype); + PUSH_VAR(utf8, cur, ashort, needs_swap); } break; #else - /* Fall through! */ + /* FALLTHROUGH */ #endif case 's': while (len-- > 0) { I16 ai16; fromstr = NEXTFROM; - ai16 = (I16)SvIV(fromstr); - DO_BO_PACK(ai16, 16); - PUSH16(utf8, cur, &ai16); + ai16 = (I16)SvIV_no_inf(fromstr, datumtype); + PUSH16(utf8, cur, &ai16, needs_swap); } break; case 'I': @@ -3265,50 +2833,32 @@ extern const double _double_constants[]; while (len-- > 0) { unsigned int auint; fromstr = NEXTFROM; - auint = SvUV(fromstr); - DO_BO_PACK(auint, i); - PUSH_VAR(utf8, cur, auint); + auint = SvUV_no_inf(fromstr, datumtype); + PUSH_VAR(utf8, cur, auint, needs_swap); } break; case 'j': while (len-- > 0) { IV aiv; fromstr = NEXTFROM; - aiv = SvIV(fromstr); -#if IVSIZE == INTSIZE - DO_BO_PACK(aiv, i); -#elif IVSIZE == LONGSIZE - DO_BO_PACK(aiv, l); -#elif defined(HAS_QUAD) && IVSIZE == U64SIZE - DO_BO_PACK(aiv, 64); -#else - Perl_croak(aTHX_ "'j' not supported on this platform"); -#endif - PUSH_VAR(utf8, cur, aiv); + aiv = SvIV_no_inf(fromstr, datumtype); + PUSH_VAR(utf8, cur, aiv, needs_swap); } break; case 'J': while (len-- > 0) { UV auv; fromstr = NEXTFROM; - auv = SvUV(fromstr); -#if UVSIZE == INTSIZE - DO_BO_PACK(auv, i); -#elif UVSIZE == LONGSIZE - DO_BO_PACK(auv, l); -#elif defined(HAS_QUAD) && UVSIZE == U64SIZE - DO_BO_PACK(auv, 64); -#else - Perl_croak(aTHX_ "'J' not supported on this platform"); -#endif - PUSH_VAR(utf8, cur, auv); + auv = SvUV_no_inf(fromstr, datumtype); + PUSH_VAR(utf8, cur, auv, needs_swap); } break; case 'w': while (len-- > 0) { NV anv; fromstr = NEXTFROM; - anv = SvNV(fromstr); + S_sv_check_infnan(aTHX_ fromstr, datumtype); + anv = SvNV_nomg(fromstr); if (anv < 0) { *cur = '\0'; @@ -3324,7 +2874,7 @@ extern const double _double_constants[]; if (SvIOK(fromstr) || anv < UV_MAX_P1) { char buf[(sizeof(UV)*CHAR_BIT)/7+1]; char *in = buf + sizeof(buf); - UV auv = SvUV(fromstr); + UV auv = SvUV_nomg(fromstr); do { *--in = (char)((auv & 0x7f) | 0x80); @@ -3337,7 +2887,7 @@ extern const double _double_constants[]; 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. @@ -3375,7 +2925,7 @@ extern const double _double_constants[]; w_string: /* Copy string and check for compliance */ - from = SvPV_const(fromstr, len); + from = SvPV_nomg_const(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) Perl_croak(aTHX_ "Can only compress unsigned integers in pack"); @@ -3396,37 +2946,28 @@ extern const double _double_constants[]; while (len-- > 0) { int aint; fromstr = NEXTFROM; - aint = SvIV(fromstr); - DO_BO_PACK(aint, i); - PUSH_VAR(utf8, cur, aint); + aint = SvIV_no_inf(fromstr, datumtype); + PUSH_VAR(utf8, cur, aint, needs_swap); } break; -#ifdef PERL_PACK_CAN_SHRIEKSIGN case 'N' | TYPE_IS_SHRIEKING: -#endif case 'N': while (len-- > 0) { U32 au32; fromstr = NEXTFROM; - au32 = SvUV(fromstr); -#ifdef HAS_HTONL + au32 = SvUV_no_inf(fromstr, datumtype); au32 = PerlSock_htonl(au32); -#endif - PUSH32(utf8, cur, &au32); + PUSH32(utf8, cur, &au32, FALSE); } break; -#ifdef PERL_PACK_CAN_SHRIEKSIGN case 'V' | TYPE_IS_SHRIEKING: -#endif case 'V': while (len-- > 0) { U32 au32; fromstr = NEXTFROM; - au32 = SvUV(fromstr); -#ifdef HAS_HTOVL + au32 = SvUV_no_inf(fromstr, datumtype); au32 = htovl(au32); -#endif - PUSH32(utf8, cur, &au32); + PUSH32(utf8, cur, &au32, FALSE); } break; case 'L' | TYPE_IS_SHRIEKING: @@ -3434,9 +2975,8 @@ extern const double _double_constants[]; while (len-- > 0) { unsigned long aulong; fromstr = NEXTFROM; - aulong = SvUV(fromstr); - DO_BO_PACK(aulong, l); - PUSH_VAR(utf8, cur, aulong); + aulong = SvUV_no_inf(fromstr, datumtype); + PUSH_VAR(utf8, cur, aulong, needs_swap); } break; #else @@ -3446,9 +2986,8 @@ extern const double _double_constants[]; while (len-- > 0) { U32 au32; fromstr = NEXTFROM; - au32 = SvUV(fromstr); - DO_BO_PACK(au32, 32); - PUSH32(utf8, cur, &au32); + au32 = SvUV_no_inf(fromstr, datumtype); + PUSH32(utf8, cur, &au32, needs_swap); } break; case 'l' | TYPE_IS_SHRIEKING: @@ -3456,9 +2995,8 @@ extern const double _double_constants[]; while (len-- > 0) { long along; fromstr = NEXTFROM; - along = SvIV(fromstr); - DO_BO_PACK(along, l); - PUSH_VAR(utf8, cur, along); + along = SvIV_no_inf(fromstr, datumtype); + PUSH_VAR(utf8, cur, along, needs_swap); } break; #else @@ -3468,35 +3006,32 @@ extern const double _double_constants[]; while (len-- > 0) { I32 ai32; fromstr = NEXTFROM; - ai32 = SvIV(fromstr); - DO_BO_PACK(ai32, 32); - PUSH32(utf8, cur, &ai32); + ai32 = SvIV_no_inf(fromstr, datumtype); + PUSH32(utf8, cur, &ai32, needs_swap); } break; -#ifdef HAS_QUAD +#if defined(HAS_QUAD) && IVSIZE >= 8 case 'Q': while (len-- > 0) { Uquad_t auquad; fromstr = NEXTFROM; - auquad = (Uquad_t) SvUV(fromstr); - DO_BO_PACK(auquad, 64); - PUSH_VAR(utf8, cur, auquad); + auquad = (Uquad_t) SvUV_no_inf(fromstr, datumtype); + PUSH_VAR(utf8, cur, auquad, needs_swap); } break; case 'q': while (len-- > 0) { Quad_t aquad; fromstr = NEXTFROM; - aquad = (Quad_t)SvIV(fromstr); - DO_BO_PACK(aquad, 64); - PUSH_VAR(utf8, cur, aquad); + aquad = (Quad_t)SvIV_no_inf(fromstr, datumtype); + PUSH_VAR(utf8, cur, aquad, needs_swap); } break; -#endif /* HAS_QUAD */ +#endif case 'P': len = 1; /* assume SV is correct length */ GROWING(utf8, cat, start, cur, sizeof(char *)); - /* Fall through! */ + /* FALLTHROUGH */ case 'p': while (len-- > 0) { const char *aptr; @@ -3511,17 +3046,16 @@ extern const double _double_constants[]; * 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); else aptr = SvPV_force_flags_nolen(fromstr, 0); } - DO_BO_PACK_PC(aptr); - PUSH_VAR(utf8, cur, aptr); + PUSH_VAR(utf8, cur, aptr, needs_swap); } break; case 'u': { @@ -3532,16 +3066,15 @@ extern const double _double_constants[]; 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); from_utf8 = DO_UTF8(fromstr); if (from_utf8) { aend = aptr + fromlen; - fromlen = sv_len_utf8(fromstr); + fromlen = sv_len_utf8_nomg(fromstr); } else aend = NULL; /* Unused, but keep compilers happy */ GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2); while (fromlen > 0) { @@ -3559,14 +3092,16 @@ extern const double _double_constants[]; '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, " + "aptr=%p, aend=%p, buffer=%p, todo=%ld", + aptr, aend, buffer, (long) todo); } end = doencodes(hunk, buffer, todo); } else { end = doencodes(hunk, aptr, todo); aptr += todo; } - PUSH_BYTES(utf8, cur, hunk, end-hunk); + PUSH_BYTES(utf8, cur, hunk, end-hunk, 0); fromlen -= todo; } break; @@ -3584,12 +3119,12 @@ extern const double _double_constants[]; PP(pp_pack) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; - register SV *cat = TARG; + dSP; dMARK; dORIGMARK; dTARGET; + SV *cat = TARG; STRLEN fromlen; SV *pat_sv = *++MARK; - register const char *pat = SvPV_const(pat_sv, fromlen); - register const char *patend = pat + fromlen; + const char *pat = SvPV_const(pat_sv, fromlen); + const char *patend = pat + fromlen; MARK++; sv_setpvs(cat, ""); @@ -3607,8 +3142,8 @@ PP(pp_pack) * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */