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