} ld_bytes;
#endif
-#if PERL_VERSION >= 9
-# define PERL_PACK_CAN_BYTEORDER
-# define PERL_PACK_CAN_SHRIEKSIGN
-#endif
-
#ifndef CHAR_BIT
# define CHAR_BIT 8
#endif
#define TYPE_MODIFIERS(t) ((t) & ~0xFF)
#define TYPE_NO_MODIFIERS(t) ((t) & 0xFF)
-#ifdef PERL_PACK_CAN_SHRIEKSIGN
-# define SHRIEKING_ALLOWED_TYPES "sSiIlLxXnNvV@."
-#else
-# define SHRIEKING_ALLOWED_TYPES "sSiIlLxX"
-#endif
-
-#ifndef PERL_PACK_CAN_BYTEORDER
-/* Put "can't" first because it is shorter */
-# define TYPE_ENDIANNESS(t) 0
-# define TYPE_NO_ENDIANNESS(t) (t)
-
-# define ENDIANNESS_ALLOWED_TYPES ""
-
-# define DO_BO_UNPACK(var, type)
-# define DO_BO_PACK(var, type)
-# define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast)
-# define DO_BO_PACK_PTR(var, type, pre_cast, post_cast)
-# define DO_BO_UNPACK_N(var, type)
-# define DO_BO_PACK_N(var, type)
-# define DO_BO_UNPACK_P(var)
-# define DO_BO_PACK_P(var)
-# define DO_BO_UNPACK_PC(var)
-# define DO_BO_PACK_PC(var)
-
-#else /* PERL_PACK_CAN_BYTEORDER */
-
# define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK)
# define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK)
# define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP("
+#if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
+
# 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; \
+ if (TYPE_ENDIANNESS(datumtype) == TYPE_IS_LITTLE_ENDIAN) { \
+ my_swabn(&var, sizeof(var)); \
} \
} 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; \
+ if (TYPE_ENDIANNESS(datumtype) == TYPE_IS_LITTLE_ENDIAN) { \
+ my_swabn(&var, sizeof(var)); \
} \
} STMT_END
-# define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast) \
+# elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
+
+# define DO_BO_UNPACK(var, type) \
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; \
+ if (TYPE_ENDIANNESS(datumtype) == TYPE_IS_BIG_ENDIAN) { \
+ my_swabn(&var, sizeof(var)); \
} \
} STMT_END
-# define DO_BO_PACK_PTR(var, type, pre_cast, post_cast) \
+# define DO_BO_PACK(var, type) \
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; \
+ if (TYPE_ENDIANNESS(datumtype) == TYPE_IS_BIG_ENDIAN) { \
+ 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)) { \
} \
} 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
-# if LONGSIZE < IVSIZE && IVSIZE == 8
-# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, 64, IV, void)
-# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, 64, IV, void)
-# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, 64, IV, char)
-# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, 64, IV, char)
-# else
-# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, IV, void)
-# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, IV, void)
-# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, IV, char)
-# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, IV, char)
-# endif
-# elif PTRSIZE == IVSIZE
-# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, IV, void)
-# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, IV, void)
-# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, IV, char)
-# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, IV, char)
-# else
-# define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer)
-# define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer)
-# define DO_BO_UNPACK_PC(var) BO_CANT_DOIT(unpack, pointer)
-# define DO_BO_PACK_PC(var) BO_CANT_DOIT(pack, pointer)
-# endif
-
-# if defined(my_htolen) && defined(my_letohn) && \
- defined(my_htoben) && defined(my_betohn)
-# define DO_BO_UNPACK_N(var, type) \
- STMT_START { \
- switch (TYPE_ENDIANNESS(datumtype)) { \
- case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\
- case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
- default: break; \
- } \
- } STMT_END
-
-# define DO_BO_PACK_N(var, type) \
- STMT_START { \
- switch (TYPE_ENDIANNESS(datumtype)) { \
- case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\
- case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
- default: break; \
- } \
- } STMT_END
-# else
-# define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type)
-# define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type)
-# endif
-
-#endif /* PERL_PACK_CAN_BYTEORDER */
-
#define PACK_SIZE_CANNOT_CSUM 0x80
#define PACK_SIZE_UNPREDICTABLE 0x40 /* Not a fixed size element */
#define PACK_SIZE_MASK 0x3F
-/* These tables are regenerated by genpacksizetables.pl (and then hand pasted
- in). You're unlikely ever to need to regenerate them. */
-
-#if TYPE_IS_SHRIEKING != 0x100
- ++++shriek offset should be 256
-#endif
-
-typedef U8 packprops_t;
-#if 'J'-'I' == 1
-/* ASCII */
-STATIC const packprops_t packprops[512] = {
- /* normal */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0,
- /* C */ sizeof(unsigned char),
-#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
- /* D */ LONG_DOUBLESIZE,
-#else
- 0,
-#endif
- 0,
- /* F */ NVSIZE,
- 0, 0,
- /* I */ sizeof(unsigned int),
- /* J */ UVSIZE,
- 0,
- /* L */ SIZE32,
- 0,
- /* N */ SIZE32,
- 0, 0,
-#if defined(HAS_QUAD)
- /* Q */ sizeof(Uquad_t),
-#else
- 0,
-#endif
- 0,
- /* S */ SIZE16,
- 0,
- /* U */ sizeof(char) | PACK_SIZE_UNPREDICTABLE,
- /* V */ SIZE32,
- /* W */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- /* c */ sizeof(char),
- /* d */ sizeof(double),
- 0,
- /* f */ sizeof(float),
- 0, 0,
- /* i */ sizeof(int),
- /* j */ IVSIZE,
- 0,
- /* l */ SIZE32,
- 0,
- /* n */ SIZE16,
- 0,
- /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM,
-#if defined(HAS_QUAD)
- /* q */ sizeof(Quad_t),
-#else
- 0,
-#endif
- 0,
- /* s */ SIZE16,
- 0, 0,
- /* v */ SIZE16,
- /* w */ sizeof(char) | PACK_SIZE_UNPREDICTABLE | PACK_SIZE_CANNOT_CSUM,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0,
- /* shrieking */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- /* I */ sizeof(unsigned int),
- 0, 0,
- /* L */ sizeof(unsigned long),
- 0,
-#if defined(PERL_PACK_CAN_SHRIEKSIGN)
- /* N */ SIZE32,
-#else
- 0,
-#endif
- 0, 0, 0, 0,
- /* S */ sizeof(unsigned short),
- 0, 0,
-#if defined(PERL_PACK_CAN_SHRIEKSIGN)
- /* V */ SIZE32,
-#else
- 0,
-#endif
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0,
- /* i */ sizeof(int),
- 0, 0,
- /* l */ sizeof(long),
- 0,
-#if defined(PERL_PACK_CAN_SHRIEKSIGN)
- /* n */ SIZE16,
-#else
- 0,
-#endif
- 0, 0, 0, 0,
- /* s */ sizeof(short),
- 0, 0,
-#if defined(PERL_PACK_CAN_SHRIEKSIGN)
- /* v */ SIZE16,
-#else
- 0,
-#endif
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0
-};
-#else
-/* EBCDIC (or bust) */
-STATIC const packprops_t packprops[512] = {
- /* normal */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0,
- /* c */ sizeof(char),
- /* d */ sizeof(double),
- 0,
- /* f */ sizeof(float),
- 0, 0,
- /* i */ sizeof(int),
- 0, 0, 0, 0, 0, 0, 0,
- /* j */ IVSIZE,
- 0,
- /* l */ SIZE32,
- 0,
- /* n */ SIZE16,
- 0,
- /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM,
-#if defined(HAS_QUAD)
- /* q */ sizeof(Quad_t),
-#else
- 0,
-#endif
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- /* s */ SIZE16,
- 0, 0,
- /* v */ SIZE16,
- /* w */ sizeof(char) | PACK_SIZE_UNPREDICTABLE | PACK_SIZE_CANNOT_CSUM,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- /* C */ sizeof(unsigned char),
-#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
- /* D */ LONG_DOUBLESIZE,
-#else
- 0,
-#endif
- 0,
- /* F */ NVSIZE,
- 0, 0,
- /* I */ sizeof(unsigned int),
- 0, 0, 0, 0, 0, 0, 0,
- /* J */ UVSIZE,
- 0,
- /* L */ SIZE32,
- 0,
- /* N */ SIZE32,
- 0, 0,
-#if defined(HAS_QUAD)
- /* Q */ sizeof(Uquad_t),
-#else
- 0,
-#endif
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- /* S */ SIZE16,
- 0,
- /* U */ sizeof(char) | PACK_SIZE_UNPREDICTABLE,
- /* V */ SIZE32,
- /* W */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- /* shrieking */
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- /* i */ sizeof(int),
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- /* l */ sizeof(long),
- 0,
-#if defined(PERL_PACK_CAN_SHRIEKSIGN)
- /* n */ SIZE16,
-#else
- 0,
-#endif
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- /* s */ sizeof(short),
- 0, 0,
-#if defined(PERL_PACK_CAN_SHRIEKSIGN)
- /* v */ SIZE16,
-#else
- 0,
-#endif
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0,
- /* I */ sizeof(unsigned int),
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- /* L */ sizeof(unsigned long),
- 0,
-#if defined(PERL_PACK_CAN_SHRIEKSIGN)
- /* N */ SIZE32,
-#else
- 0,
-#endif
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- /* S */ sizeof(unsigned short),
- 0, 0,
-#if defined(PERL_PACK_CAN_SHRIEKSIGN)
- /* V */ SIZE32,
-#else
- 0,
-#endif
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
-};
-#endif
+#include "packsizetables.c"
STATIC U8
uni_to_byte(pTHX_ const char **s, const char *end, I32 datumtype)
STRLEN retlen;
UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen,
ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
- /* We try to process malformed UTF-8 as much as possible (preferrably with
+ /* We try to process malformed UTF-8 as much as possible (preferably with
warnings), but these two mean we make no progress in the string and
might enter an infinite loop */
if (retlen == (STRLEN) -1 || retlen == 0)
Perl_croak(aTHX_ "Invalid type '%c' in %s",
(int)TYPE_NO_MODIFIERS(symptr->code),
_action( symptr ) );
-#ifdef PERL_PACK_CAN_SHRIEKSIGN
case '.' | TYPE_IS_SHRIEKING:
case '@' | TYPE_IS_SHRIEKING:
-#endif
case '@':
case '.':
case '/':
* returns char pointer to char after match, or NULL
*/
STATIC const char *
-S_group_end(pTHX_ register const char *patptr, register const char *patend, char ender)
+S_group_end(pTHX_ const char *patptr, const char *patend, char ender)
{
PERL_ARGS_ASSERT_GROUP_END;
* Advances char pointer to 1st non-digit char and returns number
*/
STATIC const char *
-S_get_num(pTHX_ register const char *patptr, I32 *lenptr )
+S_get_num(pTHX_ const char *patptr, I32 *lenptr )
{
I32 len = *patptr++ - '0';
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;
modifier = TYPE_IS_LITTLE_ENDIAN;
allowed = ENDIANNESS_ALLOWED_TYPES;
break;
-#endif /* PERL_PACK_CAN_BYTEORDER */
default:
allowed = "";
modifier = 0;
/*
=for apidoc unpackstring
-The engine implementing unpack() Perl function. C<unpackstring> puts the
-extracted list items on the stack and returns the number of elements.
-Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
+The engine implementing the unpack() Perl function.
+
+Using the template pat..patend, this function unpacks the string
+s..strend into a number of mortal SVs, which it pushes onto the perl
+argument (@_) stack (so you will need to issue a C<PUTBACK> before and
+C<SPAGAIN> after the call to this function). It returns the number of
+pushed elements.
+
+The strend and patend pointers should point to the byte following the last
+character of each string.
+
+Although this function returns its values on the perl argument stack, it
+doesn't take any parameters from that stack (and thus in particular
+there's no need to do a PUSHMARK before calling it, unlike L</call_pv> for
+example).
=cut */
S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s )
{
dVAR; dSP;
- SV *sv;
+ SV *sv = NULL;
const I32 start_sp_offset = SP - PL_stack_base;
howlen_t howlen;
I32 checksum = 0;
*symptr = savsym;
break;
}
-#ifdef PERL_PACK_CAN_SHRIEKSIGN
case '.' | TYPE_IS_SHRIEKING:
-#endif
case '.': {
const char *from;
SV *sv;
-#ifdef PERL_PACK_CAN_SHRIEKSIGN
const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING);
-#else /* PERL_PACK_CAN_SHRIEKSIGN */
- const bool u8 = utf8;
-#endif
if (howlen == e_star) from = strbeg;
else if (len <= 0) from = s;
else {
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)
if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) {
for (ptr = s+len-1; ptr >= s; ptr--)
if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) &&
- !is_utf8_space((U8 *) ptr)) break;
+ !isSPACE_utf8(ptr)) break;
if (ptr >= s) ptr += UTF8SKIP(ptr);
else ptr++;
if (ptr > s+len)
}
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;
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
len = UTF8SKIP(result);
if (!uni_to_bytes(aTHX_ &ptr, strend,
(char *) &result[1], len-1, 'U')) break;
- auv = utf8n_to_uvuni(result, len, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
+ auv = utf8n_to_uvuni(result, len, &retlen, UTF8_ALLOW_DEFAULT);
s = ptr;
} else {
- auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
+ auv = utf8n_to_uvuni((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;
}
break;
#else
- /* Fallhrough! */
+ /* Fallthrough! */
#endif
case 'v':
case 'n':
#endif
SHIFT16(utf8, s, strend, &au16, datumtype);
DO_BO_UNPACK(au16, 16);
-#ifdef HAS_NTOHS
if (datumtype == 'n')
au16 = PerlSock_ntohs(au16);
-#endif
-#ifdef HAS_VTOHS
if (datumtype == 'v')
au16 = vtohs(au16);
-#endif
if (!checksum)
mPUSHu(au16);
else if (checksum > bits_in_uv)
cuv += au16;
}
break;
-#ifdef PERL_PACK_CAN_SHRIEKSIGN
case 'v' | TYPE_IS_SHRIEKING:
case 'n' | TYPE_IS_SHRIEKING:
while (len-- > 0) {
ai16 = 0;
# endif
SHIFT16(utf8, s, strend, &ai16, datumtype);
-# ifdef HAS_NTOHS
if (datumtype == ('n' | TYPE_IS_SHRIEKING))
ai16 = (I16) PerlSock_ntohs((U16) ai16);
-# endif /* HAS_NTOHS */
-# ifdef HAS_VTOHS
if (datumtype == ('v' | TYPE_IS_SHRIEKING))
ai16 = (I16) vtohs((U16) ai16);
-# endif /* HAS_VTOHS */
if (!checksum)
mPUSHi(ai16);
else if (checksum > bits_in_uv)
cuv += ai16;
}
break;
-#endif /* PERL_PACK_CAN_SHRIEKSIGN */
case 'i':
case 'i' | TYPE_IS_SHRIEKING:
while (len-- > 0) {
#endif
SHIFT32(utf8, s, strend, &au32, datumtype);
DO_BO_UNPACK(au32, 32);
-#ifdef HAS_NTOHL
if (datumtype == 'N')
au32 = PerlSock_ntohl(au32);
-#endif
-#ifdef HAS_VTOHL
if (datumtype == 'V')
au32 = vtohl(au32);
-#endif
if (!checksum)
mPUSHu(au32);
else if (checksum > bits_in_uv)
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
+#endif
SHIFT32(utf8, s, strend, &ai32, datumtype);
-# ifdef HAS_NTOHL
if (datumtype == ('N' | TYPE_IS_SHRIEKING))
ai32 = (I32)PerlSock_ntohl((U32)ai32);
-# endif
-# ifdef HAS_VTOHL
if (datumtype == ('V' | TYPE_IS_SHRIEKING))
ai32 = (I32)vtohl((U32)ai32);
-# endif
if (!checksum)
mPUSHi(ai32);
else if (checksum > bits_in_uv)
cuv += ai32;
}
break;
-#endif /* PERL_PACK_CAN_SHRIEKSIGN */
case 'p':
while (len-- > 0) {
const char *aptr;
SHIFT_VAR(utf8, s, strend, aptr, datumtype);
- DO_BO_UNPACK_PC(aptr);
+ DO_BO_UNPACK(aptr, pointer);
/* newSVpv generates undef if aptr is NULL */
mPUSHs(newSVpv(aptr, 0));
}
if (s + sizeof(char*) <= strend) {
char *aptr;
SHIFT_VAR(utf8, s, strend, aptr, datumtype);
- DO_BO_UNPACK_PC(aptr);
+ DO_BO_UNPACK(aptr, pointer);
/* newSVpvn generates undef if aptr is NULL */
PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP));
}
while (len-- > 0) {
float afloat;
SHIFT_VAR(utf8, s, strend, afloat, datumtype);
- DO_BO_UNPACK_N(afloat, float);
+ DO_BO_UNPACK(afloat, float);
if (!checksum)
mPUSHn(afloat);
else
while (len-- > 0) {
double adouble;
SHIFT_VAR(utf8, s, strend, adouble, datumtype);
- DO_BO_UNPACK_N(adouble, double);
+ DO_BO_UNPACK(adouble, double);
if (!checksum)
mPUSHn(adouble);
else
while (len-- > 0) {
NV_bytes anv;
SHIFT_BYTES(utf8, s, strend, anv.bytes, sizeof(anv.bytes), datumtype);
- DO_BO_UNPACK_N(anv.nv, NV);
+ DO_BO_UNPACK(anv.nv, NV);
if (!checksum)
mPUSHn(anv.nv);
else
while (len-- > 0) {
ld_bytes aldouble;
SHIFT_BYTES(utf8, s, strend, aldouble.bytes, sizeof(aldouble.bytes), datumtype);
- DO_BO_UNPACK_N(aldouble.ld, long double);
+ DO_BO_UNPACK(aldouble.ld, long double);
if (!checksum)
mPUSHn(aldouble.ld);
else
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" );
*/
void
-Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist )
+Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist )
{
dVAR;
tempsym_t sym;
if (m != marks + sym_ptr->level+1) {
Safefree(marks);
Safefree(to_start);
- Perl_croak(aTHX_ "panic: 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;
if (lookahead.howlen == e_number) count = lookahead.length;
else {
if (items > 0) {
- if (SvGAMAGIC(*beglist)) {
- /* Avoid reading the active data more than once
- by copying it to a temporary. */
- STRLEN len;
- const char *const pv = SvPV_const(*beglist, len);
- SV *const temp
- = newSVpvn_flags(pv, len,
- SVs_TEMP | SvUTF8(*beglist));
- *beglist = temp;
- }
- count = DO_UTF8(*beglist) ?
- sv_len_utf8(*beglist) : sv_len(*beglist);
+ count = sv_len_utf8(*beglist);
}
else count = 0;
if (lookahead.code == 'Z') count++;
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;
fromstr = NEXTFROM;
len = SvIV(fromstr);
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);
GROWING(0, cat, start, cur, len);
if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
datumtype | TYPE_IS_PACK))
- Perl_croak(aTHX_ "panic: predicted utf8 length not available");
+ Perl_croak(aTHX_ "panic: predicted utf8 length not available, "
+ "for '%c', aptr=%p end=%p cur=%p, fromlen=%"UVuf,
+ (int)datumtype, aptr, end, cur, (UV)fromlen);
cur += fromlen;
len -= fromlen;
} else if (utf8) {
NV anv;
fromstr = NEXTFROM;
anv = SvNV(fromstr);
-#ifdef __VOS__
- /* VOS does not automatically map a floating-point overflow
- during conversion from double to float into infinity, so we
- do it by hand. This code should either be generalized for
- any OS that needs it, or removed if and when VOS implements
- posix-976 (suggestion to support mapping to infinity).
- Paul.Green@stratus.com 02-04-02. */
-{
-extern const float _float_constants[];
- if (anv > FLT_MAX)
- afloat = _float_constants[0]; /* single prec. inf. */
- else if (anv < -FLT_MAX)
- afloat = _float_constants[0]; /* single prec. inf. */
- else afloat = (float) anv;
-}
-#else /* __VOS__ */
-# if defined(VMS) && !defined(__IEEE_FP)
+# if defined(VMS) && !defined(_IEEE_FP)
/* IEEE fp overflow shenanigans are unavailable on VAX and optional
* on Alpha; fake it if we don't have them.
*/
# else
afloat = (float)anv;
# endif
-#endif /* __VOS__ */
- DO_BO_PACK_N(afloat, float);
+ DO_BO_PACK(afloat, float);
PUSH_VAR(utf8, cur, afloat);
}
break;
NV anv;
fromstr = NEXTFROM;
anv = SvNV(fromstr);
-#ifdef __VOS__
- /* VOS does not automatically map a floating-point overflow
- during conversion from long double to double into infinity,
- so we do it by hand. This code should either be generalized
- for any OS that needs it, or removed if and when VOS
- implements posix-976 (suggestion to support mapping to
- infinity). Paul.Green@stratus.com 02-04-02. */
-{
-extern const double _double_constants[];
- if (anv > DBL_MAX)
- adouble = _double_constants[0]; /* double prec. inf. */
- else if (anv < -DBL_MAX)
- adouble = _double_constants[0]; /* double prec. inf. */
- else adouble = (double) anv;
-}
-#else /* __VOS__ */
-# if defined(VMS) && !defined(__IEEE_FP)
+# if defined(VMS) && !defined(_IEEE_FP)
/* IEEE fp overflow shenanigans are unavailable on VAX and optional
* on Alpha; fake it if we don't have them.
*/
# else
adouble = (double)anv;
# endif
-#endif /* __VOS__ */
- DO_BO_PACK_N(adouble, double);
+ DO_BO_PACK(adouble, double);
PUSH_VAR(utf8, cur, adouble);
}
break;
Zero(&anv, 1, NV); /* can be long double with unused bits */
while (len-- > 0) {
fromstr = NEXTFROM;
+#ifdef __GNUC__
+ /* to work round a gcc/x86 bug; don't use SvNV */
+ anv.nv = sv_2nv(fromstr);
+#else
anv.nv = SvNV(fromstr);
- DO_BO_PACK_N(anv, NV);
+#endif
+ DO_BO_PACK(anv, NV);
PUSH_BYTES(utf8, cur, anv.bytes, sizeof(anv.bytes));
}
break;
Zero(&aldouble, 1, long double);
while (len-- > 0) {
fromstr = NEXTFROM;
+# ifdef __GNUC__
+ /* to work round a gcc/x86 bug; don't use SvNV */
+ aldouble.ld = (long double)sv_2nv(fromstr);
+# else
aldouble.ld = (long double)SvNV(fromstr);
- DO_BO_PACK_N(aldouble, long double);
+# endif
+ DO_BO_PACK(aldouble, long double);
PUSH_BYTES(utf8, cur, aldouble.bytes, sizeof(aldouble.bytes));
}
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 = PerlSock_htons(ai16);
-#endif
PUSH16(utf8, cur, &ai16);
}
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 = htovs(ai16);
-#endif
PUSH16(utf8, cur, &ai16);
}
break;
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.
PUSH_VAR(utf8, cur, aint);
}
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 = PerlSock_htonl(au32);
-#endif
PUSH32(utf8, cur, &au32);
}
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 = htovl(au32);
-#endif
PUSH32(utf8, cur, &au32);
}
break;
else
aptr = SvPV_force_flags_nolen(fromstr, 0);
}
- DO_BO_PACK_PC(aptr);
+ DO_BO_PACK(aptr, pointer);
PUSH_VAR(utf8, cur, aptr);
}
break;
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) {
'u' | TYPE_IS_PACK)) {
*cur = '\0';
SvCUR_set(cat, cur - start);
- Perl_croak(aTHX_ "panic: string is shorter than advertised");
+ Perl_croak(aTHX_ "panic: string is shorter than advertised, "
+ "aptr=%p, aend=%p, buffer=%p, todo=%ld",
+ aptr, aend, buffer, (long) todo);
}
end = doencodes(hunk, buffer, todo);
} else {
PP(pp_pack)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- register SV *cat = TARG;
+ SV *cat = TARG;
STRLEN fromlen;
SV *pat_sv = *++MARK;
- register const char *pat = SvPV_const(pat_sv, fromlen);
- register const char *patend = pat + fromlen;
+ const char *pat = SvPV_const(pat_sv, fromlen);
+ const char *patend = pat + fromlen;
MARK++;
sv_setpvs(cat, "");
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff