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     STRLEN no_len;
2374     tempsym_t sym;
2375
2376     TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
2377
2378     /* We're going to do changes through SvPVX(cat). Make sure it's valid.
2379        Also make sure any UTF8 flag is loaded */
2380     SvPV_force(cat, no_len);
2381     if (DO_UTF8(cat))
2382         sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8;
2383
2384     (void)pack_rec( cat, &sym, beglist, endlist );
2385 }
2386
2387 /* like sv_utf8_upgrade, but also repoint the group start markers */
2388 STATIC void
2389 marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) {
2390     STRLEN len;
2391     tempsym_t *group;
2392     const char *from_ptr, *from_start, *from_end, **marks, **m;
2393     char *to_start, *to_ptr;
2394
2395     if (SvUTF8(sv)) return;
2396
2397     from_start = SvPVX_const(sv);
2398     from_end = from_start + SvCUR(sv);
2399     for (from_ptr = from_start; from_ptr < from_end; from_ptr++)
2400         if (!NATIVE_IS_INVARIANT(*from_ptr)) break;
2401     if (from_ptr == from_end) {
2402         /* Simple case: no character needs to be changed */
2403         SvUTF8_on(sv);
2404         return;
2405     }
2406
2407     len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1;
2408     Newx(to_start, len, char);
2409     Copy(from_start, to_start, from_ptr-from_start, char);
2410     to_ptr = to_start + (from_ptr-from_start);
2411
2412     Newx(marks, sym_ptr->level+2, const char *);
2413     for (group=sym_ptr; group; group = group->previous)
2414         marks[group->level] = from_start + group->strbeg;
2415     marks[sym_ptr->level+1] = from_end+1;
2416     for (m = marks; *m < from_ptr; m++)
2417         *m = to_start + (*m-from_start);
2418
2419     for (;from_ptr < from_end; from_ptr++) {
2420         while (*m == from_ptr) *m++ = to_ptr;
2421         to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr);
2422     }
2423     *to_ptr = 0;
2424
2425     while (*m == from_ptr) *m++ = to_ptr;
2426     if (m != marks + sym_ptr->level+1) {
2427         Safefree(marks);
2428         Safefree(to_start);
2429         Perl_croak(aTHX_ "Assertion: marks beyond string end");
2430     }
2431     for (group=sym_ptr; group; group = group->previous)
2432         group->strbeg = marks[group->level] - to_start;
2433     Safefree(marks);
2434
2435     if (SvOOK(sv)) {
2436         if (SvIVX(sv)) {
2437             SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2438             from_start -= SvIVX(sv);
2439             SvIV_set(sv, 0);
2440         }
2441         SvFLAGS(sv) &= ~SVf_OOK;
2442     }
2443     if (SvLEN(sv) != 0)
2444         Safefree(from_start);
2445     SvPV_set(sv, to_start);
2446     SvCUR_set(sv, to_ptr - to_start);
2447     SvLEN_set(sv, len);
2448     SvUTF8_on(sv);
2449 }
2450
2451 /* Exponential string grower. Makes string extension effectively O(n)
2452    needed says how many extra bytes we need (not counting the final '\0')
2453    Only grows the string if there is an actual lack of space
2454 */
2455 STATIC char *
2456 S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) {
2457     const STRLEN cur = SvCUR(sv);
2458     const STRLEN len = SvLEN(sv);
2459     STRLEN extend;
2460     if (len - cur > needed) return SvPVX(sv);
2461     extend = needed > len ? needed : len;
2462     return SvGROW(sv, len+extend+1);
2463 }
2464
2465 STATIC
2466 SV **
2467 S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
2468 {
2469     dVAR;
2470     tempsym_t lookahead;
2471     I32 items  = endlist - beglist;
2472     bool found = next_symbol(symptr);
2473     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
2474     bool warn_utf8 = ckWARN(WARN_UTF8);
2475
2476     if (symptr->level == 0 && found && symptr->code == 'U') {
2477         marked_upgrade(aTHX_ cat, symptr);
2478         symptr->flags |= FLAG_DO_UTF8;
2479         utf8 = 0;
2480     }
2481     symptr->strbeg = SvCUR(cat);
2482
2483     while (found) {
2484         SV *fromstr;
2485         STRLEN fromlen;
2486         I32 len;
2487         SV *lengthcode = NULL;
2488         I32 datumtype = symptr->code;
2489         howlen_t howlen = symptr->howlen;
2490         char *start = SvPVX(cat);
2491         char *cur   = start + SvCUR(cat);
2492
2493 #define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2494
2495         switch (howlen) {
2496           case e_star:
2497             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ?
2498                 0 : items;
2499             break;
2500           default:
2501             /* e_no_len and e_number */
2502             len = symptr->length;
2503             break;
2504         }
2505
2506         if (len) {
2507             packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
2508
2509             if (props && !(props & PACK_SIZE_UNPREDICTABLE)) {
2510                 /* We can process this letter. */
2511                 STRLEN size = props & PACK_SIZE_MASK;
2512                 GROWING(utf8, cat, start, cur, (STRLEN) len * size);
2513             }
2514         }
2515
2516         /* Look ahead for next symbol. Do we have code/code? */
2517         lookahead = *symptr;
2518         found = next_symbol(&lookahead);
2519         if (symptr->flags & FLAG_SLASH) {
2520             IV count;
2521             if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack");
2522             if (strchr("aAZ", lookahead.code)) {
2523                 if (lookahead.howlen == e_number) count = lookahead.length;
2524                 else {
2525                     if (items > 0) {
2526                         if (SvGAMAGIC(*beglist)) {
2527                             /* Avoid reading the active data more than once
2528                                by copying it to a temporary.  */
2529                             STRLEN len;
2530                             const char *const pv = SvPV_const(*beglist, len);
2531                             SV *const temp = sv_2mortal(newSVpvn(pv, len));
2532                             if (SvUTF8(*beglist))
2533                                 SvUTF8_on(temp);
2534                             *beglist = temp;
2535                         }
2536                         count = DO_UTF8(*beglist) ?
2537                             sv_len_utf8(*beglist) : sv_len(*beglist);
2538                     }
2539                     else count = 0;
2540                     if (lookahead.code == 'Z') count++;
2541                 }
2542             } else {
2543                 if (lookahead.howlen == e_number && lookahead.length < items)
2544                     count = lookahead.length;
2545                 else count = items;
2546             }
2547             lookahead.howlen = e_number;
2548             lookahead.length = count;
2549             lengthcode = sv_2mortal(newSViv(count));
2550         }
2551
2552         /* Code inside the switch must take care to properly update
2553            cat (CUR length and '\0' termination) if it updated *cur and
2554            doesn't simply leave using break */
2555         switch(TYPE_NO_ENDIANNESS(datumtype)) {
2556         default:
2557             Perl_croak(aTHX_ "Invalid type '%c' in pack",
2558                        (int) TYPE_NO_MODIFIERS(datumtype));
2559         case '%':
2560             Perl_croak(aTHX_ "'%%' may not be used in pack");
2561         {
2562             char *from;
2563 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2564         case '.' | TYPE_IS_SHRIEKING:
2565 #endif
2566         case '.':
2567             if (howlen == e_star) from = start;
2568             else if (len == 0) from = cur;
2569             else {
2570                 tempsym_t *group = symptr;
2571
2572                 while (--len && group) group = group->previous;
2573                 from = group ? start + group->strbeg : start;
2574             }
2575             fromstr = NEXTFROM;
2576             len = SvIV(fromstr);
2577             goto resize;
2578 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2579         case '@' | TYPE_IS_SHRIEKING:
2580 #endif
2581         case '@':
2582             from = start + symptr->strbeg;
2583           resize:
2584 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2585             if (utf8  && !(datumtype & TYPE_IS_SHRIEKING))
2586 #else /* PERL_PACK_CAN_SHRIEKSIGN */
2587             if (utf8)
2588 #endif
2589                 if (len >= 0) {
2590                     while (len && from < cur) {
2591                         from += UTF8SKIP(from);
2592                         len--;
2593                     }
2594                     if (from > cur)
2595                         Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2596                     if (len) {
2597                         /* Here we know from == cur */
2598                       grow:
2599                         GROWING(0, cat, start, cur, len);
2600                         Zero(cur, len, char);
2601                         cur += len;
2602                     } else if (from < cur) {
2603                         len = cur - from;
2604                         goto shrink;
2605                     } else goto no_change;
2606                 } else {
2607                     cur = from;
2608                     len = -len;
2609                     goto utf8_shrink;
2610                 }
2611             else {
2612                 len -= cur - from;
2613                 if (len > 0) goto grow;
2614                 if (len == 0) goto no_change;
2615                 len = -len;
2616                 goto shrink;
2617             }
2618             break;
2619         }
2620         case '(': {
2621             tempsym_t savsym = *symptr;
2622             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2623             symptr->flags |= group_modifiers;
2624             symptr->patend = savsym.grpend;
2625             symptr->level++;
2626             symptr->previous = &lookahead;
2627             while (len--) {
2628                 U32 was_utf8;
2629                 if (utf8) symptr->flags |=  FLAG_PARSE_UTF8;
2630                 else      symptr->flags &= ~FLAG_PARSE_UTF8;
2631                 was_utf8 = SvUTF8(cat);
2632                 symptr->patptr = savsym.grpbeg;
2633                 beglist = pack_rec(cat, symptr, beglist, endlist);
2634                 if (SvUTF8(cat) != was_utf8)
2635                     /* This had better be an upgrade while in utf8==0 mode */
2636                     utf8 = 1;
2637
2638                 if (savsym.howlen == e_star && beglist == endlist)
2639                     break;              /* No way to continue */
2640             }
2641             lookahead.flags  = symptr->flags & ~group_modifiers;
2642             goto no_change;
2643         }
2644         case 'X' | TYPE_IS_SHRIEKING:
2645             if (!len)                   /* Avoid division by 0 */
2646                 len = 1;
2647             if (utf8) {
2648                 char *hop, *last;
2649                 I32 l = len;
2650                 hop = last = start;
2651                 while (hop < cur) {
2652                     hop += UTF8SKIP(hop);
2653                     if (--l == 0) {
2654                         last = hop;
2655                         l = len;
2656                     }
2657                 }
2658                 if (last > cur)
2659                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2660                 cur = last;
2661                 break;
2662             }
2663             len = (cur-start) % len;
2664             /* FALL THROUGH */
2665         case 'X':
2666             if (utf8) {
2667                 if (len < 1) goto no_change;
2668               utf8_shrink:
2669                 while (len > 0) {
2670                     if (cur <= start)
2671                         Perl_croak(aTHX_ "'%c' outside of string in pack",
2672                                    (int) TYPE_NO_MODIFIERS(datumtype));
2673                     while (--cur, UTF8_IS_CONTINUATION(*cur)) {
2674                         if (cur <= start)
2675                             Perl_croak(aTHX_ "'%c' outside of string in pack",
2676                                        (int) TYPE_NO_MODIFIERS(datumtype));
2677                     }
2678                     len--;
2679                 }
2680             } else {
2681               shrink:
2682                 if (cur - start < len)
2683                     Perl_croak(aTHX_ "'%c' outside of string in pack",
2684                                (int) TYPE_NO_MODIFIERS(datumtype));
2685                 cur -= len;
2686             }
2687             if (cur < start+symptr->strbeg) {
2688                 /* Make sure group starts don't point into the void */
2689                 tempsym_t *group;
2690                 const STRLEN length = cur-start;
2691                 for (group = symptr;
2692                      group && length < group->strbeg;
2693                      group = group->previous) group->strbeg = length;
2694                 lookahead.strbeg = length;
2695             }
2696             break;
2697         case 'x' | TYPE_IS_SHRIEKING: {
2698             I32 ai32;
2699             if (!len)                   /* Avoid division by 0 */
2700                 len = 1;
2701             if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len;
2702             else      ai32 = (cur - start) % len;
2703             if (ai32 == 0) goto no_change;
2704             len -= ai32;
2705         }
2706         /* FALL THROUGH */
2707         case 'x':
2708             goto grow;
2709         case 'A':
2710         case 'Z':
2711         case 'a': {
2712             const char *aptr;
2713
2714             fromstr = NEXTFROM;
2715             aptr = SvPV_const(fromstr, fromlen);
2716             if (DO_UTF8(fromstr)) {
2717                 const char *end, *s;
2718
2719                 if (!utf8 && !SvUTF8(cat)) {
2720                     marked_upgrade(aTHX_ cat, symptr);
2721                     lookahead.flags |= FLAG_DO_UTF8;
2722                     lookahead.strbeg = symptr->strbeg;
2723                     utf8 = 1;
2724                     start = SvPVX(cat);
2725                     cur = start + SvCUR(cat);
2726                 }
2727                 if (howlen == e_star) {
2728                     if (utf8) goto string_copy;
2729                     len = fromlen+1;
2730                 }
2731                 s = aptr;
2732                 end = aptr + fromlen;
2733                 fromlen = datumtype == 'Z' ? len-1 : len;
2734                 while ((I32) fromlen > 0 && s < end) {
2735                     s += UTF8SKIP(s);
2736                     fromlen--;
2737                 }
2738                 if (s > end)
2739                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2740                 if (utf8) {
2741                     len = fromlen;
2742                     if (datumtype == 'Z') len++;
2743                     fromlen = s-aptr;
2744                     len += fromlen;
2745
2746                     goto string_copy;
2747                 }
2748                 fromlen = len - fromlen;
2749                 if (datumtype == 'Z') fromlen--;
2750                 if (howlen == e_star) {
2751                     len = fromlen;
2752                     if (datumtype == 'Z') len++;
2753                 }
2754                 GROWING(0, cat, start, cur, len);
2755                 if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
2756                                   datumtype | TYPE_IS_PACK))
2757                     Perl_croak(aTHX_ "Perl bug: predicted utf8 length not available");
2758                 cur += fromlen;
2759                 len -= fromlen;
2760             } else if (utf8) {
2761                 if (howlen == e_star) {
2762                     len = fromlen;
2763                     if (datumtype == 'Z') len++;
2764                 }
2765                 if (len <= (I32) fromlen) {
2766                     fromlen = len;
2767                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2768                 }
2769                 /* assumes a byte expands to at most UTF8_EXPAND bytes on
2770                    upgrade, so:
2771                    expected_length <= from_len*UTF8_EXPAND + (len-from_len) */
2772                 GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len);
2773                 len -= fromlen;
2774                 while (fromlen > 0) {
2775                     cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr);
2776                     aptr++;
2777                     fromlen--;
2778                 }
2779             } else {
2780               string_copy:
2781                 if (howlen == e_star) {
2782                     len = fromlen;
2783                     if (datumtype == 'Z') len++;
2784                 }
2785                 if (len <= (I32) fromlen) {
2786                     fromlen = len;
2787                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2788                 }
2789                 GROWING(0, cat, start, cur, len);
2790                 Copy(aptr, cur, fromlen, char);
2791                 cur += fromlen;
2792                 len -= fromlen;
2793             }
2794             memset(cur, datumtype == 'A' ? ' ' : '\0', len);
2795             cur += len;
2796             break;
2797         }
2798         case 'B':
2799         case 'b': {
2800             const char *str, *end;
2801             I32 l, field_len;
2802             U8 bits;
2803             bool utf8_source;
2804             U32 utf8_flags;
2805
2806             fromstr = NEXTFROM;
2807             str = SvPV_const(fromstr, fromlen);
2808             end = str + fromlen;
2809             if (DO_UTF8(fromstr)) {
2810                 utf8_source = TRUE;
2811                 utf8_flags  = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2812             } else {
2813                 utf8_source = FALSE;
2814                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2815             }
2816             if (howlen == e_star) len = fromlen;
2817             field_len = (len+7)/8;
2818             GROWING(utf8, cat, start, cur, field_len);
2819             if (len > (I32)fromlen) len = fromlen;
2820             bits = 0;
2821             l = 0;
2822             if (datumtype == 'B')
2823                 while (l++ < len) {
2824                     if (utf8_source) {
2825                         UV val = 0;
2826                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2827                         bits |= val & 1;
2828                     } else bits |= *str++ & 1;
2829                     if (l & 7) bits <<= 1;
2830                     else {
2831                         PUSH_BYTE(utf8, cur, bits);
2832                         bits = 0;
2833                     }
2834                 }
2835             else
2836                 /* datumtype == 'b' */
2837                 while (l++ < len) {
2838                     if (utf8_source) {
2839                         UV val = 0;
2840                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2841                         if (val & 1) bits |= 0x80;
2842                     } else if (*str++ & 1)
2843                         bits |= 0x80;
2844                     if (l & 7) bits >>= 1;
2845                     else {
2846                         PUSH_BYTE(utf8, cur, bits);
2847                         bits = 0;
2848                     }
2849                 }
2850             l--;
2851             if (l & 7) {
2852                 if (datumtype == 'B')
2853                     bits <<= 7 - (l & 7);
2854                 else
2855                     bits >>= 7 - (l & 7);
2856                 PUSH_BYTE(utf8, cur, bits);
2857                 l += 7;
2858             }
2859             /* Determine how many chars are left in the requested field */
2860             l /= 8;
2861             if (howlen == e_star) field_len = 0;
2862             else field_len -= l;
2863             Zero(cur, field_len, char);
2864             cur += field_len;
2865             break;
2866         }
2867         case 'H':
2868         case 'h': {
2869             const char *str, *end;
2870             I32 l, field_len;
2871             U8 bits;
2872             bool utf8_source;
2873             U32 utf8_flags;
2874
2875             fromstr = NEXTFROM;
2876             str = SvPV_const(fromstr, fromlen);
2877             end = str + fromlen;
2878             if (DO_UTF8(fromstr)) {
2879                 utf8_source = TRUE;
2880                 utf8_flags  = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2881             } else {
2882                 utf8_source = FALSE;
2883                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2884             }
2885             if (howlen == e_star) len = fromlen;
2886             field_len = (len+1)/2;
2887             GROWING(utf8, cat, start, cur, field_len);
2888             if (!utf8 && len > (I32)fromlen) len = fromlen;
2889             bits = 0;
2890             l = 0;
2891             if (datumtype == 'H')
2892                 while (l++ < len) {
2893                     if (utf8_source) {
2894                         UV val = 0;
2895                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2896                         if (val < 256 && isALPHA(val))
2897                             bits |= (val + 9) & 0xf;
2898                         else
2899                             bits |= val & 0xf;
2900                     } else if (isALPHA(*str))
2901                         bits |= (*str++ + 9) & 0xf;
2902                     else
2903                         bits |= *str++ & 0xf;
2904                     if (l & 1) bits <<= 4;
2905                     else {
2906                         PUSH_BYTE(utf8, cur, bits);
2907                         bits = 0;
2908                     }
2909                 }
2910             else
2911                 while (l++ < len) {
2912                     if (utf8_source) {
2913                         UV val = 0;
2914                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2915                         if (val < 256 && isALPHA(val))
2916                             bits |= ((val + 9) & 0xf) << 4;
2917                         else
2918                             bits |= (val & 0xf) << 4;
2919                     } else if (isALPHA(*str))
2920                         bits |= ((*str++ + 9) & 0xf) << 4;
2921                     else
2922                         bits |= (*str++ & 0xf) << 4;
2923                     if (l & 1) bits >>= 4;
2924                     else {
2925                         PUSH_BYTE(utf8, cur, bits);
2926                         bits = 0;
2927                     }
2928                 }
2929             l--;
2930             if (l & 1) {
2931                 PUSH_BYTE(utf8, cur, bits);
2932                 l++;
2933             }
2934             /* Determine how many chars are left in the requested field */
2935             l /= 2;
2936             if (howlen == e_star) field_len = 0;
2937             else field_len -= l;
2938             Zero(cur, field_len, char);
2939             cur += field_len;
2940             break;
2941         }
2942         case 'c':
2943             while (len-- > 0) {
2944                 IV aiv;
2945                 fromstr = NEXTFROM;
2946                 aiv = SvIV(fromstr);
2947                 if ((-128 > aiv || aiv > 127) &&
2948                     ckWARN(WARN_PACK))
2949                     Perl_warner(aTHX_ packWARN(WARN_PACK),
2950                                 "Character in 'c' format wrapped in pack");
2951                 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2952             }
2953             break;
2954         case 'C':
2955             if (len == 0) {
2956                 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
2957                 break;
2958             }
2959             GROWING(0, cat, start, cur, len);
2960             while (len-- > 0) {
2961                 IV aiv;
2962                 fromstr = NEXTFROM;
2963                 aiv = SvIV(fromstr);
2964                 if ((0 > aiv || aiv > 0xff) &&
2965                     ckWARN(WARN_PACK))
2966                     Perl_warner(aTHX_ packWARN(WARN_PACK),
2967                                 "Character in 'C' format wrapped in pack");
2968                 *cur++ = (char)(aiv & 0xff);
2969             }
2970             break;
2971         case 'W': {
2972             char *end;
2973             U8 in_bytes = IN_BYTES;
2974
2975             end = start+SvLEN(cat)-1;
2976             if (utf8) end -= UTF8_MAXLEN-1;
2977             while (len-- > 0) {
2978                 UV auv;
2979                 fromstr = NEXTFROM;
2980                 auv = SvUV(fromstr);
2981                 if (in_bytes) auv = auv % 0x100;
2982                 if (utf8) {
2983                   W_utf8:
2984                     if (cur > end) {
2985                         *cur = '\0';
2986                         SvCUR_set(cat, cur - start);
2987
2988                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2989                         end = start+SvLEN(cat)-UTF8_MAXLEN;
2990                     }
2991                     cur = (char *) uvuni_to_utf8_flags((U8 *) cur,
2992                                                        NATIVE_TO_UNI(auv),
2993                                                        warn_utf8 ?
2994                                                        0 : UNICODE_ALLOW_ANY);
2995                 } else {
2996                     if (auv >= 0x100) {
2997                         if (!SvUTF8(cat)) {
2998                             *cur = '\0';
2999                             SvCUR_set(cat, cur - start);
3000                             marked_upgrade(aTHX_ cat, symptr);
3001                             lookahead.flags |= FLAG_DO_UTF8;
3002                             lookahead.strbeg = symptr->strbeg;
3003                             utf8 = 1;
3004                             start = SvPVX(cat);
3005                             cur = start + SvCUR(cat);
3006                             end = start+SvLEN(cat)-UTF8_MAXLEN;
3007                             goto W_utf8;
3008                         }
3009                         if (ckWARN(WARN_PACK))
3010                             Perl_warner(aTHX_ packWARN(WARN_PACK),
3011                                         "Character in 'W' format wrapped in pack");
3012                         auv &= 0xff;
3013                     }
3014                     if (cur >= end) {
3015                         *cur = '\0';
3016                         SvCUR_set(cat, cur - start);
3017                         GROWING(0, cat, start, cur, len+1);
3018                         end = start+SvLEN(cat)-1;
3019                     }
3020                     *(U8 *) cur++ = (U8)auv;
3021                 }
3022             }
3023             break;
3024         }
3025         case 'U': {
3026             char *end;
3027
3028             if (len == 0) {
3029                 if (!(symptr->flags & FLAG_DO_UTF8)) {
3030                     marked_upgrade(aTHX_ cat, symptr);
3031                     lookahead.flags |= FLAG_DO_UTF8;
3032                     lookahead.strbeg = symptr->strbeg;
3033                 }
3034                 utf8 = 0;
3035                 goto no_change;
3036             }
3037
3038             end = start+SvLEN(cat);
3039             if (!utf8) end -= UTF8_MAXLEN;
3040             while (len-- > 0) {
3041                 UV auv;
3042                 fromstr = NEXTFROM;
3043                 auv = SvUV(fromstr);
3044                 if (utf8) {
3045                     U8 buffer[UTF8_MAXLEN], *endb;
3046                     endb = uvuni_to_utf8_flags(buffer, auv,
3047                                                warn_utf8 ?
3048                                                0 : UNICODE_ALLOW_ANY);
3049                     if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
3050                         *cur = '\0';
3051                         SvCUR_set(cat, cur - start);
3052                         GROWING(0, cat, start, cur,
3053                                 len+(endb-buffer)*UTF8_EXPAND);
3054                         end = start+SvLEN(cat);
3055                     }
3056                     bytes_to_uni(aTHX_ buffer, endb-buffer, &cur);
3057                 } else {
3058                     if (cur >= end) {
3059                         *cur = '\0';
3060                         SvCUR_set(cat, cur - start);
3061                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
3062                         end = start+SvLEN(cat)-UTF8_MAXLEN;
3063                     }
3064                     cur = (char *) uvuni_to_utf8_flags((U8 *) cur, auv,
3065                                                        warn_utf8 ?
3066                                                        0 : UNICODE_ALLOW_ANY);
3067                 }
3068             }
3069             break;
3070         }
3071         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
3072         case 'f':
3073             while (len-- > 0) {
3074                 float afloat;
3075                 NV anv;
3076                 fromstr = NEXTFROM;
3077                 anv = SvNV(fromstr);
3078 #ifdef __VOS__
3079                 /* VOS does not automatically map a floating-point overflow
3080                    during conversion from double to float into infinity, so we
3081                    do it by hand.  This code should either be generalized for
3082                    any OS that needs it, or removed if and when VOS implements
3083                    posix-976 (suggestion to support mapping to infinity).
3084                    Paul.Green@stratus.com 02-04-02.  */
3085                 if (anv > FLT_MAX)
3086                     afloat = _float_constants[0];   /* single prec. inf. */
3087                 else if (anv < -FLT_MAX)
3088                     afloat = _float_constants[0];   /* single prec. inf. */
3089                 else afloat = (float) anv;
3090 #else /* __VOS__ */
3091 # if defined(VMS) && !defined(__IEEE_FP)
3092                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
3093                  * on Alpha; fake it if we don't have them.
3094                  */
3095                 if (anv > FLT_MAX)
3096                     afloat = FLT_MAX;
3097                 else if (anv < -FLT_MAX)
3098                     afloat = -FLT_MAX;
3099                 else afloat = (float)anv;
3100 # else
3101                 afloat = (float)anv;
3102 # endif
3103 #endif /* __VOS__ */
3104                 DO_BO_PACK_N(afloat, float);
3105                 PUSH_VAR(utf8, cur, afloat);
3106             }
3107             break;
3108         case 'd':
3109             while (len-- > 0) {
3110                 double adouble;
3111                 NV anv;
3112                 fromstr = NEXTFROM;
3113                 anv = SvNV(fromstr);
3114 #ifdef __VOS__
3115                 /* VOS does not automatically map a floating-point overflow
3116                    during conversion from long double to double into infinity,
3117                    so we do it by hand.  This code should either be generalized
3118                    for any OS that needs it, or removed if and when VOS
3119                    implements posix-976 (suggestion to support mapping to
3120                    infinity).  Paul.Green@stratus.com 02-04-02.  */
3121                 if (anv > DBL_MAX)
3122                     adouble = _double_constants[0];   /* double prec. inf. */
3123                 else if (anv < -DBL_MAX)
3124                     adouble = _double_constants[0];   /* double prec. inf. */
3125                 else adouble = (double) anv;
3126 #else /* __VOS__ */
3127 # if defined(VMS) && !defined(__IEEE_FP)
3128                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
3129                  * on Alpha; fake it if we don't have them.
3130                  */
3131                 if (anv > DBL_MAX)
3132                     adouble = DBL_MAX;
3133                 else if (anv < -DBL_MAX)
3134                     adouble = -DBL_MAX;
3135                 else adouble = (double)anv;
3136 # else
3137                 adouble = (double)anv;
3138 # endif
3139 #endif /* __VOS__ */
3140                 DO_BO_PACK_N(adouble, double);
3141                 PUSH_VAR(utf8, cur, adouble);
3142             }
3143             break;
3144         case 'F': {
3145             NV anv;
3146             Zero(&anv, 1, NV); /* can be long double with unused bits */
3147             while (len-- > 0) {
3148                 fromstr = NEXTFROM;
3149                 anv = SvNV(fromstr);
3150                 DO_BO_PACK_N(anv, NV);
3151                 PUSH_VAR(utf8, cur, anv);
3152             }
3153             break;
3154         }
3155 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
3156         case 'D': {
3157             long double aldouble;
3158             /* long doubles can have unused bits, which may be nonzero */
3159             Zero(&aldouble, 1, long double);
3160             while (len-- > 0) {
3161                 fromstr = NEXTFROM;
3162                 aldouble = (long double)SvNV(fromstr);
3163                 DO_BO_PACK_N(aldouble, long double);
3164                 PUSH_VAR(utf8, cur, aldouble);
3165             }
3166             break;
3167         }
3168 #endif
3169 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3170         case 'n' | TYPE_IS_SHRIEKING:
3171 #endif
3172         case 'n':
3173             while (len-- > 0) {
3174                 I16 ai16;
3175                 fromstr = NEXTFROM;
3176                 ai16 = (I16)SvIV(fromstr);
3177 #ifdef HAS_HTONS
3178                 ai16 = PerlSock_htons(ai16);
3179 #endif
3180                 PUSH16(utf8, cur, &ai16);
3181             }
3182             break;
3183 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3184         case 'v' | TYPE_IS_SHRIEKING:
3185 #endif
3186         case 'v':
3187             while (len-- > 0) {
3188                 I16 ai16;
3189                 fromstr = NEXTFROM;
3190                 ai16 = (I16)SvIV(fromstr);
3191 #ifdef HAS_HTOVS
3192                 ai16 = htovs(ai16);
3193 #endif
3194                 PUSH16(utf8, cur, &ai16);
3195             }
3196             break;
3197         case 'S' | TYPE_IS_SHRIEKING:
3198 #if SHORTSIZE != SIZE16
3199             while (len-- > 0) {
3200                 unsigned short aushort;
3201                 fromstr = NEXTFROM;
3202                 aushort = SvUV(fromstr);
3203                 DO_BO_PACK(aushort, s);
3204                 PUSH_VAR(utf8, cur, aushort);
3205             }
3206             break;
3207 #else
3208             /* Fall through! */
3209 #endif
3210         case 'S':
3211             while (len-- > 0) {
3212                 U16 au16;
3213                 fromstr = NEXTFROM;
3214                 au16 = (U16)SvUV(fromstr);
3215                 DO_BO_PACK(au16, 16);
3216                 PUSH16(utf8, cur, &au16);
3217             }
3218             break;
3219         case 's' | TYPE_IS_SHRIEKING:
3220 #if SHORTSIZE != SIZE16
3221             while (len-- > 0) {
3222                 short ashort;
3223                 fromstr = NEXTFROM;
3224                 ashort = SvIV(fromstr);
3225                 DO_BO_PACK(ashort, s);
3226                 PUSH_VAR(utf8, cur, ashort);
3227             }
3228             break;
3229 #else
3230             /* Fall through! */
3231 #endif
3232         case 's':
3233             while (len-- > 0) {
3234                 I16 ai16;
3235                 fromstr = NEXTFROM;
3236                 ai16 = (I16)SvIV(fromstr);
3237                 DO_BO_PACK(ai16, 16);
3238                 PUSH16(utf8, cur, &ai16);
3239             }
3240             break;
3241         case 'I':
3242         case 'I' | TYPE_IS_SHRIEKING:
3243             while (len-- > 0) {
3244                 unsigned int auint;
3245                 fromstr = NEXTFROM;
3246                 auint = SvUV(fromstr);
3247                 DO_BO_PACK(auint, i);
3248                 PUSH_VAR(utf8, cur, auint);
3249             }
3250             break;
3251         case 'j':
3252             while (len-- > 0) {
3253                 IV aiv;
3254                 fromstr = NEXTFROM;
3255                 aiv = SvIV(fromstr);
3256 #if IVSIZE == INTSIZE
3257                 DO_BO_PACK(aiv, i);
3258 #elif IVSIZE == LONGSIZE
3259                 DO_BO_PACK(aiv, l);
3260 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
3261                 DO_BO_PACK(aiv, 64);
3262 #else
3263                 Perl_croak(aTHX_ "'j' not supported on this platform");
3264 #endif
3265                 PUSH_VAR(utf8, cur, aiv);
3266             }
3267             break;
3268         case 'J':
3269             while (len-- > 0) {
3270                 UV auv;
3271                 fromstr = NEXTFROM;
3272                 auv = SvUV(fromstr);
3273 #if UVSIZE == INTSIZE
3274                 DO_BO_PACK(auv, i);
3275 #elif UVSIZE == LONGSIZE
3276                 DO_BO_PACK(auv, l);
3277 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
3278                 DO_BO_PACK(auv, 64);
3279 #else
3280                 Perl_croak(aTHX_ "'J' not supported on this platform");
3281 #endif
3282                 PUSH_VAR(utf8, cur, auv);
3283             }
3284             break;
3285         case 'w':
3286             while (len-- > 0) {
3287                 NV anv;
3288                 fromstr = NEXTFROM;
3289                 anv = SvNV(fromstr);
3290
3291                 if (anv < 0) {
3292                     *cur = '\0';
3293                     SvCUR_set(cat, cur - start);
3294                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
3295                 }
3296
3297                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
3298                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
3299                    any negative IVs will have already been got by the croak()
3300                    above. IOK is untrue for fractions, so we test them
3301                    against UV_MAX_P1.  */
3302                 if (SvIOK(fromstr) || anv < UV_MAX_P1) {
3303                     char   buf[(sizeof(UV)*CHAR_BIT)/7+1];
3304                     char  *in = buf + sizeof(buf);
3305                     UV     auv = SvUV(fromstr);
3306
3307                     do {
3308                         *--in = (char)((auv & 0x7f) | 0x80);
3309                         auv >>= 7;
3310                     } while (auv);
3311                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3312                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3313                                        in, (buf + sizeof(buf)) - in);
3314                 } else if (SvPOKp(fromstr))
3315                     goto w_string;
3316                 else if (SvNOKp(fromstr)) {
3317                     /* 10**NV_MAX_10_EXP is the largest power of 10
3318                        so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
3319                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
3320                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
3321                        And with that many bytes only Inf can overflow.
3322                        Some C compilers are strict about integral constant
3323                        expressions so we conservatively divide by a slightly
3324                        smaller integer instead of multiplying by the exact
3325                        floating-point value.
3326                     */
3327 #ifdef NV_MAX_10_EXP
3328                     /* char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
3329                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
3330 #else
3331                     /* char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
3332                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
3333 #endif
3334                     char  *in = buf + sizeof(buf);
3335
3336                     anv = Perl_floor(anv);
3337                     do {
3338                         const NV next = Perl_floor(anv / 128);
3339                         if (in <= buf)  /* this cannot happen ;-) */
3340                             Perl_croak(aTHX_ "Cannot compress integer in pack");
3341                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
3342                         anv = next;
3343                     } while (anv > 0);
3344                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3345                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3346                                        in, (buf + sizeof(buf)) - in);
3347                 } else {
3348                     const char     *from;
3349                     char           *result, *in;
3350                     SV             *norm;
3351                     STRLEN          len;
3352                     bool            done;
3353
3354                   w_string:
3355                     /* Copy string and check for compliance */
3356                     from = SvPV_const(fromstr, len);
3357                     if ((norm = is_an_int(from, len)) == NULL)
3358                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
3359
3360                     Newx(result, len, char);
3361                     in = result + len;
3362                     done = FALSE;
3363                     while (!done) *--in = div128(norm, &done) | 0x80;
3364                     result[len - 1] &= 0x7F; /* clear continue bit */
3365                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3366                                        in, (result + len) - in);
3367                     Safefree(result);
3368                     SvREFCNT_dec(norm); /* free norm */
3369                 }
3370             }
3371             break;
3372         case 'i':
3373         case 'i' | TYPE_IS_SHRIEKING:
3374             while (len-- > 0) {
3375                 int aint;
3376                 fromstr = NEXTFROM;
3377                 aint = SvIV(fromstr);
3378                 DO_BO_PACK(aint, i);
3379                 PUSH_VAR(utf8, cur, aint);
3380             }
3381             break;
3382 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3383         case 'N' | TYPE_IS_SHRIEKING:
3384 #endif
3385         case 'N':
3386             while (len-- > 0) {
3387                 U32 au32;
3388                 fromstr = NEXTFROM;
3389                 au32 = SvUV(fromstr);
3390 #ifdef HAS_HTONL
3391                 au32 = PerlSock_htonl(au32);
3392 #endif
3393                 PUSH32(utf8, cur, &au32);
3394             }
3395             break;
3396 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3397         case 'V' | TYPE_IS_SHRIEKING:
3398 #endif
3399         case 'V':
3400             while (len-- > 0) {
3401                 U32 au32;
3402                 fromstr = NEXTFROM;
3403                 au32 = SvUV(fromstr);
3404 #ifdef HAS_HTOVL
3405                 au32 = htovl(au32);
3406 #endif
3407                 PUSH32(utf8, cur, &au32);
3408             }
3409             break;
3410         case 'L' | TYPE_IS_SHRIEKING:
3411 #if LONGSIZE != SIZE32
3412             while (len-- > 0) {
3413                 unsigned long aulong;
3414                 fromstr = NEXTFROM;
3415                 aulong = SvUV(fromstr);
3416                 DO_BO_PACK(aulong, l);
3417                 PUSH_VAR(utf8, cur, aulong);
3418             }
3419             break;
3420 #else
3421             /* Fall though! */
3422 #endif
3423         case 'L':
3424             while (len-- > 0) {
3425                 U32 au32;
3426                 fromstr = NEXTFROM;
3427                 au32 = SvUV(fromstr);
3428                 DO_BO_PACK(au32, 32);
3429                 PUSH32(utf8, cur, &au32);
3430             }
3431             break;
3432         case 'l' | TYPE_IS_SHRIEKING:
3433 #if LONGSIZE != SIZE32
3434             while (len-- > 0) {
3435                 long along;
3436                 fromstr = NEXTFROM;
3437                 along = SvIV(fromstr);
3438                 DO_BO_PACK(along, l);
3439                 PUSH_VAR(utf8, cur, along);
3440             }
3441             break;
3442 #else
3443             /* Fall though! */
3444 #endif
3445         case 'l':
3446             while (len-- > 0) {
3447                 I32 ai32;
3448                 fromstr = NEXTFROM;
3449                 ai32 = SvIV(fromstr);
3450                 DO_BO_PACK(ai32, 32);
3451                 PUSH32(utf8, cur, &ai32);
3452             }
3453             break;
3454 #ifdef HAS_QUAD
3455         case 'Q':
3456             while (len-- > 0) {
3457                 Uquad_t auquad;
3458                 fromstr = NEXTFROM;
3459                 auquad = (Uquad_t) SvUV(fromstr);
3460                 DO_BO_PACK(auquad, 64);
3461                 PUSH_VAR(utf8, cur, auquad);
3462             }
3463             break;
3464         case 'q':
3465             while (len-- > 0) {
3466                 Quad_t aquad;
3467                 fromstr = NEXTFROM;
3468                 aquad = (Quad_t)SvIV(fromstr);
3469                 DO_BO_PACK(aquad, 64);
3470                 PUSH_VAR(utf8, cur, aquad);
3471             }
3472             break;
3473 #endif /* HAS_QUAD */
3474         case 'P':
3475             len = 1;            /* assume SV is correct length */
3476             GROWING(utf8, cat, start, cur, sizeof(char *));
3477             /* Fall through! */
3478         case 'p':
3479             while (len-- > 0) {
3480                 const char *aptr;
3481
3482                 fromstr = NEXTFROM;
3483                 SvGETMAGIC(fromstr);
3484                 if (!SvOK(fromstr)) aptr = NULL;
3485                 else {
3486                     /* XXX better yet, could spirit away the string to
3487                      * a safe spot and hang on to it until the result
3488                      * of pack() (and all copies of the result) are
3489                      * gone.
3490                      */
3491                     if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
3492                              !SvREADONLY(fromstr))) && ckWARN(WARN_PACK)) {
3493                         Perl_warner(aTHX_ packWARN(WARN_PACK),
3494                                     "Attempt to pack pointer to temporary value");
3495                     }
3496                     if (SvPOK(fromstr) || SvNIOK(fromstr))
3497                         aptr = SvPV_nomg_const_nolen(fromstr);
3498                     else
3499                         aptr = SvPV_force_flags_nolen(fromstr, 0);
3500                 }
3501                 DO_BO_PACK_PC(aptr);
3502                 PUSH_VAR(utf8, cur, aptr);
3503             }
3504             break;
3505         case 'u': {
3506             const char *aptr, *aend;
3507             bool from_utf8;
3508
3509             fromstr = NEXTFROM;
3510             if (len <= 2) len = 45;
3511             else len = len / 3 * 3;
3512             if (len >= 64) {
3513                 if (ckWARN(WARN_PACK))
3514                     Perl_warner(aTHX_ packWARN(WARN_PACK),
3515                             "Field too wide in 'u' format in pack");
3516                 len = 63;
3517             }
3518             aptr = SvPV_const(fromstr, fromlen);
3519             from_utf8 = DO_UTF8(fromstr);
3520             if (from_utf8) {
3521                 aend = aptr + fromlen;
3522                 fromlen = sv_len_utf8(fromstr);
3523             } else aend = NULL; /* Unused, but keep compilers happy */
3524             GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2);
3525             while (fromlen > 0) {
3526                 U8 *end;
3527                 I32 todo;
3528                 U8 hunk[1+63/3*4+1];
3529
3530                 if ((I32)fromlen > len)
3531                     todo = len;
3532                 else
3533                     todo = fromlen;
3534                 if (from_utf8) {
3535                     char buffer[64];
3536                     if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo,
3537                                       'u' | TYPE_IS_PACK)) {
3538                         *cur = '\0';
3539                         SvCUR_set(cat, cur - start);
3540                         Perl_croak(aTHX_ "Assertion: string is shorter than advertised");
3541                     }
3542                     end = doencodes(hunk, buffer, todo);
3543                 } else {
3544                     end = doencodes(hunk, aptr, todo);
3545                     aptr += todo;
3546                 }
3547                 PUSH_BYTES(utf8, cur, hunk, end-hunk);
3548                 fromlen -= todo;
3549             }
3550             break;
3551         }
3552         }
3553         *cur = '\0';
3554         SvCUR_set(cat, cur - start);
3555       no_change:
3556         *symptr = lookahead;
3557     }
3558     return beglist;
3559 }
3560 #undef NEXTFROM
3561
3562
3563 PP(pp_pack)
3564 {
3565     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3566     register SV *cat = TARG;
3567     STRLEN fromlen;
3568     SV *pat_sv = *++MARK;
3569     register const char *pat = SvPV_const(pat_sv, fromlen);
3570     register const char *patend = pat + fromlen;
3571
3572     MARK++;
3573     sv_setpvn(cat, "", 0);
3574     SvUTF8_off(cat);
3575
3576     packlist(cat, pat, patend, MARK, SP + 1);
3577
3578     SvSETMAGIC(cat);
3579     SP = ORIGMARK;
3580     PUSHs(cat);
3581     RETURN;
3582 }
3583
3584 /*
3585  * Local variables:
3586  * c-indentation-style: bsd
3587  * c-basic-offset: 4
3588  * indent-tabs-mode: t
3589  * End:
3590  *
3591  * ex: set ts=8 sts=4 sw=4 noet:
3592  */