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