pp_pack.c

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