pp_pack.c

   1 /*    pp_pack.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * He still hopefully carried some of his gear in his pack: a small tinder-box,
  13  * two small shallow pans, the smaller fitting into the larger; inside them a
  14  * wooden spoon, a short two-pronged fork and some skewers were stowed; and
  15  * hidden at the bottom of the pack in a flat wooden box a dwindling treasure,
  16  * some salt.
  17  *
  18  *     [p.653 of _The Lord of the Rings_, IV/iv: "Of Herbs and Stewed Rabbit"]
  19  */
  20
  21 /* This file contains pp ("push/pop") functions that
  22  * execute the opcodes that make up a perl program. A typical pp function
  23  * expects to find its arguments on the stack, and usually pushes its
  24  * results onto the stack, hence the 'pp' terminology. Each OP structure
  25  * contains a pointer to the relevant pp_foo() function.
  26  *
  27  * This particular file just contains pp_pack() and pp_unpack(). See the
  28  * other pp*.c files for the rest of the pp_ functions.
  29  */
  30
  31 #include "EXTERN.h"
  32 #define PERL_IN_PP_PACK_C
  33 #include "perl.h"
  34
  35 /* Types used by pack/unpack */
  36 typedef enum {
  37   e_no_len,     /* no length  */
  38   e_number,     /* number, [] */
  39   e_star        /* asterisk   */
  40 } howlen_t;
  41
  42 typedef struct tempsym {
  43   const char*    patptr;   /* current template char */
  44   const char*    patend;   /* one after last char   */
  45   const char*    grpbeg;   /* 1st char of ()-group  */
  46   const char*    grpend;   /* end of ()-group       */
  47   I32      code;     /* template code (!<>)   */
  48   I32      length;   /* length/repeat count   */
  49   howlen_t howlen;   /* how length is given   */
  50   int      level;    /* () nesting level      */
  51   U32      flags;    /* /=4, comma=2, pack=1  */
  52                      /*   and group modifiers */
  53   STRLEN   strbeg;   /* offset of group start */
  54   struct tempsym *previous; /* previous group */
  55 } tempsym_t;
  56
  57 #define TEMPSYM_INIT(symptr, p, e, f) \
  58     STMT_START {        \
  59         (symptr)->patptr   = (p);       \
  60         (symptr)->patend   = (e);       \
  61         (symptr)->grpbeg   = NULL;      \
  62         (symptr)->grpend   = NULL;      \
  63         (symptr)->grpend   = NULL;      \
  64         (symptr)->code     = 0;         \
  65         (symptr)->length   = 0;         \
  66         (symptr)->howlen   = e_no_len;  \
  67         (symptr)->level    = 0;         \
  68         (symptr)->flags    = (f);       \
  69         (symptr)->strbeg   = 0;         \
  70         (symptr)->previous = NULL;      \
  71    } STMT_END
  72
  73 typedef union {
  74     NV nv;
  75     U8 bytes[sizeof(NV)];
  76 } NV_bytes;
  77
  78 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
  79 typedef union {
  80     long double ld;
  81     U8 bytes[sizeof(long double)];
  82 } ld_bytes;
  83 #endif
  84
  85 #ifndef CHAR_BIT
  86 # define CHAR_BIT       8
  87 #endif
  88 /* Maximum number of bytes to which a byte can grow due to upgrade */
  89 #define UTF8_EXPAND     2
  90
  91 /*
  92  * Offset for integer pack/unpack.
  93  *
  94  * On architectures where I16 and I32 aren't really 16 and 32 bits,
  95  * which for now are all Crays, pack and unpack have to play games.
  96  */
  97
  98 /*
  99  * These values are required for portability of pack() output.
 100  * If they're not right on your machine, then pack() and unpack()
 101  * wouldn't work right anyway; you'll need to apply the Cray hack.
 102  * (I'd like to check them with #if, but you can't use sizeof() in
 103  * the preprocessor.)  --???
 104  */
 105 /*
 106     The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
 107     defines are now in config.h.  --Andy Dougherty  April 1998
 108  */
 109 #define SIZE16 2
 110 #define SIZE32 4
 111
 112 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
 113    --jhi Feb 1999 */
 114
 115 #if U16SIZE > SIZE16 || U32SIZE > SIZE32
 116 #  if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678    /* little-endian */
 117 #    define OFF16(p)    ((char*)(p))
 118 #    define OFF32(p)    ((char*)(p))
 119 #  else
 120 #    if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321  /* big-endian */
 121 #      define OFF16(p)  ((char*)(p) + (sizeof(U16) - SIZE16))
 122 #      define OFF32(p)  ((char*)(p) + (sizeof(U32) - SIZE32))
 123 #    else
 124        ++++ bad cray byte order
 125 #    endif
 126 #  endif
 127 #else
 128 #  define OFF16(p)     ((char *) (p))
 129 #  define OFF32(p)     ((char *) (p))
 130 #endif
 131
 132 /* Only to be used inside a loop (see the break) */
 133 #define SHIFT16(utf8, s, strend, p, datumtype) STMT_START {             \
 134     if (utf8) {                                                         \
 135         if (!uni_to_bytes(aTHX_ &(s), strend, OFF16(p), SIZE16, datumtype)) break;      \
 136     } else {                                                            \
 137         Copy(s, OFF16(p), SIZE16, char);                                \
 138         (s) += SIZE16;                                                  \
 139     }                                                                   \
 140 } STMT_END
 141
 142 /* Only to be used inside a loop (see the break) */
 143 #define SHIFT32(utf8, s, strend, p, datumtype) STMT_START {             \
 144     if (utf8) {                                                         \
 145         if (!uni_to_bytes(aTHX_ &(s), strend, OFF32(p), SIZE32, datumtype)) break;      \
 146     } else {                                                            \
 147         Copy(s, OFF32(p), SIZE32, char);                                \
 148         (s) += SIZE32;                                                  \
 149     }                                                                   \
 150 } STMT_END
 151
 152 #define PUSH16(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF16(p), SIZE16)
 153 #define PUSH32(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF32(p), SIZE32)
 154
 155 /* Only to be used inside a loop (see the break) */
 156 #define SHIFT_BYTES(utf8, s, strend, buf, len, datumtype)       \
 157 STMT_START {                                            \
 158     if (utf8) {                                         \
 159         if (!uni_to_bytes(aTHX_ &s, strend,             \
 160           (char *) (buf), len, datumtype)) break;       \
 161     } else {                                            \
 162         Copy(s, (char *) (buf), len, char);             \
 163         s += len;                                       \
 164     }                                                   \
 165 } STMT_END
 166
 167 #define SHIFT_VAR(utf8, s, strend, var, datumtype)      \
 168        SHIFT_BYTES(utf8, s, strend, &(var), sizeof(var), datumtype)
 169
 170 #define PUSH_VAR(utf8, aptr, var)       \
 171         PUSH_BYTES(utf8, aptr, &(var), sizeof(var))
 172
 173 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
 174 #define MAX_SUB_TEMPLATE_LEVEL 100
 175
 176 /* flags (note that type modifiers can also be used as flags!) */
 177 #define FLAG_WAS_UTF8         0x40
 178 #define FLAG_PARSE_UTF8       0x20      /* Parse as utf8 */
 179 #define FLAG_UNPACK_ONLY_ONE  0x10
 180 #define FLAG_DO_UTF8          0x08      /* The underlying string is utf8 */
 181 #define FLAG_SLASH            0x04
 182 #define FLAG_COMMA            0x02
 183 #define FLAG_PACK             0x01
 184
 185 STATIC SV *
 186 S_mul128(pTHX_ SV *sv, U8 m)
 187 {
 188   STRLEN          len;
 189   char           *s = SvPV(sv, len);
 190   char           *t;
 191
 192   PERL_ARGS_ASSERT_MUL128;
 193
 194   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
 195     SV * const tmpNew = newSVpvs("0000000000");
 196
 197     sv_catsv(tmpNew, sv);
 198     SvREFCNT_dec(sv);           /* free old sv */
 199     sv = tmpNew;
 200     s = SvPV(sv, len);
 201   }
 202   t = s + len - 1;
 203   while (!*t)                   /* trailing '\0'? */
 204     t--;
 205   while (t > s) {
 206     const U32 i = ((*t - '0') << 7) + m;
 207     *(t--) = '0' + (char)(i % 10);
 208     m = (char)(i / 10);
 209   }
 210   return (sv);
 211 }
 212
 213 /* Explosives and implosives. */
 214
 215 #if 'I' == 73 && 'J' == 74
 216 /* On an ASCII/ISO kind of system */
 217 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
 218 #else
 219 /*
 220   Some other sort of character set - use memchr() so we don't match
 221   the null byte.
 222  */
 223 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
 224 #endif
 225
 226 /* type modifiers */
 227 #define TYPE_IS_SHRIEKING       0x100
 228 #define TYPE_IS_BIG_ENDIAN      0x200
 229 #define TYPE_IS_LITTLE_ENDIAN   0x400
 230 #define TYPE_IS_PACK            0x800
 231 #define TYPE_ENDIANNESS_MASK    (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
 232 #define TYPE_MODIFIERS(t)       ((t) & ~0xFF)
 233 #define TYPE_NO_MODIFIERS(t)    ((t) & 0xFF)
 234
 235 # define TYPE_ENDIANNESS(t)     ((t) & TYPE_ENDIANNESS_MASK)
 236 # define TYPE_NO_ENDIANNESS(t)  ((t) & ~TYPE_ENDIANNESS_MASK)
 237
 238 # define ENDIANNESS_ALLOWED_TYPES   "sSiIlLqQjJfFdDpP("
 239
 240 # define DO_BO_UNPACK(var, type)                                              \
 241         STMT_START {                                                          \
 242           switch (TYPE_ENDIANNESS(datumtype)) {                               \
 243             case TYPE_IS_BIG_ENDIAN:    var = my_betoh ## type (var); break;  \
 244             case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break;  \
 245             default: break;                                                   \
 246           }                                                                   \
 247         } STMT_END
 248
 249 # define DO_BO_PACK(var, type)                                                \
 250         STMT_START {                                                          \
 251           switch (TYPE_ENDIANNESS(datumtype)) {                               \
 252             case TYPE_IS_BIG_ENDIAN:    var = my_htobe ## type (var); break;  \
 253             case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break;  \
 254             default: break;                                                   \
 255           }                                                                   \
 256         } STMT_END
 257
 258 # define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast)                     \
 259         STMT_START {                                                          \
 260           switch (TYPE_ENDIANNESS(datumtype)) {                               \
 261             case TYPE_IS_BIG_ENDIAN:                                          \
 262               var = (post_cast*) my_betoh ## type ((pre_cast) var);           \
 263               break;                                                          \
 264             case TYPE_IS_LITTLE_ENDIAN:                                       \
 265               var = (post_cast *) my_letoh ## type ((pre_cast) var);          \
 266               break;                                                          \
 267             default:                                                          \
 268               break;                                                          \
 269           }                                                                   \
 270         } STMT_END
 271
 272 # define DO_BO_PACK_PTR(var, type, pre_cast, post_cast)                       \
 273         STMT_START {                                                          \
 274           switch (TYPE_ENDIANNESS(datumtype)) {                               \
 275             case TYPE_IS_BIG_ENDIAN:                                          \
 276               var = (post_cast *) my_htobe ## type ((pre_cast) var);          \
 277               break;                                                          \
 278             case TYPE_IS_LITTLE_ENDIAN:                                       \
 279               var = (post_cast *) my_htole ## type ((pre_cast) var);          \
 280               break;                                                          \
 281             default:                                                          \
 282               break;                                                          \
 283           }                                                                   \
 284         } STMT_END
 285
 286 # define BO_CANT_DOIT(action, type)                                           \
 287         STMT_START {                                                          \
 288           switch (TYPE_ENDIANNESS(datumtype)) {                               \
 289              case TYPE_IS_BIG_ENDIAN:                                         \
 290                Perl_croak(aTHX_ "Can't %s big-endian %ss on this "            \
 291                                 "platform", #action, #type);                  \
 292                break;                                                         \
 293              case TYPE_IS_LITTLE_ENDIAN:                                      \
 294                Perl_croak(aTHX_ "Can't %s little-endian %ss on this "         \
 295                                 "platform", #action, #type);                  \
 296                break;                                                         \
 297              default:                                                         \
 298                break;                                                         \
 299            }                                                                  \
 300          } STMT_END
 301
 302 # if PTRSIZE == INTSIZE
 303 #  define DO_BO_UNPACK_P(var)   DO_BO_UNPACK_PTR(var, i, int, void)
 304 #  define DO_BO_PACK_P(var)     DO_BO_PACK_PTR(var, i, int, void)
 305 #  define DO_BO_UNPACK_PC(var)  DO_BO_UNPACK_PTR(var, i, int, char)
 306 #  define DO_BO_PACK_PC(var)    DO_BO_PACK_PTR(var, i, int, char)
 307 # elif PTRSIZE == LONGSIZE
 308 #  if LONGSIZE < IVSIZE && IVSIZE == 8
 309 #   define DO_BO_UNPACK_P(var)  DO_BO_UNPACK_PTR(var, 64, IV, void)
 310 #   define DO_BO_PACK_P(var)    DO_BO_PACK_PTR(var, 64, IV, void)
 311 #   define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, 64, IV, char)
 312 #   define DO_BO_PACK_PC(var)   DO_BO_PACK_PTR(var, 64, IV, char)
 313 #  else
 314 #   define DO_BO_UNPACK_P(var)  DO_BO_UNPACK_PTR(var, l, IV, void)
 315 #   define DO_BO_PACK_P(var)    DO_BO_PACK_PTR(var, l, IV, void)
 316 #   define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, IV, char)
 317 #   define DO_BO_PACK_PC(var)   DO_BO_PACK_PTR(var, l, IV, char)
 318 #  endif
 319 # elif PTRSIZE == IVSIZE
 320 #  define DO_BO_UNPACK_P(var)   DO_BO_UNPACK_PTR(var, l, IV, void)
 321 #  define DO_BO_PACK_P(var)     DO_BO_PACK_PTR(var, l, IV, void)
 322 #  define DO_BO_UNPACK_PC(var)  DO_BO_UNPACK_PTR(var, l, IV, char)
 323 #  define DO_BO_PACK_PC(var)    DO_BO_PACK_PTR(var, l, IV, char)
 324 # else
 325 #  define DO_BO_UNPACK_P(var)   BO_CANT_DOIT(unpack, pointer)
 326 #  define DO_BO_PACK_P(var)     BO_CANT_DOIT(pack, pointer)
 327 #  define DO_BO_UNPACK_PC(var)  BO_CANT_DOIT(unpack, pointer)
 328 #  define DO_BO_PACK_PC(var)    BO_CANT_DOIT(pack, pointer)
 329 # endif
 330
 331 # if defined(my_htolen) && defined(my_letohn) && \
 332     defined(my_htoben) && defined(my_betohn)
 333 #  define DO_BO_UNPACK_N(var, type)                                           \
 334          STMT_START {                                                         \
 335            switch (TYPE_ENDIANNESS(datumtype)) {                              \
 336              case TYPE_IS_BIG_ENDIAN:    my_betohn(&var, sizeof(type)); break;\
 337              case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
 338              default: break;                                                  \
 339            }                                                                  \
 340          } STMT_END
 341
 342 #  define DO_BO_PACK_N(var, type)                                             \
 343          STMT_START {                                                         \
 344            switch (TYPE_ENDIANNESS(datumtype)) {                              \
 345              case TYPE_IS_BIG_ENDIAN:    my_htoben(&var, sizeof(type)); break;\
 346              case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
 347              default: break;                                                  \
 348            }                                                                  \
 349          } STMT_END
 350 # else
 351 #  define DO_BO_UNPACK_N(var, type)     BO_CANT_DOIT(unpack, type)
 352 #  define DO_BO_PACK_N(var, type)       BO_CANT_DOIT(pack, type)
 353 # endif
 354
 355 #define PACK_SIZE_CANNOT_CSUM           0x80
 356 #define PACK_SIZE_UNPREDICTABLE         0x40    /* Not a fixed size element */
 357 #define PACK_SIZE_MASK                  0x3F
 358
 359 #include "packsizetables.c"
 360
 361 STATIC U8
 362 uni_to_byte(pTHX_ const char **s, const char *end, I32 datumtype)
 363 {
 364     STRLEN retlen;
 365     UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen,
 366                          ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
 367     /* We try to process malformed UTF-8 as much as possible (preferably with
 368        warnings), but these two mean we make no progress in the string and
 369        might enter an infinite loop */
 370     if (retlen == (STRLEN) -1 || retlen == 0)
 371         Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack",
 372                    (int) TYPE_NO_MODIFIERS(datumtype));
 373     if (val >= 0x100) {
 374         Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK),
 375                        "Character in '%c' format wrapped in unpack",
 376                        (int) TYPE_NO_MODIFIERS(datumtype));
 377         val &= 0xff;
 378     }
 379     *s += retlen;
 380     return (U8)val;
 381 }
 382
 383 #define SHIFT_BYTE(utf8, s, strend, datumtype) ((utf8) ? \
 384         uni_to_byte(aTHX_ &(s), (strend), (datumtype)) : \
 385         *(U8 *)(s)++)
 386
 387 STATIC bool
 388 uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len, I32 datumtype)
 389 {
 390     UV val;
 391     STRLEN retlen;
 392     const char *from = *s;
 393     int bad = 0;
 394     const U32 flags = ckWARN(WARN_UTF8) ?
 395         UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY | UTF8_ALLOW_ANY);
 396     for (;buf_len > 0; buf_len--) {
 397         if (from >= end) return FALSE;
 398         val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags);
 399         if (retlen == (STRLEN) -1 || retlen == 0) {
 400             from += UTF8SKIP(from);
 401             bad |= 1;
 402         } else from += retlen;
 403         if (val >= 0x100) {
 404             bad |= 2;
 405             val &= 0xff;
 406         }
 407         *(U8 *)buf++ = (U8)val;
 408     }
 409     /* We have enough characters for the buffer. Did we have problems ? */
 410     if (bad) {
 411         if (bad & 1) {
 412             /* Rewalk the string fragment while warning */
 413             const char *ptr;
 414             const int flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
 415             for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) {
 416                 if (ptr >= end) break;
 417                 utf8n_to_uvuni((U8 *) ptr, end-ptr, &retlen, flags);
 418             }
 419             if (from > end) from = end;
 420         }
 421         if ((bad & 2))
 422             Perl_ck_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ?
 423                                        WARN_PACK : WARN_UNPACK),
 424                            "Character(s) in '%c' format wrapped in %s",
 425                            (int) TYPE_NO_MODIFIERS(datumtype),
 426                            datumtype & TYPE_IS_PACK ? "pack" : "unpack");
 427     }
 428     *s = from;
 429     return TRUE;
 430 }
 431
 432 STATIC bool
 433 next_uni_uu(pTHX_ const char **s, const char *end, I32 *out)
 434 {
 435     dVAR;
 436     STRLEN retlen;
 437     const UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY);
 438     if (val >= 0x100 || !ISUUCHAR(val) ||
 439         retlen == (STRLEN) -1 || retlen == 0) {
 440         *out = 0;
 441         return FALSE;
 442     }
 443     *out = PL_uudmap[val] & 077;
 444     *s += retlen;
 445     return TRUE;
 446 }
 447
 448 STATIC char *
 449 S_bytes_to_uni(const U8 *start, STRLEN len, char *dest) {
 450     const U8 * const end = start + len;
 451
 452     PERL_ARGS_ASSERT_BYTES_TO_UNI;
 453
 454     while (start < end) {
 455         const UV uv = NATIVE_TO_ASCII(*start);
 456         if (UNI_IS_INVARIANT(uv))
 457             *dest++ = (char)(U8)UTF_TO_NATIVE(uv);
 458         else {
 459             *dest++ = (char)(U8)UTF8_EIGHT_BIT_HI(uv);
 460             *dest++ = (char)(U8)UTF8_EIGHT_BIT_LO(uv);
 461         }
 462         start++;
 463     }
 464     return dest;
 465 }
 466
 467 #define PUSH_BYTES(utf8, cur, buf, len)                         \
 468 STMT_START {                                                    \
 469     if (utf8)                                                   \
 470         (cur) = bytes_to_uni((U8 *) buf, len, (cur));           \
 471     else {                                                      \
 472         Copy(buf, cur, len, char);                              \
 473         (cur) += (len);                                         \
 474     }                                                           \
 475 } STMT_END
 476
 477 #define GROWING(utf8, cat, start, cur, in_len)  \
 478 STMT_START {                                    \
 479     STRLEN glen = (in_len);                     \
 480     if (utf8) glen *= UTF8_EXPAND;              \
 481     if ((cur) + glen >= (start) + SvLEN(cat)) { \
 482         (start) = sv_exp_grow(cat, glen);       \
 483         (cur) = (start) + SvCUR(cat);           \
 484     }                                           \
 485 } STMT_END
 486
 487 #define PUSH_GROWING_BYTES(utf8, cat, start, cur, buf, in_len) \
 488 STMT_START {                                    \
 489     const STRLEN glen = (in_len);               \
 490     STRLEN gl = glen;                           \
 491     if (utf8) gl *= UTF8_EXPAND;                \
 492     if ((cur) + gl >= (start) + SvLEN(cat)) {   \
 493         *cur = '\0';                            \
 494         SvCUR_set((cat), (cur) - (start));      \
 495         (start) = sv_exp_grow(cat, gl);         \
 496         (cur) = (start) + SvCUR(cat);           \
 497     }                                           \
 498     PUSH_BYTES(utf8, cur, buf, glen);           \
 499 } STMT_END
 500
 501 #define PUSH_BYTE(utf8, s, byte)                \
 502 STMT_START {                                    \
 503     if (utf8) {                                 \
 504         const U8 au8 = (byte);                  \
 505         (s) = bytes_to_uni(&au8, 1, (s));       \
 506     } else *(U8 *)(s)++ = (byte);               \
 507 } STMT_END
 508
 509 /* Only to be used inside a loop (see the break) */
 510 #define NEXT_UNI_VAL(val, cur, str, end, utf8_flags)            \
 511 STMT_START {                                                    \
 512     STRLEN retlen;                                              \
 513     if (str >= end) break;                                      \
 514     val = utf8n_to_uvchr((U8 *) str, end-str, &retlen, utf8_flags);     \
 515     if (retlen == (STRLEN) -1 || retlen == 0) {                 \
 516         *cur = '\0';                                            \
 517         Perl_croak(aTHX_ "Malformed UTF-8 string in pack");     \
 518     }                                                           \
 519     str += retlen;                                              \
 520 } STMT_END
 521
 522 static const char *_action( const tempsym_t* symptr )
 523 {
 524     return (const char *)(( symptr->flags & FLAG_PACK ) ? "pack" : "unpack");
 525 }
 526
 527 /* Returns the sizeof() struct described by pat */
 528 STATIC I32
 529 S_measure_struct(pTHX_ tempsym_t* symptr)
 530 {
 531     I32 total = 0;
 532
 533     PERL_ARGS_ASSERT_MEASURE_STRUCT;
 534
 535     while (next_symbol(symptr)) {
 536         I32 len;
 537         int size;
 538
 539         switch (symptr->howlen) {
 540           case e_star:
 541             Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
 542                         _action( symptr ) );
 543             break;
 544           default:
 545             /* e_no_len and e_number */
 546             len = symptr->length;
 547             break;
 548         }
 549
 550         size = packprops[TYPE_NO_ENDIANNESS(symptr->code)] & PACK_SIZE_MASK;
 551         if (!size) {
 552             int star;
 553             /* endianness doesn't influence the size of a type */
 554             switch(TYPE_NO_ENDIANNESS(symptr->code)) {
 555             default:
 556                 Perl_croak(aTHX_ "Invalid type '%c' in %s",
 557                            (int)TYPE_NO_MODIFIERS(symptr->code),
 558                            _action( symptr ) );
 559             case '.' | TYPE_IS_SHRIEKING:
 560             case '@' | TYPE_IS_SHRIEKING:
 561             case '@':
 562             case '.':
 563             case '/':
 564             case 'U':                   /* XXXX Is it correct? */
 565             case 'w':
 566             case 'u':
 567                 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
 568                            (int) TYPE_NO_MODIFIERS(symptr->code),
 569                            _action( symptr ) );
 570             case '%':
 571                 size = 0;
 572                 break;
 573             case '(':
 574             {
 575                 tempsym_t savsym = *symptr;
 576                 symptr->patptr = savsym.grpbeg;
 577                 symptr->patend = savsym.grpend;
 578                 /* XXXX Theoretically, we need to measure many times at
 579                    different positions, since the subexpression may contain
 580                    alignment commands, but be not of aligned length.
 581                    Need to detect this and croak().  */
 582                 size = measure_struct(symptr);
 583                 *symptr = savsym;
 584                 break;
 585             }
 586             case 'X' | TYPE_IS_SHRIEKING:
 587                 /* XXXX Is this useful?  Then need to treat MEASURE_BACKWARDS.
 588                  */
 589                 if (!len)               /* Avoid division by 0 */
 590                     len = 1;
 591                 len = total % len;      /* Assumed: the start is aligned. */
 592                 /* FALL THROUGH */
 593             case 'X':
 594                 size = -1;
 595                 if (total < len)
 596                     Perl_croak(aTHX_ "'X' outside of string in %s", _action( symptr ) );
 597                 break;
 598             case 'x' | TYPE_IS_SHRIEKING:
 599                 if (!len)               /* Avoid division by 0 */
 600                     len = 1;
 601                 star = total % len;     /* Assumed: the start is aligned. */
 602                 if (star)               /* Other portable ways? */
 603                     len = len - star;
 604                 else
 605                     len = 0;
 606                 /* FALL THROUGH */
 607             case 'x':
 608             case 'A':
 609             case 'Z':
 610             case 'a':
 611                 size = 1;
 612                 break;
 613             case 'B':
 614             case 'b':
 615                 len = (len + 7)/8;
 616                 size = 1;
 617                 break;
 618             case 'H':
 619             case 'h':
 620                 len = (len + 1)/2;
 621                 size = 1;
 622                 break;
 623
 624             case 'P':
 625                 len = 1;
 626                 size = sizeof(char*);
 627                 break;
 628             }
 629         }
 630         total += len * size;
 631     }
 632     return total;
 633 }
 634
 635
 636 /* locate matching closing parenthesis or bracket
 637  * returns char pointer to char after match, or NULL
 638  */
 639 STATIC const char *
 640 S_group_end(pTHX_ const char *patptr, const char *patend, char ender)
 641 {
 642     PERL_ARGS_ASSERT_GROUP_END;
 643
 644     while (patptr < patend) {
 645         const char c = *patptr++;
 646
 647         if (isSPACE(c))
 648             continue;
 649         else if (c == ender)
 650             return patptr-1;
 651         else if (c == '#') {
 652             while (patptr < patend && *patptr != '\n')
 653                 patptr++;
 654             continue;
 655         } else if (c == '(')
 656             patptr = group_end(patptr, patend, ')') + 1;
 657         else if (c == '[')
 658             patptr = group_end(patptr, patend, ']') + 1;
 659     }
 660     Perl_croak(aTHX_ "No group ending character '%c' found in template",
 661                ender);
 662     return 0;
 663 }
 664
 665
 666 /* Convert unsigned decimal number to binary.
 667  * Expects a pointer to the first digit and address of length variable
 668  * Advances char pointer to 1st non-digit char and returns number
 669  */
 670 STATIC const char *
 671 S_get_num(pTHX_ const char *patptr, I32 *lenptr )
 672 {
 673   I32 len = *patptr++ - '0';
 674
 675   PERL_ARGS_ASSERT_GET_NUM;
 676
 677   while (isDIGIT(*patptr)) {
 678     if (len >= 0x7FFFFFFF/10)
 679       Perl_croak(aTHX_ "pack/unpack repeat count overflow");
 680     len = (len * 10) + (*patptr++ - '0');
 681   }
 682   *lenptr = len;
 683   return patptr;
 684 }
 685
 686 /* The marvellous template parsing routine: Using state stored in *symptr,
 687  * locates next template code and count
 688  */
 689 STATIC bool
 690 S_next_symbol(pTHX_ tempsym_t* symptr )
 691 {
 692   const char* patptr = symptr->patptr;
 693   const char* const patend = symptr->patend;
 694
 695   PERL_ARGS_ASSERT_NEXT_SYMBOL;
 696
 697   symptr->flags &= ~FLAG_SLASH;
 698
 699   while (patptr < patend) {
 700     if (isSPACE(*patptr))
 701       patptr++;
 702     else if (*patptr == '#') {
 703       patptr++;
 704       while (patptr < patend && *patptr != '\n')
 705         patptr++;
 706       if (patptr < patend)
 707         patptr++;
 708     } else {
 709       /* We should have found a template code */
 710       I32 code = *patptr++ & 0xFF;
 711       U32 inherited_modifiers = 0;
 712
 713       if (code == ','){ /* grandfather in commas but with a warning */
 714         if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
 715           symptr->flags |= FLAG_COMMA;
 716           Perl_warner(aTHX_ packWARN(WARN_UNPACK),
 717                       "Invalid type ',' in %s", _action( symptr ) );
 718         }
 719         continue;
 720       }
 721
 722       /* for '(', skip to ')' */
 723       if (code == '(') {
 724         if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
 725           Perl_croak(aTHX_ "()-group starts with a count in %s",
 726                         _action( symptr ) );
 727         symptr->grpbeg = patptr;
 728         patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
 729         if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
 730           Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
 731                         _action( symptr ) );
 732       }
 733
 734       /* look for group modifiers to inherit */
 735       if (TYPE_ENDIANNESS(symptr->flags)) {
 736         if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
 737           inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
 738       }
 739
 740       /* look for modifiers */
 741       while (patptr < patend) {
 742         const char *allowed;
 743         I32 modifier;
 744         switch (*patptr) {
 745           case '!':
 746             modifier = TYPE_IS_SHRIEKING;
 747             allowed = "sSiIlLxXnNvV@.";
 748             break;
 749           case '>':
 750             modifier = TYPE_IS_BIG_ENDIAN;
 751             allowed = ENDIANNESS_ALLOWED_TYPES;
 752             break;
 753           case '<':
 754             modifier = TYPE_IS_LITTLE_ENDIAN;
 755             allowed = ENDIANNESS_ALLOWED_TYPES;
 756             break;
 757           default:
 758             allowed = "";
 759             modifier = 0;
 760             break;
 761         }
 762
 763         if (modifier == 0)
 764           break;
 765
 766         if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
 767           Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
 768                         allowed, _action( symptr ) );
 769
 770         if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
 771           Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
 772                      (int) TYPE_NO_MODIFIERS(code), _action( symptr ) );
 773         else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
 774                  TYPE_ENDIANNESS_MASK)
 775           Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
 776                      *patptr, _action( symptr ) );
 777
 778         if ((code & modifier)) {
 779             Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK),
 780                            "Duplicate modifier '%c' after '%c' in %s",
 781                            *patptr, (int) TYPE_NO_MODIFIERS(code),
 782                            _action( symptr ) );
 783         }
 784
 785         code |= modifier;
 786         patptr++;
 787       }
 788
 789       /* inherit modifiers */
 790       code |= inherited_modifiers;
 791
 792       /* look for count and/or / */
 793       if (patptr < patend) {
 794         if (isDIGIT(*patptr)) {
 795           patptr = get_num( patptr, &symptr->length );
 796           symptr->howlen = e_number;
 797
 798         } else if (*patptr == '*') {
 799           patptr++;
 800           symptr->howlen = e_star;
 801
 802         } else if (*patptr == '[') {
 803           const char* lenptr = ++patptr;
 804           symptr->howlen = e_number;
 805           patptr = group_end( patptr, patend, ']' ) + 1;
 806           /* what kind of [] is it? */
 807           if (isDIGIT(*lenptr)) {
 808             lenptr = get_num( lenptr, &symptr->length );
 809             if( *lenptr != ']' )
 810               Perl_croak(aTHX_ "Malformed integer in [] in %s",
 811                             _action( symptr ) );
 812           } else {
 813             tempsym_t savsym = *symptr;
 814             symptr->patend = patptr-1;
 815             symptr->patptr = lenptr;
 816             savsym.length = measure_struct(symptr);
 817             *symptr = savsym;
 818           }
 819         } else {
 820           symptr->howlen = e_no_len;
 821           symptr->length = 1;
 822         }
 823
 824         /* try to find / */
 825         while (patptr < patend) {
 826           if (isSPACE(*patptr))
 827             patptr++;
 828           else if (*patptr == '#') {
 829             patptr++;
 830             while (patptr < patend && *patptr != '\n')
 831               patptr++;
 832             if (patptr < patend)
 833               patptr++;
 834           } else {
 835             if (*patptr == '/') {
 836               symptr->flags |= FLAG_SLASH;
 837               patptr++;
 838               if (patptr < patend &&
 839                   (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
 840                 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
 841                             _action( symptr ) );
 842             }
 843             break;
 844           }
 845         }
 846       } else {
 847         /* at end - no count, no / */
 848         symptr->howlen = e_no_len;
 849         symptr->length = 1;
 850       }
 851
 852       symptr->code = code;
 853       symptr->patptr = patptr;
 854       return TRUE;
 855     }
 856   }
 857   symptr->patptr = patptr;
 858   return FALSE;
 859 }
 860
 861 /*
 862    There is no way to cleanly handle the case where we should process the
 863    string per byte in its upgraded form while it's really in downgraded form
 864    (e.g. estimates like strend-s as an upper bound for the number of
 865    characters left wouldn't work). So if we foresee the need of this
 866    (pattern starts with U or contains U0), we want to work on the encoded
 867    version of the string. Users are advised to upgrade their pack string
 868    themselves if they need to do a lot of unpacks like this on it
 869 */
 870 STATIC bool
 871 need_utf8(const char *pat, const char *patend)
 872 {
 873     bool first = TRUE;
 874
 875     PERL_ARGS_ASSERT_NEED_UTF8;
 876
 877     while (pat < patend) {
 878         if (pat[0] == '#') {
 879             pat++;
 880             pat = (const char *) memchr(pat, '\n', patend-pat);
 881             if (!pat) return FALSE;
 882         } else if (pat[0] == 'U') {
 883             if (first || pat[1] == '0') return TRUE;
 884         } else first = FALSE;
 885         pat++;
 886     }
 887     return FALSE;
 888 }
 889
 890 STATIC char
 891 first_symbol(const char *pat, const char *patend) {
 892     PERL_ARGS_ASSERT_FIRST_SYMBOL;
 893
 894     while (pat < patend) {
 895         if (pat[0] != '#') return pat[0];
 896         pat++;
 897         pat = (const char *) memchr(pat, '\n', patend-pat);
 898         if (!pat) return 0;
 899         pat++;
 900     }
 901     return 0;
 902 }
 903
 904 /*
 905 =for apidoc unpackstring
 906
 907 The engine implementing the unpack() Perl function.
 908
 909 Using the template pat..patend, this function unpacks the string
 910 s..strend into a number of mortal SVs, which it pushes onto the perl
 911 argument (@_) stack (so you will need to issue a C<PUTBACK> before and
 912 C<SPAGAIN> after the call to this function). It returns the number of
 913 pushed elements.
 914
 915 The strend and patend pointers should point to the byte following the last
 916 character of each string.
 917
 918 Although this function returns its values on the perl argument stack, it
 919 doesn't take any parameters from that stack (and thus in particular
 920 there's no need to do a PUSHMARK before calling it, unlike L</call_pv> for
 921 example).
 922
 923 =cut */
 924
 925 I32
 926 Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, const char *strend, U32 flags)
 927 {
 928     tempsym_t sym;
 929
 930     PERL_ARGS_ASSERT_UNPACKSTRING;
 931
 932     if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8;
 933     else if (need_utf8(pat, patend)) {
 934         /* We probably should try to avoid this in case a scalar context call
 935            wouldn't get to the "U0" */
 936         STRLEN len = strend - s;
 937         s = (char *) bytes_to_utf8((U8 *) s, &len);
 938         SAVEFREEPV(s);
 939         strend = s + len;
 940         flags |= FLAG_DO_UTF8;
 941     }
 942
 943     if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8))
 944         flags |= FLAG_PARSE_UTF8;
 945
 946     TEMPSYM_INIT(&sym, pat, patend, flags);
 947
 948     return unpack_rec(&sym, s, s, strend, NULL );
 949 }
 950
 951 STATIC I32
 952 S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s )
 953 {
 954     dVAR; dSP;
 955     SV *sv = NULL;
 956     const I32 start_sp_offset = SP - PL_stack_base;
 957     howlen_t howlen;
 958     I32 checksum = 0;
 959     UV cuv = 0;
 960     NV cdouble = 0.0;
 961     const int bits_in_uv = CHAR_BIT * sizeof(cuv);
 962     bool beyond = FALSE;
 963     bool explicit_length;
 964     const bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
 965     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
 966
 967     PERL_ARGS_ASSERT_UNPACK_REC;
 968
 969     symptr->strbeg = s - strbeg;
 970
 971     while (next_symbol(symptr)) {
 972         packprops_t props;
 973         I32 len;
 974         I32 datumtype = symptr->code;
 975         /* do first one only unless in list context
 976            / is implemented by unpacking the count, then popping it from the
 977            stack, so must check that we're not in the middle of a /  */
 978         if ( unpack_only_one
 979              && (SP - PL_stack_base == start_sp_offset + 1)
 980              && (datumtype != '/') )   /* XXX can this be omitted */
 981             break;
 982
 983         switch (howlen = symptr->howlen) {
 984           case e_star:
 985             len = strend - strbeg;      /* long enough */
 986             break;
 987           default:
 988             /* e_no_len and e_number */
 989             len = symptr->length;
 990             break;
 991         }
 992
 993         explicit_length = TRUE;
 994       redo_switch:
 995         beyond = s >= strend;
 996
 997         props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
 998         if (props) {
 999             /* props nonzero means we can process this letter. */
1000             const long size = props & PACK_SIZE_MASK;
1001             const long howmany = (strend - s) / size;
1002             if (len > howmany)
1003                 len = howmany;
1004
1005             if (!checksum || (props & PACK_SIZE_CANNOT_CSUM)) {
1006                 if (len && unpack_only_one) len = 1;
1007                 EXTEND(SP, len);
1008                 EXTEND_MORTAL(len);
1009             }
1010         }
1011
1012         switch(TYPE_NO_ENDIANNESS(datumtype)) {
1013         default:
1014             Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
1015
1016         case '%':
1017             if (howlen == e_no_len)
1018                 len = 16;               /* len is not specified */
1019             checksum = len;
1020             cuv = 0;
1021             cdouble = 0;
1022             continue;
1023             break;
1024         case '(':
1025         {
1026             tempsym_t savsym = *symptr;
1027             const U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
1028             symptr->flags |= group_modifiers;
1029             symptr->patend = savsym.grpend;
1030             symptr->previous = &savsym;
1031             symptr->level++;
1032             PUTBACK;
1033             if (len && unpack_only_one) len = 1;
1034             while (len--) {
1035                 symptr->patptr = savsym.grpbeg;
1036                 if (utf8) symptr->flags |=  FLAG_PARSE_UTF8;
1037                 else      symptr->flags &= ~FLAG_PARSE_UTF8;
1038                 unpack_rec(symptr, s, strbeg, strend, &s);
1039                 if (s == strend && savsym.howlen == e_star)
1040                     break; /* No way to continue */
1041             }
1042             SPAGAIN;
1043             savsym.flags = symptr->flags & ~group_modifiers;
1044             *symptr = savsym;
1045             break;
1046         }
1047         case '.' | TYPE_IS_SHRIEKING:
1048         case '.': {
1049             const char *from;
1050             SV *sv;
1051             const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING);
1052             if (howlen == e_star) from = strbeg;
1053             else if (len <= 0) from = s;
1054             else {
1055                 tempsym_t *group = symptr;
1056
1057                 while (--len && group) group = group->previous;
1058                 from = group ? strbeg + group->strbeg : strbeg;
1059             }
1060             sv = from <= s ?
1061                 newSVuv(  u8 ? (UV) utf8_length((const U8*)from, (const U8*)s) : (UV) (s-from)) :
1062                 newSViv(-(u8 ? (IV) utf8_length((const U8*)s, (const U8*)from) : (IV) (from-s)));
1063             mXPUSHs(sv);
1064             break;
1065         }
1066         case '@' | TYPE_IS_SHRIEKING:
1067         case '@':
1068             s = strbeg + symptr->strbeg;
1069             if (utf8  && !(datumtype & TYPE_IS_SHRIEKING))
1070             {
1071                 while (len > 0) {
1072                     if (s >= strend)
1073                         Perl_croak(aTHX_ "'@' outside of string in unpack");
1074                     s += UTF8SKIP(s);
1075                     len--;
1076                 }
1077                 if (s > strend)
1078                     Perl_croak(aTHX_ "'@' outside of string with malformed UTF-8 in unpack");
1079             } else {
1080                 if (strend-s < len)
1081                     Perl_croak(aTHX_ "'@' outside of string in unpack");
1082                 s += len;
1083             }
1084             break;
1085         case 'X' | TYPE_IS_SHRIEKING:
1086             if (!len)                   /* Avoid division by 0 */
1087                 len = 1;
1088             if (utf8) {
1089                 const char *hop, *last;
1090                 I32 l = len;
1091                 hop = last = strbeg;
1092                 while (hop < s) {
1093                     hop += UTF8SKIP(hop);
1094                     if (--l == 0) {
1095                         last = hop;
1096                         l = len;
1097                     }
1098                 }
1099                 if (last > s)
1100                     Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1101                 s = last;
1102                 break;
1103             }
1104             len = (s - strbeg) % len;
1105             /* FALL THROUGH */
1106         case 'X':
1107             if (utf8) {
1108                 while (len > 0) {
1109                     if (s <= strbeg)
1110                         Perl_croak(aTHX_ "'X' outside of string in unpack");
1111                     while (--s, UTF8_IS_CONTINUATION(*s)) {
1112                         if (s <= strbeg)
1113                             Perl_croak(aTHX_ "'X' outside of string in unpack");
1114                     }
1115                     len--;
1116                 }
1117             } else {
1118                 if (len > s - strbeg)
1119                     Perl_croak(aTHX_ "'X' outside of string in unpack" );
1120                 s -= len;
1121             }
1122             break;
1123         case 'x' | TYPE_IS_SHRIEKING: {
1124             I32 ai32;
1125             if (!len)                   /* Avoid division by 0 */
1126                 len = 1;
1127             if (utf8) ai32 = utf8_length((U8 *) strbeg, (U8 *) s) % len;
1128             else      ai32 = (s - strbeg)                         % len;
1129             if (ai32 == 0) break;
1130             len -= ai32;
1131             }
1132             /* FALL THROUGH */
1133         case 'x':
1134             if (utf8) {
1135                 while (len>0) {
1136                     if (s >= strend)
1137                         Perl_croak(aTHX_ "'x' outside of string in unpack");
1138                     s += UTF8SKIP(s);
1139                     len--;
1140                 }
1141             } else {
1142                 if (len > strend - s)
1143                     Perl_croak(aTHX_ "'x' outside of string in unpack");
1144                 s += len;
1145             }
1146             break;
1147         case '/':
1148             Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1149             break;
1150         case 'A':
1151         case 'Z':
1152         case 'a':
1153             if (checksum) {
1154                 /* Preliminary length estimate is assumed done in 'W' */
1155                 if (len > strend - s) len = strend - s;
1156                 goto W_checksum;
1157             }
1158             if (utf8) {
1159                 I32 l;
1160                 const char *hop;
1161                 for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) {
1162                     if (hop >= strend) {
1163                         if (hop > strend)
1164                             Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1165                         break;
1166                     }
1167                 }
1168                 if (hop > strend)
1169                     Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1170                 len = hop - s;
1171             } else if (len > strend - s)
1172                 len = strend - s;
1173
1174             if (datumtype == 'Z') {
1175                 /* 'Z' strips stuff after first null */
1176                 const char *ptr, *end;
1177                 end = s + len;
1178                 for (ptr = s; ptr < end; ptr++) if (*ptr == 0) break;
1179                 sv = newSVpvn(s, ptr-s);
1180                 if (howlen == e_star) /* exact for 'Z*' */
1181                     len = ptr-s + (ptr != strend ? 1 : 0);
1182             } else if (datumtype == 'A') {
1183                 /* 'A' strips both nulls and spaces */
1184                 const char *ptr;
1185                 if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) {
1186                     for (ptr = s+len-1; ptr >= s; ptr--)
1187                         if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) &&
1188                             !isSPACE_utf8(ptr)) break;
1189                     if (ptr >= s) ptr += UTF8SKIP(ptr);
1190                     else ptr++;
1191                     if (ptr > s+len)
1192                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1193                 } else {
1194                     for (ptr = s+len-1; ptr >= s; ptr--)
1195                         if (*ptr != 0 && !isSPACE(*ptr)) break;
1196                     ptr++;
1197                 }
1198                 sv = newSVpvn(s, ptr-s);
1199             } else sv = newSVpvn(s, len);
1200
1201             if (utf8) {
1202                 SvUTF8_on(sv);
1203                 /* Undo any upgrade done due to need_utf8() */
1204                 if (!(symptr->flags & FLAG_WAS_UTF8))
1205                     sv_utf8_downgrade(sv, 0);
1206             }
1207             mXPUSHs(sv);
1208             s += len;
1209             break;
1210         case 'B':
1211         case 'b': {
1212             char *str;
1213             if (howlen == e_star || len > (strend - s) * 8)
1214                 len = (strend - s) * 8;
1215             if (checksum) {
1216                 if (utf8)
1217                     while (len >= 8 && s < strend) {
1218                         cuv += PL_bitcount[uni_to_byte(aTHX_ &s, strend, datumtype)];
1219                         len -= 8;
1220                     }
1221                 else
1222                     while (len >= 8) {
1223                         cuv += PL_bitcount[*(U8 *)s++];
1224                         len -= 8;
1225                     }
1226                 if (len && s < strend) {
1227                     U8 bits;
1228                     bits = SHIFT_BYTE(utf8, s, strend, datumtype);
1229                     if (datumtype == 'b')
1230                         while (len-- > 0) {
1231                             if (bits & 1) cuv++;
1232                             bits >>= 1;
1233                         }
1234                     else
1235                         while (len-- > 0) {
1236                             if (bits & 0x80) cuv++;
1237                             bits <<= 1;
1238                         }
1239                 }
1240                 break;
1241             }
1242
1243             sv = sv_2mortal(newSV(len ? len : 1));
1244             SvPOK_on(sv);
1245             str = SvPVX(sv);
1246             if (datumtype == 'b') {
1247                 U8 bits = 0;
1248                 const I32 ai32 = len;
1249                 for (len = 0; len < ai32; len++) {
1250                     if (len & 7) bits >>= 1;
1251                     else if (utf8) {
1252                         if (s >= strend) break;
1253                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1254                     } else bits = *(U8 *) s++;
1255                     *str++ = bits & 1 ? '1' : '0';
1256                 }
1257             } else {
1258                 U8 bits = 0;
1259                 const I32 ai32 = len;
1260                 for (len = 0; len < ai32; len++) {
1261                     if (len & 7) bits <<= 1;
1262                     else if (utf8) {
1263                         if (s >= strend) break;
1264                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1265                     } else bits = *(U8 *) s++;
1266                     *str++ = bits & 0x80 ? '1' : '0';
1267                 }
1268             }
1269             *str = '\0';
1270             SvCUR_set(sv, str - SvPVX_const(sv));
1271             XPUSHs(sv);
1272             break;
1273         }
1274         case 'H':
1275         case 'h': {
1276             char *str = NULL;
1277             /* Preliminary length estimate, acceptable for utf8 too */
1278             if (howlen == e_star || len > (strend - s) * 2)
1279                 len = (strend - s) * 2;
1280             if (!checksum) {
1281                 sv = sv_2mortal(newSV(len ? len : 1));
1282                 SvPOK_on(sv);
1283                 str = SvPVX(sv);
1284             }
1285             if (datumtype == 'h') {
1286                 U8 bits = 0;
1287                 I32 ai32 = len;
1288                 for (len = 0; len < ai32; len++) {
1289                     if (len & 1) bits >>= 4;
1290                     else if (utf8) {
1291                         if (s >= strend) break;
1292                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1293                     } else bits = * (U8 *) s++;
1294                     if (!checksum)
1295                         *str++ = PL_hexdigit[bits & 15];
1296                 }
1297             } else {
1298                 U8 bits = 0;
1299                 const I32 ai32 = len;
1300                 for (len = 0; len < ai32; len++) {
1301                     if (len & 1) bits <<= 4;
1302                     else if (utf8) {
1303                         if (s >= strend) break;
1304                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1305                     } else bits = *(U8 *) s++;
1306                     if (!checksum)
1307                         *str++ = PL_hexdigit[(bits >> 4) & 15];
1308                 }
1309             }
1310             if (!checksum) {
1311                 *str = '\0';
1312                 SvCUR_set(sv, str - SvPVX_const(sv));
1313                 XPUSHs(sv);
1314             }
1315             break;
1316         }
1317         case 'C':
1318             if (len == 0) {
1319                 if (explicit_length)
1320                     /* Switch to "character" mode */
1321                     utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
1322                 break;
1323             }
1324             /* FALL THROUGH */
1325         case 'c':
1326             while (len-- > 0 && s < strend) {
1327                 int aint;
1328                 if (utf8)
1329                   {
1330                     STRLEN retlen;
1331                     aint = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
1332                                  ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1333                     if (retlen == (STRLEN) -1 || retlen == 0)
1334                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1335                     s += retlen;
1336                   }
1337                 else
1338                   aint = *(U8 *)(s)++;
1339                 if (aint >= 128 && datumtype != 'C')    /* fake up signed chars */
1340                     aint -= 256;
1341                 if (!checksum)
1342                     mPUSHi(aint);
1343                 else if (checksum > bits_in_uv)
1344                     cdouble += (NV)aint;
1345                 else
1346                     cuv += aint;
1347             }
1348             break;
1349         case 'W':
1350           W_checksum:
1351             if (utf8) {
1352                 while (len-- > 0 && s < strend) {
1353                     STRLEN retlen;
1354                     const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
1355                                          ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1356                     if (retlen == (STRLEN) -1 || retlen == 0)
1357                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1358                     s += retlen;
1359                     if (!checksum)
1360                         mPUSHu(val);
1361                     else if (checksum > bits_in_uv)
1362                         cdouble += (NV) val;
1363                     else
1364                         cuv += val;
1365                 }
1366             } else if (!checksum)
1367                 while (len-- > 0) {
1368                     const U8 ch = *(U8 *) s++;
1369                     mPUSHu(ch);
1370             }
1371             else if (checksum > bits_in_uv)
1372                 while (len-- > 0) cdouble += (NV) *(U8 *) s++;
1373             else
1374                 while (len-- > 0) cuv += *(U8 *) s++;
1375             break;
1376         case 'U':
1377             if (len == 0) {
1378                 if (explicit_length && howlen != e_star) {
1379                     /* Switch to "bytes in UTF-8" mode */
1380                     if (symptr->flags & FLAG_DO_UTF8) utf8 = 0;
1381                     else
1382                         /* Should be impossible due to the need_utf8() test */
1383                         Perl_croak(aTHX_ "U0 mode on a byte string");
1384                 }
1385                 break;
1386             }
1387             if (len > strend - s) len = strend - s;
1388             if (!checksum) {
1389                 if (len && unpack_only_one) len = 1;
1390                 EXTEND(SP, len);
1391                 EXTEND_MORTAL(len);
1392             }
1393             while (len-- > 0 && s < strend) {
1394                 STRLEN retlen;
1395                 UV auv;
1396                 if (utf8) {
1397                     U8 result[UTF8_MAXLEN];
1398                     const char *ptr = s;
1399                     STRLEN len;
1400                     /* Bug: warns about bad utf8 even if we are short on bytes
1401                        and will break out of the loop */
1402                     if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) result, 1,
1403                                       'U'))
1404                         break;
1405                     len = UTF8SKIP(result);
1406                     if (!uni_to_bytes(aTHX_ &ptr, strend,
1407                                       (char *) &result[1], len-1, 'U')) break;
1408                     auv = utf8n_to_uvuni(result, len, &retlen, UTF8_ALLOW_DEFAULT);
1409                     s = ptr;
1410                 } else {
1411                     auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, UTF8_ALLOW_DEFAULT);
1412                     if (retlen == (STRLEN) -1 || retlen == 0)
1413                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1414                     s += retlen;
1415                 }
1416                 if (!checksum)
1417                     mPUSHu(auv);
1418                 else if (checksum > bits_in_uv)
1419                     cdouble += (NV) auv;
1420                 else
1421                     cuv += auv;
1422             }
1423             break;
1424         case 's' | TYPE_IS_SHRIEKING:
1425 #if SHORTSIZE != SIZE16
1426             while (len-- > 0) {
1427                 short ashort;
1428                 SHIFT_VAR(utf8, s, strend, ashort, datumtype);
1429                 DO_BO_UNPACK(ashort, s);
1430                 if (!checksum)
1431                     mPUSHi(ashort);
1432                 else if (checksum > bits_in_uv)
1433                     cdouble += (NV)ashort;
1434                 else
1435                     cuv += ashort;
1436             }
1437             break;
1438 #else
1439             /* Fallthrough! */
1440 #endif
1441         case 's':
1442             while (len-- > 0) {
1443                 I16 ai16;
1444
1445 #if U16SIZE > SIZE16
1446                 ai16 = 0;
1447 #endif
1448                 SHIFT16(utf8, s, strend, &ai16, datumtype);
1449                 DO_BO_UNPACK(ai16, 16);
1450 #if U16SIZE > SIZE16
1451                 if (ai16 > 32767)
1452                     ai16 -= 65536;
1453 #endif
1454                 if (!checksum)
1455                     mPUSHi(ai16);
1456                 else if (checksum > bits_in_uv)
1457                     cdouble += (NV)ai16;
1458                 else
1459                     cuv += ai16;
1460             }
1461             break;
1462         case 'S' | TYPE_IS_SHRIEKING:
1463 #if SHORTSIZE != SIZE16
1464             while (len-- > 0) {
1465                 unsigned short aushort;
1466                 SHIFT_VAR(utf8, s, strend, aushort, datumtype);
1467                 DO_BO_UNPACK(aushort, s);
1468                 if (!checksum)
1469                     mPUSHu(aushort);
1470                 else if (checksum > bits_in_uv)
1471                     cdouble += (NV)aushort;
1472                 else
1473                     cuv += aushort;
1474             }
1475             break;
1476 #else
1477             /* Fallthrough! */
1478 #endif
1479         case 'v':
1480         case 'n':
1481         case 'S':
1482             while (len-- > 0) {
1483                 U16 au16;
1484 #if U16SIZE > SIZE16
1485                 au16 = 0;
1486 #endif
1487                 SHIFT16(utf8, s, strend, &au16, datumtype);
1488                 DO_BO_UNPACK(au16, 16);
1489 #ifdef HAS_NTOHS
1490                 if (datumtype == 'n')
1491                     au16 = PerlSock_ntohs(au16);
1492 #endif
1493 #ifdef HAS_VTOHS
1494                 if (datumtype == 'v')
1495                     au16 = vtohs(au16);
1496 #endif
1497                 if (!checksum)
1498                     mPUSHu(au16);
1499                 else if (checksum > bits_in_uv)
1500                     cdouble += (NV) au16;
1501                 else
1502                     cuv += au16;
1503             }
1504             break;
1505         case 'v' | TYPE_IS_SHRIEKING:
1506         case 'n' | TYPE_IS_SHRIEKING:
1507             while (len-- > 0) {
1508                 I16 ai16;
1509 # if U16SIZE > SIZE16
1510                 ai16 = 0;
1511 # endif
1512                 SHIFT16(utf8, s, strend, &ai16, datumtype);
1513 # ifdef HAS_NTOHS
1514                 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1515                     ai16 = (I16) PerlSock_ntohs((U16) ai16);
1516 # endif /* HAS_NTOHS */
1517 # ifdef HAS_VTOHS
1518                 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1519                     ai16 = (I16) vtohs((U16) ai16);
1520 # endif /* HAS_VTOHS */
1521                 if (!checksum)
1522                     mPUSHi(ai16);
1523                 else if (checksum > bits_in_uv)
1524                     cdouble += (NV) ai16;
1525                 else
1526                     cuv += ai16;
1527             }
1528             break;
1529         case 'i':
1530         case 'i' | TYPE_IS_SHRIEKING:
1531             while (len-- > 0) {
1532                 int aint;
1533                 SHIFT_VAR(utf8, s, strend, aint, datumtype);
1534                 DO_BO_UNPACK(aint, i);
1535                 if (!checksum)
1536                     mPUSHi(aint);
1537                 else if (checksum > bits_in_uv)
1538                     cdouble += (NV)aint;
1539                 else
1540                     cuv += aint;
1541             }
1542             break;
1543         case 'I':
1544         case 'I' | TYPE_IS_SHRIEKING:
1545             while (len-- > 0) {
1546                 unsigned int auint;
1547                 SHIFT_VAR(utf8, s, strend, auint, datumtype);
1548                 DO_BO_UNPACK(auint, i);
1549                 if (!checksum)
1550                     mPUSHu(auint);
1551                 else if (checksum > bits_in_uv)
1552                     cdouble += (NV)auint;
1553                 else
1554                     cuv += auint;
1555             }
1556             break;
1557         case 'j':
1558             while (len-- > 0) {
1559                 IV aiv;
1560                 SHIFT_VAR(utf8, s, strend, aiv, datumtype);
1561 #if IVSIZE == INTSIZE
1562                 DO_BO_UNPACK(aiv, i);
1563 #elif IVSIZE == LONGSIZE
1564                 DO_BO_UNPACK(aiv, l);
1565 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1566                 DO_BO_UNPACK(aiv, 64);
1567 #else
1568                 Perl_croak(aTHX_ "'j' not supported on this platform");
1569 #endif
1570                 if (!checksum)
1571                     mPUSHi(aiv);
1572                 else if (checksum > bits_in_uv)
1573                     cdouble += (NV)aiv;
1574                 else
1575                     cuv += aiv;
1576             }
1577             break;
1578         case 'J':
1579             while (len-- > 0) {
1580                 UV auv;
1581                 SHIFT_VAR(utf8, s, strend, auv, datumtype);
1582 #if IVSIZE == INTSIZE
1583                 DO_BO_UNPACK(auv, i);
1584 #elif IVSIZE == LONGSIZE
1585                 DO_BO_UNPACK(auv, l);
1586 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1587                 DO_BO_UNPACK(auv, 64);
1588 #else
1589                 Perl_croak(aTHX_ "'J' not supported on this platform");
1590 #endif
1591                 if (!checksum)
1592                     mPUSHu(auv);
1593                 else if (checksum > bits_in_uv)
1594                     cdouble += (NV)auv;
1595                 else
1596                     cuv += auv;
1597             }
1598             break;
1599         case 'l' | TYPE_IS_SHRIEKING:
1600 #if LONGSIZE != SIZE32
1601             while (len-- > 0) {
1602                 long along;
1603                 SHIFT_VAR(utf8, s, strend, along, datumtype);
1604                 DO_BO_UNPACK(along, l);
1605                 if (!checksum)
1606                     mPUSHi(along);
1607                 else if (checksum > bits_in_uv)
1608                     cdouble += (NV)along;
1609                 else
1610                     cuv += along;
1611             }
1612             break;
1613 #else
1614             /* Fallthrough! */
1615 #endif
1616         case 'l':
1617             while (len-- > 0) {
1618                 I32 ai32;
1619 #if U32SIZE > SIZE32
1620                 ai32 = 0;
1621 #endif
1622                 SHIFT32(utf8, s, strend, &ai32, datumtype);
1623                 DO_BO_UNPACK(ai32, 32);
1624 #if U32SIZE > SIZE32
1625                 if (ai32 > 2147483647) ai32 -= 4294967296;
1626 #endif
1627                 if (!checksum)
1628                     mPUSHi(ai32);
1629                 else if (checksum > bits_in_uv)
1630                     cdouble += (NV)ai32;
1631                 else
1632                     cuv += ai32;
1633             }
1634             break;
1635         case 'L' | TYPE_IS_SHRIEKING:
1636 #if LONGSIZE != SIZE32
1637             while (len-- > 0) {
1638                 unsigned long aulong;
1639                 SHIFT_VAR(utf8, s, strend, aulong, datumtype);
1640                 DO_BO_UNPACK(aulong, l);
1641                 if (!checksum)
1642                     mPUSHu(aulong);
1643                 else if (checksum > bits_in_uv)
1644                     cdouble += (NV)aulong;
1645                 else
1646                     cuv += aulong;
1647             }
1648             break;
1649 #else
1650             /* Fall through! */
1651 #endif
1652         case 'V':
1653         case 'N':
1654         case 'L':
1655             while (len-- > 0) {
1656                 U32 au32;
1657 #if U32SIZE > SIZE32
1658                 au32 = 0;
1659 #endif
1660                 SHIFT32(utf8, s, strend, &au32, datumtype);
1661                 DO_BO_UNPACK(au32, 32);
1662 #ifdef HAS_NTOHL
1663                 if (datumtype == 'N')
1664                     au32 = PerlSock_ntohl(au32);
1665 #endif
1666 #ifdef HAS_VTOHL
1667                 if (datumtype == 'V')
1668                     au32 = vtohl(au32);
1669 #endif
1670                 if (!checksum)
1671                     mPUSHu(au32);
1672                 else if (checksum > bits_in_uv)
1673                     cdouble += (NV)au32;
1674                 else
1675                     cuv += au32;
1676             }
1677             break;
1678         case 'V' | TYPE_IS_SHRIEKING:
1679         case 'N' | TYPE_IS_SHRIEKING:
1680             while (len-- > 0) {
1681                 I32 ai32;
1682 #if U32SIZE > SIZE32
1683                 ai32 = 0;
1684 #endif
1685                 SHIFT32(utf8, s, strend, &ai32, datumtype);
1686 #ifdef HAS_NTOHL
1687                 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1688                     ai32 = (I32)PerlSock_ntohl((U32)ai32);
1689 #endif
1690 #ifdef HAS_VTOHL
1691                 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1692                     ai32 = (I32)vtohl((U32)ai32);
1693 #endif
1694                 if (!checksum)
1695                     mPUSHi(ai32);
1696                 else if (checksum > bits_in_uv)
1697                     cdouble += (NV)ai32;
1698                 else
1699                     cuv += ai32;
1700             }
1701             break;
1702         case 'p':
1703             while (len-- > 0) {
1704                 const char *aptr;
1705                 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
1706                 DO_BO_UNPACK_PC(aptr);
1707                 /* newSVpv generates undef if aptr is NULL */
1708                 mPUSHs(newSVpv(aptr, 0));
1709             }
1710             break;
1711         case 'w':
1712             {
1713                 UV auv = 0;
1714                 U32 bytes = 0;
1715
1716                 while (len > 0 && s < strend) {
1717                     U8 ch;
1718                     ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1719                     auv = (auv << 7) | (ch & 0x7f);
1720                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1721                     if (ch < 0x80) {
1722                         bytes = 0;
1723                         mPUSHu(auv);
1724                         len--;
1725                         auv = 0;
1726                         continue;
1727                     }
1728                     if (++bytes >= sizeof(UV)) {        /* promote to string */
1729                         const char *t;
1730
1731                         sv = Perl_newSVpvf(aTHX_ "%.*"UVuf, (int)TYPE_DIGITS(UV), auv);
1732                         while (s < strend) {
1733                             ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1734                             sv = mul128(sv, (U8)(ch & 0x7f));
1735                             if (!(ch & 0x80)) {
1736                                 bytes = 0;
1737                                 break;
1738                             }
1739                         }
1740                         t = SvPV_nolen_const(sv);
1741                         while (*t == '0')
1742                             t++;
1743                         sv_chop(sv, t);
1744                         mPUSHs(sv);
1745                         len--;
1746                         auv = 0;
1747                     }
1748                 }
1749                 if ((s >= strend) && bytes)
1750                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1751             }
1752             break;
1753         case 'P':
1754             if (symptr->howlen == e_star)
1755                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1756             EXTEND(SP, 1);
1757             if (s + sizeof(char*) <= strend) {
1758                 char *aptr;
1759                 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
1760                 DO_BO_UNPACK_PC(aptr);
1761                 /* newSVpvn generates undef if aptr is NULL */
1762                 PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP));
1763             }
1764             break;
1765 #ifdef HAS_QUAD
1766         case 'q':
1767             while (len-- > 0) {
1768                 Quad_t aquad;
1769                 SHIFT_VAR(utf8, s, strend, aquad, datumtype);
1770                 DO_BO_UNPACK(aquad, 64);
1771                 if (!checksum)
1772                     mPUSHs(aquad >= IV_MIN && aquad <= IV_MAX ?
1773                            newSViv((IV)aquad) : newSVnv((NV)aquad));
1774                 else if (checksum > bits_in_uv)
1775                     cdouble += (NV)aquad;
1776                 else
1777                     cuv += aquad;
1778             }
1779             break;
1780         case 'Q':
1781             while (len-- > 0) {
1782                 Uquad_t auquad;
1783                 SHIFT_VAR(utf8, s, strend, auquad, datumtype);
1784                 DO_BO_UNPACK(auquad, 64);
1785                 if (!checksum)
1786                     mPUSHs(auquad <= UV_MAX ?
1787                            newSVuv((UV)auquad) : newSVnv((NV)auquad));
1788                 else if (checksum > bits_in_uv)
1789                     cdouble += (NV)auquad;
1790                 else
1791                     cuv += auquad;
1792             }
1793             break;
1794 #endif /* HAS_QUAD */
1795         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1796         case 'f':
1797             while (len-- > 0) {
1798                 float afloat;
1799                 SHIFT_VAR(utf8, s, strend, afloat, datumtype);
1800                 DO_BO_UNPACK_N(afloat, float);
1801                 if (!checksum)
1802                     mPUSHn(afloat);
1803                 else
1804                     cdouble += afloat;
1805             }
1806             break;
1807         case 'd':
1808             while (len-- > 0) {
1809                 double adouble;
1810                 SHIFT_VAR(utf8, s, strend, adouble, datumtype);
1811                 DO_BO_UNPACK_N(adouble, double);
1812                 if (!checksum)
1813                     mPUSHn(adouble);
1814                 else
1815                     cdouble += adouble;
1816             }
1817             break;
1818         case 'F':
1819             while (len-- > 0) {
1820                 NV_bytes anv;
1821                 SHIFT_BYTES(utf8, s, strend, anv.bytes, sizeof(anv.bytes), datumtype);
1822                 DO_BO_UNPACK_N(anv.nv, NV);
1823                 if (!checksum)
1824                     mPUSHn(anv.nv);
1825                 else
1826                     cdouble += anv.nv;
1827             }
1828             break;
1829 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1830         case 'D':
1831             while (len-- > 0) {
1832                 ld_bytes aldouble;
1833                 SHIFT_BYTES(utf8, s, strend, aldouble.bytes, sizeof(aldouble.bytes), datumtype);
1834                 DO_BO_UNPACK_N(aldouble.ld, long double);
1835                 if (!checksum)
1836                     mPUSHn(aldouble.ld);
1837                 else
1838                     cdouble += aldouble.ld;
1839             }
1840             break;
1841 #endif
1842         case 'u':
1843             if (!checksum) {
1844                 const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
1845                 sv = sv_2mortal(newSV(l));
1846                 if (l) SvPOK_on(sv);
1847             }
1848             if (utf8) {
1849                 while (next_uni_uu(aTHX_ &s, strend, &len)) {
1850                     I32 a, b, c, d;
1851                     char hunk[3];
1852
1853                     while (len > 0) {
1854                         next_uni_uu(aTHX_ &s, strend, &a);
1855                         next_uni_uu(aTHX_ &s, strend, &b);
1856                         next_uni_uu(aTHX_ &s, strend, &c);
1857                         next_uni_uu(aTHX_ &s, strend, &d);
1858                         hunk[0] = (char)((a << 2) | (b >> 4));
1859                         hunk[1] = (char)((b << 4) | (c >> 2));
1860                         hunk[2] = (char)((c << 6) | d);
1861                         if (!checksum)
1862                             sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1863                         len -= 3;
1864                     }
1865                     if (s < strend) {
1866                         if (*s == '\n') {
1867                             s++;
1868                         }
1869                         else {
1870                             /* possible checksum byte */
1871                             const char *skip = s+UTF8SKIP(s);
1872                             if (skip < strend && *skip == '\n')
1873                                 s = skip+1;
1874                         }
1875                     }
1876                 }
1877             } else {
1878                 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1879                     I32 a, b, c, d;
1880                     char hunk[3];
1881
1882                     len = PL_uudmap[*(U8*)s++] & 077;
1883                     while (len > 0) {
1884                         if (s < strend && ISUUCHAR(*s))
1885                             a = PL_uudmap[*(U8*)s++] & 077;
1886                         else
1887                             a = 0;
1888                         if (s < strend && ISUUCHAR(*s))
1889                             b = PL_uudmap[*(U8*)s++] & 077;
1890                         else
1891                             b = 0;
1892                         if (s < strend && ISUUCHAR(*s))
1893                             c = PL_uudmap[*(U8*)s++] & 077;
1894                         else
1895                             c = 0;
1896                         if (s < strend && ISUUCHAR(*s))
1897                             d = PL_uudmap[*(U8*)s++] & 077;
1898                         else
1899                             d = 0;
1900                         hunk[0] = (char)((a << 2) | (b >> 4));
1901                         hunk[1] = (char)((b << 4) | (c >> 2));
1902                         hunk[2] = (char)((c << 6) | d);
1903                         if (!checksum)
1904                             sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1905                         len -= 3;
1906                     }
1907                     if (*s == '\n')
1908                         s++;
1909                     else        /* possible checksum byte */
1910                         if (s + 1 < strend && s[1] == '\n')
1911                             s += 2;
1912                 }
1913             }
1914             if (!checksum)
1915                 XPUSHs(sv);
1916             break;
1917         }
1918
1919         if (checksum) {
1920             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1921               (checksum > bits_in_uv &&
1922                strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1923                 NV trouble, anv;
1924
1925                 anv = (NV) (1 << (checksum & 15));
1926                 while (checksum >= 16) {
1927                     checksum -= 16;
1928                     anv *= 65536.0;
1929                 }
1930                 while (cdouble < 0.0)
1931                     cdouble += anv;
1932                 cdouble = Perl_modf(cdouble / anv, &trouble) * anv;
1933                 sv = newSVnv(cdouble);
1934             }
1935             else {
1936                 if (checksum < bits_in_uv) {
1937                     UV mask = ((UV)1 << checksum) - 1;
1938                     cuv &= mask;
1939                 }
1940                 sv = newSVuv(cuv);
1941             }
1942             mXPUSHs(sv);
1943             checksum = 0;
1944         }
1945
1946         if (symptr->flags & FLAG_SLASH){
1947             if (SP - PL_stack_base - start_sp_offset <= 0)
1948                 break;
1949             if( next_symbol(symptr) ){
1950               if( symptr->howlen == e_number )
1951                 Perl_croak(aTHX_ "Count after length/code in unpack" );
1952               if( beyond ){
1953                 /* ...end of char buffer then no decent length available */
1954                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1955               } else {
1956                 /* take top of stack (hope it's numeric) */
1957                 len = POPi;
1958                 if( len < 0 )
1959                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
1960               }
1961             } else {
1962                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1963             }
1964             datumtype = symptr->code;
1965             explicit_length = FALSE;
1966             goto redo_switch;
1967         }
1968     }
1969
1970     if (new_s)
1971         *new_s = s;
1972     PUTBACK;
1973     return SP - PL_stack_base - start_sp_offset;
1974 }
1975
1976 PP(pp_unpack)
1977 {
1978     dVAR;
1979     dSP;
1980     dPOPPOPssrl;
1981     I32 gimme = GIMME_V;
1982     STRLEN llen;
1983     STRLEN rlen;
1984     const char *pat = SvPV_const(left,  llen);
1985     const char *s   = SvPV_const(right, rlen);
1986     const char *strend = s + rlen;
1987     const char *patend = pat + llen;
1988     I32 cnt;
1989
1990     PUTBACK;
1991     cnt = unpackstring(pat, patend, s, strend,
1992                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1993                      | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0));
1994
1995     SPAGAIN;
1996     if ( !cnt && gimme == G_SCALAR )
1997        PUSHs(&PL_sv_undef);
1998     RETURN;
1999 }
2000
2001 STATIC U8 *
2002 doencodes(U8 *h, const char *s, I32 len)
2003 {
2004     *h++ = PL_uuemap[len];
2005     while (len > 2) {
2006         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
2007         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))];
2008         *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
2009         *h++ = PL_uuemap[(077 & (s[2] & 077))];
2010         s += 3;
2011         len -= 3;
2012     }
2013     if (len > 0) {
2014         const char r = (len > 1 ? s[1] : '\0');
2015         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
2016         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))];
2017         *h++ = PL_uuemap[(077 & ((r << 2) & 074))];
2018         *h++ = PL_uuemap[0];
2019     }
2020     *h++ = '\n';
2021     return h;
2022 }
2023
2024 STATIC SV *
2025 S_is_an_int(pTHX_ const char *s, STRLEN l)
2026 {
2027   SV *result = newSVpvn(s, l);
2028   char *const result_c = SvPV_nolen(result);    /* convenience */
2029   char *out = result_c;
2030   bool skip = 1;
2031   bool ignore = 0;
2032
2033   PERL_ARGS_ASSERT_IS_AN_INT;
2034
2035   while (*s) {
2036     switch (*s) {
2037     case ' ':
2038       break;
2039     case '+':
2040       if (!skip) {
2041         SvREFCNT_dec(result);
2042         return (NULL);
2043       }
2044       break;
2045     case '0':
2046     case '1':
2047     case '2':
2048     case '3':
2049     case '4':
2050     case '5':
2051     case '6':
2052     case '7':
2053     case '8':
2054     case '9':
2055       skip = 0;
2056       if (!ignore) {
2057         *(out++) = *s;
2058       }
2059       break;
2060     case '.':
2061       ignore = 1;
2062       break;
2063     default:
2064       SvREFCNT_dec(result);
2065       return (NULL);
2066     }
2067     s++;
2068   }
2069   *(out++) = '\0';
2070   SvCUR_set(result, out - result_c);
2071   return (result);
2072 }
2073
2074 /* pnum must be '\0' terminated */
2075 STATIC int
2076 S_div128(pTHX_ SV *pnum, bool *done)
2077 {
2078     STRLEN len;
2079     char * const s = SvPV(pnum, len);
2080     char *t = s;
2081     int m = 0;
2082
2083     PERL_ARGS_ASSERT_DIV128;
2084
2085     *done = 1;
2086     while (*t) {
2087         const int i = m * 10 + (*t - '0');
2088         const int r = (i >> 7); /* r < 10 */
2089         m = i & 0x7F;
2090         if (r) {
2091             *done = 0;
2092         }
2093         *(t++) = '0' + r;
2094     }
2095     *(t++) = '\0';
2096     SvCUR_set(pnum, (STRLEN) (t - s));
2097     return (m);
2098 }
2099
2100 /*
2101 =for apidoc packlist
2102
2103 The engine implementing pack() Perl function.
2104
2105 =cut
2106 */
2107
2108 void
2109 Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist )
2110 {
2111     dVAR;
2112     tempsym_t sym;
2113
2114     PERL_ARGS_ASSERT_PACKLIST;
2115
2116     TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
2117
2118     /* We're going to do changes through SvPVX(cat). Make sure it's valid.
2119        Also make sure any UTF8 flag is loaded */
2120     SvPV_force_nolen(cat);
2121     if (DO_UTF8(cat))
2122         sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8;
2123
2124     (void)pack_rec( cat, &sym, beglist, endlist );
2125 }
2126
2127 /* like sv_utf8_upgrade, but also repoint the group start markers */
2128 STATIC void
2129 marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) {
2130     STRLEN len;
2131     tempsym_t *group;
2132     const char *from_ptr, *from_start, *from_end, **marks, **m;
2133     char *to_start, *to_ptr;
2134
2135     if (SvUTF8(sv)) return;
2136
2137     from_start = SvPVX_const(sv);
2138     from_end = from_start + SvCUR(sv);
2139     for (from_ptr = from_start; from_ptr < from_end; from_ptr++)
2140         if (!NATIVE_IS_INVARIANT(*from_ptr)) break;
2141     if (from_ptr == from_end) {
2142         /* Simple case: no character needs to be changed */
2143         SvUTF8_on(sv);
2144         return;
2145     }
2146
2147     len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1;
2148     Newx(to_start, len, char);
2149     Copy(from_start, to_start, from_ptr-from_start, char);
2150     to_ptr = to_start + (from_ptr-from_start);
2151
2152     Newx(marks, sym_ptr->level+2, const char *);
2153     for (group=sym_ptr; group; group = group->previous)
2154         marks[group->level] = from_start + group->strbeg;
2155     marks[sym_ptr->level+1] = from_end+1;
2156     for (m = marks; *m < from_ptr; m++)
2157         *m = to_start + (*m-from_start);
2158
2159     for (;from_ptr < from_end; from_ptr++) {
2160         while (*m == from_ptr) *m++ = to_ptr;
2161         to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr);
2162     }
2163     *to_ptr = 0;
2164
2165     while (*m == from_ptr) *m++ = to_ptr;
2166     if (m != marks + sym_ptr->level+1) {
2167         Safefree(marks);
2168         Safefree(to_start);
2169         Perl_croak(aTHX_ "panic: marks beyond string end, m=%p, marks=%p, "
2170                    "level=%d", m, marks, sym_ptr->level);
2171     }
2172     for (group=sym_ptr; group; group = group->previous)
2173         group->strbeg = marks[group->level] - to_start;
2174     Safefree(marks);
2175
2176     if (SvOOK(sv)) {
2177         if (SvIVX(sv)) {
2178             SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2179             from_start -= SvIVX(sv);
2180             SvIV_set(sv, 0);
2181         }
2182         SvFLAGS(sv) &= ~SVf_OOK;
2183     }
2184     if (SvLEN(sv) != 0)
2185         Safefree(from_start);
2186     SvPV_set(sv, to_start);
2187     SvCUR_set(sv, to_ptr - to_start);
2188     SvLEN_set(sv, len);
2189     SvUTF8_on(sv);
2190 }
2191
2192 /* Exponential string grower. Makes string extension effectively O(n)
2193    needed says how many extra bytes we need (not counting the final '\0')
2194    Only grows the string if there is an actual lack of space
2195 */
2196 STATIC char *
2197 S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) {
2198     const STRLEN cur = SvCUR(sv);
2199     const STRLEN len = SvLEN(sv);
2200     STRLEN extend;
2201
2202     PERL_ARGS_ASSERT_SV_EXP_GROW;
2203
2204     if (len - cur > needed) return SvPVX(sv);
2205     extend = needed > len ? needed : len;
2206     return SvGROW(sv, len+extend+1);
2207 }
2208
2209 STATIC
2210 SV **
2211 S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
2212 {
2213     dVAR;
2214     tempsym_t lookahead;
2215     I32 items  = endlist - beglist;
2216     bool found = next_symbol(symptr);
2217     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
2218     bool warn_utf8 = ckWARN(WARN_UTF8);
2219
2220     PERL_ARGS_ASSERT_PACK_REC;
2221
2222     if (symptr->level == 0 && found && symptr->code == 'U') {
2223         marked_upgrade(aTHX_ cat, symptr);
2224         symptr->flags |= FLAG_DO_UTF8;
2225         utf8 = 0;
2226     }
2227     symptr->strbeg = SvCUR(cat);
2228
2229     while (found) {
2230         SV *fromstr;
2231         STRLEN fromlen;
2232         I32 len;
2233         SV *lengthcode = NULL;
2234         I32 datumtype = symptr->code;
2235         howlen_t howlen = symptr->howlen;
2236         char *start = SvPVX(cat);
2237         char *cur   = start + SvCUR(cat);
2238
2239 #define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2240
2241         switch (howlen) {
2242           case e_star:
2243             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ?
2244                 0 : items;
2245             break;
2246           default:
2247             /* e_no_len and e_number */
2248             len = symptr->length;
2249             break;
2250         }
2251
2252         if (len) {
2253             packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
2254
2255             if (props && !(props & PACK_SIZE_UNPREDICTABLE)) {
2256                 /* We can process this letter. */
2257                 STRLEN size = props & PACK_SIZE_MASK;
2258                 GROWING(utf8, cat, start, cur, (STRLEN) len * size);
2259             }
2260         }
2261
2262         /* Look ahead for next symbol. Do we have code/code? */
2263         lookahead = *symptr;
2264         found = next_symbol(&lookahead);
2265         if (symptr->flags & FLAG_SLASH) {
2266             IV count;
2267             if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack");
2268             if (strchr("aAZ", lookahead.code)) {
2269                 if (lookahead.howlen == e_number) count = lookahead.length;
2270                 else {
2271                     if (items > 0) {
2272                         count = sv_len_utf8(*beglist);
2273                     }
2274                     else count = 0;
2275                     if (lookahead.code == 'Z') count++;
2276                 }
2277             } else {
2278                 if (lookahead.howlen == e_number && lookahead.length < items)
2279                     count = lookahead.length;
2280                 else count = items;
2281             }
2282             lookahead.howlen = e_number;
2283             lookahead.length = count;
2284             lengthcode = sv_2mortal(newSViv(count));
2285         }
2286
2287         /* Code inside the switch must take care to properly update
2288            cat (CUR length and '\0' termination) if it updated *cur and
2289            doesn't simply leave using break */
2290         switch(TYPE_NO_ENDIANNESS(datumtype)) {
2291         default:
2292             Perl_croak(aTHX_ "Invalid type '%c' in pack",
2293                        (int) TYPE_NO_MODIFIERS(datumtype));
2294         case '%':
2295             Perl_croak(aTHX_ "'%%' may not be used in pack");
2296         {
2297             char *from;
2298         case '.' | TYPE_IS_SHRIEKING:
2299         case '.':
2300             if (howlen == e_star) from = start;
2301             else if (len == 0) from = cur;
2302             else {
2303                 tempsym_t *group = symptr;
2304
2305                 while (--len && group) group = group->previous;
2306                 from = group ? start + group->strbeg : start;
2307             }
2308             fromstr = NEXTFROM;
2309             len = SvIV(fromstr);
2310             goto resize;
2311         case '@' | TYPE_IS_SHRIEKING:
2312         case '@':
2313             from = start + symptr->strbeg;
2314           resize:
2315             if (utf8  && !(datumtype & TYPE_IS_SHRIEKING))
2316                 if (len >= 0) {
2317                     while (len && from < cur) {
2318                         from += UTF8SKIP(from);
2319                         len--;
2320                     }
2321                     if (from > cur)
2322                         Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2323                     if (len) {
2324                         /* Here we know from == cur */
2325                       grow:
2326                         GROWING(0, cat, start, cur, len);
2327                         Zero(cur, len, char);
2328                         cur += len;
2329                     } else if (from < cur) {
2330                         len = cur - from;
2331                         goto shrink;
2332                     } else goto no_change;
2333                 } else {
2334                     cur = from;
2335                     len = -len;
2336                     goto utf8_shrink;
2337                 }
2338             else {
2339                 len -= cur - from;
2340                 if (len > 0) goto grow;
2341                 if (len == 0) goto no_change;
2342                 len = -len;
2343                 goto shrink;
2344             }
2345             break;
2346         }
2347         case '(': {
2348             tempsym_t savsym = *symptr;
2349             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2350             symptr->flags |= group_modifiers;
2351             symptr->patend = savsym.grpend;
2352             symptr->level++;
2353             symptr->previous = &lookahead;
2354             while (len--) {
2355                 U32 was_utf8;
2356                 if (utf8) symptr->flags |=  FLAG_PARSE_UTF8;
2357                 else      symptr->flags &= ~FLAG_PARSE_UTF8;
2358                 was_utf8 = SvUTF8(cat);
2359                 symptr->patptr = savsym.grpbeg;
2360                 beglist = pack_rec(cat, symptr, beglist, endlist);
2361                 if (SvUTF8(cat) != was_utf8)
2362                     /* This had better be an upgrade while in utf8==0 mode */
2363                     utf8 = 1;
2364
2365                 if (savsym.howlen == e_star && beglist == endlist)
2366                     break;              /* No way to continue */
2367             }
2368             items = endlist - beglist;
2369             lookahead.flags  = symptr->flags & ~group_modifiers;
2370             goto no_change;
2371         }
2372         case 'X' | TYPE_IS_SHRIEKING:
2373             if (!len)                   /* Avoid division by 0 */
2374                 len = 1;
2375             if (utf8) {
2376                 char *hop, *last;
2377                 I32 l = len;
2378                 hop = last = start;
2379                 while (hop < cur) {
2380                     hop += UTF8SKIP(hop);
2381                     if (--l == 0) {
2382                         last = hop;
2383                         l = len;
2384                     }
2385                 }
2386                 if (last > cur)
2387                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2388                 cur = last;
2389                 break;
2390             }
2391             len = (cur-start) % len;
2392             /* FALL THROUGH */
2393         case 'X':
2394             if (utf8) {
2395                 if (len < 1) goto no_change;
2396               utf8_shrink:
2397                 while (len > 0) {
2398                     if (cur <= start)
2399                         Perl_croak(aTHX_ "'%c' outside of string in pack",
2400                                    (int) TYPE_NO_MODIFIERS(datumtype));
2401                     while (--cur, UTF8_IS_CONTINUATION(*cur)) {
2402                         if (cur <= start)
2403                             Perl_croak(aTHX_ "'%c' outside of string in pack",
2404                                        (int) TYPE_NO_MODIFIERS(datumtype));
2405                     }
2406                     len--;
2407                 }
2408             } else {
2409               shrink:
2410                 if (cur - start < len)
2411                     Perl_croak(aTHX_ "'%c' outside of string in pack",
2412                                (int) TYPE_NO_MODIFIERS(datumtype));
2413                 cur -= len;
2414             }
2415             if (cur < start+symptr->strbeg) {
2416                 /* Make sure group starts don't point into the void */
2417                 tempsym_t *group;
2418                 const STRLEN length = cur-start;
2419                 for (group = symptr;
2420                      group && length < group->strbeg;
2421                      group = group->previous) group->strbeg = length;
2422                 lookahead.strbeg = length;
2423             }
2424             break;
2425         case 'x' | TYPE_IS_SHRIEKING: {
2426             I32 ai32;
2427             if (!len)                   /* Avoid division by 0 */
2428                 len = 1;
2429             if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len;
2430             else      ai32 = (cur - start) % len;
2431             if (ai32 == 0) goto no_change;
2432             len -= ai32;
2433         }
2434         /* FALL THROUGH */
2435         case 'x':
2436             goto grow;
2437         case 'A':
2438         case 'Z':
2439         case 'a': {
2440             const char *aptr;
2441
2442             fromstr = NEXTFROM;
2443             aptr = SvPV_const(fromstr, fromlen);
2444             if (DO_UTF8(fromstr)) {
2445                 const char *end, *s;
2446
2447                 if (!utf8 && !SvUTF8(cat)) {
2448                     marked_upgrade(aTHX_ cat, symptr);
2449                     lookahead.flags |= FLAG_DO_UTF8;
2450                     lookahead.strbeg = symptr->strbeg;
2451                     utf8 = 1;
2452                     start = SvPVX(cat);
2453                     cur = start + SvCUR(cat);
2454                 }
2455                 if (howlen == e_star) {
2456                     if (utf8) goto string_copy;
2457                     len = fromlen+1;
2458                 }
2459                 s = aptr;
2460                 end = aptr + fromlen;
2461                 fromlen = datumtype == 'Z' ? len-1 : len;
2462                 while ((I32) fromlen > 0 && s < end) {
2463                     s += UTF8SKIP(s);
2464                     fromlen--;
2465                 }
2466                 if (s > end)
2467                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2468                 if (utf8) {
2469                     len = fromlen;
2470                     if (datumtype == 'Z') len++;
2471                     fromlen = s-aptr;
2472                     len += fromlen;
2473
2474                     goto string_copy;
2475                 }
2476                 fromlen = len - fromlen;
2477                 if (datumtype == 'Z') fromlen--;
2478                 if (howlen == e_star) {
2479                     len = fromlen;
2480                     if (datumtype == 'Z') len++;
2481                 }
2482                 GROWING(0, cat, start, cur, len);
2483                 if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
2484                                   datumtype | TYPE_IS_PACK))
2485                     Perl_croak(aTHX_ "panic: predicted utf8 length not available, "
2486                                "for '%c', aptr=%p end=%p cur=%p, fromlen=%"UVuf,
2487                                (int)datumtype, aptr, end, cur, (UV)fromlen);
2488                 cur += fromlen;
2489                 len -= fromlen;
2490             } else if (utf8) {
2491                 if (howlen == e_star) {
2492                     len = fromlen;
2493                     if (datumtype == 'Z') len++;
2494                 }
2495                 if (len <= (I32) fromlen) {
2496                     fromlen = len;
2497                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2498                 }
2499                 /* assumes a byte expands to at most UTF8_EXPAND bytes on
2500                    upgrade, so:
2501                    expected_length <= from_len*UTF8_EXPAND + (len-from_len) */
2502                 GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len);
2503                 len -= fromlen;
2504                 while (fromlen > 0) {
2505                     cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr);
2506                     aptr++;
2507                     fromlen--;
2508                 }
2509             } else {
2510               string_copy:
2511                 if (howlen == e_star) {
2512                     len = fromlen;
2513                     if (datumtype == 'Z') len++;
2514                 }
2515                 if (len <= (I32) fromlen) {
2516                     fromlen = len;
2517                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2518                 }
2519                 GROWING(0, cat, start, cur, len);
2520                 Copy(aptr, cur, fromlen, char);
2521                 cur += fromlen;
2522                 len -= fromlen;
2523             }
2524             memset(cur, datumtype == 'A' ? ' ' : '\0', len);
2525             cur += len;
2526             SvTAINT(cat);
2527             break;
2528         }
2529         case 'B':
2530         case 'b': {
2531             const char *str, *end;
2532             I32 l, field_len;
2533             U8 bits;
2534             bool utf8_source;
2535             U32 utf8_flags;
2536
2537             fromstr = NEXTFROM;
2538             str = SvPV_const(fromstr, fromlen);
2539             end = str + fromlen;
2540             if (DO_UTF8(fromstr)) {
2541                 utf8_source = TRUE;
2542                 utf8_flags  = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2543             } else {
2544                 utf8_source = FALSE;
2545                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2546             }
2547             if (howlen == e_star) len = fromlen;
2548             field_len = (len+7)/8;
2549             GROWING(utf8, cat, start, cur, field_len);
2550             if (len > (I32)fromlen) len = fromlen;
2551             bits = 0;
2552             l = 0;
2553             if (datumtype == 'B')
2554                 while (l++ < len) {
2555                     if (utf8_source) {
2556                         UV val = 0;
2557                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2558                         bits |= val & 1;
2559                     } else bits |= *str++ & 1;
2560                     if (l & 7) bits <<= 1;
2561                     else {
2562                         PUSH_BYTE(utf8, cur, bits);
2563                         bits = 0;
2564                     }
2565                 }
2566             else
2567                 /* datumtype == 'b' */
2568                 while (l++ < len) {
2569                     if (utf8_source) {
2570                         UV val = 0;
2571                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2572                         if (val & 1) bits |= 0x80;
2573                     } else if (*str++ & 1)
2574                         bits |= 0x80;
2575                     if (l & 7) bits >>= 1;
2576                     else {
2577                         PUSH_BYTE(utf8, cur, bits);
2578                         bits = 0;
2579                     }
2580                 }
2581             l--;
2582             if (l & 7) {
2583                 if (datumtype == 'B')
2584                     bits <<= 7 - (l & 7);
2585                 else
2586                     bits >>= 7 - (l & 7);
2587                 PUSH_BYTE(utf8, cur, bits);
2588                 l += 7;
2589             }
2590             /* Determine how many chars are left in the requested field */
2591             l /= 8;
2592             if (howlen == e_star) field_len = 0;
2593             else field_len -= l;
2594             Zero(cur, field_len, char);
2595             cur += field_len;
2596             break;
2597         }
2598         case 'H':
2599         case 'h': {
2600             const char *str, *end;
2601             I32 l, field_len;
2602             U8 bits;
2603             bool utf8_source;
2604             U32 utf8_flags;
2605
2606             fromstr = NEXTFROM;
2607             str = SvPV_const(fromstr, fromlen);
2608             end = str + fromlen;
2609             if (DO_UTF8(fromstr)) {
2610                 utf8_source = TRUE;
2611                 utf8_flags  = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2612             } else {
2613                 utf8_source = FALSE;
2614                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2615             }
2616             if (howlen == e_star) len = fromlen;
2617             field_len = (len+1)/2;
2618             GROWING(utf8, cat, start, cur, field_len);
2619             if (!utf8 && len > (I32)fromlen) len = fromlen;
2620             bits = 0;
2621             l = 0;
2622             if (datumtype == 'H')
2623                 while (l++ < len) {
2624                     if (utf8_source) {
2625                         UV val = 0;
2626                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2627                         if (val < 256 && isALPHA(val))
2628                             bits |= (val + 9) & 0xf;
2629                         else
2630                             bits |= val & 0xf;
2631                     } else if (isALPHA(*str))
2632                         bits |= (*str++ + 9) & 0xf;
2633                     else
2634                         bits |= *str++ & 0xf;
2635                     if (l & 1) bits <<= 4;
2636                     else {
2637                         PUSH_BYTE(utf8, cur, bits);
2638                         bits = 0;
2639                     }
2640                 }
2641             else
2642                 while (l++ < len) {
2643                     if (utf8_source) {
2644                         UV val = 0;
2645                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2646                         if (val < 256 && isALPHA(val))
2647                             bits |= ((val + 9) & 0xf) << 4;
2648                         else
2649                             bits |= (val & 0xf) << 4;
2650                     } else if (isALPHA(*str))
2651                         bits |= ((*str++ + 9) & 0xf) << 4;
2652                     else
2653                         bits |= (*str++ & 0xf) << 4;
2654                     if (l & 1) bits >>= 4;
2655                     else {
2656                         PUSH_BYTE(utf8, cur, bits);
2657                         bits = 0;
2658                     }
2659                 }
2660             l--;
2661             if (l & 1) {
2662                 PUSH_BYTE(utf8, cur, bits);
2663                 l++;
2664             }
2665             /* Determine how many chars are left in the requested field */
2666             l /= 2;
2667             if (howlen == e_star) field_len = 0;
2668             else field_len -= l;
2669             Zero(cur, field_len, char);
2670             cur += field_len;
2671             break;
2672         }
2673         case 'c':
2674             while (len-- > 0) {
2675                 IV aiv;
2676                 fromstr = NEXTFROM;
2677                 aiv = SvIV(fromstr);
2678                 if ((-128 > aiv || aiv > 127))
2679                     Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2680                                    "Character in 'c' format wrapped in pack");
2681                 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2682             }
2683             break;
2684         case 'C':
2685             if (len == 0) {
2686                 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
2687                 break;
2688             }
2689             while (len-- > 0) {
2690                 IV aiv;
2691                 fromstr = NEXTFROM;
2692                 aiv = SvIV(fromstr);
2693                 if ((0 > aiv || aiv > 0xff))
2694                     Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2695                                    "Character in 'C' format wrapped in pack");
2696                 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2697             }
2698             break;
2699         case 'W': {
2700             char *end;
2701             U8 in_bytes = (U8)IN_BYTES;
2702
2703             end = start+SvLEN(cat)-1;
2704             if (utf8) end -= UTF8_MAXLEN-1;
2705             while (len-- > 0) {
2706                 UV auv;
2707                 fromstr = NEXTFROM;
2708                 auv = SvUV(fromstr);
2709                 if (in_bytes) auv = auv % 0x100;
2710                 if (utf8) {
2711                   W_utf8:
2712                     if (cur > end) {
2713                         *cur = '\0';
2714                         SvCUR_set(cat, cur - start);
2715
2716                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2717                         end = start+SvLEN(cat)-UTF8_MAXLEN;
2718                     }
2719                     cur = (char *) uvuni_to_utf8_flags((U8 *) cur,
2720                                                        NATIVE_TO_UNI(auv),
2721                                                        warn_utf8 ?
2722                                                        0 : UNICODE_ALLOW_ANY);
2723                 } else {
2724                     if (auv >= 0x100) {
2725                         if (!SvUTF8(cat)) {
2726                             *cur = '\0';
2727                             SvCUR_set(cat, cur - start);
2728                             marked_upgrade(aTHX_ cat, symptr);
2729                             lookahead.flags |= FLAG_DO_UTF8;
2730                             lookahead.strbeg = symptr->strbeg;
2731                             utf8 = 1;
2732                             start = SvPVX(cat);
2733                             cur = start + SvCUR(cat);
2734                             end = start+SvLEN(cat)-UTF8_MAXLEN;
2735                             goto W_utf8;
2736                         }
2737                         Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2738                                        "Character in 'W' format wrapped in pack");
2739                         auv &= 0xff;
2740                     }
2741                     if (cur >= end) {
2742                         *cur = '\0';
2743                         SvCUR_set(cat, cur - start);
2744                         GROWING(0, cat, start, cur, len+1);
2745                         end = start+SvLEN(cat)-1;
2746                     }
2747                     *(U8 *) cur++ = (U8)auv;
2748                 }
2749             }
2750             break;
2751         }
2752         case 'U': {
2753             char *end;
2754
2755             if (len == 0) {
2756                 if (!(symptr->flags & FLAG_DO_UTF8)) {
2757                     marked_upgrade(aTHX_ cat, symptr);
2758                     lookahead.flags |= FLAG_DO_UTF8;
2759                     lookahead.strbeg = symptr->strbeg;
2760                 }
2761                 utf8 = 0;
2762                 goto no_change;
2763             }
2764
2765             end = start+SvLEN(cat);
2766             if (!utf8) end -= UTF8_MAXLEN;
2767             while (len-- > 0) {
2768                 UV auv;
2769                 fromstr = NEXTFROM;
2770                 auv = SvUV(fromstr);
2771                 if (utf8) {
2772                     U8 buffer[UTF8_MAXLEN], *endb;
2773                     endb = uvuni_to_utf8_flags(buffer, auv,
2774                                                warn_utf8 ?
2775                                                0 : UNICODE_ALLOW_ANY);
2776                     if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
2777                         *cur = '\0';
2778                         SvCUR_set(cat, cur - start);
2779                         GROWING(0, cat, start, cur,
2780                                 len+(endb-buffer)*UTF8_EXPAND);
2781                         end = start+SvLEN(cat);
2782                     }
2783                     cur = bytes_to_uni(buffer, endb-buffer, cur);
2784                 } else {
2785                     if (cur >= end) {
2786                         *cur = '\0';
2787                         SvCUR_set(cat, cur - start);
2788                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2789                         end = start+SvLEN(cat)-UTF8_MAXLEN;
2790                     }
2791                     cur = (char *) uvuni_to_utf8_flags((U8 *) cur, auv,
2792                                                        warn_utf8 ?
2793                                                        0 : UNICODE_ALLOW_ANY);
2794                 }
2795             }
2796             break;
2797         }
2798         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2799         case 'f':
2800             while (len-- > 0) {
2801                 float afloat;
2802                 NV anv;
2803                 fromstr = NEXTFROM;
2804                 anv = SvNV(fromstr);
2805 # if defined(VMS) && !defined(_IEEE_FP)
2806                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2807                  * on Alpha; fake it if we don't have them.
2808                  */
2809                 if (anv > FLT_MAX)
2810                     afloat = FLT_MAX;
2811                 else if (anv < -FLT_MAX)
2812                     afloat = -FLT_MAX;
2813                 else afloat = (float)anv;
2814 # else
2815                 afloat = (float)anv;
2816 # endif
2817                 DO_BO_PACK_N(afloat, float);
2818                 PUSH_VAR(utf8, cur, afloat);
2819             }
2820             break;
2821         case 'd':
2822             while (len-- > 0) {
2823                 double adouble;
2824                 NV anv;
2825                 fromstr = NEXTFROM;
2826                 anv = SvNV(fromstr);
2827 # if defined(VMS) && !defined(_IEEE_FP)
2828                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2829                  * on Alpha; fake it if we don't have them.
2830                  */
2831                 if (anv > DBL_MAX)
2832                     adouble = DBL_MAX;
2833                 else if (anv < -DBL_MAX)
2834                     adouble = -DBL_MAX;
2835                 else adouble = (double)anv;
2836 # else
2837                 adouble = (double)anv;
2838 # endif
2839                 DO_BO_PACK_N(adouble, double);
2840                 PUSH_VAR(utf8, cur, adouble);
2841             }
2842             break;
2843         case 'F': {
2844             NV_bytes anv;
2845             Zero(&anv, 1, NV); /* can be long double with unused bits */
2846             while (len-- > 0) {
2847                 fromstr = NEXTFROM;
2848 #ifdef __GNUC__
2849                 /* to work round a gcc/x86 bug; don't use SvNV */
2850                 anv.nv = sv_2nv(fromstr);
2851 #else
2852                 anv.nv = SvNV(fromstr);
2853 #endif
2854                 DO_BO_PACK_N(anv, NV);
2855                 PUSH_BYTES(utf8, cur, anv.bytes, sizeof(anv.bytes));
2856             }
2857             break;
2858         }
2859 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2860         case 'D': {
2861             ld_bytes aldouble;
2862             /* long doubles can have unused bits, which may be nonzero */
2863             Zero(&aldouble, 1, long double);
2864             while (len-- > 0) {
2865                 fromstr = NEXTFROM;
2866 #  ifdef __GNUC__
2867                 /* to work round a gcc/x86 bug; don't use SvNV */
2868                 aldouble.ld = (long double)sv_2nv(fromstr);
2869 #  else
2870                 aldouble.ld = (long double)SvNV(fromstr);
2871 #  endif
2872                 DO_BO_PACK_N(aldouble, long double);
2873                 PUSH_BYTES(utf8, cur, aldouble.bytes, sizeof(aldouble.bytes));
2874             }
2875             break;
2876         }
2877 #endif
2878         case 'n' | TYPE_IS_SHRIEKING:
2879         case 'n':
2880             while (len-- > 0) {
2881                 I16 ai16;
2882                 fromstr = NEXTFROM;
2883                 ai16 = (I16)SvIV(fromstr);
2884 #ifdef HAS_HTONS
2885                 ai16 = PerlSock_htons(ai16);
2886 #endif
2887                 PUSH16(utf8, cur, &ai16);
2888             }
2889             break;
2890         case 'v' | TYPE_IS_SHRIEKING:
2891         case 'v':
2892             while (len-- > 0) {
2893                 I16 ai16;
2894                 fromstr = NEXTFROM;
2895                 ai16 = (I16)SvIV(fromstr);
2896 #ifdef HAS_HTOVS
2897                 ai16 = htovs(ai16);
2898 #endif
2899                 PUSH16(utf8, cur, &ai16);
2900             }
2901             break;
2902         case 'S' | TYPE_IS_SHRIEKING:
2903 #if SHORTSIZE != SIZE16
2904             while (len-- > 0) {
2905                 unsigned short aushort;
2906                 fromstr = NEXTFROM;
2907                 aushort = SvUV(fromstr);
2908                 DO_BO_PACK(aushort, s);
2909                 PUSH_VAR(utf8, cur, aushort);
2910             }
2911             break;
2912 #else
2913             /* Fall through! */
2914 #endif
2915         case 'S':
2916             while (len-- > 0) {
2917                 U16 au16;
2918                 fromstr = NEXTFROM;
2919                 au16 = (U16)SvUV(fromstr);
2920                 DO_BO_PACK(au16, 16);
2921                 PUSH16(utf8, cur, &au16);
2922             }
2923             break;
2924         case 's' | TYPE_IS_SHRIEKING:
2925 #if SHORTSIZE != SIZE16
2926             while (len-- > 0) {
2927                 short ashort;
2928                 fromstr = NEXTFROM;
2929                 ashort = SvIV(fromstr);
2930                 DO_BO_PACK(ashort, s);
2931                 PUSH_VAR(utf8, cur, ashort);
2932             }
2933             break;
2934 #else
2935             /* Fall through! */
2936 #endif
2937         case 's':
2938             while (len-- > 0) {
2939                 I16 ai16;
2940                 fromstr = NEXTFROM;
2941                 ai16 = (I16)SvIV(fromstr);
2942                 DO_BO_PACK(ai16, 16);
2943                 PUSH16(utf8, cur, &ai16);
2944             }
2945             break;
2946         case 'I':
2947         case 'I' | TYPE_IS_SHRIEKING:
2948             while (len-- > 0) {
2949                 unsigned int auint;
2950                 fromstr = NEXTFROM;
2951                 auint = SvUV(fromstr);
2952                 DO_BO_PACK(auint, i);
2953                 PUSH_VAR(utf8, cur, auint);
2954             }
2955             break;
2956         case 'j':
2957             while (len-- > 0) {
2958                 IV aiv;
2959                 fromstr = NEXTFROM;
2960                 aiv = SvIV(fromstr);
2961 #if IVSIZE == INTSIZE
2962                 DO_BO_PACK(aiv, i);
2963 #elif IVSIZE == LONGSIZE
2964                 DO_BO_PACK(aiv, l);
2965 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2966                 DO_BO_PACK(aiv, 64);
2967 #else
2968                 Perl_croak(aTHX_ "'j' not supported on this platform");
2969 #endif
2970                 PUSH_VAR(utf8, cur, aiv);
2971             }
2972             break;
2973         case 'J':
2974             while (len-- > 0) {
2975                 UV auv;
2976                 fromstr = NEXTFROM;
2977                 auv = SvUV(fromstr);
2978 #if UVSIZE == INTSIZE
2979                 DO_BO_PACK(auv, i);
2980 #elif UVSIZE == LONGSIZE
2981                 DO_BO_PACK(auv, l);
2982 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2983                 DO_BO_PACK(auv, 64);
2984 #else
2985                 Perl_croak(aTHX_ "'J' not supported on this platform");
2986 #endif
2987                 PUSH_VAR(utf8, cur, auv);
2988             }
2989             break;
2990         case 'w':
2991             while (len-- > 0) {
2992                 NV anv;
2993                 fromstr = NEXTFROM;
2994                 anv = SvNV(fromstr);
2995
2996                 if (anv < 0) {
2997                     *cur = '\0';
2998                     SvCUR_set(cat, cur - start);
2999                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
3000                 }
3001
3002                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
3003                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
3004                    any negative IVs will have already been got by the croak()
3005                    above. IOK is untrue for fractions, so we test them
3006                    against UV_MAX_P1.  */
3007                 if (SvIOK(fromstr) || anv < UV_MAX_P1) {
3008                     char   buf[(sizeof(UV)*CHAR_BIT)/7+1];
3009                     char  *in = buf + sizeof(buf);
3010                     UV     auv = SvUV(fromstr);
3011
3012                     do {
3013                         *--in = (char)((auv & 0x7f) | 0x80);
3014                         auv >>= 7;
3015                     } while (auv);
3016                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3017                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3018                                        in, (buf + sizeof(buf)) - in);
3019                 } else if (SvPOKp(fromstr))
3020                     goto w_string;
3021                 else if (SvNOKp(fromstr)) {
3022                     /* 10**NV_MAX_10_EXP is the largest power of 10
3023                        so 10**(NV_MAX_10_EXP+1) is definitely unrepresentable
3024                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
3025                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
3026                        And with that many bytes only Inf can overflow.
3027                        Some C compilers are strict about integral constant
3028                        expressions so we conservatively divide by a slightly
3029                        smaller integer instead of multiplying by the exact
3030                        floating-point value.
3031                     */
3032 #ifdef NV_MAX_10_EXP
3033                     /* char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
3034                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
3035 #else
3036                     /* char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
3037                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
3038 #endif
3039                     char  *in = buf + sizeof(buf);
3040
3041                     anv = Perl_floor(anv);
3042                     do {
3043                         const NV next = Perl_floor(anv / 128);
3044                         if (in <= buf)  /* this cannot happen ;-) */
3045                             Perl_croak(aTHX_ "Cannot compress integer in pack");
3046                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
3047                         anv = next;
3048                     } while (anv > 0);
3049                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3050                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3051                                        in, (buf + sizeof(buf)) - in);
3052                 } else {
3053                     const char     *from;
3054                     char           *result, *in;
3055                     SV             *norm;
3056                     STRLEN          len;
3057                     bool            done;
3058
3059                   w_string:
3060                     /* Copy string and check for compliance */
3061                     from = SvPV_const(fromstr, len);
3062                     if ((norm = is_an_int(from, len)) == NULL)
3063                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
3064
3065                     Newx(result, len, char);
3066                     in = result + len;
3067                     done = FALSE;
3068                     while (!done) *--in = div128(norm, &done) | 0x80;
3069                     result[len - 1] &= 0x7F; /* clear continue bit */
3070                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3071                                        in, (result + len) - in);
3072                     Safefree(result);
3073                     SvREFCNT_dec(norm); /* free norm */
3074                 }
3075             }
3076             break;
3077         case 'i':
3078         case 'i' | TYPE_IS_SHRIEKING:
3079             while (len-- > 0) {
3080                 int aint;
3081                 fromstr = NEXTFROM;
3082                 aint = SvIV(fromstr);
3083                 DO_BO_PACK(aint, i);
3084                 PUSH_VAR(utf8, cur, aint);
3085             }
3086             break;
3087         case 'N' | TYPE_IS_SHRIEKING:
3088         case 'N':
3089             while (len-- > 0) {
3090                 U32 au32;
3091                 fromstr = NEXTFROM;
3092                 au32 = SvUV(fromstr);
3093 #ifdef HAS_HTONL
3094                 au32 = PerlSock_htonl(au32);
3095 #endif
3096                 PUSH32(utf8, cur, &au32);
3097             }
3098             break;
3099         case 'V' | TYPE_IS_SHRIEKING:
3100         case 'V':
3101             while (len-- > 0) {
3102                 U32 au32;
3103                 fromstr = NEXTFROM;
3104                 au32 = SvUV(fromstr);
3105 #ifdef HAS_HTOVL
3106                 au32 = htovl(au32);
3107 #endif
3108                 PUSH32(utf8, cur, &au32);
3109             }
3110             break;
3111         case 'L' | TYPE_IS_SHRIEKING:
3112 #if LONGSIZE != SIZE32
3113             while (len-- > 0) {
3114                 unsigned long aulong;
3115                 fromstr = NEXTFROM;
3116                 aulong = SvUV(fromstr);
3117                 DO_BO_PACK(aulong, l);
3118                 PUSH_VAR(utf8, cur, aulong);
3119             }
3120             break;
3121 #else
3122             /* Fall though! */
3123 #endif
3124         case 'L':
3125             while (len-- > 0) {
3126                 U32 au32;
3127                 fromstr = NEXTFROM;
3128                 au32 = SvUV(fromstr);
3129                 DO_BO_PACK(au32, 32);
3130                 PUSH32(utf8, cur, &au32);
3131             }
3132             break;
3133         case 'l' | TYPE_IS_SHRIEKING:
3134 #if LONGSIZE != SIZE32
3135             while (len-- > 0) {
3136                 long along;
3137                 fromstr = NEXTFROM;
3138                 along = SvIV(fromstr);
3139                 DO_BO_PACK(along, l);
3140                 PUSH_VAR(utf8, cur, along);
3141             }
3142             break;
3143 #else
3144             /* Fall though! */
3145 #endif
3146         case 'l':
3147             while (len-- > 0) {
3148                 I32 ai32;
3149                 fromstr = NEXTFROM;
3150                 ai32 = SvIV(fromstr);
3151                 DO_BO_PACK(ai32, 32);
3152                 PUSH32(utf8, cur, &ai32);
3153             }
3154             break;
3155 #ifdef HAS_QUAD
3156         case 'Q':
3157             while (len-- > 0) {
3158                 Uquad_t auquad;
3159                 fromstr = NEXTFROM;
3160                 auquad = (Uquad_t) SvUV(fromstr);
3161                 DO_BO_PACK(auquad, 64);
3162                 PUSH_VAR(utf8, cur, auquad);
3163             }
3164             break;
3165         case 'q':
3166             while (len-- > 0) {
3167                 Quad_t aquad;
3168                 fromstr = NEXTFROM;
3169                 aquad = (Quad_t)SvIV(fromstr);
3170                 DO_BO_PACK(aquad, 64);
3171                 PUSH_VAR(utf8, cur, aquad);
3172             }
3173             break;
3174 #endif /* HAS_QUAD */
3175         case 'P':
3176             len = 1;            /* assume SV is correct length */
3177             GROWING(utf8, cat, start, cur, sizeof(char *));
3178             /* Fall through! */
3179         case 'p':
3180             while (len-- > 0) {
3181                 const char *aptr;
3182
3183                 fromstr = NEXTFROM;
3184                 SvGETMAGIC(fromstr);
3185                 if (!SvOK(fromstr)) aptr = NULL;
3186                 else {
3187                     /* XXX better yet, could spirit away the string to
3188                      * a safe spot and hang on to it until the result
3189                      * of pack() (and all copies of the result) are
3190                      * gone.
3191                      */
3192                     if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
3193                              !SvREADONLY(fromstr)))) {
3194                         Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3195                                        "Attempt to pack pointer to temporary value");
3196                     }
3197                     if (SvPOK(fromstr) || SvNIOK(fromstr))
3198                         aptr = SvPV_nomg_const_nolen(fromstr);
3199                     else
3200                         aptr = SvPV_force_flags_nolen(fromstr, 0);
3201                 }
3202                 DO_BO_PACK_PC(aptr);
3203                 PUSH_VAR(utf8, cur, aptr);
3204             }
3205             break;
3206         case 'u': {
3207             const char *aptr, *aend;
3208             bool from_utf8;
3209
3210             fromstr = NEXTFROM;
3211             if (len <= 2) len = 45;
3212             else len = len / 3 * 3;
3213             if (len >= 64) {
3214                 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3215                                "Field too wide in 'u' format in pack");
3216                 len = 63;
3217             }
3218             aptr = SvPV_const(fromstr, fromlen);
3219             from_utf8 = DO_UTF8(fromstr);
3220             if (from_utf8) {
3221                 aend = aptr + fromlen;
3222                 fromlen = sv_len_utf8_nomg(fromstr);
3223             } else aend = NULL; /* Unused, but keep compilers happy */
3224             GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2);
3225             while (fromlen > 0) {
3226                 U8 *end;
3227                 I32 todo;
3228                 U8 hunk[1+63/3*4+1];
3229
3230                 if ((I32)fromlen > len)
3231                     todo = len;
3232                 else
3233                     todo = fromlen;
3234                 if (from_utf8) {
3235                     char buffer[64];
3236                     if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo,
3237                                       'u' | TYPE_IS_PACK)) {
3238                         *cur = '\0';
3239                         SvCUR_set(cat, cur - start);
3240                         Perl_croak(aTHX_ "panic: string is shorter than advertised, "
3241                                    "aptr=%p, aend=%p, buffer=%p, todo=%ld",
3242                                    aptr, aend, buffer, (long) todo);
3243                     }
3244                     end = doencodes(hunk, buffer, todo);
3245                 } else {
3246                     end = doencodes(hunk, aptr, todo);
3247                     aptr += todo;
3248                 }
3249                 PUSH_BYTES(utf8, cur, hunk, end-hunk);
3250                 fromlen -= todo;
3251             }
3252             break;
3253         }
3254         }
3255         *cur = '\0';
3256         SvCUR_set(cat, cur - start);
3257       no_change:
3258         *symptr = lookahead;
3259     }
3260     return beglist;
3261 }
3262 #undef NEXTFROM
3263
3264
3265 PP(pp_pack)
3266 {
3267     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3268     SV *cat = TARG;
3269     STRLEN fromlen;
3270     SV *pat_sv = *++MARK;
3271     const char *pat = SvPV_const(pat_sv, fromlen);
3272     const char *patend = pat + fromlen;
3273
3274     MARK++;
3275     sv_setpvs(cat, "");
3276     SvUTF8_off(cat);
3277
3278     packlist(cat, pat, patend, MARK, SP + 1);
3279
3280     SvSETMAGIC(cat);
3281     SP = ORIGMARK;
3282     PUSHs(cat);
3283     RETURN;
3284 }
3285
3286 /*
3287  * Local variables:
3288  * c-indentation-style: bsd
3289  * c-basic-offset: 4
3290  * indent-tabs-mode: nil
3291  * End:
3292  *
3293  * ex: set ts=8 sts=4 sw=4 et:
3294  */