X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a1219b5e0bb6c311848c834f67e70ff7a19c6bf4..1f4ef0f182b07bd3c970ed636971821c8f754668:/pp_pack.c diff --git a/pp_pack.c b/pp_pack.c index 2819421..d35a5af 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -129,28 +129,10 @@ typedef union { # define OFF32(p) ((char *) (p)) #endif -/* Only to be used inside a loop (see the break) */ -#define SHIFT16(utf8, s, strend, p, datumtype) STMT_START { \ - if (utf8) { \ - if (!uni_to_bytes(aTHX_ &(s), strend, OFF16(p), SIZE16, datumtype)) break; \ - } else { \ - Copy(s, OFF16(p), SIZE16, char); \ - (s) += SIZE16; \ - } \ -} STMT_END - -/* Only to be used inside a loop (see the break) */ -#define SHIFT32(utf8, s, strend, p, datumtype) STMT_START { \ - if (utf8) { \ - if (!uni_to_bytes(aTHX_ &(s), strend, OFF32(p), SIZE32, datumtype)) break; \ - } else { \ - Copy(s, OFF32(p), SIZE32, char); \ - (s) += SIZE32; \ - } \ -} STMT_END - -#define PUSH16(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF16(p), SIZE16) -#define PUSH32(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF32(p), SIZE32) +#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) #if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */ # define NEEDS_SWAP(d) (TYPE_ENDIANNESS(d) == TYPE_IS_LITTLE_ENDIAN) @@ -158,26 +140,39 @@ typedef union { # 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. */ + /* Need to add code here to re-instate mixed endian support. + NEEDS_SWAP would need to hold a flag indicating which action to + take, and S_reverse_copy and the code in uni_to_bytes would need + logic adding to deal with any mixed-endian transformations needed. + */ #endif /* Only to be used inside a loop (see the break) */ -#define SHIFT_BYTES(utf8, s, strend, buf, len, datumtype) \ +#define SHIFT_BYTES(utf8, s, strend, buf, len, datumtype, needs_swap) \ STMT_START { \ - if (utf8) { \ + if (UNLIKELY(utf8)) { \ if (!uni_to_bytes(aTHX_ &s, strend, \ (char *) (buf), len, datumtype)) break; \ } else { \ - Copy(s, (char *) (buf), len, char); \ + if (UNLIKELY(needs_swap)) \ + S_reverse_copy(s, (char *) (buf), len); \ + else \ + Copy(s, (char *) (buf), len, char); \ s += len; \ } \ } STMT_END -#define SHIFT_VAR(utf8, s, strend, var, datumtype) \ - SHIFT_BYTES(utf8, s, strend, &(var), sizeof(var), datumtype) +#define 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 PUSH_VAR(utf8, aptr, var) \ - PUSH_BYTES(utf8, aptr, &(var), sizeof(var)) +#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 @@ -246,65 +241,20 @@ S_mul128(pTHX_ SV *sv, U8 m) # define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP(" -#if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */ - -# define DO_BO_UNPACK(var, type) \ - STMT_START { \ - if (needs_swap) { \ - my_swabn(&var, sizeof(var)); \ - } \ - } STMT_END - -# define DO_BO_PACK(var, type) \ - STMT_START { \ - if (needs_swap) { \ - my_swabn(&var, sizeof(var)); \ - } \ - } STMT_END - -# elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */ - -# define DO_BO_UNPACK(var, type) \ - STMT_START { \ - if (needs_swap) { \ - my_swabn(&var, sizeof(var)); \ - } \ - } STMT_END - -# define DO_BO_PACK(var, type) \ - STMT_START { \ - if (needs_swap) { \ - my_swabn(&var, sizeof(var)); \ - } \ - } STMT_END - -#else -# define DO_BO_UNPACK(var, type) BO_CANT_DOIT(unpack, type) -# define DO_BO_PACK(var, type) BO_CANT_DOIT(pack, type) -#endif - -# 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 - #define PACK_SIZE_CANNOT_CSUM 0x80 #define PACK_SIZE_UNPREDICTABLE 0x40 /* Not a fixed size element */ #define PACK_SIZE_MASK 0x3F #include "packsizetables.c" +static void +S_reverse_copy(const char *src, char *dest, STRLEN len) +{ + dest += len; + while (len--) + *--dest = *src++; +} + STATIC U8 uni_to_byte(pTHX_ const char **s, const char *end, I32 datumtype) { @@ -340,6 +290,11 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len int bad = 0; const U32 flags = ckWARN(WARN_UTF8) ? UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY | UTF8_ALLOW_ANY); + const bool needs_swap = NEEDS_SWAP(datumtype); + + if (UNLIKELY(needs_swap)) + buf += buf_len; + for (;buf_len > 0; buf_len--) { if (from >= end) return FALSE; val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags); @@ -351,7 +306,10 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len bad |= 2; val &= 0xff; } - *(U8 *)buf++ = (U8)val; + if (UNLIKELY(needs_swap)) + *(U8 *)--buf = (U8)val; + else + *(U8 *)buf++ = (U8)val; } /* We have enough characters for the buffer. Did we have problems ? */ if (bad) { @@ -361,7 +319,7 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len const int flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) { if (ptr >= end) break; - utf8n_to_uvuni((U8 *) ptr, end-ptr, &retlen, flags); + utf8n_to_uvchr((U8 *) ptr, end-ptr, &retlen, flags); } if (from > end) from = end; } @@ -379,7 +337,6 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len STATIC bool next_uni_uu(pTHX_ const char **s, const char *end, I32 *out) { - dVAR; STRLEN retlen; const UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY); if (val >= 0x100 || !ISUUCHAR(val) || @@ -393,30 +350,33 @@ next_uni_uu(pTHX_ const char **s, const char *end, I32 *out) } STATIC char * -S_bytes_to_uni(const U8 *start, STRLEN len, char *dest) { - const U8 * const end = start + len; - +S_bytes_to_uni(const U8 *start, STRLEN len, char *dest, const bool needs_swap) { PERL_ARGS_ASSERT_BYTES_TO_UNI; - while (start < end) { - const UV uv = NATIVE_TO_ASCII(*start); - if (UNI_IS_INVARIANT(uv)) - *dest++ = (char)(U8)UTF_TO_NATIVE(uv); - else { - *dest++ = (char)(U8)UTF8_EIGHT_BIT_HI(uv); - *dest++ = (char)(U8)UTF8_EIGHT_BIT_LO(uv); - } - start++; + if (UNLIKELY(needs_swap)) { + const U8 *p = start + len; + while (p-- > start) { + append_utf8_from_native_byte(*p, (U8 **) & dest); + } + } else { + const U8 * const end = start + len; + while (start < end) { + append_utf8_from_native_byte(*start, (U8 **) & dest); + start++; + } } return dest; } -#define PUSH_BYTES(utf8, cur, buf, len) \ +#define PUSH_BYTES(utf8, cur, buf, len, needs_swap) \ STMT_START { \ - if (utf8) \ - (cur) = bytes_to_uni((U8 *) buf, len, (cur)); \ + if (UNLIKELY(utf8)) \ + (cur) = S_bytes_to_uni((U8 *) buf, len, (cur), needs_swap); \ else { \ - Copy(buf, cur, len, char); \ + if (UNLIKELY(needs_swap)) \ + S_reverse_copy((char *)(buf), cur, len); \ + else \ + Copy(buf, cur, len, char); \ (cur) += (len); \ } \ } STMT_END @@ -442,14 +402,14 @@ STMT_START { \ (start) = sv_exp_grow(cat, gl); \ (cur) = (start) + SvCUR(cat); \ } \ - PUSH_BYTES(utf8, cur, buf, glen); \ + PUSH_BYTES(utf8, cur, buf, glen, 0); \ } STMT_END #define PUSH_BYTE(utf8, s, byte) \ STMT_START { \ if (utf8) { \ const U8 au8 = (byte); \ - (s) = bytes_to_uni(&au8, 1, (s)); \ + (s) = S_bytes_to_uni(&au8, 1, (s), 0); \ } else *(U8 *)(s)++ = (byte); \ } STMT_END @@ -487,7 +447,7 @@ S_measure_struct(pTHX_ tempsym_t* symptr) case e_star: Perl_croak(aTHX_ "Within []-length '*' not allowed in %s", _action( symptr ) ); - break; + default: /* e_no_len and e_number */ len = symptr->length; @@ -536,7 +496,7 @@ S_measure_struct(pTHX_ tempsym_t* symptr) if (!len) /* Avoid division by 0 */ len = 1; len = total % len; /* Assumed: the start is aligned. */ - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'X': size = -1; if (total < len) @@ -550,7 +510,7 @@ S_measure_struct(pTHX_ tempsym_t* symptr) len = len - star; else len = 0; - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'x': case 'A': case 'Z': @@ -606,7 +566,7 @@ S_group_end(pTHX_ const char *patptr, const char *patend, char ender) } Perl_croak(aTHX_ "No group ending character '%c' found in template", ender); - return 0; + NOT_REACHED; /* NOTREACHED */ } @@ -849,6 +809,9 @@ first_symbol(const char *pat, const char *patend) { } /* + +=head1 Pack and Unpack + =for apidoc unpackstring The engine implementing the unpack() Perl function. @@ -856,7 +819,7 @@ The engine implementing the unpack() Perl function. Using the template pat..patend, this function unpacks the string s..strend into a number of mortal SVs, which it pushes onto the perl argument (@_) stack (so you will need to issue a C before and -C after the call to this function). It returns the number of +C after the call to this function). It returns the number of pushed elements. The strend and patend pointers should point to the byte following the last @@ -898,7 +861,7 @@ Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, cons STATIC I32 S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s ) { - dVAR; dSP; + dSP; SV *sv = NULL; const I32 start_sp_offset = SP - PL_stack_base; howlen_t howlen; @@ -970,7 +933,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c cuv = 0; cdouble = 0; continue; - break; + case '(': { tempsym_t savsym = *symptr; @@ -1052,7 +1015,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c break; } len = (s - strbeg) % len; - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'X': if (utf8) { while (len > 0) { @@ -1079,7 +1042,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (ai32 == 0) break; len -= ai32; } - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'x': if (utf8) { while (len>0) { @@ -1096,7 +1059,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c break; case '/': Perl_croak(aTHX_ "'/' must follow a numeric type in unpack"); - break; + case 'A': case 'Z': case 'a': @@ -1271,7 +1234,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; break; } - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'c': while (len-- > 0 && s < strend) { int aint; @@ -1355,10 +1318,10 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c len = UTF8SKIP(result); if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) &result[1], len-1, 'U')) break; - auv = utf8n_to_uvuni(result, len, &retlen, UTF8_ALLOW_DEFAULT); + auv = utf8n_to_uvchr(result, len, &retlen, UTF8_ALLOW_DEFAULT); s = ptr; } else { - auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, UTF8_ALLOW_DEFAULT); + auv = utf8n_to_uvchr((U8*)s, strend - s, &retlen, UTF8_ALLOW_DEFAULT); if (retlen == (STRLEN) -1 || retlen == 0) Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); s += retlen; @@ -1375,8 +1338,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if SHORTSIZE != SIZE16 while (len-- > 0) { short ashort; - SHIFT_VAR(utf8, s, strend, ashort, datumtype); - DO_BO_UNPACK(ashort, s); + SHIFT_VAR(utf8, s, strend, ashort, datumtype, needs_swap); if (!checksum) mPUSHi(ashort); else if (checksum > bits_in_uv) @@ -1386,7 +1348,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } break; #else - /* Fallthrough! */ + /* FALLTHROUGH */ #endif case 's': while (len-- > 0) { @@ -1395,8 +1357,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if U16SIZE > SIZE16 ai16 = 0; #endif - SHIFT16(utf8, s, strend, &ai16, datumtype); - DO_BO_UNPACK(ai16, 16); + SHIFT16(utf8, s, strend, &ai16, datumtype, needs_swap); #if U16SIZE > SIZE16 if (ai16 > 32767) ai16 -= 65536; @@ -1413,8 +1374,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if SHORTSIZE != SIZE16 while (len-- > 0) { unsigned short aushort; - SHIFT_VAR(utf8, s, strend, aushort, datumtype); - DO_BO_UNPACK(aushort, s); + SHIFT_VAR(utf8, s, strend, aushort, datumtype, needs_swap, + needs_swap); if (!checksum) mPUSHu(aushort); else if (checksum > bits_in_uv) @@ -1424,7 +1385,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } break; #else - /* Fallthrough! */ + /* FALLTHROUGH */ #endif case 'v': case 'n': @@ -1434,8 +1395,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if U16SIZE > SIZE16 au16 = 0; #endif - SHIFT16(utf8, s, strend, &au16, datumtype); - DO_BO_UNPACK(au16, 16); + SHIFT16(utf8, s, strend, &au16, datumtype, needs_swap); if (datumtype == 'n') au16 = PerlSock_ntohs(au16); if (datumtype == 'v') @@ -1455,7 +1415,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c # if U16SIZE > SIZE16 ai16 = 0; # endif - SHIFT16(utf8, s, strend, &ai16, datumtype); + 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); if (datumtype == ('v' | TYPE_IS_SHRIEKING)) @@ -1472,8 +1434,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'i' | TYPE_IS_SHRIEKING: while (len-- > 0) { int aint; - SHIFT_VAR(utf8, s, strend, aint, datumtype); - DO_BO_UNPACK(aint, i); + SHIFT_VAR(utf8, s, strend, aint, datumtype, needs_swap); if (!checksum) mPUSHi(aint); else if (checksum > bits_in_uv) @@ -1486,8 +1447,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'I' | TYPE_IS_SHRIEKING: while (len-- > 0) { unsigned int auint; - SHIFT_VAR(utf8, s, strend, auint, datumtype); - DO_BO_UNPACK(auint, i); + SHIFT_VAR(utf8, s, strend, auint, datumtype, needs_swap); if (!checksum) mPUSHu(auint); else if (checksum > bits_in_uv) @@ -1499,16 +1459,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'j': while (len-- > 0) { IV aiv; - SHIFT_VAR(utf8, s, strend, aiv, datumtype); -#if IVSIZE == INTSIZE - DO_BO_UNPACK(aiv, i); -#elif IVSIZE == LONGSIZE - DO_BO_UNPACK(aiv, l); -#elif defined(HAS_QUAD) && IVSIZE == U64SIZE - DO_BO_UNPACK(aiv, 64); -#else - Perl_croak(aTHX_ "'j' not supported on this platform"); -#endif + SHIFT_VAR(utf8, s, strend, aiv, datumtype, needs_swap); if (!checksum) mPUSHi(aiv); else if (checksum > bits_in_uv) @@ -1520,16 +1471,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'J': while (len-- > 0) { UV auv; - SHIFT_VAR(utf8, s, strend, auv, datumtype); -#if IVSIZE == INTSIZE - DO_BO_UNPACK(auv, i); -#elif IVSIZE == LONGSIZE - DO_BO_UNPACK(auv, l); -#elif defined(HAS_QUAD) && IVSIZE == U64SIZE - DO_BO_UNPACK(auv, 64); -#else - Perl_croak(aTHX_ "'J' not supported on this platform"); -#endif + SHIFT_VAR(utf8, s, strend, auv, datumtype, needs_swap); if (!checksum) mPUSHu(auv); else if (checksum > bits_in_uv) @@ -1542,8 +1484,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if LONGSIZE != SIZE32 while (len-- > 0) { long along; - SHIFT_VAR(utf8, s, strend, along, datumtype); - DO_BO_UNPACK(along, l); + SHIFT_VAR(utf8, s, strend, along, datumtype, needs_swap); if (!checksum) mPUSHi(along); else if (checksum > bits_in_uv) @@ -1553,7 +1494,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } break; #else - /* Fallthrough! */ + /* FALLTHROUGH */ #endif case 'l': while (len-- > 0) { @@ -1561,8 +1502,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if U32SIZE > SIZE32 ai32 = 0; #endif - SHIFT32(utf8, s, strend, &ai32, datumtype); - DO_BO_UNPACK(ai32, 32); + SHIFT32(utf8, s, strend, &ai32, datumtype, needs_swap); #if U32SIZE > SIZE32 if (ai32 > 2147483647) ai32 -= 4294967296; #endif @@ -1578,8 +1518,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if LONGSIZE != SIZE32 while (len-- > 0) { unsigned long aulong; - SHIFT_VAR(utf8, s, strend, aulong, datumtype); - DO_BO_UNPACK(aulong, l); + SHIFT_VAR(utf8, s, strend, aulong, datumtype, needs_swap); if (!checksum) mPUSHu(aulong); else if (checksum > bits_in_uv) @@ -1589,7 +1528,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } break; #else - /* Fall through! */ + /* FALLTHROUGH */ #endif case 'V': case 'N': @@ -1599,8 +1538,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if U32SIZE > SIZE32 au32 = 0; #endif - SHIFT32(utf8, s, strend, &au32, datumtype); - DO_BO_UNPACK(au32, 32); + SHIFT32(utf8, s, strend, &au32, datumtype, needs_swap); if (datumtype == 'N') au32 = PerlSock_ntohl(au32); if (datumtype == 'V') @@ -1620,7 +1558,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c #if U32SIZE > SIZE32 ai32 = 0; #endif - SHIFT32(utf8, s, strend, &ai32, datumtype); + 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); if (datumtype == ('V' | TYPE_IS_SHRIEKING)) @@ -1636,8 +1576,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'p': while (len-- > 0) { const char *aptr; - SHIFT_VAR(utf8, s, strend, aptr, datumtype); - DO_BO_UNPACK(aptr, pointer); + SHIFT_VAR(utf8, s, strend, aptr, datumtype, needs_swap); /* newSVpv generates undef if aptr is NULL */ mPUSHs(newSVpv(aptr, 0)); } @@ -1690,21 +1629,18 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c EXTEND(SP, 1); if (s + sizeof(char*) <= strend) { char *aptr; - SHIFT_VAR(utf8, s, strend, aptr, datumtype); - DO_BO_UNPACK(aptr, pointer); + SHIFT_VAR(utf8, s, strend, aptr, datumtype, needs_swap); /* newSVpvn generates undef if aptr is NULL */ PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP)); } break; -#ifdef HAS_QUAD +#if defined(HAS_QUAD) && IVSIZE >= 8 case 'q': while (len-- > 0) { Quad_t aquad; - SHIFT_VAR(utf8, s, strend, aquad, datumtype); - DO_BO_UNPACK(aquad, 64); + SHIFT_VAR(utf8, s, strend, aquad, datumtype, needs_swap); if (!checksum) - mPUSHs(aquad >= IV_MIN && aquad <= IV_MAX ? - newSViv((IV)aquad) : newSVnv((NV)aquad)); + mPUSHs(newSViv((IV)aquad)); else if (checksum > bits_in_uv) cdouble += (NV)aquad; else @@ -1714,24 +1650,21 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'Q': while (len-- > 0) { Uquad_t auquad; - SHIFT_VAR(utf8, s, strend, auquad, datumtype); - DO_BO_UNPACK(auquad, 64); + SHIFT_VAR(utf8, s, strend, auquad, datumtype, needs_swap); if (!checksum) - mPUSHs(auquad <= UV_MAX ? - newSVuv((UV)auquad) : newSVnv((NV)auquad)); + mPUSHs(newSVuv((UV)auquad)); else if (checksum > bits_in_uv) cdouble += (NV)auquad; else cuv += auquad; } break; -#endif /* HAS_QUAD */ +#endif /* float and double added gnb@melba.bby.oz.au 22/11/89 */ case 'f': while (len-- > 0) { float afloat; - SHIFT_VAR(utf8, s, strend, afloat, datumtype); - DO_BO_UNPACK(afloat, float); + SHIFT_VAR(utf8, s, strend, afloat, datumtype, needs_swap); if (!checksum) mPUSHn(afloat); else @@ -1741,8 +1674,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'd': while (len-- > 0) { double adouble; - SHIFT_VAR(utf8, s, strend, adouble, datumtype); - DO_BO_UNPACK(adouble, double); + SHIFT_VAR(utf8, s, strend, adouble, datumtype, needs_swap); if (!checksum) mPUSHn(adouble); else @@ -1752,8 +1684,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'F': while (len-- > 0) { NV_bytes anv; - SHIFT_BYTES(utf8, s, strend, anv.bytes, sizeof(anv.bytes), datumtype); - DO_BO_UNPACK(anv.nv, NV); + SHIFT_BYTES(utf8, s, strend, anv.bytes, sizeof(anv.bytes), + datumtype, needs_swap); if (!checksum) mPUSHn(anv.nv); else @@ -1764,8 +1696,8 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c case 'D': while (len-- > 0) { ld_bytes aldouble; - SHIFT_BYTES(utf8, s, strend, aldouble.bytes, sizeof(aldouble.bytes), datumtype); - DO_BO_UNPACK(aldouble.ld, long double); + SHIFT_BYTES(utf8, s, strend, aldouble.bytes, + sizeof(aldouble.bytes), datumtype, needs_swap); if (!checksum) mPUSHn(aldouble.ld); else @@ -1909,7 +1841,6 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c PP(pp_unpack) { - dVAR; dSP; dPOPPOPssrl; I32 gimme = GIMME_V; @@ -2042,7 +1973,6 @@ The engine implementing pack() Perl function. void Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist ) { - dVAR; tempsym_t sym; PERL_ARGS_ASSERT_PACKLIST; @@ -2071,7 +2001,7 @@ marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) { from_start = SvPVX_const(sv); from_end = from_start + SvCUR(sv); for (from_ptr = from_start; from_ptr < from_end; from_ptr++) - if (!NATIVE_IS_INVARIANT(*from_ptr)) break; + if (!NATIVE_BYTE_IS_INVARIANT(*from_ptr)) break; if (from_ptr == from_end) { /* Simple case: no character needs to be changed */ SvUTF8_on(sv); @@ -2144,12 +2074,12 @@ STATIC SV ** S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) { - dVAR; tempsym_t lookahead; I32 items = endlist - beglist; bool found = next_symbol(symptr); bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0; bool warn_utf8 = ckWARN(WARN_UTF8); + char* from; PERL_ARGS_ASSERT_PACK_REC; @@ -2230,8 +2160,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) (int) TYPE_NO_MODIFIERS(datumtype)); case '%': Perl_croak(aTHX_ "'%%' may not be used in pack"); - { - char *from; + case '.' | TYPE_IS_SHRIEKING: case '.': if (howlen == e_star) from = start; @@ -2280,7 +2209,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); @@ -2326,7 +2255,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; @@ -2368,7 +2297,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (ai32 == 0) goto no_change; len -= ai32; } - /* FALL THROUGH */ + /* FALLTHROUGH */ case 'x': goto grow; case 'A': @@ -2611,7 +2540,15 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) while (len-- > 0) { IV aiv; fromstr = NEXTFROM; - aiv = SvIV(fromstr); + if (SvNOK(fromstr) && Perl_isinfnan(SvNV(fromstr))) { + /* 255 is a pretty arbitrary choice, but with + * inf/-inf/nan and 256 bytes there is not much room. */ + aiv = 255; + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'c' format overflow in pack"); + } + else + aiv = SvIV(fromstr); if ((-128 > aiv || aiv > 127)) Perl_ck_warner(aTHX_ packWARN(WARN_PACK), "Character in 'c' format wrapped in pack"); @@ -2626,7 +2563,14 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) while (len-- > 0) { IV aiv; fromstr = NEXTFROM; - aiv = SvIV(fromstr); + if (SvNOK(fromstr) && Perl_isinfnan(SvNV(fromstr))) { + /* See the 'c' case. */ + aiv = 255; + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'C' format overflow in pack"); + } + else + aiv = SvIV(fromstr); if ((0 > aiv || aiv > 0xff)) Perl_ck_warner(aTHX_ packWARN(WARN_PACK), "Character in 'C' format wrapped in pack"); @@ -2653,8 +2597,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) GROWING(0, cat, start, cur, len+UTF8_MAXLEN); end = start+SvLEN(cat)-UTF8_MAXLEN; } - cur = (char *) uvuni_to_utf8_flags((U8 *) cur, - NATIVE_TO_UNI(auv), + cur = (char *) uvchr_to_utf8_flags((U8 *) cur, + auv, warn_utf8 ? 0 : UNICODE_ALLOW_ANY); } else { @@ -2707,7 +2651,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) auv = SvUV(fromstr); if (utf8) { U8 buffer[UTF8_MAXLEN], *endb; - endb = uvuni_to_utf8_flags(buffer, auv, + endb = uvchr_to_utf8_flags(buffer, auv, warn_utf8 ? 0 : UNICODE_ALLOW_ANY); if (cur+(endb-buffer)*UTF8_EXPAND >= end) { @@ -2717,7 +2661,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) len+(endb-buffer)*UTF8_EXPAND); end = start+SvLEN(cat); } - cur = bytes_to_uni(buffer, endb-buffer, cur); + cur = S_bytes_to_uni(buffer, endb-buffer, cur, 0); } else { if (cur >= end) { *cur = '\0'; @@ -2725,7 +2669,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) GROWING(0, cat, start, cur, len+UTF8_MAXLEN); end = start+SvLEN(cat)-UTF8_MAXLEN; } - cur = (char *) uvuni_to_utf8_flags((U8 *) cur, auv, + cur = (char *) uvchr_to_utf8_flags((U8 *) cur, auv, warn_utf8 ? 0 : UNICODE_ALLOW_ANY); } @@ -2751,8 +2695,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) # else afloat = (float)anv; # endif - DO_BO_PACK(afloat, float); - PUSH_VAR(utf8, cur, afloat); + PUSH_VAR(utf8, cur, afloat, needs_swap); } break; case 'd': @@ -2773,8 +2716,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) # else adouble = (double)anv; # endif - DO_BO_PACK(adouble, double); - PUSH_VAR(utf8, cur, adouble); + PUSH_VAR(utf8, cur, adouble, needs_swap); } break; case 'F': { @@ -2788,8 +2730,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) #else anv.nv = SvNV(fromstr); #endif - DO_BO_PACK(anv, NV); - PUSH_BYTES(utf8, cur, anv.bytes, sizeof(anv.bytes)); + PUSH_BYTES(utf8, cur, anv.bytes, sizeof(anv.bytes), needs_swap); } break; } @@ -2806,8 +2747,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) # else aldouble.ld = (long double)SvNV(fromstr); # endif - DO_BO_PACK(aldouble, long double); - PUSH_BYTES(utf8, cur, aldouble.bytes, sizeof(aldouble.bytes)); + PUSH_BYTES(utf8, cur, aldouble.bytes, sizeof(aldouble.bytes), + needs_swap); } break; } @@ -2819,7 +2760,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) fromstr = NEXTFROM; ai16 = (I16)SvIV(fromstr); ai16 = PerlSock_htons(ai16); - PUSH16(utf8, cur, &ai16); + PUSH16(utf8, cur, &ai16, FALSE); } break; case 'v' | TYPE_IS_SHRIEKING: @@ -2829,7 +2770,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) fromstr = NEXTFROM; ai16 = (I16)SvIV(fromstr); ai16 = htovs(ai16); - PUSH16(utf8, cur, &ai16); + PUSH16(utf8, cur, &ai16, FALSE); } break; case 'S' | TYPE_IS_SHRIEKING: @@ -2838,20 +2779,18 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) unsigned short aushort; fromstr = NEXTFROM; aushort = SvUV(fromstr); - DO_BO_PACK(aushort, s); - PUSH_VAR(utf8, cur, aushort); + 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); + PUSH16(utf8, cur, &au16, needs_swap); } break; case 's' | TYPE_IS_SHRIEKING: @@ -2860,20 +2799,18 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) short ashort; fromstr = NEXTFROM; ashort = SvIV(fromstr); - DO_BO_PACK(ashort, s); - PUSH_VAR(utf8, cur, ashort); + 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); + PUSH16(utf8, cur, &ai16, needs_swap); } break; case 'I': @@ -2882,8 +2819,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) unsigned int auint; fromstr = NEXTFROM; auint = SvUV(fromstr); - DO_BO_PACK(auint, i); - PUSH_VAR(utf8, cur, auint); + PUSH_VAR(utf8, cur, auint, needs_swap); } break; case 'j': @@ -2891,16 +2827,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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); + PUSH_VAR(utf8, cur, aiv, needs_swap); } break; case 'J': @@ -2908,16 +2835,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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); + PUSH_VAR(utf8, cur, auv, needs_swap); } break; case 'w': @@ -3013,8 +2931,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) int aint; fromstr = NEXTFROM; aint = SvIV(fromstr); - DO_BO_PACK(aint, i); - PUSH_VAR(utf8, cur, aint); + PUSH_VAR(utf8, cur, aint, needs_swap); } break; case 'N' | TYPE_IS_SHRIEKING: @@ -3024,7 +2941,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) fromstr = NEXTFROM; au32 = SvUV(fromstr); au32 = PerlSock_htonl(au32); - PUSH32(utf8, cur, &au32); + PUSH32(utf8, cur, &au32, FALSE); } break; case 'V' | TYPE_IS_SHRIEKING: @@ -3034,7 +2951,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) fromstr = NEXTFROM; au32 = SvUV(fromstr); au32 = htovl(au32); - PUSH32(utf8, cur, &au32); + PUSH32(utf8, cur, &au32, FALSE); } break; case 'L' | TYPE_IS_SHRIEKING: @@ -3043,8 +2960,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) unsigned long aulong; fromstr = NEXTFROM; aulong = SvUV(fromstr); - DO_BO_PACK(aulong, l); - PUSH_VAR(utf8, cur, aulong); + PUSH_VAR(utf8, cur, aulong, needs_swap); } break; #else @@ -3055,8 +2971,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) U32 au32; fromstr = NEXTFROM; au32 = SvUV(fromstr); - DO_BO_PACK(au32, 32); - PUSH32(utf8, cur, &au32); + PUSH32(utf8, cur, &au32, needs_swap); } break; case 'l' | TYPE_IS_SHRIEKING: @@ -3065,8 +2980,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) long along; fromstr = NEXTFROM; along = SvIV(fromstr); - DO_BO_PACK(along, l); - PUSH_VAR(utf8, cur, along); + PUSH_VAR(utf8, cur, along, needs_swap); } break; #else @@ -3077,18 +2991,16 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) I32 ai32; fromstr = NEXTFROM; ai32 = SvIV(fromstr); - DO_BO_PACK(ai32, 32); - PUSH32(utf8, cur, &ai32); + 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); + PUSH_VAR(utf8, cur, auquad, needs_swap); } break; case 'q': @@ -3096,15 +3008,14 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) Quad_t aquad; fromstr = NEXTFROM; aquad = (Quad_t)SvIV(fromstr); - DO_BO_PACK(aquad, 64); - PUSH_VAR(utf8, cur, aquad); + PUSH_VAR(utf8, cur, aquad, needs_swap); } break; -#endif /* HAS_QUAD */ +#endif case 'P': len = 1; /* assume SV is correct length */ GROWING(utf8, cat, start, cur, sizeof(char *)); - /* Fall through! */ + /* FALLTHROUGH */ case 'p': while (len-- > 0) { const char *aptr; @@ -3128,8 +3039,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) else aptr = SvPV_force_flags_nolen(fromstr, 0); } - DO_BO_PACK(aptr, pointer); - PUSH_VAR(utf8, cur, aptr); + PUSH_VAR(utf8, cur, aptr, needs_swap); } break; case 'u': { @@ -3175,7 +3085,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) end = doencodes(hunk, aptr, todo); aptr += todo; } - PUSH_BYTES(utf8, cur, hunk, end-hunk); + PUSH_BYTES(utf8, cur, hunk, end-hunk, 0); fromlen -= todo; } break; @@ -3193,7 +3103,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) PP(pp_pack) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SV *cat = TARG; STRLEN fromlen; SV *pat_sv = *++MARK;