pp_pack.c

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