X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/27da23d53ccce622bc51822f59df8def79b4df95..7d4ca04c5c923a5f9d7537da52b257a597b79742:/pp_pack.c diff --git a/pp_pack.c b/pp_pack.c index 9a7cc53..8ac5316 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, 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,14 +28,58 @@ * other pp*.c files for the rest of the pp_ functions. */ - #include "EXTERN.h" #define PERL_IN_PP_PACK_C #include "perl.h" -#if PERL_VERSION >= 9 -# define PERL_PACK_CAN_BYTEORDER -# define PERL_PACK_CAN_SHRIEKSIGN +/* Types used by pack/unpack */ +typedef enum { + e_no_len, /* no length */ + e_number, /* number, [] */ + e_star /* asterisk */ +} howlen_t; + +typedef struct tempsym { + const char* patptr; /* current template char */ + const char* patend; /* one after last char */ + const char* grpbeg; /* 1st char of ()-group */ + const char* grpend; /* end of ()-group */ + I32 code; /* template code (!<>) */ + U32 flags; /* /=4, comma=2, pack=1 */ + /* and group modifiers */ + SSize_t length; /* length/repeat count */ + howlen_t howlen; /* how length is given */ + int level; /* () nesting level */ + STRLEN strbeg; /* offset of group start */ + struct tempsym *previous; /* previous group */ +} tempsym_t; + +#define TEMPSYM_INIT(symptr, p, e, f) \ + STMT_START { \ + (symptr)->patptr = (p); \ + (symptr)->patend = (e); \ + (symptr)->grpbeg = NULL; \ + (symptr)->grpend = NULL; \ + (symptr)->grpend = NULL; \ + (symptr)->code = 0; \ + (symptr)->length = 0; \ + (symptr)->howlen = e_no_len; \ + (symptr)->level = 0; \ + (symptr)->flags = (f); \ + (symptr)->strbeg = 0; \ + (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 #ifndef CHAR_BIT @@ -66,60 +112,63 @@ /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack(). --jhi Feb 1999 */ -#if U16SIZE > SIZE16 || U32SIZE > SIZE32 -# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */ -# define OFF16(p) ((char*)(p)) -# define OFF32(p) ((char*)(p)) -# else -# if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */ -# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16)) -# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32)) -# else - ++++ bad cray byte order -# endif -# endif -#else +#if U16SIZE <= SIZE16 && U32SIZE <= SIZE32 # define OFF16(p) ((char *) (p)) # define OFF32(p) ((char *) (p)) +#elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */ +# define OFF16(p) ((char*)(p)) +# define OFF32(p) ((char*)(p)) +#elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */ +# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16)) +# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32)) +#else +# error "bad cray byte order" #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 - -/* 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, 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) -#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 S_utf8_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 (!uni_to_bytes(aTHX_ &s, strend, \ - (char *) &var, sizeof(var), datumtype)) break;\ + if (UNLIKELY(utf8)) { \ + if (!S_utf8_to_bytes(aTHX_ &s, strend, \ + (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 @@ -139,10 +188,11 @@ S_mul128(pTHX_ SV *sv, U8 m) STRLEN len; char *s = SvPV(sv, len); char *t; - U32 i = 0; - if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ - SV *tmpNew = newSVpvn("0000000000", 10); + PERL_ARGS_ASSERT_MUL128; + + if (! memBEGINs(s, len, "0000")) { /* need to grow sv */ + SV * const tmpNew = newSVpvs("0000000000"); sv_catsv(tmpNew, sv); SvREFCNT_dec(sv); /* free old sv */ @@ -153,7 +203,7 @@ S_mul128(pTHX_ SV *sv, U8 m) while (!*t) /* trailing '\0'? */ t--; while (t > s) { - i = ((*t - '0') << 7) + m; + const U32 i = ((*t - '0') << 7) + m; *(t--) = '0' + (char)(i % 10); m = (char)(i / 10); } @@ -162,16 +212,9 @@ S_mul128(pTHX_ SV *sv, U8 m) /* Explosives and implosives. */ -#if 'I' == 73 && 'J' == 74 -/* On an ASCII/ISO kind of system */ -#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a') -#else -/* - Some other sort of character set - use memchr() so we don't match - the null byte. - */ -#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ') -#endif +#define ISUUCHAR(ch) inRANGE(NATIVE_TO_LATIN1(ch), \ + NATIVE_TO_LATIN1(' '), \ + NATIVE_TO_LATIN1('a') - 1) /* type modifiers */ #define TYPE_IS_SHRIEKING 0x100 @@ -182,410 +225,44 @@ 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) - -#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) -# else -# define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer) -# define DO_BO_PACK_P(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. */ - -#if TYPE_IS_SHRIEKING != 0x100 - ++++shriek offset should be 256 -#endif +#include "packsizetables.inc" -typedef U8 packprops_t; -#if 'J'-'I' == 1 -/* ASCII */ -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) | PACK_SIZE_UNPREDICTABLE, -#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) */ -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) | PACK_SIZE_UNPREDICTABLE, -#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_ char **s, const char *end, I32 datumtype) +utf8_to_byte(pTHX_ const char **s, const char *end, I32 datumtype) { - UV val; STRLEN retlen; + UV val; + + if (*s >= end) { + goto croak; + } 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 - warnings), but these two mean we make no progress in the string and - might enter an infinite loop */ - if (retlen == (STRLEN) -1 || retlen == 0) + if (retlen == (STRLEN) -1) + croak: 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; @@ -593,133 +270,140 @@ uni_to_byte(pTHX_ char **s, const char *end, I32 datumtype) } #define SHIFT_BYTE(utf8, s, strend, datumtype) ((utf8) ? \ - uni_to_byte(aTHX_ &(s), (strend), (datumtype)) : \ + utf8_to_byte(aTHX_ &(s), (strend), (datumtype)) : \ *(U8 *)(s)++) STATIC bool -uni_to_bytes(pTHX_ char **s, char *end, char *buf, int buf_len, I32 datumtype) +S_utf8_to_bytes(pTHX_ const char **s, const char *end, const char *buf, SSize_t buf_len, I32 datumtype) { UV val; STRLEN retlen; - char *from = *s; + const char *from = *s; int bad = 0; - U32 flags = ckWARN(WARN_UTF8) ? + 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); - if (retlen == (STRLEN) -1 || retlen == 0) { - from += UTF8SKIP(from); + if (retlen == (STRLEN) -1) { + from += UTF8_SAFE_SKIP(from, end); bad |= 1; } else from += retlen; if (val >= 0x100) { 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) { if (bad & 1) { /* Rewalk the string fragment while warning */ - char *ptr; - flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; + const char *ptr; + const U32 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; } -STATIC bool -next_uni_uu(pTHX_ char **s, const char *end, I32 *out) -{ - UV val; - STRLEN retlen; - val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY); - if (val >= 0x100 || !ISUUCHAR(val) || - retlen == (STRLEN) -1 || retlen == 0) { - *out = 0; - return FALSE; - } - *out = PL_uudmap[val] & 077; - *s += retlen; - return TRUE; -} +STATIC char * +S_my_bytes_to_utf8(const U8 *start, STRLEN len, char *dest, const bool needs_swap) { + PERL_ARGS_ASSERT_MY_BYTES_TO_UTF8; -STATIC void -bytes_to_uni(pTHX_ U8 *start, STRLEN len, char **dest) { - U8 buffer[UTF8_MAXLEN]; - U8 *end = start + len; - char *d = *dest; - while (start < end) { - int length = - uvuni_to_utf8_flags(buffer, NATIVE_TO_UNI(*start), 0) - buffer; - switch(length) { - case 1: - *d++ = buffer[0]; - break; - case 2: - *d++ = buffer[0]; - *d++ = buffer[1]; - break; - default: - Perl_croak(aTHX_ "Perl bug: value %d UTF-8 expands to %d bytes", - *start, length); - } - 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++; + } } - *dest = d; + return dest; } -#define PUSH_BYTES(utf8, cur, buf, len) \ +#define PUSH_BYTES(utf8, cur, buf, len, needs_swap) \ STMT_START { \ - if (utf8) bytes_to_uni(aTHX_ (U8 *) buf, len, &(cur)); \ + if (UNLIKELY(utf8)) \ + (cur) = my_bytes_to_utf8((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 +#define SAFE_UTF8_EXPAND(var) \ +STMT_START { \ + if ((var) > SSize_t_MAX / UTF8_EXPAND) \ + Perl_croak(aTHX_ "%s", "Out of memory during pack()"); \ + (var) = (var) * UTF8_EXPAND; \ +} STMT_END + +#define GROWING2(utf8, cat, start, cur, item_size, item_count) \ +STMT_START { \ + if (SSize_t_MAX / (item_size) < (item_count)) \ + Perl_croak(aTHX_ "%s", "Out of memory during pack()"); \ + GROWING((utf8), (cat), (start), (cur), (item_size) * (item_count)); \ +} STMT_END + #define GROWING(utf8, cat, start, cur, in_len) \ STMT_START { \ STRLEN glen = (in_len); \ - if (utf8) glen *= UTF8_EXPAND; \ - if ((cur) + glen >= (start) + SvLEN(cat)) { \ - (start) = sv_exp_grow(aTHX_ cat, glen); \ + STRLEN catcur = (STRLEN)((cur) - (start)); \ + if (utf8) SAFE_UTF8_EXPAND(glen); \ + if (SSize_t_MAX - glen < catcur) \ + Perl_croak(aTHX_ "%s", "Out of memory during pack()"); \ + if (catcur + glen >= SvLEN(cat)) { \ + (start) = sv_exp_grow(cat, glen); \ (cur) = (start) + SvCUR(cat); \ } \ } STMT_END #define PUSH_GROWING_BYTES(utf8, cat, start, cur, buf, in_len) \ STMT_START { \ - STRLEN glen = (in_len); \ + const STRLEN glen = (in_len); \ STRLEN gl = glen; \ - if (utf8) gl *= UTF8_EXPAND; \ + if (utf8) SAFE_UTF8_EXPAND(gl); \ if ((cur) + gl >= (start) + SvLEN(cat)) { \ *cur = '\0'; \ SvCUR_set((cat), (cur) - (start)); \ - (start) = sv_exp_grow(aTHX_ cat, gl); \ + (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) { \ - U8 au8 = (byte); \ - bytes_to_uni(aTHX_ &au8, 1, &(s)); \ + const U8 au8 = (byte); \ + (s) = my_bytes_to_utf8(&au8, 1, (s), 0);\ } else *(U8 *)(s)++ = (byte); \ } STMT_END @@ -729,28 +413,34 @@ STMT_START { \ STRLEN retlen; \ if (str >= end) break; \ val = utf8n_to_uvchr((U8 *) str, end-str, &retlen, utf8_flags); \ - if (retlen == (STRLEN) -1 || retlen == 0) { \ + if (retlen == (STRLEN) -1) { \ *cur = '\0'; \ Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); \ } \ str += retlen; \ } STMT_END +static const char *_action( const tempsym_t* symptr ) +{ + return (const char *)(( symptr->flags & FLAG_PACK ) ? "pack" : "unpack"); +} + /* Returns the sizeof() struct described by pat */ -STATIC I32 +STATIC SSize_t S_measure_struct(pTHX_ tempsym_t* symptr) { - I32 total = 0; + SSize_t total = 0; + + PERL_ARGS_ASSERT_MEASURE_STRUCT; while (next_symbol(symptr)) { - I32 len; - int star, size; + SSize_t len, size; switch (symptr->howlen) { case e_star: Perl_croak(aTHX_ "Within []-length '*' not allowed in %s", - symptr->flags & FLAG_PACK ? "pack" : "unpack" ); - break; + _action( symptr ) ); + default: /* e_no_len and e_number */ len = symptr->length; @@ -759,16 +449,15 @@ S_measure_struct(pTHX_ tempsym_t* symptr) size = packprops[TYPE_NO_ENDIANNESS(symptr->code)] & PACK_SIZE_MASK; if (!size) { + SSize_t star; /* endianness doesn't influence the size of a type */ switch(TYPE_NO_ENDIANNESS(symptr->code)) { default: Perl_croak(aTHX_ "Invalid type '%c' in %s", (int)TYPE_NO_MODIFIERS(symptr->code), - symptr->flags & FLAG_PACK ? "pack" : "unpack" ); -#ifdef PERL_PACK_CAN_SHRIEKSIGN + _action( symptr ) ); case '.' | TYPE_IS_SHRIEKING: case '@' | TYPE_IS_SHRIEKING: -#endif case '@': case '.': case '/': @@ -777,7 +466,7 @@ S_measure_struct(pTHX_ tempsym_t* symptr) case 'u': Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s", (int) TYPE_NO_MODIFIERS(symptr->code), - symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + _action( symptr ) ); case '%': size = 0; break; @@ -800,12 +489,11 @@ 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) - Perl_croak(aTHX_ "'X' outside of string in %s", - symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + Perl_croak(aTHX_ "'X' outside of string in %s", _action( symptr ) ); break; case 'x' | TYPE_IS_SHRIEKING: if (!len) /* Avoid division by 0 */ @@ -815,7 +503,7 @@ S_measure_struct(pTHX_ tempsym_t* symptr) len = len - star; else len = 0; - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'x': case 'A': case 'Z': @@ -848,11 +536,13 @@ S_measure_struct(pTHX_ tempsym_t* symptr) /* locate matching closing parenthesis or bracket * returns char pointer to char after match, or NULL */ -STATIC char * -S_group_end(pTHX_ register char *patptr, register char *patend, char ender) +STATIC const char * +S_group_end(pTHX_ const char *patptr, const char *patend, char ender) { + PERL_ARGS_ASSERT_GROUP_END; + while (patptr < patend) { - char c = *patptr++; + const char c = *patptr++; if (isSPACE(c)) continue; @@ -869,7 +559,7 @@ S_group_end(pTHX_ register char *patptr, register char *patend, char ender) } Perl_croak(aTHX_ "No group ending character '%c' found in template", ender); - return 0; + NOT_REACHED; /* NOTREACHED */ } @@ -877,14 +567,18 @@ S_group_end(pTHX_ register char *patptr, register char *patend, char ender) * Expects a pointer to the first digit and address of length variable * Advances char pointer to 1st non-digit char and returns number */ -STATIC char * -S_get_num(pTHX_ register char *patptr, I32 *lenptr ) +STATIC const char * +S_get_num(pTHX_ const char *patptr, SSize_t *lenptr ) { - I32 len = *patptr++ - '0'; + SSize_t len = *patptr++ - '0'; + + PERL_ARGS_ASSERT_GET_NUM; + while (isDIGIT(*patptr)) { - if (len >= 0x7FFFFFFF/10) + SSize_t nlen = (len * 10) + (*patptr++ - '0'); + if (nlen < 0 || nlen/10 != len) Perl_croak(aTHX_ "pack/unpack repeat count overflow"); - len = (len * 10) + (*patptr++ - '0'); + len = nlen; } *lenptr = len; return patptr; @@ -896,9 +590,10 @@ S_get_num(pTHX_ register char *patptr, I32 *lenptr ) STATIC bool S_next_symbol(pTHX_ tempsym_t* symptr ) { - char* patptr = symptr->patptr; - char* patend = symptr->patend; - const char *allowed = ""; + const char* patptr = symptr->patptr; + const char* const patend = symptr->patend; + + PERL_ARGS_ASSERT_NEXT_SYMBOL; symptr->flags &= ~FLAG_SLASH; @@ -920,8 +615,7 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){ symptr->flags |= FLAG_COMMA; Perl_warner(aTHX_ packWARN(WARN_UNPACK), - "Invalid type ',' in %s", - symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + "Invalid type ',' in %s", _action( symptr ) ); } continue; } @@ -930,12 +624,12 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) if (code == '(') { if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' ) Perl_croak(aTHX_ "()-group starts with a count in %s", - symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + _action( symptr ) ); symptr->grpbeg = patptr; patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') ); if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL ) Perl_croak(aTHX_ "Too deeply nested ()-groups in %s", - symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + _action( symptr ) ); } /* look for group modifiers to inherit */ @@ -946,13 +640,13 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) /* look for modifiers */ while (patptr < patend) { - I32 modifier = 0; + const char *allowed; + I32 modifier; 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; @@ -961,8 +655,9 @@ 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; break; } @@ -971,23 +666,21 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) if (!strchr(allowed, TYPE_NO_MODIFIERS(code))) Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr, - allowed, symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + allowed, _action( symptr ) ); if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK) Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s", - (int) TYPE_NO_MODIFIERS(code), - symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + (int) TYPE_NO_MODIFIERS(code), _action( symptr ) ); else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) == TYPE_ENDIANNESS_MASK) Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s", - *patptr, symptr->flags & FLAG_PACK ? "pack" : "unpack" ); - - if (ckWARN(WARN_UNPACK)) { - if (code & modifier) - Perl_warner(aTHX_ packWARN(WARN_UNPACK), - "Duplicate modifier '%c' after '%c' in %s", - *patptr, (int) TYPE_NO_MODIFIERS(code), - symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + *patptr, _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; @@ -1008,7 +701,7 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) symptr->howlen = e_star; } else if (*patptr == '[') { - char* lenptr = ++patptr; + const char* lenptr = ++patptr; symptr->howlen = e_number; patptr = group_end( patptr, patend, ']' ) + 1; /* what kind of [] is it? */ @@ -1016,7 +709,7 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) lenptr = get_num( lenptr, &symptr->length ); if( *lenptr != ']' ) Perl_croak(aTHX_ "Malformed integer in [] in %s", - symptr->flags & FLAG_PACK ? "pack" : "unpack"); + _action( symptr ) ); } else { tempsym_t savsym = *symptr; symptr->patend = patptr-1; @@ -1046,7 +739,7 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) if (patptr < patend && (isDIGIT(*patptr) || *patptr == '*' || *patptr == '[')) Perl_croak(aTHX_ "'/' does not take a repeat count in %s", - symptr->flags & FLAG_PACK ? "pack" : "unpack" ); + _action( symptr ) ); } break; } @@ -1079,10 +772,13 @@ 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++; - pat = (char *) memchr(pat, '\n', patend-pat); + pat = (const char *) memchr(pat, '\n', patend-pat); if (!pat) return FALSE; } else if (pat[0] == 'U') { if (first || pat[1] == '0') return TRUE; @@ -1094,10 +790,12 @@ 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++; - pat = (char *) memchr(pat, '\n', patend-pat); + pat = (const char *) memchr(pat, '\n', patend-pat); if (!pat) return 0; pat++; } @@ -1105,52 +803,35 @@ first_symbol(const char *pat, const char *patend) { } /* -=for apidoc unpack_str - -The engine implementing unpack() Perl function. Note: parameters strbeg, new_s -and ocnt are not used. This call should not be used, use unpackstring instead. -=cut */ - -I32 -Perl_unpack_str(pTHX_ char *pat, char *patend, char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags) -{ - tempsym_t sym = { 0 }; - - 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 - wouldn't get to the "U0" */ - STRLEN len = strend - s; - s = (char *) bytes_to_utf8((U8 *) s, &len); - SAVEFREEPV(s); - strend = s + len; - flags |= FLAG_DO_UTF8; - } +=head1 Pack and Unpack - if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8)) - flags |= FLAG_PARSE_UTF8; +=for apidoc unpackstring - sym.patptr = pat; - sym.patend = patend; - sym.flags = flags; +The engine implementing the C Perl function. - return unpack_rec(&sym, s, s, strend, NULL ); -} +Using the template C, this function unpacks the string +C into a number of mortal SVs, which it pushes onto the perl +argument (C<@_>) 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. -/* -=for apidoc unpackstring +The C and C pointers should point to the byte following the +last character of each string. -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. +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 C before calling it, unlike L for +example). =cut */ -I32 -Perl_unpackstring(pTHX_ char *pat, char *patend, char *s, char *strend, U32 flags) +SSize_t +Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, const char *strend, U32 flags) { - tempsym_t sym = { 0 }; + tempsym_t sym; + + PERL_ARGS_ASSERT_UNPACKSTRING; if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8; else if (need_utf8(pat, patend)) { @@ -1166,36 +847,36 @@ Perl_unpackstring(pTHX_ char *pat, char *patend, char *s, char *strend, U32 flag if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8)) flags |= FLAG_PARSE_UTF8; - sym.patptr = pat; - sym.patend = patend; - sym.flags = flags; + TEMPSYM_INIT(&sym, pat, patend, flags); return unpack_rec(&sym, s, s, strend, NULL ); } -STATIC -I32 -S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char **new_s ) +STATIC SSize_t +S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s ) { - dVAR; dSP; - SV *sv; - I32 start_sp_offset = SP - PL_stack_base; + dSP; + SV *sv = NULL; + const SSize_t start_sp_offset = SP - PL_stack_base; howlen_t howlen; - - I32 checksum = 0; + SSize_t checksum = 0; UV cuv = 0; NV cdouble = 0.0; - const int bits_in_uv = CHAR_BIT * sizeof(cuv); + const SSize_t bits_in_uv = CHAR_BIT * sizeof(cuv); bool beyond = FALSE; bool explicit_length; - bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0; + 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)) { packprops_t props; - I32 len, ai32; + SSize_t 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 / */ @@ -1221,8 +902,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char props = packprops[TYPE_NO_ENDIANNESS(datumtype)]; if (props) { /* props nonzero means we can process this letter. */ - long size = props & PACK_SIZE_MASK; - long howmany = (strend - s) / size; + const SSize_t size = props & PACK_SIZE_MASK; + const SSize_t howmany = (strend - s) / size; if (len > howmany) len = howmany; @@ -1233,6 +914,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char } } + needs_swap = NEEDS_SWAP(datumtype); + switch(TYPE_NO_ENDIANNESS(datumtype)) { default: Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) ); @@ -1244,16 +927,17 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char cuv = 0; cdouble = 0; continue; - break; + case '(': { tempsym_t savsym = *symptr; - U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags); + const U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags); symptr->flags |= group_modifiers; symptr->patend = savsym.grpend; 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; @@ -1267,17 +951,11 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char *symptr = savsym; break; } -#ifdef PERL_PACK_CAN_SHRIEKSIGN case '.' | TYPE_IS_SHRIEKING: -#endif case '.': { - char *from; + const char *from; SV *sv; -#ifdef PERL_PACK_CAN_SHRIEKSIGN - bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING); -#else /* PERL_PACK_CAN_SHRIEKSIGN */ - bool u8 = utf8; -#endif + const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING); if (howlen == e_star) from = strbeg; else if (len <= 0) from = s; else { @@ -1289,19 +967,13 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char 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 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) @@ -1321,8 +993,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char if (!len) /* Avoid division by 0 */ len = 1; if (utf8) { - char *hop, *last; - I32 l = len; + const char *hop, *last; + SSize_t l = len; hop = last = strbeg; while (hop < s) { hop += UTF8SKIP(hop); @@ -1337,7 +1009,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char break; } len = (s - strbeg) % len; - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'X': if (utf8) { while (len > 0) { @@ -1355,14 +1027,16 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char s -= len; } break; - case 'x' | TYPE_IS_SHRIEKING: + case 'x' | TYPE_IS_SHRIEKING: { + SSize_t ai32; if (!len) /* Avoid division by 0 */ len = 1; if (utf8) ai32 = utf8_length((U8 *) strbeg, (U8 *) s) % len; else ai32 = (s - strbeg) % len; if (ai32 == 0) break; len -= ai32; - /* FALL THROUGH */ + } + /* FALLTHROUGH */ case 'x': if (utf8) { while (len>0) { @@ -1379,7 +1053,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char break; case '/': Perl_croak(aTHX_ "'/' must follow a numeric type in unpack"); - break; + case 'A': case 'Z': case 'a': @@ -1389,8 +1063,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char goto W_checksum; } if (utf8) { - I32 l; - char *hop; + SSize_t l; + const char *hop; for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) { if (hop >= strend) { if (hop > strend) @@ -1406,7 +1080,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char if (datumtype == 'Z') { /* 'Z' strips stuff after first null */ - char *ptr, *end; + const char *ptr, *end; end = s + len; for (ptr = s; ptr < end; ptr++) if (*ptr == 0) break; sv = newSVpvn(s, ptr-s); @@ -1414,11 +1088,16 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char len = ptr-s + (ptr != strend ? 1 : 0); } else if (datumtype == 'A') { /* 'A' strips both nulls and spaces */ - char *ptr; + const char *ptr; 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; + for (ptr = s+len-1; ptr >= s; ptr--) { + if ( *ptr != 0 + && !UTF8_IS_CONTINUATION(*ptr) + && !isSPACE_utf8_safe(ptr, strend)) + { + break; + } + } if (ptr >= s) ptr += UTF8SKIP(ptr); else ptr++; if (ptr > s+len) @@ -1437,7 +1116,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char if (!(symptr->flags & FLAG_WAS_UTF8)) sv_utf8_downgrade(sv, 0); } - XPUSHs(sv_2mortal(sv)); + mXPUSHs(sv); s += len; break; case 'B': @@ -1446,23 +1125,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char if (howlen == e_star || len > (strend - s) * 8) len = (strend - s) * 8; if (checksum) { - if (!PL_bitcount) { - int bits; - Newz(601, 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)]; + cuv += PL_bitcount[utf8_to_byte(aTHX_ &s, strend, datumtype)]; len -= 8; } else @@ -1487,109 +1152,124 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char break; } - sv = sv_2mortal(NEWSV(35, len ? len : 1)); + sv = sv_2mortal(newSV(len ? len : 1)); SvPOK_on(sv); str = SvPVX(sv); if (datumtype == 'b') { U8 bits = 0; - ai32 = len; + const SSize_t ai32 = len; for (len = 0; len < ai32; len++) { if (len & 7) bits >>= 1; else if (utf8) { if (s >= strend) break; - bits = uni_to_byte(aTHX_ &s, strend, datumtype); + bits = utf8_to_byte(aTHX_ &s, strend, datumtype); } else bits = *(U8 *) s++; *str++ = bits & 1 ? '1' : '0'; } } else { U8 bits = 0; - ai32 = len; + const SSize_t ai32 = len; for (len = 0; len < ai32; len++) { if (len & 7) bits <<= 1; else if (utf8) { if (s >= strend) break; - bits = uni_to_byte(aTHX_ &s, strend, datumtype); + bits = utf8_to_byte(aTHX_ &s, strend, datumtype); } else bits = *(U8 *) s++; *str++ = bits & 0x80 ? '1' : '0'; } } *str = '\0'; - SvCUR_set(sv, str - SvPVX(sv)); + SvCUR_set(sv, str - SvPVX_const(sv)); XPUSHs(sv); break; } 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(35, 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; - ai32 = len; + SSize_t ai32 = len; for (len = 0; len < ai32; len++) { if (len & 1) bits >>= 4; else if (utf8) { if (s >= strend) break; - bits = uni_to_byte(aTHX_ &s, strend, datumtype); + bits = utf8_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; - ai32 = len; + const SSize_t ai32 = len; for (len = 0; len < ai32; len++) { if (len & 1) bits <<= 4; else if (utf8) { if (s >= strend) break; - bits = uni_to_byte(aTHX_ &s, strend, datumtype); + bits = utf8_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(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; + } + /* FALLTHROUGH */ 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) + 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) { - UV val; STRLEN retlen; - val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen, + const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); - if (retlen == (STRLEN) -1 || retlen == 0) + if (retlen == (STRLEN) -1) 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 @@ -1597,8 +1277,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char } } else if (!checksum) while (len-- > 0) { - U8 ch = *(U8 *) s++; - PUSHs(sv_2mortal(newSVuv((UV) ch))); + const U8 ch = *(U8 *) s++; + mPUSHu(ch); } else if (checksum > bits_in_uv) while (len-- > 0) cdouble += (NV) *(U8 *) s++; @@ -1607,7 +1287,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char 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 @@ -1626,28 +1306,33 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char STRLEN retlen; UV auv; if (utf8) { - U8 result[UTF8_MAXLEN]; - char *ptr; + U8 result[UTF8_MAXLEN+1]; + const char *ptr = s; STRLEN len; - ptr = s; /* Bug: warns about bad utf8 even if we are short on bytes and will break out of the loop */ - if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) result, 1, + if (!S_utf8_to_bytes(aTHX_ &ptr, strend, (char *) result, 1, 'U')) break; len = UTF8SKIP(result); - if (!uni_to_bytes(aTHX_ &ptr, strend, + if (!S_utf8_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 = NATIVE_TO_UNI(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); - if (retlen == (STRLEN) -1 || retlen == 0) + auv = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, + strend - s, + &retlen, + UTF8_ALLOW_DEFAULT)); + if (retlen == (STRLEN) -1) Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); s += retlen; } if (!checksum) - PUSHs(sv_2mortal(newSVuv((UV) auv))); + mPUSHu(auv); else if (checksum > bits_in_uv) cdouble += (NV) auv; else @@ -1658,10 +1343,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char #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) - PUSHs(sv_2mortal(newSViv((IV)ashort))); + mPUSHi(ashort); else if (checksum > bits_in_uv) cdouble += (NV)ashort; else @@ -1669,7 +1353,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char } break; #else - /* Fallthrough! */ + /* FALLTHROUGH */ #endif case 's': while (len-- > 0) { @@ -1678,14 +1362,13 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char #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; #endif if (!checksum) - PUSHs(sv_2mortal(newSViv((IV)ai16))); + mPUSHi(ai16); else if (checksum > bits_in_uv) cdouble += (NV)ai16; else @@ -1696,10 +1379,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char #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); if (!checksum) - PUSHs(sv_2mortal(newSVuv((UV) aushort))); + mPUSHu(aushort); else if (checksum > bits_in_uv) cdouble += (NV)aushort; else @@ -1707,7 +1389,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char } break; #else - /* Fallhrough! */ + /* FALLTHROUGH */ #endif case 'v': case 'n': @@ -1717,25 +1399,19 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char #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) - PUSHs(sv_2mortal(newSVuv((UV)au16))); + mPUSHu(au16); else if (checksum > bits_in_uv) cdouble += (NV) au16; else cuv += au16; } break; -#ifdef PERL_PACK_CAN_SHRIEKSIGN case 'v' | TYPE_IS_SHRIEKING: case 'n' | TYPE_IS_SHRIEKING: while (len-- > 0) { @@ -1743,32 +1419,28 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char # 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) - PUSHs(sv_2mortal(newSViv((IV)ai16))); + mPUSHi(ai16); else if (checksum > bits_in_uv) cdouble += (NV) ai16; else 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) - PUSHs(sv_2mortal(newSViv((IV)aint))); + mPUSHi(aint); else if (checksum > bits_in_uv) cdouble += (NV)aint; else @@ -1779,10 +1451,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char 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) - PUSHs(sv_2mortal(newSVuv((UV)auint))); + mPUSHu(auint); else if (checksum > bits_in_uv) cdouble += (NV)auint; else @@ -1792,18 +1463,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char 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) - PUSHs(sv_2mortal(newSViv(aiv))); + mPUSHi(aiv); else if (checksum > bits_in_uv) cdouble += (NV)aiv; else @@ -1813,18 +1475,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char 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) - PUSHs(sv_2mortal(newSVuv(auv))); + mPUSHu(auv); else if (checksum > bits_in_uv) cdouble += (NV)auv; else @@ -1835,10 +1488,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char #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) - PUSHs(sv_2mortal(newSViv((IV)along))); + mPUSHi(along); else if (checksum > bits_in_uv) cdouble += (NV)along; else @@ -1846,7 +1498,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char } break; #else - /* Fallthrough! */ + /* FALLTHROUGH */ #endif case 'l': while (len-- > 0) { @@ -1854,13 +1506,12 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char #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 if (!checksum) - PUSHs(sv_2mortal(newSViv((IV)ai32))); + mPUSHi(ai32); else if (checksum > bits_in_uv) cdouble += (NV)ai32; else @@ -1871,10 +1522,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char #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) - PUSHs(sv_2mortal(newSVuv((UV)aulong))); + mPUSHu(aulong); else if (checksum > bits_in_uv) cdouble += (NV)aulong; else @@ -1882,7 +1532,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char } break; #else - /* Fall through! */ + /* FALLTHROUGH */ #endif case 'V': case 'N': @@ -1892,81 +1542,72 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char #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) - PUSHs(sv_2mortal(newSVuv((UV)au32))); + mPUSHu(au32); else if (checksum > bits_in_uv) cdouble += (NV)au32; else 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) - PUSHs(sv_2mortal(newSViv((IV)ai32))); + mPUSHi(ai32); else if (checksum > bits_in_uv) cdouble += (NV)ai32; else cuv += ai32; } break; -#endif /* PERL_PACK_CAN_SHRIEKSIGN */ case 'p': while (len-- > 0) { - char *aptr; - SHIFT_VAR(utf8, s, strend, aptr, datumtype); - DO_BO_UNPACK_PC(aptr); + const char *aptr; + SHIFT_VAR(utf8, s, strend, aptr, datumtype, needs_swap); /* newSVpv generates undef if aptr is NULL */ - PUSHs(sv_2mortal(newSVpv(aptr, 0))); + mPUSHs(newSVpv(aptr, 0)); } break; case 'w': { UV auv = 0; - U32 bytes = 0; + size_t bytes = 0; while (len > 0 && s < strend) { U8 ch; ch = SHIFT_BYTE(utf8, s, strend, datumtype); auv = (auv << 7) | (ch & 0x7f); - /* UTF8_IS_XXXXX not right here - using constant 0x80 */ + /* UTF8_IS_XXXXX not right here because this is a BER, not + * UTF-8 format - using constant 0x80 */ if (ch < 0x80) { bytes = 0; - PUSHs(sv_2mortal(newSVuv(auv))); + mPUSHu(auv); len--; auv = 0; continue; } if (++bytes >= sizeof(UV)) { /* promote to string */ - char *t; - STRLEN n_a; + const char *t; - sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv); + sv = Perl_newSVpvf(aTHX_ "%.*" UVuf, + (int)TYPE_DIGITS(UV), auv); while (s < strend) { ch = SHIFT_BYTE(utf8, s, strend, datumtype); sv = mul128(sv, (U8)(ch & 0x7f)); @@ -1975,11 +1616,11 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char break; } } - t = SvPV(sv, n_a); + t = SvPV_nolen_const(sv); while (*t == '0') t++; sv_chop(sv, t); - PUSHs(sv_2mortal(sv)); + mPUSHs(sv); len--; auv = 0; } @@ -1992,23 +1633,20 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char if (symptr->howlen == e_star) Perl_croak(aTHX_ "'P' must have an explicit size in unpack"); EXTEND(SP, 1); - if (sizeof(char*) <= strend - s) { + 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(sv_2mortal(newSVpvn(aptr, len))); + 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) - PUSHs(sv_2mortal(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 @@ -2018,26 +1656,23 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char 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) - PUSHs(sv_2mortal(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) - PUSHs(sv_2mortal(newSVnv((NV)afloat))); + mPUSHn(afloat); else cdouble += afloat; } @@ -2045,131 +1680,109 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char 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) - 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, needs_swap); 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, 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) - 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['M'] == 0) { - int i; - - for (i = 0; i < sizeof(PL_uuemap); i += 1) - PL_uudmap[(U8)PL_uuemap[i]] = i; - /* - * Because ' ' and '`' map to the same value, - * we need to decode them both the same. - */ - PL_uudmap[' '] = 0; + if (!checksum) { + const STRLEN l = (STRLEN) (strend - s) * 3 / 4; + sv = sv_2mortal(newSV(l)); + if (l) { + SvPOK_on(sv); + *SvEND(sv) = '\0'; + } + } + + /* Note that all legal uuencoded strings are ASCII printables, so + * have the same representation under UTF-8 vs not. This means we + * can ignore UTF8ness on legal input. For illegal we stop at the + * first failure, and don't report where/what that is, so again we + * can ignore UTF8ness */ + + while (s < strend && *s != ' ' && ISUUCHAR(*s)) { + I32 a, b, c, d; + char hunk[3]; + + len = PL_uudmap[*(U8*)s++] & 077; + while (len > 0) { + if (s < strend && ISUUCHAR(*s)) + a = PL_uudmap[*(U8*)s++] & 077; + else + a = 0; + if (s < strend && ISUUCHAR(*s)) + b = PL_uudmap[*(U8*)s++] & 077; + else + b = 0; + if (s < strend && ISUUCHAR(*s)) + c = PL_uudmap[*(U8*)s++] & 077; + else + c = 0; + if (s < strend && ISUUCHAR(*s)) + d = PL_uudmap[*(U8*)s++] & 077; + else + d = 0; + hunk[0] = (char)((a << 2) | (b >> 4)); + hunk[1] = (char)((b << 4) | (c >> 2)); + hunk[2] = (char)((c << 6) | d); + if (!checksum) + sv_catpvn(sv, hunk, (len > 3) ? 3 : len); + len -= 3; + } + if (*s == '\n') + s++; + else /* possible checksum byte */ + if (s + 1 < strend && s[1] == '\n') + s += 2; } - { - STRLEN l = (STRLEN) (strend - s) * 3 / 4; - sv = sv_2mortal(NEWSV(42, l)); - if (l) SvPOK_on(sv); - } - if (utf8) { - while (next_uni_uu(aTHX_ &s, strend, &len)) { - I32 a, b, c, d; - char hunk[4]; - - hunk[3] = '\0'; - while (len > 0) { - next_uni_uu(aTHX_ &s, strend, &a); - next_uni_uu(aTHX_ &s, strend, &b); - next_uni_uu(aTHX_ &s, strend, &c); - next_uni_uu(aTHX_ &s, strend, &d); - hunk[0] = (char)((a << 2) | (b >> 4)); - hunk[1] = (char)((b << 4) | (c >> 2)); - hunk[2] = (char)((c << 6) | d); - sv_catpvn(sv, hunk, (len > 3) ? 3 : len); - len -= 3; - } - if (s < strend) { - if (*s == '\n') s++; - else { - /* possible checksum byte */ - char *skip = s+UTF8SKIP(s); - if (skip < strend && *skip == '\n') s = skip+1; - } - } - } - } else { - while (s < strend && *s > ' ' && ISUUCHAR(*s)) { - I32 a, b, c, d; - char hunk[4]; - - hunk[3] = '\0'; - len = PL_uudmap[*(U8*)s++] & 077; - while (len > 0) { - if (s < strend && ISUUCHAR(*s)) - a = PL_uudmap[*(U8*)s++] & 077; - else - a = 0; - if (s < strend && ISUUCHAR(*s)) - b = PL_uudmap[*(U8*)s++] & 077; - else - b = 0; - if (s < strend && ISUUCHAR(*s)) - c = PL_uudmap[*(U8*)s++] & 077; - else - c = 0; - if (s < strend && ISUUCHAR(*s)) - d = PL_uudmap[*(U8*)s++] & 077; - else - d = 0; - hunk[0] = (char)((a << 2) | (b >> 4)); - hunk[1] = (char)((b << 4) | (c >> 2)); - hunk[2] = (char)((c << 6) | d); - sv_catpvn(sv, hunk, (len > 3) ? 3 : len); - len -= 3; - } - if (*s == '\n') - s++; - else /* possible checksum byte */ - if (s + 1 < strend && s[1] == '\n') - s += 2; - } - } - XPUSHs(sv); + if (!checksum) + XPUSHs(sv); break; - } + } /* End of switch */ if (checksum) { - if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) || + if (memCHRs("fFdD", TYPE_NO_MODIFIERS(datumtype)) || (checksum > bits_in_uv && - strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) { + memCHRs("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) { NV trouble, anv; anv = (NV) (1 << (checksum & 15)); @@ -2179,7 +1792,18 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char } while (cdouble < 0.0) cdouble += anv; - cdouble = Perl_modf(cdouble / anv, &trouble) * anv; + cdouble = Perl_modf(cdouble / anv, &trouble); +#ifdef LONGDOUBLE_DOUBLEDOUBLE + /* Workaround for powerpc doubledouble modfl bug: + * close to 1.0L and -1.0L cdouble is 0, and trouble + * is cdouble / anv. */ + if (trouble != Perl_ceil(trouble)) { + cdouble = trouble; + if (cdouble > 1.0L) cdouble -= 1.0L; + if (cdouble < -1.0L) cdouble += 1.0L; + } +#endif + cdouble *= anv; sv = newSVnv(cdouble); } else { @@ -2189,13 +1813,13 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char } sv = newSVuv(cuv); } - XPUSHs(sv_2mortal(sv)); + mXPUSHs(sv); checksum = 0; } 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" ); @@ -2227,14 +1851,14 @@ PP(pp_unpack) { dSP; dPOPPOPssrl; - I32 gimme = GIMME_V; + U8 gimme = GIMME_V; STRLEN llen; STRLEN rlen; - char *pat = SvPV(left, llen); - char *s = SvPV(right, rlen); - char *strend = s + rlen; - char *patend = pat + llen; - I32 cnt; + const char *pat = SvPV_const(left, llen); + const char *s = SvPV_const(right, rlen); + const char *strend = s + rlen; + const char *patend = pat + llen; + SSize_t cnt; PUTBACK; cnt = unpackstring(pat, patend, s, strend, @@ -2248,7 +1872,7 @@ PP(pp_unpack) } STATIC U8 * -doencodes(U8 *h, char *s, I32 len) +doencodes(U8 *h, const U8 *s, SSize_t len) { *h++ = PL_uuemap[len]; while (len > 2) { @@ -2260,7 +1884,7 @@ doencodes(U8 *h, char *s, I32 len) len -= 3; } if (len > 0) { - char r = (len > 1 ? s[1] : '\0'); + const U8 r = (len > 1 ? s[1] : '\0'); *h++ = PL_uuemap[(077 & (s[0] >> 2))]; *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))]; *h++ = PL_uuemap[(077 & ((r << 2) & 074))]; @@ -2271,14 +1895,15 @@ doencodes(U8 *h, char *s, I32 len) } STATIC SV * -S_is_an_int(pTHX_ char *s, STRLEN l) +S_is_an_int(pTHX_ const char *s, STRLEN l) { - STRLEN n_a; - SV *result = newSVpvn(s, l); - char *result_c = SvPV(result, n_a); /* convenience */ - char *out = result_c; - bool skip = 1; - bool ignore = 0; + SV *result = newSVpvn(s, l); + char *const result_c = SvPV_nolen(result); /* convenience */ + char *out = result_c; + bool skip = 1; + bool ignore = 0; + + PERL_ARGS_ASSERT_IS_AN_INT; while (*s) { switch (*s) { @@ -2323,74 +1948,50 @@ S_is_an_int(pTHX_ char *s, STRLEN l) STATIC int S_div128(pTHX_ SV *pnum, bool *done) { - STRLEN len; - char *s = SvPV(pnum, len); - int m = 0; - int r = 0; - char *t = s; - - *done = 1; - while (*t) { - int i; - - i = m * 10 + (*t - '0'); - m = i & 0x7F; - r = (i >> 7); /* r < 10 */ - if (r) { - *done = 0; + STRLEN len; + char * const s = SvPV(pnum, len); + char *t = s; + int m = 0; + + PERL_ARGS_ASSERT_DIV128; + + *done = 1; + while (*t) { + const int i = m * 10 + (*t - '0'); + const int r = (i >> 7); /* r < 10 */ + m = i & 0x7F; + if (r) { + *done = 0; + } + *(t++) = '0' + r; } - *(t++) = '0' + r; - } - *(t++) = '\0'; - SvCUR_set(pnum, (STRLEN) (t - s)); - return (m); -} - - - -/* -=for apidoc pack_cat - -The engine implementing pack() Perl function. Note: parameters next_in_list and -flags are not used. This call should not be used; use packlist instead. - -=cut */ - - -void -Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags) -{ - tempsym_t sym = { 0 }; - sym.patptr = pat; - sym.patend = patend; - sym.flags = FLAG_PACK; - - (void)pack_rec( cat, &sym, beglist, endlist ); + *(t++) = '\0'; + SvCUR_set(pnum, (STRLEN) (t - s)); + return (m); } - /* =for apidoc packlist -The engine implementing pack() Perl function. - -=cut */ +The engine implementing C Perl function. +=cut +*/ void -Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist ) +Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist ) { - STRLEN no_len; - tempsym_t sym = { 0 }; + tempsym_t sym; + + PERL_ARGS_ASSERT_PACKLIST; - sym.patptr = pat; - sym.patend = patend; - sym.flags = FLAG_PACK; + TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK); /* We're going to do changes through SvPVX(cat). Make sure it's valid. Also make sure any UTF8 flag is loaded */ - SvPV_force(cat, no_len); - if (DO_UTF8(cat)) sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8; + SvPV_force_nolen(cat); + if (DO_UTF8(cat)) + sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8; (void)pack_rec( cat, &sym, beglist, endlist ); } @@ -2400,14 +2001,15 @@ STATIC void marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) { STRLEN len; tempsym_t *group; - char *from_ptr, *to_start, *to_ptr, **marks, **m, *from_start, *from_end; + const char *from_ptr, *from_start, *from_end, **marks, **m; + char *to_start, *to_ptr; if (SvUTF8(sv)) return; - from_start = SvPVX(sv); + 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); @@ -2415,11 +2017,11 @@ marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) { } len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1; - New('U', to_start, len, char); + Newx(to_start, len, char); Copy(from_start, to_start, from_ptr-from_start, char); to_ptr = to_start + (from_ptr-from_start); - New('U', marks, sym_ptr->level+2, char *); + Newx(marks, sym_ptr->level+2, const char *); for (group=sym_ptr; group; group = group->previous) marks[group->level] = from_start + group->strbeg; marks[sym_ptr->level+1] = from_end+1; @@ -2436,7 +2038,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; @@ -2463,23 +2066,52 @@ marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) { Only grows the string if there is an actual lack of space */ STATIC char * -sv_exp_grow(pTHX_ SV *sv, STRLEN needed) { - STRLEN cur = SvCUR(sv); - STRLEN len = SvLEN(sv); +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); } +static SV * +S_sv_check_infnan(pTHX_ SV *sv, I32 datumtype) +{ + SvGETMAGIC(sv); + if (UNLIKELY(SvAMAGIC(sv))) + sv = sv_2num(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); + } + return sv; +} + +#define SvIV_no_inf(sv,d) \ + ((sv) = S_sv_check_infnan(aTHX_ sv,d), SvIV_nomg(sv)) +#define SvUV_no_inf(sv,d) \ + ((sv) = 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 ) { tempsym_t lookahead; - I32 items = endlist - beglist; + SSize_t 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; if (symptr->level == 0 && found && symptr->code == 'U') { marked_upgrade(aTHX_ cat, symptr); @@ -2491,18 +2123,20 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) while (found) { SV *fromstr; STRLEN fromlen; - I32 len; - SV *lengthcode = Nullsv; + SSize_t len; + SV *lengthcode = NULL; I32 datumtype = symptr->code; 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 NEXTFROM (lengthcode ? lengthcode : items > 0 ? (--items, *beglist++) : &PL_sv_no) +#define PEEKFROM (lengthcode ? lengthcode : items > 0 ? *beglist : &PL_sv_no) switch (howlen) { case e_star: - len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? + len = memCHRs("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items; break; default: @@ -2517,7 +2151,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (props && !(props & PACK_SIZE_UNPREDICTABLE)) { /* We can process this letter. */ STRLEN size = props & PACK_SIZE_MASK; - GROWING(utf8, cat, start, cur, (STRLEN) len * size); + GROWING2(utf8, cat, start, cur, size, (STRLEN)len); } } @@ -2527,12 +2161,12 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (symptr->flags & FLAG_SLASH) { IV count; if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack"); - if (strchr("aAZ", lookahead.code)) { + if (memCHRs("aAZ", lookahead.code)) { if (lookahead.howlen == e_number) count = lookahead.length; else { - if (items > 0) - count = DO_UTF8(*beglist) ? - sv_len_utf8(*beglist) : sv_len(*beglist); + if (items > 0) { + count = sv_len_utf8(*beglist); + } else count = 0; if (lookahead.code == 'Z') count++; } @@ -2546,20 +2180,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; @@ -2570,19 +2203,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); @@ -2613,7 +2240,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); @@ -2635,6 +2262,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (savsym.howlen == e_star && beglist == endlist) break; /* No way to continue */ } + items = endlist - beglist; lookahead.flags = symptr->flags & ~group_modifiers; goto no_change; } @@ -2643,7 +2271,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) len = 1; if (utf8) { char *hop, *last; - I32 l = len; + SSize_t l = len; hop = last = start; while (hop < cur) { hop += UTF8SKIP(hop); @@ -2658,7 +2286,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; @@ -2684,7 +2312,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (cur < start+symptr->strbeg) { /* Make sure group starts don't point into the void */ tempsym_t *group; - STRLEN length = cur-start; + const STRLEN length = cur-start; for (group = symptr; group && length < group->strbeg; group = group->previous) group->strbeg = length; @@ -2692,7 +2320,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) } break; case 'x' | TYPE_IS_SHRIEKING: { - I32 ai32; + SSize_t ai32; if (!len) /* Avoid division by 0 */ len = 1; if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len; @@ -2700,18 +2328,18 @@ 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': case 'Z': case 'a': { - char *aptr; + const char *aptr; fromstr = NEXTFROM; - aptr = SvPV(fromstr, fromlen); + aptr = SvPV_const(fromstr, fromlen); if (DO_UTF8(fromstr)) { - char *end, *s; + const char *end, *s; if (!utf8 && !SvUTF8(cat)) { marked_upgrade(aTHX_ cat, symptr); @@ -2728,7 +2356,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) s = aptr; end = aptr + fromlen; fromlen = datumtype == 'Z' ? len-1 : len; - while ((I32) fromlen > 0 && s < end) { + while ((SSize_t) fromlen > 0 && s < end) { s += UTF8SKIP(s); fromlen--; } @@ -2749,9 +2377,11 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (datumtype == 'Z') len++; } GROWING(0, cat, start, cur, len); - if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen, + if (!S_utf8_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=%zu", + (int)datumtype, aptr, end, cur, fromlen); cur += fromlen; len -= fromlen; } else if (utf8) { @@ -2759,7 +2389,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) len = fromlen; if (datumtype == 'Z') len++; } - if (len <= (I32) fromlen) { + if (len <= (SSize_t) fromlen) { fromlen = len; if (datumtype == 'Z' && fromlen > 0) fromlen--; } @@ -2779,7 +2409,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) len = fromlen; if (datumtype == 'Z') len++; } - if (len <= (I32) fromlen) { + if (len <= (SSize_t) fromlen) { fromlen = len; if (datumtype == 'Z' && fromlen > 0) fromlen--; } @@ -2790,22 +2420,23 @@ 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': case 'b': { - char *str, *end; - I32 l, field_len; + const char *str, *end; + SSize_t l, field_len; U8 bits; bool utf8_source; U32 utf8_flags; fromstr = NEXTFROM; - str = SvPV(fromstr, fromlen); + str = SvPV_const(fromstr, fromlen); end = str + fromlen; if (DO_UTF8(fromstr)) { utf8_source = TRUE; - utf8_flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; + utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY; } else { utf8_source = FALSE; utf8_flags = 0; /* Unused, but keep compilers happy */ @@ -2813,13 +2444,13 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (howlen == e_star) len = fromlen; field_len = (len+7)/8; GROWING(utf8, cat, start, cur, field_len); - if (len > (I32)fromlen) len = fromlen; + if (len > (SSize_t)fromlen) len = fromlen; bits = 0; l = 0; if (datumtype == 'B') while (l++ < len) { if (utf8_source) { - UV val; + UV val = 0; NEXT_UNI_VAL(val, cur, str, end, utf8_flags); bits |= val & 1; } else bits |= *str++ & 1; @@ -2833,7 +2464,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) /* datumtype == 'b' */ while (l++ < len) { if (utf8_source) { - UV val; + UV val = 0; NEXT_UNI_VAL(val, cur, str, end, utf8_flags); if (val & 1) bits |= 0x80; } else if (*str++ & 1) @@ -2863,18 +2494,18 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) } case 'H': case 'h': { - char *str, *end; - I32 l, field_len; + const char *str, *end; + SSize_t l, field_len; U8 bits; bool utf8_source; U32 utf8_flags; fromstr = NEXTFROM; - str = SvPV(fromstr, fromlen); + str = SvPV_const(fromstr, fromlen); end = str + fromlen; if (DO_UTF8(fromstr)) { utf8_source = TRUE; - utf8_flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; + utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY; } else { utf8_source = FALSE; utf8_flags = 0; /* Unused, but keep compilers happy */ @@ -2882,13 +2513,13 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (howlen == e_star) len = fromlen; field_len = (len+1)/2; GROWING(utf8, cat, start, cur, field_len); - if (!utf8 && len > (I32)fromlen) len = fromlen; + if (!utf8_source && len > (SSize_t)fromlen) len = fromlen; bits = 0; l = 0; if (datumtype == 'H') while (l++ < len) { if (utf8_source) { - UV val; + UV val = 0; NEXT_UNI_VAL(val, cur, str, end, utf8_flags); if (val < 256 && isALPHA(val)) bits |= (val + 9) & 0xf; @@ -2907,7 +2538,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) else while (l++ < len) { if (utf8_source) { - UV val; + UV val = 0; NEXT_UNI_VAL(val, cur, str, end, utf8_flags); if (val < 256 && isALPHA(val)) bits |= ((val + 9) & 0xf) << 4; @@ -2940,12 +2571,11 @@ 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"); - PUSH_BYTE(utf8, cur, aiv & 0xff); + 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; case 'C': @@ -2953,42 +2583,37 @@ 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++ = aiv & 0xff; + 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; case 'W': { char *end; - U8 in_bytes = IN_BYTES; + U8 in_bytes = (U8)IN_BYTES; end = start+SvLEN(cat)-1; if (utf8) end -= UTF8_MAXLEN-1; 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: - if (cur > end) { + if (cur >= end) { *cur = '\0'; SvCUR_set(cat, cur - start); 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), - ckWARN(WARN_UTF8) ? - 0 : UNICODE_ALLOW_ANY); + cur = (char *) uvchr_to_utf8_flags((U8 *) cur, auv, 0); } else { if (auv >= 0x100) { if (!SvUTF8(cat)) { @@ -3003,9 +2628,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) { @@ -3037,12 +2661,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, - ckWARN(WARN_UTF8) ? - 0 : UNICODE_ALLOW_ANY); + U8 buffer[UTF8_MAXLEN+1], *endb; + endb = uvchr_to_utf8_flags(buffer, UNI_TO_NATIVE(auv), 0); if (cur+(endb-buffer)*UTF8_EXPAND >= end) { *cur = '\0'; SvCUR_set(cat, cur - start); @@ -3050,7 +2672,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) len+(endb-buffer)*UTF8_EXPAND); end = start+SvLEN(cat); } - bytes_to_uni(aTHX_ buffer, endb-buffer, &cur); + cur = my_bytes_to_utf8(buffer, endb-buffer, cur, 0); } else { if (cur >= end) { *cur = '\0'; @@ -3058,9 +2680,9 @@ 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, - ckWARN(WARN_UTF8) ? - 0 : UNICODE_ALLOW_ANY); + cur = (char *) uvchr_to_utf8_flags((U8 *) cur, + UNI_TO_NATIVE(auv), + 0); } } break; @@ -3072,20 +2694,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. */ - 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)) || defined(DOUBLE_IS_VAX_FLOAT) /* IEEE fp overflow shenanigans are unavailable on VAX and optional * on Alpha; fake it if we don't have them. */ @@ -3095,11 +2704,19 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) afloat = -FLT_MAX; else afloat = (float)anv; # else - afloat = (float)anv; +# if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) + if(Perl_isnan(anv)) + afloat = (float)NV_NAN; + else +# endif +# ifdef NV_INF + /* a simple cast to float is undefined if outside + * the range of values that can be represented */ + afloat = (float)(anv > FLT_MAX ? NV_INF : + anv < -FLT_MAX ? -NV_INF : anv); +# endif # endif -#endif /* __VOS__ */ - DO_BO_PACK_N(afloat, float); - PUSH_VAR(utf8, cur, afloat); + PUSH_VAR(utf8, cur, afloat, needs_swap); } break; case 'd': @@ -3108,20 +2725,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 long double to double into infinity, - so we do it by hand. This code should either be generalized - for any OS that needs it, or removed if and when VOS - implements posix-976 (suggestion to support mapping to - infinity). Paul.Green@stratus.com 02-04-02. */ - if (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)) || defined(DOUBLE_IS_VAX_FLOAT) /* IEEE fp overflow shenanigans are unavailable on VAX and optional * on Alpha; fake it if we don't have them. */ @@ -3133,62 +2737,72 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) # 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); +# if defined(LONGDOUBLE_X86_80_BIT) && defined(USE_LONG_DOUBLE) \ + && LONG_DOUBLESIZE > 10 + /* GCC sometimes overwrites the padding in the + assignment above */ + Zero(anv.bytes+10, sizeof(anv.bytes) - 10, U8); +# endif +#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); +# if defined(LONGDOUBLE_X86_80_BIT) && LONG_DOUBLESIZE > 10 + /* GCC sometimes overwrites the padding in the + assignment above */ + Zero(aldouble.bytes+10, sizeof(aldouble.bytes) - 10, U8); +# endif +# 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: @@ -3196,21 +2810,19 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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: @@ -3218,21 +2830,19 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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': @@ -3240,50 +2850,32 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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'; @@ -3299,7 +2891,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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); @@ -3312,7 +2904,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. @@ -3330,9 +2922,9 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) #endif char *in = buf + sizeof(buf); - anv = Perl_floor(anv); + anv = Perl_floor(anv); do { - NV next = Perl_floor(anv / 128); + const NV next = Perl_floor(anv / 128); if (in <= buf) /* this cannot happen ;-) */ Perl_croak(aTHX_ "Cannot compress integer in pack"); *--in = (unsigned char)(anv - (next * 128)) | 0x80; @@ -3342,18 +2934,19 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) PUSH_GROWING_BYTES(utf8, cat, start, cur, in, (buf + sizeof(buf)) - in); } else { - char *from, *result, *in; + const char *from; + char *result, *in; SV *norm; STRLEN len; bool done; w_string: /* Copy string and check for compliance */ - from = SvPV(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"); - New('w', result, len, char); + Newx(result, len, char); in = result + len; done = FALSE; while (!done) *--in = div128(norm, &done) | 0x80; @@ -3370,37 +2963,28 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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: @@ -3408,9 +2992,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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 @@ -3420,9 +3003,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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: @@ -3430,9 +3012,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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 @@ -3442,106 +3023,103 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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) { - char *aptr; + const char *aptr; fromstr = NEXTFROM; SvGETMAGIC(fromstr); if (!SvOK(fromstr)) aptr = NULL; else { - STRLEN n_a; /* XXX better yet, could spirit away the string to * a safe spot and hang on to it until the result * of pack() (and all copies of the result) are * gone. */ - if (ckWARN(WARN_PACK) && - (SvTEMP(fromstr) || (SvPADTMP(fromstr) && - !SvREADONLY(fromstr)))) { - Perl_warner(aTHX_ packWARN(WARN_PACK), - "Attempt to pack pointer to temporary value"); + if (((SvTEMP(fromstr) && SvREFCNT(fromstr) == 1) + || (SvPADTMP(fromstr) && + !SvREADONLY(fromstr)))) { + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Attempt to pack pointer to temporary value"); } if (SvPOK(fromstr) || SvNIOK(fromstr)) - aptr = SvPV_flags(fromstr, n_a, 0); + aptr = SvPV_nomg_const_nolen(fromstr); else - aptr = SvPV_force_flags(fromstr, n_a, 0); + 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': { - char *aptr, *aend; + const char *aptr, *aend; bool from_utf8; fromstr = NEXTFROM; if (len <= 2) len = 45; else len = len / 3 * 3; if (len >= 64) { - 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(fromstr, fromlen); + 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) { U8 *end; - I32 todo; + SSize_t todo; U8 hunk[1+63/3*4+1]; - if ((I32)fromlen > len) + if ((SSize_t)fromlen > len) todo = len; else todo = fromlen; if (from_utf8) { char buffer[64]; - if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo, + if (!S_utf8_to_bytes(aTHX_ &aptr, aend, buffer, todo, '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=%zd", + aptr, aend, buffer, todo); } - end = doencodes(hunk, buffer, todo); + end = doencodes(hunk, (const U8 *)buffer, todo); } else { - end = doencodes(hunk, aptr, todo); + end = doencodes(hunk, (const U8 *)aptr, todo); aptr += todo; } - PUSH_BYTES(utf8, cur, hunk, end-hunk); + PUSH_BYTES(utf8, cur, hunk, end-hunk, 0); fromlen -= todo; } break; @@ -3560,17 +3138,33 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) PP(pp_pack) { dSP; dMARK; dORIGMARK; dTARGET; - register SV *cat = TARG; + SV *cat = TARG; STRLEN fromlen; - register char *pat = SvPVx(*++MARK, fromlen); - register char *patend = pat + fromlen; + SV *pat_sv = *++MARK; + const char *pat = SvPV_const(pat_sv, fromlen); + const char *patend = pat + fromlen; MARK++; - sv_setpvn(cat, "", 0); + SvPVCLEAR(cat); SvUTF8_off(cat); packlist(cat, pat, patend, MARK, SP + 1); + if (SvUTF8(cat)) { + STRLEN result_len; + const char * result = SvPV_nomg(cat, result_len); + const U8 * error_pos; + + if (! is_utf8_string_loc((U8 *) result, result_len, &error_pos)) { + _force_out_malformed_utf8_message(error_pos, + (U8 *) result + result_len, + 0, /* no flags */ + 1 /* Die */ + ); + NOT_REACHED; /* NOTREACHED */ + } + } + SvSETMAGIC(cat); SP = ORIGMARK; PUSHs(cat); @@ -3578,11 +3172,5 @@ PP(pp_pack) } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: t - * End: - * - * vim: shiftwidth=4: -*/ + * ex: set ts=8 sts=4 sw=4 et: + */