pp_pack.c

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