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                 if (datumtype == 'v')
1484                     au16 = vtohs(au16);
1485                 if (!checksum)
1486                     mPUSHu(au16);
1487                 else if (checksum > bits_in_uv)
1488                     cdouble += (NV) au16;
1489                 else
1490                     cuv += au16;
1491             }
1492             break;
1493         case 'v' | TYPE_IS_SHRIEKING:
1494         case 'n' | TYPE_IS_SHRIEKING:
1495             while (len-- > 0) {
1496                 I16 ai16;
1497 # if U16SIZE > SIZE16
1498                 ai16 = 0;
1499 # endif
1500                 SHIFT16(utf8, s, strend, &ai16, datumtype);
1501 # ifdef HAS_NTOHS
1502                 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1503                     ai16 = (I16) PerlSock_ntohs((U16) ai16);
1504 # endif /* HAS_NTOHS */
1505                 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1506                     ai16 = (I16) vtohs((U16) ai16);
1507                 if (!checksum)
1508                     mPUSHi(ai16);
1509                 else if (checksum > bits_in_uv)
1510                     cdouble += (NV) ai16;
1511                 else
1512                     cuv += ai16;
1513             }
1514             break;
1515         case 'i':
1516         case 'i' | TYPE_IS_SHRIEKING:
1517             while (len-- > 0) {
1518                 int aint;
1519                 SHIFT_VAR(utf8, s, strend, aint, datumtype);
1520                 DO_BO_UNPACK(aint, i);
1521                 if (!checksum)
1522                     mPUSHi(aint);
1523                 else if (checksum > bits_in_uv)
1524                     cdouble += (NV)aint;
1525                 else
1526                     cuv += aint;
1527             }
1528             break;
1529         case 'I':
1530         case 'I' | TYPE_IS_SHRIEKING:
1531             while (len-- > 0) {
1532                 unsigned int auint;
1533                 SHIFT_VAR(utf8, s, strend, auint, datumtype);
1534                 DO_BO_UNPACK(auint, i);
1535                 if (!checksum)
1536                     mPUSHu(auint);
1537                 else if (checksum > bits_in_uv)
1538                     cdouble += (NV)auint;
1539                 else
1540                     cuv += auint;
1541             }
1542             break;
1543         case 'j':
1544             while (len-- > 0) {
1545                 IV aiv;
1546                 SHIFT_VAR(utf8, s, strend, aiv, datumtype);
1547 #if IVSIZE == INTSIZE
1548                 DO_BO_UNPACK(aiv, i);
1549 #elif IVSIZE == LONGSIZE
1550                 DO_BO_UNPACK(aiv, l);
1551 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1552                 DO_BO_UNPACK(aiv, 64);
1553 #else
1554                 Perl_croak(aTHX_ "'j' not supported on this platform");
1555 #endif
1556                 if (!checksum)
1557                     mPUSHi(aiv);
1558                 else if (checksum > bits_in_uv)
1559                     cdouble += (NV)aiv;
1560                 else
1561                     cuv += aiv;
1562             }
1563             break;
1564         case 'J':
1565             while (len-- > 0) {
1566                 UV auv;
1567                 SHIFT_VAR(utf8, s, strend, auv, datumtype);
1568 #if IVSIZE == INTSIZE
1569                 DO_BO_UNPACK(auv, i);
1570 #elif IVSIZE == LONGSIZE
1571                 DO_BO_UNPACK(auv, l);
1572 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1573                 DO_BO_UNPACK(auv, 64);
1574 #else
1575                 Perl_croak(aTHX_ "'J' not supported on this platform");
1576 #endif
1577                 if (!checksum)
1578                     mPUSHu(auv);
1579                 else if (checksum > bits_in_uv)
1580                     cdouble += (NV)auv;
1581                 else
1582                     cuv += auv;
1583             }
1584             break;
1585         case 'l' | TYPE_IS_SHRIEKING:
1586 #if LONGSIZE != SIZE32
1587             while (len-- > 0) {
1588                 long along;
1589                 SHIFT_VAR(utf8, s, strend, along, datumtype);
1590                 DO_BO_UNPACK(along, l);
1591                 if (!checksum)
1592                     mPUSHi(along);
1593                 else if (checksum > bits_in_uv)
1594                     cdouble += (NV)along;
1595                 else
1596                     cuv += along;
1597             }
1598             break;
1599 #else
1600             /* Fallthrough! */
1601 #endif
1602         case 'l':
1603             while (len-- > 0) {
1604                 I32 ai32;
1605 #if U32SIZE > SIZE32
1606                 ai32 = 0;
1607 #endif
1608                 SHIFT32(utf8, s, strend, &ai32, datumtype);
1609                 DO_BO_UNPACK(ai32, 32);
1610 #if U32SIZE > SIZE32
1611                 if (ai32 > 2147483647) ai32 -= 4294967296;
1612 #endif
1613                 if (!checksum)
1614                     mPUSHi(ai32);
1615                 else if (checksum > bits_in_uv)
1616                     cdouble += (NV)ai32;
1617                 else
1618                     cuv += ai32;
1619             }
1620             break;
1621         case 'L' | TYPE_IS_SHRIEKING:
1622 #if LONGSIZE != SIZE32
1623             while (len-- > 0) {
1624                 unsigned long aulong;
1625                 SHIFT_VAR(utf8, s, strend, aulong, datumtype);
1626                 DO_BO_UNPACK(aulong, l);
1627                 if (!checksum)
1628                     mPUSHu(aulong);
1629                 else if (checksum > bits_in_uv)
1630                     cdouble += (NV)aulong;
1631                 else
1632                     cuv += aulong;
1633             }
1634             break;
1635 #else
1636             /* Fall through! */
1637 #endif
1638         case 'V':
1639         case 'N':
1640         case 'L':
1641             while (len-- > 0) {
1642                 U32 au32;
1643 #if U32SIZE > SIZE32
1644                 au32 = 0;
1645 #endif
1646                 SHIFT32(utf8, s, strend, &au32, datumtype);
1647                 DO_BO_UNPACK(au32, 32);
1648 #ifdef HAS_NTOHL
1649                 if (datumtype == 'N')
1650                     au32 = PerlSock_ntohl(au32);
1651 #endif
1652                 if (datumtype == 'V')
1653                     au32 = vtohl(au32);
1654                 if (!checksum)
1655                     mPUSHu(au32);
1656                 else if (checksum > bits_in_uv)
1657                     cdouble += (NV)au32;
1658                 else
1659                     cuv += au32;
1660             }
1661             break;
1662         case 'V' | TYPE_IS_SHRIEKING:
1663         case 'N' | TYPE_IS_SHRIEKING:
1664             while (len-- > 0) {
1665                 I32 ai32;
1666 #if U32SIZE > SIZE32
1667                 ai32 = 0;
1668 #endif
1669                 SHIFT32(utf8, s, strend, &ai32, datumtype);
1670 #ifdef HAS_NTOHL
1671                 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1672                     ai32 = (I32)PerlSock_ntohl((U32)ai32);
1673 #endif
1674                 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1675                     ai32 = (I32)vtohl((U32)ai32);
1676                 if (!checksum)
1677                     mPUSHi(ai32);
1678                 else if (checksum > bits_in_uv)
1679                     cdouble += (NV)ai32;
1680                 else
1681                     cuv += ai32;
1682             }
1683             break;
1684         case 'p':
1685             while (len-- > 0) {
1686                 const char *aptr;
1687                 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
1688                 DO_BO_UNPACK_PC(aptr);
1689                 /* newSVpv generates undef if aptr is NULL */
1690                 mPUSHs(newSVpv(aptr, 0));
1691             }
1692             break;
1693         case 'w':
1694             {
1695                 UV auv = 0;
1696                 U32 bytes = 0;
1697
1698                 while (len > 0 && s < strend) {
1699                     U8 ch;
1700                     ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1701                     auv = (auv << 7) | (ch & 0x7f);
1702                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1703                     if (ch < 0x80) {
1704                         bytes = 0;
1705                         mPUSHu(auv);
1706                         len--;
1707                         auv = 0;
1708                         continue;
1709                     }
1710                     if (++bytes >= sizeof(UV)) {        /* promote to string */
1711                         const char *t;
1712
1713                         sv = Perl_newSVpvf(aTHX_ "%.*"UVuf, (int)TYPE_DIGITS(UV), auv);
1714                         while (s < strend) {
1715                             ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1716                             sv = mul128(sv, (U8)(ch & 0x7f));
1717                             if (!(ch & 0x80)) {
1718                                 bytes = 0;
1719                                 break;
1720                             }
1721                         }
1722                         t = SvPV_nolen_const(sv);
1723                         while (*t == '0')
1724                             t++;
1725                         sv_chop(sv, t);
1726                         mPUSHs(sv);
1727                         len--;
1728                         auv = 0;
1729                     }
1730                 }
1731                 if ((s >= strend) && bytes)
1732                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1733             }
1734             break;
1735         case 'P':
1736             if (symptr->howlen == e_star)
1737                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1738             EXTEND(SP, 1);
1739             if (s + sizeof(char*) <= strend) {
1740                 char *aptr;
1741                 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
1742                 DO_BO_UNPACK_PC(aptr);
1743                 /* newSVpvn generates undef if aptr is NULL */
1744                 PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP));
1745             }
1746             break;
1747 #ifdef HAS_QUAD
1748         case 'q':
1749             while (len-- > 0) {
1750                 Quad_t aquad;
1751                 SHIFT_VAR(utf8, s, strend, aquad, datumtype);
1752                 DO_BO_UNPACK(aquad, 64);
1753                 if (!checksum)
1754                     mPUSHs(aquad >= IV_MIN && aquad <= IV_MAX ?
1755                            newSViv((IV)aquad) : newSVnv((NV)aquad));
1756                 else if (checksum > bits_in_uv)
1757                     cdouble += (NV)aquad;
1758                 else
1759                     cuv += aquad;
1760             }
1761             break;
1762         case 'Q':
1763             while (len-- > 0) {
1764                 Uquad_t auquad;
1765                 SHIFT_VAR(utf8, s, strend, auquad, datumtype);
1766                 DO_BO_UNPACK(auquad, 64);
1767                 if (!checksum)
1768                     mPUSHs(auquad <= UV_MAX ?
1769                            newSVuv((UV)auquad) : newSVnv((NV)auquad));
1770                 else if (checksum > bits_in_uv)
1771                     cdouble += (NV)auquad;
1772                 else
1773                     cuv += auquad;
1774             }
1775             break;
1776 #endif /* HAS_QUAD */
1777         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1778         case 'f':
1779             while (len-- > 0) {
1780                 float afloat;
1781                 SHIFT_VAR(utf8, s, strend, afloat, datumtype);
1782                 DO_BO_UNPACK_N(afloat, float);
1783                 if (!checksum)
1784                     mPUSHn(afloat);
1785                 else
1786                     cdouble += afloat;
1787             }
1788             break;
1789         case 'd':
1790             while (len-- > 0) {
1791                 double adouble;
1792                 SHIFT_VAR(utf8, s, strend, adouble, datumtype);
1793                 DO_BO_UNPACK_N(adouble, double);
1794                 if (!checksum)
1795                     mPUSHn(adouble);
1796                 else
1797                     cdouble += adouble;
1798             }
1799             break;
1800         case 'F':
1801             while (len-- > 0) {
1802                 NV_bytes anv;
1803                 SHIFT_BYTES(utf8, s, strend, anv.bytes, sizeof(anv.bytes), datumtype);
1804                 DO_BO_UNPACK_N(anv.nv, NV);
1805                 if (!checksum)
1806                     mPUSHn(anv.nv);
1807                 else
1808                     cdouble += anv.nv;
1809             }
1810             break;
1811 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1812         case 'D':
1813             while (len-- > 0) {
1814                 ld_bytes aldouble;
1815                 SHIFT_BYTES(utf8, s, strend, aldouble.bytes, sizeof(aldouble.bytes), datumtype);
1816                 DO_BO_UNPACK_N(aldouble.ld, long double);
1817                 if (!checksum)
1818                     mPUSHn(aldouble.ld);
1819                 else
1820                     cdouble += aldouble.ld;
1821             }
1822             break;
1823 #endif
1824         case 'u':
1825             if (!checksum) {
1826                 const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
1827                 sv = sv_2mortal(newSV(l));
1828                 if (l) SvPOK_on(sv);
1829             }
1830             if (utf8) {
1831                 while (next_uni_uu(aTHX_ &s, strend, &len)) {
1832                     I32 a, b, c, d;
1833                     char hunk[3];
1834
1835                     while (len > 0) {
1836                         next_uni_uu(aTHX_ &s, strend, &a);
1837                         next_uni_uu(aTHX_ &s, strend, &b);
1838                         next_uni_uu(aTHX_ &s, strend, &c);
1839                         next_uni_uu(aTHX_ &s, strend, &d);
1840                         hunk[0] = (char)((a << 2) | (b >> 4));
1841                         hunk[1] = (char)((b << 4) | (c >> 2));
1842                         hunk[2] = (char)((c << 6) | d);
1843                         if (!checksum)
1844                             sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1845                         len -= 3;
1846                     }
1847                     if (s < strend) {
1848                         if (*s == '\n') {
1849                             s++;
1850                         }
1851                         else {
1852                             /* possible checksum byte */
1853                             const char *skip = s+UTF8SKIP(s);
1854                             if (skip < strend && *skip == '\n')
1855                                 s = skip+1;
1856                         }
1857                     }
1858                 }
1859             } else {
1860                 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1861                     I32 a, b, c, d;
1862                     char hunk[3];
1863
1864                     len = PL_uudmap[*(U8*)s++] & 077;
1865                     while (len > 0) {
1866                         if (s < strend && ISUUCHAR(*s))
1867                             a = PL_uudmap[*(U8*)s++] & 077;
1868                         else
1869                             a = 0;
1870                         if (s < strend && ISUUCHAR(*s))
1871                             b = PL_uudmap[*(U8*)s++] & 077;
1872                         else
1873                             b = 0;
1874                         if (s < strend && ISUUCHAR(*s))
1875                             c = PL_uudmap[*(U8*)s++] & 077;
1876                         else
1877                             c = 0;
1878                         if (s < strend && ISUUCHAR(*s))
1879                             d = PL_uudmap[*(U8*)s++] & 077;
1880                         else
1881                             d = 0;
1882                         hunk[0] = (char)((a << 2) | (b >> 4));
1883                         hunk[1] = (char)((b << 4) | (c >> 2));
1884                         hunk[2] = (char)((c << 6) | d);
1885                         if (!checksum)
1886                             sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1887                         len -= 3;
1888                     }
1889                     if (*s == '\n')
1890                         s++;
1891                     else        /* possible checksum byte */
1892                         if (s + 1 < strend && s[1] == '\n')
1893                             s += 2;
1894                 }
1895             }
1896             if (!checksum)
1897                 XPUSHs(sv);
1898             break;
1899         }
1900
1901         if (checksum) {
1902             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1903               (checksum > bits_in_uv &&
1904                strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1905                 NV trouble, anv;
1906
1907                 anv = (NV) (1 << (checksum & 15));
1908                 while (checksum >= 16) {
1909                     checksum -= 16;
1910                     anv *= 65536.0;
1911                 }
1912                 while (cdouble < 0.0)
1913                     cdouble += anv;
1914                 cdouble = Perl_modf(cdouble / anv, &trouble) * anv;
1915                 sv = newSVnv(cdouble);
1916             }
1917             else {
1918                 if (checksum < bits_in_uv) {
1919                     UV mask = ((UV)1 << checksum) - 1;
1920                     cuv &= mask;
1921                 }
1922                 sv = newSVuv(cuv);
1923             }
1924             mXPUSHs(sv);
1925             checksum = 0;
1926         }
1927
1928         if (symptr->flags & FLAG_SLASH){
1929             if (SP - PL_stack_base - start_sp_offset <= 0)
1930                 break;
1931             if( next_symbol(symptr) ){
1932               if( symptr->howlen == e_number )
1933                 Perl_croak(aTHX_ "Count after length/code in unpack" );
1934               if( beyond ){
1935                 /* ...end of char buffer then no decent length available */
1936                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1937               } else {
1938                 /* take top of stack (hope it's numeric) */
1939                 len = POPi;
1940                 if( len < 0 )
1941                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
1942               }
1943             } else {
1944                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1945             }
1946             datumtype = symptr->code;
1947             explicit_length = FALSE;
1948             goto redo_switch;
1949         }
1950     }
1951
1952     if (new_s)
1953         *new_s = s;
1954     PUTBACK;
1955     return SP - PL_stack_base - start_sp_offset;
1956 }
1957
1958 PP(pp_unpack)
1959 {
1960     dVAR;
1961     dSP;
1962     dPOPPOPssrl;
1963     I32 gimme = GIMME_V;
1964     STRLEN llen;
1965     STRLEN rlen;
1966     const char *pat = SvPV_const(left,  llen);
1967     const char *s   = SvPV_const(right, rlen);
1968     const char *strend = s + rlen;
1969     const char *patend = pat + llen;
1970     I32 cnt;
1971
1972     PUTBACK;
1973     cnt = unpackstring(pat, patend, s, strend,
1974                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1975                      | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0));
1976
1977     SPAGAIN;
1978     if ( !cnt && gimme == G_SCALAR )
1979        PUSHs(&PL_sv_undef);
1980     RETURN;
1981 }
1982
1983 STATIC U8 *
1984 doencodes(U8 *h, const char *s, I32 len)
1985 {
1986     *h++ = PL_uuemap[len];
1987     while (len > 2) {
1988         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
1989         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))];
1990         *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1991         *h++ = PL_uuemap[(077 & (s[2] & 077))];
1992         s += 3;
1993         len -= 3;
1994     }
1995     if (len > 0) {
1996         const char r = (len > 1 ? s[1] : '\0');
1997         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
1998         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))];
1999         *h++ = PL_uuemap[(077 & ((r << 2) & 074))];
2000         *h++ = PL_uuemap[0];
2001     }
2002     *h++ = '\n';
2003     return h;
2004 }
2005
2006 STATIC SV *
2007 S_is_an_int(pTHX_ const char *s, STRLEN l)
2008 {
2009   SV *result = newSVpvn(s, l);
2010   char *const result_c = SvPV_nolen(result);    /* convenience */
2011   char *out = result_c;
2012   bool skip = 1;
2013   bool ignore = 0;
2014
2015   PERL_ARGS_ASSERT_IS_AN_INT;
2016
2017   while (*s) {
2018     switch (*s) {
2019     case ' ':
2020       break;
2021     case '+':
2022       if (!skip) {
2023         SvREFCNT_dec(result);
2024         return (NULL);
2025       }
2026       break;
2027     case '0':
2028     case '1':
2029     case '2':
2030     case '3':
2031     case '4':
2032     case '5':
2033     case '6':
2034     case '7':
2035     case '8':
2036     case '9':
2037       skip = 0;
2038       if (!ignore) {
2039         *(out++) = *s;
2040       }
2041       break;
2042     case '.':
2043       ignore = 1;
2044       break;
2045     default:
2046       SvREFCNT_dec(result);
2047       return (NULL);
2048     }
2049     s++;
2050   }
2051   *(out++) = '\0';
2052   SvCUR_set(result, out - result_c);
2053   return (result);
2054 }
2055
2056 /* pnum must be '\0' terminated */
2057 STATIC int
2058 S_div128(pTHX_ SV *pnum, bool *done)
2059 {
2060     STRLEN len;
2061     char * const s = SvPV(pnum, len);
2062     char *t = s;
2063     int m = 0;
2064
2065     PERL_ARGS_ASSERT_DIV128;
2066
2067     *done = 1;
2068     while (*t) {
2069         const int i = m * 10 + (*t - '0');
2070         const int r = (i >> 7); /* r < 10 */
2071         m = i & 0x7F;
2072         if (r) {
2073             *done = 0;
2074         }
2075         *(t++) = '0' + r;
2076     }
2077     *(t++) = '\0';
2078     SvCUR_set(pnum, (STRLEN) (t - s));
2079     return (m);
2080 }
2081
2082 /*
2083 =for apidoc packlist
2084
2085 The engine implementing pack() Perl function.
2086
2087 =cut
2088 */
2089
2090 void
2091 Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist )
2092 {
2093     dVAR;
2094     tempsym_t sym;
2095
2096     PERL_ARGS_ASSERT_PACKLIST;
2097
2098     TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
2099
2100     /* We're going to do changes through SvPVX(cat). Make sure it's valid.
2101        Also make sure any UTF8 flag is loaded */
2102     SvPV_force_nolen(cat);
2103     if (DO_UTF8(cat))
2104         sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8;
2105
2106     (void)pack_rec( cat, &sym, beglist, endlist );
2107 }
2108
2109 /* like sv_utf8_upgrade, but also repoint the group start markers */
2110 STATIC void
2111 marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) {
2112     STRLEN len;
2113     tempsym_t *group;
2114     const char *from_ptr, *from_start, *from_end, **marks, **m;
2115     char *to_start, *to_ptr;
2116
2117     if (SvUTF8(sv)) return;
2118
2119     from_start = SvPVX_const(sv);
2120     from_end = from_start + SvCUR(sv);
2121     for (from_ptr = from_start; from_ptr < from_end; from_ptr++)
2122         if (!NATIVE_IS_INVARIANT(*from_ptr)) break;
2123     if (from_ptr == from_end) {
2124         /* Simple case: no character needs to be changed */
2125         SvUTF8_on(sv);
2126         return;
2127     }
2128
2129     len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1;
2130     Newx(to_start, len, char);
2131     Copy(from_start, to_start, from_ptr-from_start, char);
2132     to_ptr = to_start + (from_ptr-from_start);
2133
2134     Newx(marks, sym_ptr->level+2, const char *);
2135     for (group=sym_ptr; group; group = group->previous)
2136         marks[group->level] = from_start + group->strbeg;
2137     marks[sym_ptr->level+1] = from_end+1;
2138     for (m = marks; *m < from_ptr; m++)
2139         *m = to_start + (*m-from_start);
2140
2141     for (;from_ptr < from_end; from_ptr++) {
2142         while (*m == from_ptr) *m++ = to_ptr;
2143         to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr);
2144     }
2145     *to_ptr = 0;
2146
2147     while (*m == from_ptr) *m++ = to_ptr;
2148     if (m != marks + sym_ptr->level+1) {
2149         Safefree(marks);
2150         Safefree(to_start);
2151         Perl_croak(aTHX_ "panic: marks beyond string end, m=%p, marks=%p, "
2152                    "level=%d", m, marks, sym_ptr->level);
2153     }
2154     for (group=sym_ptr; group; group = group->previous)
2155         group->strbeg = marks[group->level] - to_start;
2156     Safefree(marks);
2157
2158     if (SvOOK(sv)) {
2159         if (SvIVX(sv)) {
2160             SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2161             from_start -= SvIVX(sv);
2162             SvIV_set(sv, 0);
2163         }
2164         SvFLAGS(sv) &= ~SVf_OOK;
2165     }
2166     if (SvLEN(sv) != 0)
2167         Safefree(from_start);
2168     SvPV_set(sv, to_start);
2169     SvCUR_set(sv, to_ptr - to_start);
2170     SvLEN_set(sv, len);
2171     SvUTF8_on(sv);
2172 }
2173
2174 /* Exponential string grower. Makes string extension effectively O(n)
2175    needed says how many extra bytes we need (not counting the final '\0')
2176    Only grows the string if there is an actual lack of space
2177 */
2178 STATIC char *
2179 S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) {
2180     const STRLEN cur = SvCUR(sv);
2181     const STRLEN len = SvLEN(sv);
2182     STRLEN extend;
2183
2184     PERL_ARGS_ASSERT_SV_EXP_GROW;
2185
2186     if (len - cur > needed) return SvPVX(sv);
2187     extend = needed > len ? needed : len;
2188     return SvGROW(sv, len+extend+1);
2189 }
2190
2191 STATIC
2192 SV **
2193 S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
2194 {
2195     dVAR;
2196     tempsym_t lookahead;
2197     I32 items  = endlist - beglist;
2198     bool found = next_symbol(symptr);
2199     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
2200     bool warn_utf8 = ckWARN(WARN_UTF8);
2201
2202     PERL_ARGS_ASSERT_PACK_REC;
2203
2204     if (symptr->level == 0 && found && symptr->code == 'U') {
2205         marked_upgrade(aTHX_ cat, symptr);
2206         symptr->flags |= FLAG_DO_UTF8;
2207         utf8 = 0;
2208     }
2209     symptr->strbeg = SvCUR(cat);
2210
2211     while (found) {
2212         SV *fromstr;
2213         STRLEN fromlen;
2214         I32 len;
2215         SV *lengthcode = NULL;
2216         I32 datumtype = symptr->code;
2217         howlen_t howlen = symptr->howlen;
2218         char *start = SvPVX(cat);
2219         char *cur   = start + SvCUR(cat);
2220
2221 #define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2222
2223         switch (howlen) {
2224           case e_star:
2225             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ?
2226                 0 : items;
2227             break;
2228           default:
2229             /* e_no_len and e_number */
2230             len = symptr->length;
2231             break;
2232         }
2233
2234         if (len) {
2235             packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
2236
2237             if (props && !(props & PACK_SIZE_UNPREDICTABLE)) {
2238                 /* We can process this letter. */
2239                 STRLEN size = props & PACK_SIZE_MASK;
2240                 GROWING(utf8, cat, start, cur, (STRLEN) len * size);
2241             }
2242         }
2243
2244         /* Look ahead for next symbol. Do we have code/code? */
2245         lookahead = *symptr;
2246         found = next_symbol(&lookahead);
2247         if (symptr->flags & FLAG_SLASH) {
2248             IV count;
2249             if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack");
2250             if (strchr("aAZ", lookahead.code)) {
2251                 if (lookahead.howlen == e_number) count = lookahead.length;
2252                 else {
2253                     if (items > 0) {
2254                         count = sv_len_utf8(*beglist);
2255                     }
2256                     else count = 0;
2257                     if (lookahead.code == 'Z') count++;
2258                 }
2259             } else {
2260                 if (lookahead.howlen == e_number && lookahead.length < items)
2261                     count = lookahead.length;
2262                 else count = items;
2263             }
2264             lookahead.howlen = e_number;
2265             lookahead.length = count;
2266             lengthcode = sv_2mortal(newSViv(count));
2267         }
2268
2269         /* Code inside the switch must take care to properly update
2270            cat (CUR length and '\0' termination) if it updated *cur and
2271            doesn't simply leave using break */
2272         switch(TYPE_NO_ENDIANNESS(datumtype)) {
2273         default:
2274             Perl_croak(aTHX_ "Invalid type '%c' in pack",
2275                        (int) TYPE_NO_MODIFIERS(datumtype));
2276         case '%':
2277             Perl_croak(aTHX_ "'%%' may not be used in pack");
2278         {
2279             char *from;
2280         case '.' | TYPE_IS_SHRIEKING:
2281         case '.':
2282             if (howlen == e_star) from = start;
2283             else if (len == 0) from = cur;
2284             else {
2285                 tempsym_t *group = symptr;
2286
2287                 while (--len && group) group = group->previous;
2288                 from = group ? start + group->strbeg : start;
2289             }
2290             fromstr = NEXTFROM;
2291             len = SvIV(fromstr);
2292             goto resize;
2293         case '@' | TYPE_IS_SHRIEKING:
2294         case '@':
2295             from = start + symptr->strbeg;
2296           resize:
2297             if (utf8  && !(datumtype & TYPE_IS_SHRIEKING))
2298                 if (len >= 0) {
2299                     while (len && from < cur) {
2300                         from += UTF8SKIP(from);
2301                         len--;
2302                     }
2303                     if (from > cur)
2304                         Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2305                     if (len) {
2306                         /* Here we know from == cur */
2307                       grow:
2308                         GROWING(0, cat, start, cur, len);
2309                         Zero(cur, len, char);
2310                         cur += len;
2311                     } else if (from < cur) {
2312                         len = cur - from;
2313                         goto shrink;
2314                     } else goto no_change;
2315                 } else {
2316                     cur = from;
2317                     len = -len;
2318                     goto utf8_shrink;
2319                 }
2320             else {
2321                 len -= cur - from;
2322                 if (len > 0) goto grow;
2323                 if (len == 0) goto no_change;
2324                 len = -len;
2325                 goto shrink;
2326             }
2327             break;
2328         }
2329         case '(': {
2330             tempsym_t savsym = *symptr;
2331             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2332             symptr->flags |= group_modifiers;
2333             symptr->patend = savsym.grpend;
2334             symptr->level++;
2335             symptr->previous = &lookahead;
2336             while (len--) {
2337                 U32 was_utf8;
2338                 if (utf8) symptr->flags |=  FLAG_PARSE_UTF8;
2339                 else      symptr->flags &= ~FLAG_PARSE_UTF8;
2340                 was_utf8 = SvUTF8(cat);
2341                 symptr->patptr = savsym.grpbeg;
2342                 beglist = pack_rec(cat, symptr, beglist, endlist);
2343                 if (SvUTF8(cat) != was_utf8)
2344                     /* This had better be an upgrade while in utf8==0 mode */
2345                     utf8 = 1;
2346
2347                 if (savsym.howlen == e_star && beglist == endlist)
2348                     break;              /* No way to continue */
2349             }
2350             items = endlist - beglist;
2351             lookahead.flags  = symptr->flags & ~group_modifiers;
2352             goto no_change;
2353         }
2354         case 'X' | TYPE_IS_SHRIEKING:
2355             if (!len)                   /* Avoid division by 0 */
2356                 len = 1;
2357             if (utf8) {
2358                 char *hop, *last;
2359                 I32 l = len;
2360                 hop = last = start;
2361                 while (hop < cur) {
2362                     hop += UTF8SKIP(hop);
2363                     if (--l == 0) {
2364                         last = hop;
2365                         l = len;
2366                     }
2367                 }
2368                 if (last > cur)
2369                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2370                 cur = last;
2371                 break;
2372             }
2373             len = (cur-start) % len;
2374             /* FALL THROUGH */
2375         case 'X':
2376             if (utf8) {
2377                 if (len < 1) goto no_change;
2378               utf8_shrink:
2379                 while (len > 0) {
2380                     if (cur <= start)
2381                         Perl_croak(aTHX_ "'%c' outside of string in pack",
2382                                    (int) TYPE_NO_MODIFIERS(datumtype));
2383                     while (--cur, UTF8_IS_CONTINUATION(*cur)) {
2384                         if (cur <= start)
2385                             Perl_croak(aTHX_ "'%c' outside of string in pack",
2386                                        (int) TYPE_NO_MODIFIERS(datumtype));
2387                     }
2388                     len--;
2389                 }
2390             } else {
2391               shrink:
2392                 if (cur - start < len)
2393                     Perl_croak(aTHX_ "'%c' outside of string in pack",
2394                                (int) TYPE_NO_MODIFIERS(datumtype));
2395                 cur -= len;
2396             }
2397             if (cur < start+symptr->strbeg) {
2398                 /* Make sure group starts don't point into the void */
2399                 tempsym_t *group;
2400                 const STRLEN length = cur-start;
2401                 for (group = symptr;
2402                      group && length < group->strbeg;
2403                      group = group->previous) group->strbeg = length;
2404                 lookahead.strbeg = length;
2405             }
2406             break;
2407         case 'x' | TYPE_IS_SHRIEKING: {
2408             I32 ai32;
2409             if (!len)                   /* Avoid division by 0 */
2410                 len = 1;
2411             if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len;
2412             else      ai32 = (cur - start) % len;
2413             if (ai32 == 0) goto no_change;
2414             len -= ai32;
2415         }
2416         /* FALL THROUGH */
2417         case 'x':
2418             goto grow;
2419         case 'A':
2420         case 'Z':
2421         case 'a': {
2422             const char *aptr;
2423
2424             fromstr = NEXTFROM;
2425             aptr = SvPV_const(fromstr, fromlen);
2426             if (DO_UTF8(fromstr)) {
2427                 const char *end, *s;
2428
2429                 if (!utf8 && !SvUTF8(cat)) {
2430                     marked_upgrade(aTHX_ cat, symptr);
2431                     lookahead.flags |= FLAG_DO_UTF8;
2432                     lookahead.strbeg = symptr->strbeg;
2433                     utf8 = 1;
2434                     start = SvPVX(cat);
2435                     cur = start + SvCUR(cat);
2436                 }
2437                 if (howlen == e_star) {
2438                     if (utf8) goto string_copy;
2439                     len = fromlen+1;
2440                 }
2441                 s = aptr;
2442                 end = aptr + fromlen;
2443                 fromlen = datumtype == 'Z' ? len-1 : len;
2444                 while ((I32) fromlen > 0 && s < end) {
2445                     s += UTF8SKIP(s);
2446                     fromlen--;
2447                 }
2448                 if (s > end)
2449                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2450                 if (utf8) {
2451                     len = fromlen;
2452                     if (datumtype == 'Z') len++;
2453                     fromlen = s-aptr;
2454                     len += fromlen;
2455
2456                     goto string_copy;
2457                 }
2458                 fromlen = len - fromlen;
2459                 if (datumtype == 'Z') fromlen--;
2460                 if (howlen == e_star) {
2461                     len = fromlen;
2462                     if (datumtype == 'Z') len++;
2463                 }
2464                 GROWING(0, cat, start, cur, len);
2465                 if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
2466                                   datumtype | TYPE_IS_PACK))
2467                     Perl_croak(aTHX_ "panic: predicted utf8 length not available, "
2468                                "for '%c', aptr=%p end=%p cur=%p, fromlen=%"UVuf,
2469                                (int)datumtype, aptr, end, cur, (UV)fromlen);
2470                 cur += fromlen;
2471                 len -= fromlen;
2472             } else if (utf8) {
2473                 if (howlen == e_star) {
2474                     len = fromlen;
2475                     if (datumtype == 'Z') len++;
2476                 }
2477                 if (len <= (I32) fromlen) {
2478                     fromlen = len;
2479                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2480                 }
2481                 /* assumes a byte expands to at most UTF8_EXPAND bytes on
2482                    upgrade, so:
2483                    expected_length <= from_len*UTF8_EXPAND + (len-from_len) */
2484                 GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len);
2485                 len -= fromlen;
2486                 while (fromlen > 0) {
2487                     cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr);
2488                     aptr++;
2489                     fromlen--;
2490                 }
2491             } else {
2492               string_copy:
2493                 if (howlen == e_star) {
2494                     len = fromlen;
2495                     if (datumtype == 'Z') len++;
2496                 }
2497                 if (len <= (I32) fromlen) {
2498                     fromlen = len;
2499                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2500                 }
2501                 GROWING(0, cat, start, cur, len);
2502                 Copy(aptr, cur, fromlen, char);
2503                 cur += fromlen;
2504                 len -= fromlen;
2505             }
2506             memset(cur, datumtype == 'A' ? ' ' : '\0', len);
2507             cur += len;
2508             SvTAINT(cat);
2509             break;
2510         }
2511         case 'B':
2512         case 'b': {
2513             const char *str, *end;
2514             I32 l, field_len;
2515             U8 bits;
2516             bool utf8_source;
2517             U32 utf8_flags;
2518
2519             fromstr = NEXTFROM;
2520             str = SvPV_const(fromstr, fromlen);
2521             end = str + fromlen;
2522             if (DO_UTF8(fromstr)) {
2523                 utf8_source = TRUE;
2524                 utf8_flags  = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2525             } else {
2526                 utf8_source = FALSE;
2527                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2528             }
2529             if (howlen == e_star) len = fromlen;
2530             field_len = (len+7)/8;
2531             GROWING(utf8, cat, start, cur, field_len);
2532             if (len > (I32)fromlen) len = fromlen;
2533             bits = 0;
2534             l = 0;
2535             if (datumtype == 'B')
2536                 while (l++ < len) {
2537                     if (utf8_source) {
2538                         UV val = 0;
2539                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2540                         bits |= val & 1;
2541                     } else bits |= *str++ & 1;
2542                     if (l & 7) bits <<= 1;
2543                     else {
2544                         PUSH_BYTE(utf8, cur, bits);
2545                         bits = 0;
2546                     }
2547                 }
2548             else
2549                 /* datumtype == 'b' */
2550                 while (l++ < len) {
2551                     if (utf8_source) {
2552                         UV val = 0;
2553                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2554                         if (val & 1) bits |= 0x80;
2555                     } else if (*str++ & 1)
2556                         bits |= 0x80;
2557                     if (l & 7) bits >>= 1;
2558                     else {
2559                         PUSH_BYTE(utf8, cur, bits);
2560                         bits = 0;
2561                     }
2562                 }
2563             l--;
2564             if (l & 7) {
2565                 if (datumtype == 'B')
2566                     bits <<= 7 - (l & 7);
2567                 else
2568                     bits >>= 7 - (l & 7);
2569                 PUSH_BYTE(utf8, cur, bits);
2570                 l += 7;
2571             }
2572             /* Determine how many chars are left in the requested field */
2573             l /= 8;
2574             if (howlen == e_star) field_len = 0;
2575             else field_len -= l;
2576             Zero(cur, field_len, char);
2577             cur += field_len;
2578             break;
2579         }
2580         case 'H':
2581         case 'h': {
2582             const char *str, *end;
2583             I32 l, field_len;
2584             U8 bits;
2585             bool utf8_source;
2586             U32 utf8_flags;
2587
2588             fromstr = NEXTFROM;
2589             str = SvPV_const(fromstr, fromlen);
2590             end = str + fromlen;
2591             if (DO_UTF8(fromstr)) {
2592                 utf8_source = TRUE;
2593                 utf8_flags  = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2594             } else {
2595                 utf8_source = FALSE;
2596                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2597             }
2598             if (howlen == e_star) len = fromlen;
2599             field_len = (len+1)/2;
2600             GROWING(utf8, cat, start, cur, field_len);
2601             if (!utf8 && len > (I32)fromlen) len = fromlen;
2602             bits = 0;
2603             l = 0;
2604             if (datumtype == 'H')
2605                 while (l++ < len) {
2606                     if (utf8_source) {
2607                         UV val = 0;
2608                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2609                         if (val < 256 && isALPHA(val))
2610                             bits |= (val + 9) & 0xf;
2611                         else
2612                             bits |= val & 0xf;
2613                     } else if (isALPHA(*str))
2614                         bits |= (*str++ + 9) & 0xf;
2615                     else
2616                         bits |= *str++ & 0xf;
2617                     if (l & 1) bits <<= 4;
2618                     else {
2619                         PUSH_BYTE(utf8, cur, bits);
2620                         bits = 0;
2621                     }
2622                 }
2623             else
2624                 while (l++ < len) {
2625                     if (utf8_source) {
2626                         UV val = 0;
2627                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2628                         if (val < 256 && isALPHA(val))
2629                             bits |= ((val + 9) & 0xf) << 4;
2630                         else
2631                             bits |= (val & 0xf) << 4;
2632                     } else if (isALPHA(*str))
2633                         bits |= ((*str++ + 9) & 0xf) << 4;
2634                     else
2635                         bits |= (*str++ & 0xf) << 4;
2636                     if (l & 1) bits >>= 4;
2637                     else {
2638                         PUSH_BYTE(utf8, cur, bits);
2639                         bits = 0;
2640                     }
2641                 }
2642             l--;
2643             if (l & 1) {
2644                 PUSH_BYTE(utf8, cur, bits);
2645                 l++;
2646             }
2647             /* Determine how many chars are left in the requested field */
2648             l /= 2;
2649             if (howlen == e_star) field_len = 0;
2650             else field_len -= l;
2651             Zero(cur, field_len, char);
2652             cur += field_len;
2653             break;
2654         }
2655         case 'c':
2656             while (len-- > 0) {
2657                 IV aiv;
2658                 fromstr = NEXTFROM;
2659                 aiv = SvIV(fromstr);
2660                 if ((-128 > aiv || aiv > 127))
2661                     Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2662                                    "Character in 'c' format wrapped in pack");
2663                 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2664             }
2665             break;
2666         case 'C':
2667             if (len == 0) {
2668                 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
2669                 break;
2670             }
2671             while (len-- > 0) {
2672                 IV aiv;
2673                 fromstr = NEXTFROM;
2674                 aiv = SvIV(fromstr);
2675                 if ((0 > aiv || aiv > 0xff))
2676                     Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2677                                    "Character in 'C' format wrapped in pack");
2678                 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2679             }
2680             break;
2681         case 'W': {
2682             char *end;
2683             U8 in_bytes = (U8)IN_BYTES;
2684
2685             end = start+SvLEN(cat)-1;
2686             if (utf8) end -= UTF8_MAXLEN-1;
2687             while (len-- > 0) {
2688                 UV auv;
2689                 fromstr = NEXTFROM;
2690                 auv = SvUV(fromstr);
2691                 if (in_bytes) auv = auv % 0x100;
2692                 if (utf8) {
2693                   W_utf8:
2694                     if (cur > end) {
2695                         *cur = '\0';
2696                         SvCUR_set(cat, cur - start);
2697
2698                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2699                         end = start+SvLEN(cat)-UTF8_MAXLEN;
2700                     }
2701                     cur = (char *) uvuni_to_utf8_flags((U8 *) cur,
2702                                                        NATIVE_TO_UNI(auv),
2703                                                        warn_utf8 ?
2704                                                        0 : UNICODE_ALLOW_ANY);
2705                 } else {
2706                     if (auv >= 0x100) {
2707                         if (!SvUTF8(cat)) {
2708                             *cur = '\0';
2709                             SvCUR_set(cat, cur - start);
2710                             marked_upgrade(aTHX_ cat, symptr);
2711                             lookahead.flags |= FLAG_DO_UTF8;
2712                             lookahead.strbeg = symptr->strbeg;
2713                             utf8 = 1;
2714                             start = SvPVX(cat);
2715                             cur = start + SvCUR(cat);
2716                             end = start+SvLEN(cat)-UTF8_MAXLEN;
2717                             goto W_utf8;
2718                         }
2719                         Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2720                                        "Character in 'W' format wrapped in pack");
2721                         auv &= 0xff;
2722                     }
2723                     if (cur >= end) {
2724                         *cur = '\0';
2725                         SvCUR_set(cat, cur - start);
2726                         GROWING(0, cat, start, cur, len+1);
2727                         end = start+SvLEN(cat)-1;
2728                     }
2729                     *(U8 *) cur++ = (U8)auv;
2730                 }
2731             }
2732             break;
2733         }
2734         case 'U': {
2735             char *end;
2736
2737             if (len == 0) {
2738                 if (!(symptr->flags & FLAG_DO_UTF8)) {
2739                     marked_upgrade(aTHX_ cat, symptr);
2740                     lookahead.flags |= FLAG_DO_UTF8;
2741                     lookahead.strbeg = symptr->strbeg;
2742                 }
2743                 utf8 = 0;
2744                 goto no_change;
2745             }
2746
2747             end = start+SvLEN(cat);
2748             if (!utf8) end -= UTF8_MAXLEN;
2749             while (len-- > 0) {
2750                 UV auv;
2751                 fromstr = NEXTFROM;
2752                 auv = SvUV(fromstr);
2753                 if (utf8) {
2754                     U8 buffer[UTF8_MAXLEN], *endb;
2755                     endb = uvuni_to_utf8_flags(buffer, auv,
2756                                                warn_utf8 ?
2757                                                0 : UNICODE_ALLOW_ANY);
2758                     if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
2759                         *cur = '\0';
2760                         SvCUR_set(cat, cur - start);
2761                         GROWING(0, cat, start, cur,
2762                                 len+(endb-buffer)*UTF8_EXPAND);
2763                         end = start+SvLEN(cat);
2764                     }
2765                     cur = bytes_to_uni(buffer, endb-buffer, cur);
2766                 } else {
2767                     if (cur >= end) {
2768                         *cur = '\0';
2769                         SvCUR_set(cat, cur - start);
2770                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2771                         end = start+SvLEN(cat)-UTF8_MAXLEN;
2772                     }
2773                     cur = (char *) uvuni_to_utf8_flags((U8 *) cur, auv,
2774                                                        warn_utf8 ?
2775                                                        0 : UNICODE_ALLOW_ANY);
2776                 }
2777             }
2778             break;
2779         }
2780         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2781         case 'f':
2782             while (len-- > 0) {
2783                 float afloat;
2784                 NV anv;
2785                 fromstr = NEXTFROM;
2786                 anv = SvNV(fromstr);
2787 # if defined(VMS) && !defined(_IEEE_FP)
2788                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2789                  * on Alpha; fake it if we don't have them.
2790                  */
2791                 if (anv > FLT_MAX)
2792                     afloat = FLT_MAX;
2793                 else if (anv < -FLT_MAX)
2794                     afloat = -FLT_MAX;
2795                 else afloat = (float)anv;
2796 # else
2797                 afloat = (float)anv;
2798 # endif
2799                 DO_BO_PACK_N(afloat, float);
2800                 PUSH_VAR(utf8, cur, afloat);
2801             }
2802             break;
2803         case 'd':
2804             while (len-- > 0) {
2805                 double adouble;
2806                 NV anv;
2807                 fromstr = NEXTFROM;
2808                 anv = SvNV(fromstr);
2809 # if defined(VMS) && !defined(_IEEE_FP)
2810                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2811                  * on Alpha; fake it if we don't have them.
2812                  */
2813                 if (anv > DBL_MAX)
2814                     adouble = DBL_MAX;
2815                 else if (anv < -DBL_MAX)
2816                     adouble = -DBL_MAX;
2817                 else adouble = (double)anv;
2818 # else
2819                 adouble = (double)anv;
2820 # endif
2821                 DO_BO_PACK_N(adouble, double);
2822                 PUSH_VAR(utf8, cur, adouble);
2823             }
2824             break;
2825         case 'F': {
2826             NV_bytes anv;
2827             Zero(&anv, 1, NV); /* can be long double with unused bits */
2828             while (len-- > 0) {
2829                 fromstr = NEXTFROM;
2830 #ifdef __GNUC__
2831                 /* to work round a gcc/x86 bug; don't use SvNV */
2832                 anv.nv = sv_2nv(fromstr);
2833 #else
2834                 anv.nv = SvNV(fromstr);
2835 #endif
2836                 DO_BO_PACK_N(anv, NV);
2837                 PUSH_BYTES(utf8, cur, anv.bytes, sizeof(anv.bytes));
2838             }
2839             break;
2840         }
2841 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2842         case 'D': {
2843             ld_bytes aldouble;
2844             /* long doubles can have unused bits, which may be nonzero */
2845             Zero(&aldouble, 1, long double);
2846             while (len-- > 0) {
2847                 fromstr = NEXTFROM;
2848 #  ifdef __GNUC__
2849                 /* to work round a gcc/x86 bug; don't use SvNV */
2850                 aldouble.ld = (long double)sv_2nv(fromstr);
2851 #  else
2852                 aldouble.ld = (long double)SvNV(fromstr);
2853 #  endif
2854                 DO_BO_PACK_N(aldouble, long double);
2855                 PUSH_BYTES(utf8, cur, aldouble.bytes, sizeof(aldouble.bytes));
2856             }
2857             break;
2858         }
2859 #endif
2860         case 'n' | TYPE_IS_SHRIEKING:
2861         case 'n':
2862             while (len-- > 0) {
2863                 I16 ai16;
2864                 fromstr = NEXTFROM;
2865                 ai16 = (I16)SvIV(fromstr);
2866 #ifdef HAS_HTONS
2867                 ai16 = PerlSock_htons(ai16);
2868 #endif
2869                 PUSH16(utf8, cur, &ai16);
2870             }
2871             break;
2872         case 'v' | TYPE_IS_SHRIEKING:
2873         case 'v':
2874             while (len-- > 0) {
2875                 I16 ai16;
2876                 fromstr = NEXTFROM;
2877                 ai16 = (I16)SvIV(fromstr);
2878                 ai16 = htovs(ai16);
2879                 PUSH16(utf8, cur, &ai16);
2880             }
2881             break;
2882         case 'S' | TYPE_IS_SHRIEKING:
2883 #if SHORTSIZE != SIZE16
2884             while (len-- > 0) {
2885                 unsigned short aushort;
2886                 fromstr = NEXTFROM;
2887                 aushort = SvUV(fromstr);
2888                 DO_BO_PACK(aushort, s);
2889                 PUSH_VAR(utf8, cur, aushort);
2890             }
2891             break;
2892 #else
2893             /* Fall through! */
2894 #endif
2895         case 'S':
2896             while (len-- > 0) {
2897                 U16 au16;
2898                 fromstr = NEXTFROM;
2899                 au16 = (U16)SvUV(fromstr);
2900                 DO_BO_PACK(au16, 16);
2901                 PUSH16(utf8, cur, &au16);
2902             }
2903             break;
2904         case 's' | TYPE_IS_SHRIEKING:
2905 #if SHORTSIZE != SIZE16
2906             while (len-- > 0) {
2907                 short ashort;
2908                 fromstr = NEXTFROM;
2909                 ashort = SvIV(fromstr);
2910                 DO_BO_PACK(ashort, s);
2911                 PUSH_VAR(utf8, cur, ashort);
2912             }
2913             break;
2914 #else
2915             /* Fall through! */
2916 #endif
2917         case 's':
2918             while (len-- > 0) {
2919                 I16 ai16;
2920                 fromstr = NEXTFROM;
2921                 ai16 = (I16)SvIV(fromstr);
2922                 DO_BO_PACK(ai16, 16);
2923                 PUSH16(utf8, cur, &ai16);
2924             }
2925             break;
2926         case 'I':
2927         case 'I' | TYPE_IS_SHRIEKING:
2928             while (len-- > 0) {
2929                 unsigned int auint;
2930                 fromstr = NEXTFROM;
2931                 auint = SvUV(fromstr);
2932                 DO_BO_PACK(auint, i);
2933                 PUSH_VAR(utf8, cur, auint);
2934             }
2935             break;
2936         case 'j':
2937             while (len-- > 0) {
2938                 IV aiv;
2939                 fromstr = NEXTFROM;
2940                 aiv = SvIV(fromstr);
2941 #if IVSIZE == INTSIZE
2942                 DO_BO_PACK(aiv, i);
2943 #elif IVSIZE == LONGSIZE
2944                 DO_BO_PACK(aiv, l);
2945 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2946                 DO_BO_PACK(aiv, 64);
2947 #else
2948                 Perl_croak(aTHX_ "'j' not supported on this platform");
2949 #endif
2950                 PUSH_VAR(utf8, cur, aiv);
2951             }
2952             break;
2953         case 'J':
2954             while (len-- > 0) {
2955                 UV auv;
2956                 fromstr = NEXTFROM;
2957                 auv = SvUV(fromstr);
2958 #if UVSIZE == INTSIZE
2959                 DO_BO_PACK(auv, i);
2960 #elif UVSIZE == LONGSIZE
2961                 DO_BO_PACK(auv, l);
2962 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2963                 DO_BO_PACK(auv, 64);
2964 #else
2965                 Perl_croak(aTHX_ "'J' not supported on this platform");
2966 #endif
2967                 PUSH_VAR(utf8, cur, auv);
2968             }
2969             break;
2970         case 'w':
2971             while (len-- > 0) {
2972                 NV anv;
2973                 fromstr = NEXTFROM;
2974                 anv = SvNV(fromstr);
2975
2976                 if (anv < 0) {
2977                     *cur = '\0';
2978                     SvCUR_set(cat, cur - start);
2979                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2980                 }
2981
2982                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2983                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2984                    any negative IVs will have already been got by the croak()
2985                    above. IOK is untrue for fractions, so we test them
2986                    against UV_MAX_P1.  */
2987                 if (SvIOK(fromstr) || anv < UV_MAX_P1) {
2988                     char   buf[(sizeof(UV)*CHAR_BIT)/7+1];
2989                     char  *in = buf + sizeof(buf);
2990                     UV     auv = SvUV(fromstr);
2991
2992                     do {
2993                         *--in = (char)((auv & 0x7f) | 0x80);
2994                         auv >>= 7;
2995                     } while (auv);
2996                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2997                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
2998                                        in, (buf + sizeof(buf)) - in);
2999                 } else if (SvPOKp(fromstr))
3000                     goto w_string;
3001                 else if (SvNOKp(fromstr)) {
3002                     /* 10**NV_MAX_10_EXP is the largest power of 10
3003                        so 10**(NV_MAX_10_EXP+1) is definitely unrepresentable
3004                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
3005                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
3006                        And with that many bytes only Inf can overflow.
3007                        Some C compilers are strict about integral constant
3008                        expressions so we conservatively divide by a slightly
3009                        smaller integer instead of multiplying by the exact
3010                        floating-point value.
3011                     */
3012 #ifdef NV_MAX_10_EXP
3013                     /* char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
3014                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
3015 #else
3016                     /* char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
3017                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
3018 #endif
3019                     char  *in = buf + sizeof(buf);
3020
3021                     anv = Perl_floor(anv);
3022                     do {
3023                         const NV next = Perl_floor(anv / 128);
3024                         if (in <= buf)  /* this cannot happen ;-) */
3025                             Perl_croak(aTHX_ "Cannot compress integer in pack");
3026                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
3027                         anv = next;
3028                     } while (anv > 0);
3029                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3030                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3031                                        in, (buf + sizeof(buf)) - in);
3032                 } else {
3033                     const char     *from;
3034                     char           *result, *in;
3035                     SV             *norm;
3036                     STRLEN          len;
3037                     bool            done;
3038
3039                   w_string:
3040                     /* Copy string and check for compliance */
3041                     from = SvPV_const(fromstr, len);
3042                     if ((norm = is_an_int(from, len)) == NULL)
3043                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
3044
3045                     Newx(result, len, char);
3046                     in = result + len;
3047                     done = FALSE;
3048                     while (!done) *--in = div128(norm, &done) | 0x80;
3049                     result[len - 1] &= 0x7F; /* clear continue bit */
3050                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3051                                        in, (result + len) - in);
3052                     Safefree(result);
3053                     SvREFCNT_dec(norm); /* free norm */
3054                 }
3055             }
3056             break;
3057         case 'i':
3058         case 'i' | TYPE_IS_SHRIEKING:
3059             while (len-- > 0) {
3060                 int aint;
3061                 fromstr = NEXTFROM;
3062                 aint = SvIV(fromstr);
3063                 DO_BO_PACK(aint, i);
3064                 PUSH_VAR(utf8, cur, aint);
3065             }
3066             break;
3067         case 'N' | TYPE_IS_SHRIEKING:
3068         case 'N':
3069             while (len-- > 0) {
3070                 U32 au32;
3071                 fromstr = NEXTFROM;
3072                 au32 = SvUV(fromstr);
3073 #ifdef HAS_HTONL
3074                 au32 = PerlSock_htonl(au32);
3075 #endif
3076                 PUSH32(utf8, cur, &au32);
3077             }
3078             break;
3079         case 'V' | TYPE_IS_SHRIEKING:
3080         case 'V':
3081             while (len-- > 0) {
3082                 U32 au32;
3083                 fromstr = NEXTFROM;
3084                 au32 = SvUV(fromstr);
3085                 au32 = htovl(au32);
3086                 PUSH32(utf8, cur, &au32);
3087             }
3088             break;
3089         case 'L' | TYPE_IS_SHRIEKING:
3090 #if LONGSIZE != SIZE32
3091             while (len-- > 0) {
3092                 unsigned long aulong;
3093                 fromstr = NEXTFROM;
3094                 aulong = SvUV(fromstr);
3095                 DO_BO_PACK(aulong, l);
3096                 PUSH_VAR(utf8, cur, aulong);
3097             }
3098             break;
3099 #else
3100             /* Fall though! */
3101 #endif
3102         case 'L':
3103             while (len-- > 0) {
3104                 U32 au32;
3105                 fromstr = NEXTFROM;
3106                 au32 = SvUV(fromstr);
3107                 DO_BO_PACK(au32, 32);
3108                 PUSH32(utf8, cur, &au32);
3109             }
3110             break;
3111         case 'l' | TYPE_IS_SHRIEKING:
3112 #if LONGSIZE != SIZE32
3113             while (len-- > 0) {
3114                 long along;
3115                 fromstr = NEXTFROM;
3116                 along = SvIV(fromstr);
3117                 DO_BO_PACK(along, l);
3118                 PUSH_VAR(utf8, cur, along);
3119             }
3120             break;
3121 #else
3122             /* Fall though! */
3123 #endif
3124         case 'l':
3125             while (len-- > 0) {
3126                 I32 ai32;
3127                 fromstr = NEXTFROM;
3128                 ai32 = SvIV(fromstr);
3129                 DO_BO_PACK(ai32, 32);
3130                 PUSH32(utf8, cur, &ai32);
3131             }
3132             break;
3133 #ifdef HAS_QUAD
3134         case 'Q':
3135             while (len-- > 0) {
3136                 Uquad_t auquad;
3137                 fromstr = NEXTFROM;
3138                 auquad = (Uquad_t) SvUV(fromstr);
3139                 DO_BO_PACK(auquad, 64);
3140                 PUSH_VAR(utf8, cur, auquad);
3141             }
3142             break;
3143         case 'q':
3144             while (len-- > 0) {
3145                 Quad_t aquad;
3146                 fromstr = NEXTFROM;
3147                 aquad = (Quad_t)SvIV(fromstr);
3148                 DO_BO_PACK(aquad, 64);
3149                 PUSH_VAR(utf8, cur, aquad);
3150             }
3151             break;
3152 #endif /* HAS_QUAD */
3153         case 'P':
3154             len = 1;            /* assume SV is correct length */
3155             GROWING(utf8, cat, start, cur, sizeof(char *));
3156             /* Fall through! */
3157         case 'p':
3158             while (len-- > 0) {
3159                 const char *aptr;
3160
3161                 fromstr = NEXTFROM;
3162                 SvGETMAGIC(fromstr);
3163                 if (!SvOK(fromstr)) aptr = NULL;
3164                 else {
3165                     /* XXX better yet, could spirit away the string to
3166                      * a safe spot and hang on to it until the result
3167                      * of pack() (and all copies of the result) are
3168                      * gone.
3169                      */
3170                     if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
3171                              !SvREADONLY(fromstr)))) {
3172                         Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3173                                        "Attempt to pack pointer to temporary value");
3174                     }
3175                     if (SvPOK(fromstr) || SvNIOK(fromstr))
3176                         aptr = SvPV_nomg_const_nolen(fromstr);
3177                     else
3178                         aptr = SvPV_force_flags_nolen(fromstr, 0);
3179                 }
3180                 DO_BO_PACK_PC(aptr);
3181                 PUSH_VAR(utf8, cur, aptr);
3182             }
3183             break;
3184         case 'u': {
3185             const char *aptr, *aend;
3186             bool from_utf8;
3187
3188             fromstr = NEXTFROM;
3189             if (len <= 2) len = 45;
3190             else len = len / 3 * 3;
3191             if (len >= 64) {
3192                 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3193                                "Field too wide in 'u' format in pack");
3194                 len = 63;
3195             }
3196             aptr = SvPV_const(fromstr, fromlen);
3197             from_utf8 = DO_UTF8(fromstr);
3198             if (from_utf8) {
3199                 aend = aptr + fromlen;
3200                 fromlen = sv_len_utf8_nomg(fromstr);
3201             } else aend = NULL; /* Unused, but keep compilers happy */
3202             GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2);
3203             while (fromlen > 0) {
3204                 U8 *end;
3205                 I32 todo;
3206                 U8 hunk[1+63/3*4+1];
3207
3208                 if ((I32)fromlen > len)
3209                     todo = len;
3210                 else
3211                     todo = fromlen;
3212                 if (from_utf8) {
3213                     char buffer[64];
3214                     if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo,
3215                                       'u' | TYPE_IS_PACK)) {
3216                         *cur = '\0';
3217                         SvCUR_set(cat, cur - start);
3218                         Perl_croak(aTHX_ "panic: string is shorter than advertised, "
3219                                    "aptr=%p, aend=%p, buffer=%p, todo=%ld",
3220                                    aptr, aend, buffer, (long) todo);
3221                     }
3222                     end = doencodes(hunk, buffer, todo);
3223                 } else {
3224                     end = doencodes(hunk, aptr, todo);
3225                     aptr += todo;
3226                 }
3227                 PUSH_BYTES(utf8, cur, hunk, end-hunk);
3228                 fromlen -= todo;
3229             }
3230             break;
3231         }
3232         }
3233         *cur = '\0';
3234         SvCUR_set(cat, cur - start);
3235       no_change:
3236         *symptr = lookahead;
3237     }
3238     return beglist;
3239 }
3240 #undef NEXTFROM
3241
3242
3243 PP(pp_pack)
3244 {
3245     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3246     SV *cat = TARG;
3247     STRLEN fromlen;
3248     SV *pat_sv = *++MARK;
3249     const char *pat = SvPV_const(pat_sv, fromlen);
3250     const char *patend = pat + fromlen;
3251
3252     MARK++;
3253     sv_setpvs(cat, "");
3254     SvUTF8_off(cat);
3255
3256     packlist(cat, pat, patend, MARK, SP + 1);
3257
3258     SvSETMAGIC(cat);
3259     SP = ORIGMARK;
3260     PUSHs(cat);
3261     RETURN;
3262 }
3263
3264 /*
3265  * Local variables:
3266  * c-indentation-style: bsd
3267  * c-basic-offset: 4
3268  * indent-tabs-mode: nil
3269  * End:
3270  *
3271  * ex: set ts=8 sts=4 sw=4 et:
3272  */