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