+ /* 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 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
+ warnings), but these two mean we make no progress in the string and
+ might enter an infinite loop */
+ if (retlen == (STRLEN) -1 || retlen == 0)
+ Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack",
+ (int) TYPE_NO_MODIFIERS(datumtype));
+ if (val >= 0x100) {
+ if (ckWARN(WARN_UNPACK))
+ Perl_warner(aTHX_ packWARN(WARN_UNPACK),
+ "Character in '%c' format wrapped in unpack",
+ (int) TYPE_NO_MODIFIERS(datumtype));
+ val &= 0xff;
+ }
+ *s += retlen;
+ return (U8)val;
+}
+
+#define SHIFT_BYTE(utf8, s, strend, datumtype) ((utf8) ? \
+ uni_to_byte(aTHX_ &(s), (strend), (datumtype)) : \
+ *(U8 *)(s)++)
+
+STATIC bool
+uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len, I32 datumtype)
+{
+ UV val;
+ STRLEN retlen;
+ const char *from = *s;
+ int bad = 0;
+ const U32 flags = ckWARN(WARN_UTF8) ?
+ UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY | UTF8_ALLOW_ANY);
+ 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);
+ bad |= 1;
+ } else from += retlen;
+ if (val >= 0x100) {
+ bad |= 2;
+ val &= 0xff;
+ }
+ *(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 */
+ const char *ptr;
+ 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);
+ }
+ if (from > end) from = end;
+ }
+ if ((bad & 2) && ckWARN(WARN_UNPACK))
+ Perl_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");
+ }
+ *s = from;
+ return TRUE;
+}
+
+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) ||
+ retlen == (STRLEN) -1 || retlen == 0) {
+ *out = 0;
+ return FALSE;
+ }
+ *out = PL_uudmap[val] & 077;
+ *s += retlen;
+ return TRUE;
+}
+
+STATIC char *
+S_bytes_to_uni(const U8 *start, STRLEN len, char *dest) {
+ const U8 * const end = start + len;
+
+ 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++;
+ }
+ return dest;
+}
+
+#define PUSH_BYTES(utf8, cur, buf, len) \
+STMT_START { \
+ if (utf8) \
+ (cur) = bytes_to_uni((U8 *) buf, len, (cur)); \
+ else { \
+ Copy(buf, cur, len, char); \
+ (cur) += (len); \
+ } \
+} 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(cat, glen); \
+ (cur) = (start) + SvCUR(cat); \
+ } \
+} STMT_END
+
+#define PUSH_GROWING_BYTES(utf8, cat, start, cur, buf, in_len) \
+STMT_START { \
+ const STRLEN glen = (in_len); \
+ STRLEN gl = glen; \
+ if (utf8) gl *= UTF8_EXPAND; \
+ if ((cur) + gl >= (start) + SvLEN(cat)) { \
+ *cur = '\0'; \
+ SvCUR_set((cat), (cur) - (start)); \
+ (start) = sv_exp_grow(cat, gl); \
+ (cur) = (start) + SvCUR(cat); \
+ } \
+ PUSH_BYTES(utf8, cur, buf, glen); \
+} STMT_END
+
+#define PUSH_BYTE(utf8, s, byte) \
+STMT_START { \
+ if (utf8) { \
+ const U8 au8 = (byte); \
+ (s) = bytes_to_uni(&au8, 1, (s)); \
+ } else *(U8 *)(s)++ = (byte); \
+} STMT_END
+
+/* Only to be used inside a loop (see the break) */
+#define NEXT_UNI_VAL(val, cur, str, end, utf8_flags) \
+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) { \
+ *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
+S_measure_struct(pTHX_ tempsym_t* symptr)
+{
+ I32 total = 0;
+
+ while (next_symbol(symptr)) {
+ I32 len;
+ int size;
+
+ switch (symptr->howlen) {
+ 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;