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