pp_pack.c

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