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 (!PL_bitcount) {
1481                     int bits;
1482                     Newxz(PL_bitcount, 256, char);
1483                     for (bits = 1; bits < 256; bits++) {
1484                         if (bits & 1)   PL_bitcount[bits]++;
1485                         if (bits & 2)   PL_bitcount[bits]++;
1486                         if (bits & 4)   PL_bitcount[bits]++;
1487                         if (bits & 8)   PL_bitcount[bits]++;
1488                         if (bits & 16)  PL_bitcount[bits]++;
1489                         if (bits & 32)  PL_bitcount[bits]++;
1490                         if (bits & 64)  PL_bitcount[bits]++;
1491                         if (bits & 128) PL_bitcount[bits]++;
1492                     }
1493                 }
1494                 if (utf8)
1495                     while (len >= 8 && s < strend) {
1496                         cuv += PL_bitcount[uni_to_byte(aTHX_ &s, strend, datumtype)];
1497                         len -= 8;
1498                     }
1499                 else
1500                     while (len >= 8) {
1501                         cuv += PL_bitcount[*(U8 *)s++];
1502                         len -= 8;
1503                     }
1504                 if (len && s < strend) {
1505                     U8 bits;
1506                     bits = SHIFT_BYTE(utf8, s, strend, datumtype);
1507                     if (datumtype == 'b')
1508                         while (len-- > 0) {
1509                             if (bits & 1) cuv++;
1510                             bits >>= 1;
1511                         }
1512                     else
1513                         while (len-- > 0) {
1514                             if (bits & 0x80) cuv++;
1515                             bits <<= 1;
1516                         }
1517                 }
1518                 break;
1519             }
1520
1521             sv = sv_2mortal(newSV(len ? len : 1));
1522             SvPOK_on(sv);
1523             str = SvPVX(sv);
1524             if (datumtype == 'b') {
1525                 U8 bits = 0;
1526                 const I32 ai32 = len;
1527                 for (len = 0; len < ai32; len++) {
1528                     if (len & 7) bits >>= 1;
1529                     else if (utf8) {
1530                         if (s >= strend) break;
1531                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1532                     } else bits = *(U8 *) s++;
1533                     *str++ = bits & 1 ? '1' : '0';
1534                 }
1535             } else {
1536                 U8 bits = 0;
1537                 const I32 ai32 = len;
1538                 for (len = 0; len < ai32; len++) {
1539                     if (len & 7) bits <<= 1;
1540                     else if (utf8) {
1541                         if (s >= strend) break;
1542                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1543                     } else bits = *(U8 *) s++;
1544                     *str++ = bits & 0x80 ? '1' : '0';
1545                 }
1546             }
1547             *str = '\0';
1548             SvCUR_set(sv, str - SvPVX_const(sv));
1549             XPUSHs(sv);
1550             break;
1551         }
1552         case 'H':
1553         case 'h': {
1554             char *str;
1555             /* Preliminary length estimate, acceptable for utf8 too */
1556             if (howlen == e_star || len > (strend - s) * 2)
1557                 len = (strend - s) * 2;
1558             sv = sv_2mortal(newSV(len ? len : 1));
1559             SvPOK_on(sv);
1560             str = SvPVX(sv);
1561             if (datumtype == 'h') {
1562                 U8 bits = 0;
1563                 I32 ai32 = len;
1564                 for (len = 0; len < ai32; len++) {
1565                     if (len & 1) bits >>= 4;
1566                     else if (utf8) {
1567                         if (s >= strend) break;
1568                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1569                     } else bits = * (U8 *) s++;
1570                     *str++ = PL_hexdigit[bits & 15];
1571                 }
1572             } else {
1573                 U8 bits = 0;
1574                 const I32 ai32 = len;
1575                 for (len = 0; len < ai32; len++) {
1576                     if (len & 1) bits <<= 4;
1577                     else if (utf8) {
1578                         if (s >= strend) break;
1579                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1580                     } else bits = *(U8 *) s++;
1581                     *str++ = PL_hexdigit[(bits >> 4) & 15];
1582                 }
1583             }
1584             *str = '\0';
1585             SvCUR_set(sv, str - SvPVX_const(sv));
1586             XPUSHs(sv);
1587             break;
1588         }
1589         case 'C':
1590             if (len == 0) {
1591                 if (explicit_length)
1592                     /* Switch to "character" mode */
1593                     utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
1594                 break;
1595             }
1596             /* FALL THROUGH */
1597         case 'c':
1598             while (len-- > 0 && s < strend) {
1599                 int aint;
1600                 if (utf8)
1601                   {
1602                     STRLEN retlen;
1603                     aint = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
1604                                  ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1605                     if (retlen == (STRLEN) -1 || retlen == 0)
1606                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1607                     s += retlen;
1608                   }
1609                 else
1610                   aint = *(U8 *)(s)++;
1611                 if (aint >= 128 && datumtype != 'C')    /* fake up signed chars */
1612                     aint -= 256;
1613                 if (!checksum)
1614                     mPUSHi(aint);
1615                 else if (checksum > bits_in_uv)
1616                     cdouble += (NV)aint;
1617                 else
1618                     cuv += aint;
1619             }
1620             break;
1621         case 'W':
1622           W_checksum:
1623             if (utf8) {
1624                 while (len-- > 0 && s < strend) {
1625                     STRLEN retlen;
1626                     const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
1627                                          ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1628                     if (retlen == (STRLEN) -1 || retlen == 0)
1629                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1630                     s += retlen;
1631                     if (!checksum)
1632                         mPUSHu(val);
1633                     else if (checksum > bits_in_uv)
1634                         cdouble += (NV) val;
1635                     else
1636                         cuv += val;
1637                 }
1638             } else if (!checksum)
1639                 while (len-- > 0) {
1640                     const U8 ch = *(U8 *) s++;
1641                     mPUSHu(ch);
1642             }
1643             else if (checksum > bits_in_uv)
1644                 while (len-- > 0) cdouble += (NV) *(U8 *) s++;
1645             else
1646                 while (len-- > 0) cuv += *(U8 *) s++;
1647             break;
1648         case 'U':
1649             if (len == 0) {
1650                 if (explicit_length) {
1651                     /* Switch to "bytes in UTF-8" mode */
1652                     if (symptr->flags & FLAG_DO_UTF8) utf8 = 0;
1653                     else
1654                         /* Should be impossible due to the need_utf8() test */
1655                         Perl_croak(aTHX_ "U0 mode on a byte string");
1656                 }
1657                 break;
1658             }
1659             if (len > strend - s) len = strend - s;
1660             if (!checksum) {
1661                 if (len && unpack_only_one) len = 1;
1662                 EXTEND(SP, len);
1663                 EXTEND_MORTAL(len);
1664             }
1665             while (len-- > 0 && s < strend) {
1666                 STRLEN retlen;
1667                 UV auv;
1668                 if (utf8) {
1669                     U8 result[UTF8_MAXLEN];
1670                     const char *ptr = s;
1671                     STRLEN len;
1672                     /* Bug: warns about bad utf8 even if we are short on bytes
1673                        and will break out of the loop */
1674                     if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) result, 1,
1675                                       'U'))
1676                         break;
1677                     len = UTF8SKIP(result);
1678                     if (!uni_to_bytes(aTHX_ &ptr, strend,
1679                                       (char *) &result[1], len-1, 'U')) break;
1680                     auv = utf8n_to_uvuni(result, len, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
1681                     s = ptr;
1682                 } else {
1683                     auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
1684                     if (retlen == (STRLEN) -1 || retlen == 0)
1685                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1686                     s += retlen;
1687                 }
1688                 if (!checksum)
1689                     mPUSHu(auv);
1690                 else if (checksum > bits_in_uv)
1691                     cdouble += (NV) auv;
1692                 else
1693                     cuv += auv;
1694             }
1695             break;
1696         case 's' | TYPE_IS_SHRIEKING:
1697 #if SHORTSIZE != SIZE16
1698             while (len-- > 0) {
1699                 short ashort;
1700                 SHIFT_VAR(utf8, s, strend, ashort, datumtype);
1701                 DO_BO_UNPACK(ashort, s);
1702                 if (!checksum)
1703                     mPUSHi(ashort);
1704                 else if (checksum > bits_in_uv)
1705                     cdouble += (NV)ashort;
1706                 else
1707                     cuv += ashort;
1708             }
1709             break;
1710 #else
1711             /* Fallthrough! */
1712 #endif
1713         case 's':
1714             while (len-- > 0) {
1715                 I16 ai16;
1716
1717 #if U16SIZE > SIZE16
1718                 ai16 = 0;
1719 #endif
1720                 SHIFT16(utf8, s, strend, &ai16, datumtype);
1721                 DO_BO_UNPACK(ai16, 16);
1722 #if U16SIZE > SIZE16
1723                 if (ai16 > 32767)
1724                     ai16 -= 65536;
1725 #endif
1726                 if (!checksum)
1727                     mPUSHi(ai16);
1728                 else if (checksum > bits_in_uv)
1729                     cdouble += (NV)ai16;
1730                 else
1731                     cuv += ai16;
1732             }
1733             break;
1734         case 'S' | TYPE_IS_SHRIEKING:
1735 #if SHORTSIZE != SIZE16
1736             while (len-- > 0) {
1737                 unsigned short aushort;
1738                 SHIFT_VAR(utf8, s, strend, aushort, datumtype);
1739                 DO_BO_UNPACK(aushort, s);
1740                 if (!checksum)
1741                     mPUSHu(aushort);
1742                 else if (checksum > bits_in_uv)
1743                     cdouble += (NV)aushort;
1744                 else
1745                     cuv += aushort;
1746             }
1747             break;
1748 #else
1749             /* Fallhrough! */
1750 #endif
1751         case 'v':
1752         case 'n':
1753         case 'S':
1754             while (len-- > 0) {
1755                 U16 au16;
1756 #if U16SIZE > SIZE16
1757                 au16 = 0;
1758 #endif
1759                 SHIFT16(utf8, s, strend, &au16, datumtype);
1760                 DO_BO_UNPACK(au16, 16);
1761 #ifdef HAS_NTOHS
1762                 if (datumtype == 'n')
1763                     au16 = PerlSock_ntohs(au16);
1764 #endif
1765 #ifdef HAS_VTOHS
1766                 if (datumtype == 'v')
1767                     au16 = vtohs(au16);
1768 #endif
1769                 if (!checksum)
1770                     mPUSHu(au16);
1771                 else if (checksum > bits_in_uv)
1772                     cdouble += (NV) au16;
1773                 else
1774                     cuv += au16;
1775             }
1776             break;
1777 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1778         case 'v' | TYPE_IS_SHRIEKING:
1779         case 'n' | TYPE_IS_SHRIEKING:
1780             while (len-- > 0) {
1781                 I16 ai16;
1782 # if U16SIZE > SIZE16
1783                 ai16 = 0;
1784 # endif
1785                 SHIFT16(utf8, s, strend, &ai16, datumtype);
1786 # ifdef HAS_NTOHS
1787                 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1788                     ai16 = (I16) PerlSock_ntohs((U16) ai16);
1789 # endif /* HAS_NTOHS */
1790 # ifdef HAS_VTOHS
1791                 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1792                     ai16 = (I16) vtohs((U16) ai16);
1793 # endif /* HAS_VTOHS */
1794                 if (!checksum)
1795                     mPUSHi(ai16);
1796                 else if (checksum > bits_in_uv)
1797                     cdouble += (NV) ai16;
1798                 else
1799                     cuv += ai16;
1800             }
1801             break;
1802 #endif /* PERL_PACK_CAN_SHRIEKSIGN */
1803         case 'i':
1804         case 'i' | TYPE_IS_SHRIEKING:
1805             while (len-- > 0) {
1806                 int aint;
1807                 SHIFT_VAR(utf8, s, strend, aint, datumtype);
1808                 DO_BO_UNPACK(aint, i);
1809                 if (!checksum)
1810                     mPUSHi(aint);
1811                 else if (checksum > bits_in_uv)
1812                     cdouble += (NV)aint;
1813                 else
1814                     cuv += aint;
1815             }
1816             break;
1817         case 'I':
1818         case 'I' | TYPE_IS_SHRIEKING:
1819             while (len-- > 0) {
1820                 unsigned int auint;
1821                 SHIFT_VAR(utf8, s, strend, auint, datumtype);
1822                 DO_BO_UNPACK(auint, i);
1823                 if (!checksum)
1824                     mPUSHu(auint);
1825                 else if (checksum > bits_in_uv)
1826                     cdouble += (NV)auint;
1827                 else
1828                     cuv += auint;
1829             }
1830             break;
1831         case 'j':
1832             while (len-- > 0) {
1833                 IV aiv;
1834                 SHIFT_VAR(utf8, s, strend, aiv, datumtype);
1835 #if IVSIZE == INTSIZE
1836                 DO_BO_UNPACK(aiv, i);
1837 #elif IVSIZE == LONGSIZE
1838                 DO_BO_UNPACK(aiv, l);
1839 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1840                 DO_BO_UNPACK(aiv, 64);
1841 #else
1842                 Perl_croak(aTHX_ "'j' not supported on this platform");
1843 #endif
1844                 if (!checksum)
1845                     mPUSHi(aiv);
1846                 else if (checksum > bits_in_uv)
1847                     cdouble += (NV)aiv;
1848                 else
1849                     cuv += aiv;
1850             }
1851             break;
1852         case 'J':
1853             while (len-- > 0) {
1854                 UV auv;
1855                 SHIFT_VAR(utf8, s, strend, auv, datumtype);
1856 #if IVSIZE == INTSIZE
1857                 DO_BO_UNPACK(auv, i);
1858 #elif IVSIZE == LONGSIZE
1859                 DO_BO_UNPACK(auv, l);
1860 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1861                 DO_BO_UNPACK(auv, 64);
1862 #else
1863                 Perl_croak(aTHX_ "'J' not supported on this platform");
1864 #endif
1865                 if (!checksum)
1866                     mPUSHu(auv);
1867                 else if (checksum > bits_in_uv)
1868                     cdouble += (NV)auv;
1869                 else
1870                     cuv += auv;
1871             }
1872             break;
1873         case 'l' | TYPE_IS_SHRIEKING:
1874 #if LONGSIZE != SIZE32
1875             while (len-- > 0) {
1876                 long along;
1877                 SHIFT_VAR(utf8, s, strend, along, datumtype);
1878                 DO_BO_UNPACK(along, l);
1879                 if (!checksum)
1880                     mPUSHi(along);
1881                 else if (checksum > bits_in_uv)
1882                     cdouble += (NV)along;
1883                 else
1884                     cuv += along;
1885             }
1886             break;
1887 #else
1888             /* Fallthrough! */
1889 #endif
1890         case 'l':
1891             while (len-- > 0) {
1892                 I32 ai32;
1893 #if U32SIZE > SIZE32
1894                 ai32 = 0;
1895 #endif
1896                 SHIFT32(utf8, s, strend, &ai32, datumtype);
1897                 DO_BO_UNPACK(ai32, 32);
1898 #if U32SIZE > SIZE32
1899                 if (ai32 > 2147483647) ai32 -= 4294967296;
1900 #endif
1901                 if (!checksum)
1902                     mPUSHi(ai32);
1903                 else if (checksum > bits_in_uv)
1904                     cdouble += (NV)ai32;
1905                 else
1906                     cuv += ai32;
1907             }
1908             break;
1909         case 'L' | TYPE_IS_SHRIEKING:
1910 #if LONGSIZE != SIZE32
1911             while (len-- > 0) {
1912                 unsigned long aulong;
1913                 SHIFT_VAR(utf8, s, strend, aulong, datumtype);
1914                 DO_BO_UNPACK(aulong, l);
1915                 if (!checksum)
1916                     mPUSHu(aulong);
1917                 else if (checksum > bits_in_uv)
1918                     cdouble += (NV)aulong;
1919                 else
1920                     cuv += aulong;
1921             }
1922             break;
1923 #else
1924             /* Fall through! */
1925 #endif
1926         case 'V':
1927         case 'N':
1928         case 'L':
1929             while (len-- > 0) {
1930                 U32 au32;
1931 #if U32SIZE > SIZE32
1932                 au32 = 0;
1933 #endif
1934                 SHIFT32(utf8, s, strend, &au32, datumtype);
1935                 DO_BO_UNPACK(au32, 32);
1936 #ifdef HAS_NTOHL
1937                 if (datumtype == 'N')
1938                     au32 = PerlSock_ntohl(au32);
1939 #endif
1940 #ifdef HAS_VTOHL
1941                 if (datumtype == 'V')
1942                     au32 = vtohl(au32);
1943 #endif
1944                 if (!checksum)
1945                     mPUSHu(au32);
1946                 else if (checksum > bits_in_uv)
1947                     cdouble += (NV)au32;
1948                 else
1949                     cuv += au32;
1950             }
1951             break;
1952 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1953         case 'V' | TYPE_IS_SHRIEKING:
1954         case 'N' | TYPE_IS_SHRIEKING:
1955             while (len-- > 0) {
1956                 I32 ai32;
1957 # if U32SIZE > SIZE32
1958                 ai32 = 0;
1959 # endif
1960                 SHIFT32(utf8, s, strend, &ai32, datumtype);
1961 # ifdef HAS_NTOHL
1962                 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1963                     ai32 = (I32)PerlSock_ntohl((U32)ai32);
1964 # endif
1965 # ifdef HAS_VTOHL
1966                 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1967                     ai32 = (I32)vtohl((U32)ai32);
1968 # endif
1969                 if (!checksum)
1970                     mPUSHi(ai32);
1971                 else if (checksum > bits_in_uv)
1972                     cdouble += (NV)ai32;
1973                 else
1974                     cuv += ai32;
1975             }
1976             break;
1977 #endif /* PERL_PACK_CAN_SHRIEKSIGN */
1978         case 'p':
1979             while (len-- > 0) {
1980                 const char *aptr;
1981                 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
1982                 DO_BO_UNPACK_PC(aptr);
1983                 /* newSVpv generates undef if aptr is NULL */
1984                 mPUSHs(newSVpv(aptr, 0));
1985             }
1986             break;
1987         case 'w':
1988             {
1989                 UV auv = 0;
1990                 U32 bytes = 0;
1991
1992                 while (len > 0 && s < strend) {
1993                     U8 ch;
1994                     ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1995                     auv = (auv << 7) | (ch & 0x7f);
1996                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1997                     if (ch < 0x80) {
1998                         bytes = 0;
1999                         mPUSHu(auv);
2000                         len--;
2001                         auv = 0;
2002                         continue;
2003                     }
2004                     if (++bytes >= sizeof(UV)) {        /* promote to string */
2005                         const char *t;
2006
2007                         sv = Perl_newSVpvf(aTHX_ "%.*"UVuf, (int)TYPE_DIGITS(UV), auv);
2008                         while (s < strend) {
2009                             ch = SHIFT_BYTE(utf8, s, strend, datumtype);
2010                             sv = mul128(sv, (U8)(ch & 0x7f));
2011                             if (!(ch & 0x80)) {
2012                                 bytes = 0;
2013                                 break;
2014                             }
2015                         }
2016                         t = SvPV_nolen_const(sv);
2017                         while (*t == '0')
2018                             t++;
2019                         sv_chop(sv, t);
2020                         mPUSHs(sv);
2021                         len--;
2022                         auv = 0;
2023                     }
2024                 }
2025                 if ((s >= strend) && bytes)
2026                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
2027             }
2028             break;
2029         case 'P':
2030             if (symptr->howlen == e_star)
2031                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
2032             EXTEND(SP, 1);
2033             if (s + sizeof(char*) <= strend) {
2034                 char *aptr;
2035                 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
2036                 DO_BO_UNPACK_PC(aptr);
2037                 /* newSVpvn generates undef if aptr is NULL */
2038                 PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP));
2039             }
2040             break;
2041 #ifdef HAS_QUAD
2042         case 'q':
2043             while (len-- > 0) {
2044                 Quad_t aquad;
2045                 SHIFT_VAR(utf8, s, strend, aquad, datumtype);
2046                 DO_BO_UNPACK(aquad, 64);
2047                 if (!checksum)
2048                     mPUSHs(aquad >= IV_MIN && aquad <= IV_MAX ?
2049                            newSViv((IV)aquad) : newSVnv((NV)aquad));
2050                 else if (checksum > bits_in_uv)
2051                     cdouble += (NV)aquad;
2052                 else
2053                     cuv += aquad;
2054             }
2055             break;
2056         case 'Q':
2057             while (len-- > 0) {
2058                 Uquad_t auquad;
2059                 SHIFT_VAR(utf8, s, strend, auquad, datumtype);
2060                 DO_BO_UNPACK(auquad, 64);
2061                 if (!checksum)
2062                     mPUSHs(auquad <= UV_MAX ?
2063                            newSVuv((UV)auquad) : newSVnv((NV)auquad));
2064                 else if (checksum > bits_in_uv)
2065                     cdouble += (NV)auquad;
2066                 else
2067                     cuv += auquad;
2068             }
2069             break;
2070 #endif /* HAS_QUAD */
2071         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
2072         case 'f':
2073             while (len-- > 0) {
2074                 float afloat;
2075                 SHIFT_VAR(utf8, s, strend, afloat, datumtype);
2076                 DO_BO_UNPACK_N(afloat, float);
2077                 if (!checksum)
2078                     mPUSHn(afloat);
2079                 else
2080                     cdouble += afloat;
2081             }
2082             break;
2083         case 'd':
2084             while (len-- > 0) {
2085                 double adouble;
2086                 SHIFT_VAR(utf8, s, strend, adouble, datumtype);
2087                 DO_BO_UNPACK_N(adouble, double);
2088                 if (!checksum)
2089                     mPUSHn(adouble);
2090                 else
2091                     cdouble += adouble;
2092             }
2093             break;
2094         case 'F':
2095             while (len-- > 0) {
2096                 NV anv;
2097                 SHIFT_VAR(utf8, s, strend, anv, datumtype);
2098                 DO_BO_UNPACK_N(anv, NV);
2099                 if (!checksum)
2100                     mPUSHn(anv);
2101                 else
2102                     cdouble += anv;
2103             }
2104             break;
2105 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2106         case 'D':
2107             while (len-- > 0) {
2108                 long double aldouble;
2109                 SHIFT_VAR(utf8, s, strend, aldouble, datumtype);
2110                 DO_BO_UNPACK_N(aldouble, long double);
2111                 if (!checksum)
2112                     mPUSHn(aldouble);
2113                 else
2114                     cdouble += aldouble;
2115             }
2116             break;
2117 #endif
2118         case 'u':
2119             {
2120                 const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
2121                 sv = sv_2mortal(newSV(l));
2122                 if (l) SvPOK_on(sv);
2123             }
2124             if (utf8) {
2125                 while (next_uni_uu(aTHX_ &s, strend, &len)) {
2126                     I32 a, b, c, d;
2127                     char hunk[3];
2128
2129                     while (len > 0) {
2130                         next_uni_uu(aTHX_ &s, strend, &a);
2131                         next_uni_uu(aTHX_ &s, strend, &b);
2132                         next_uni_uu(aTHX_ &s, strend, &c);
2133                         next_uni_uu(aTHX_ &s, strend, &d);
2134                         hunk[0] = (char)((a << 2) | (b >> 4));
2135                         hunk[1] = (char)((b << 4) | (c >> 2));
2136                         hunk[2] = (char)((c << 6) | d);
2137                         sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
2138                         len -= 3;
2139                     }
2140                     if (s < strend) {
2141                         if (*s == '\n') {
2142                             s++;
2143                         }
2144                         else {
2145                             /* possible checksum byte */
2146                             const char *skip = s+UTF8SKIP(s);
2147                             if (skip < strend && *skip == '\n')
2148                                 s = skip+1;
2149                         }
2150                     }
2151                 }
2152             } else {
2153                 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
2154                     I32 a, b, c, d;
2155                     char hunk[3];
2156
2157                     len = PL_uudmap[*(U8*)s++] & 077;
2158                     while (len > 0) {
2159                         if (s < strend && ISUUCHAR(*s))
2160                             a = PL_uudmap[*(U8*)s++] & 077;
2161                         else
2162                             a = 0;
2163                         if (s < strend && ISUUCHAR(*s))
2164                             b = PL_uudmap[*(U8*)s++] & 077;
2165                         else
2166                             b = 0;
2167                         if (s < strend && ISUUCHAR(*s))
2168                             c = PL_uudmap[*(U8*)s++] & 077;
2169                         else
2170                             c = 0;
2171                         if (s < strend && ISUUCHAR(*s))
2172                             d = PL_uudmap[*(U8*)s++] & 077;
2173                         else
2174                             d = 0;
2175                         hunk[0] = (char)((a << 2) | (b >> 4));
2176                         hunk[1] = (char)((b << 4) | (c >> 2));
2177                         hunk[2] = (char)((c << 6) | d);
2178                         sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
2179                         len -= 3;
2180                     }
2181                     if (*s == '\n')
2182                         s++;
2183                     else        /* possible checksum byte */
2184                         if (s + 1 < strend && s[1] == '\n')
2185                             s += 2;
2186                 }
2187             }
2188             XPUSHs(sv);
2189             break;
2190         }
2191
2192         if (checksum) {
2193             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
2194               (checksum > bits_in_uv &&
2195                strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
2196                 NV trouble, anv;
2197
2198                 anv = (NV) (1 << (checksum & 15));
2199                 while (checksum >= 16) {
2200                     checksum -= 16;
2201                     anv *= 65536.0;
2202                 }
2203                 while (cdouble < 0.0)
2204                     cdouble += anv;
2205                 cdouble = Perl_modf(cdouble / anv, &trouble) * anv;
2206                 sv = newSVnv(cdouble);
2207             }
2208             else {
2209                 if (checksum < bits_in_uv) {
2210                     UV mask = ((UV)1 << checksum) - 1;
2211                     cuv &= mask;
2212                 }
2213                 sv = newSVuv(cuv);
2214             }
2215             mXPUSHs(sv);
2216             checksum = 0;
2217         }
2218
2219         if (symptr->flags & FLAG_SLASH){
2220             if (SP - PL_stack_base - start_sp_offset <= 0)
2221                 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
2222             if( next_symbol(symptr) ){
2223               if( symptr->howlen == e_number )
2224                 Perl_croak(aTHX_ "Count after length/code in unpack" );
2225               if( beyond ){
2226                 /* ...end of char buffer then no decent length available */
2227                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
2228               } else {
2229                 /* take top of stack (hope it's numeric) */
2230                 len = POPi;
2231                 if( len < 0 )
2232                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
2233               }
2234             } else {
2235                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
2236             }
2237             datumtype = symptr->code;
2238             explicit_length = FALSE;
2239             goto redo_switch;
2240         }
2241     }
2242
2243     if (new_s)
2244         *new_s = s;
2245     PUTBACK;
2246     return SP - PL_stack_base - start_sp_offset;
2247 }
2248
2249 PP(pp_unpack)
2250 {
2251     dVAR;
2252     dSP;
2253     dPOPPOPssrl;
2254     I32 gimme = GIMME_V;
2255     STRLEN llen;
2256     STRLEN rlen;
2257     const char *pat = SvPV_const(left,  llen);
2258     const char *s   = SvPV_const(right, rlen);
2259     const char *strend = s + rlen;
2260     const char *patend = pat + llen;
2261     I32 cnt;
2262
2263     PUTBACK;
2264     cnt = unpackstring(pat, patend, s, strend,
2265                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
2266                      | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0));
2267
2268     SPAGAIN;
2269     if ( !cnt && gimme == G_SCALAR )
2270        PUSHs(&PL_sv_undef);
2271     RETURN;
2272 }
2273
2274 STATIC U8 *
2275 doencodes(U8 *h, const char *s, I32 len)
2276 {
2277     *h++ = PL_uuemap[len];
2278     while (len > 2) {
2279         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
2280         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))];
2281         *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
2282         *h++ = PL_uuemap[(077 & (s[2] & 077))];
2283         s += 3;
2284         len -= 3;
2285     }
2286     if (len > 0) {
2287         const char r = (len > 1 ? s[1] : '\0');
2288         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
2289         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))];
2290         *h++ = PL_uuemap[(077 & ((r << 2) & 074))];
2291         *h++ = PL_uuemap[0];
2292     }
2293     *h++ = '\n';
2294     return h;
2295 }
2296
2297 STATIC SV *
2298 S_is_an_int(pTHX_ const char *s, STRLEN l)
2299 {
2300   SV *result = newSVpvn(s, l);
2301   char *const result_c = SvPV_nolen(result);    /* convenience */
2302   char *out = result_c;
2303   bool skip = 1;
2304   bool ignore = 0;
2305
2306   PERL_ARGS_ASSERT_IS_AN_INT;
2307
2308   while (*s) {
2309     switch (*s) {
2310     case ' ':
2311       break;
2312     case '+':
2313       if (!skip) {
2314         SvREFCNT_dec(result);
2315         return (NULL);
2316       }
2317       break;
2318     case '0':
2319     case '1':
2320     case '2':
2321     case '3':
2322     case '4':
2323     case '5':
2324     case '6':
2325     case '7':
2326     case '8':
2327     case '9':
2328       skip = 0;
2329       if (!ignore) {
2330         *(out++) = *s;
2331       }
2332       break;
2333     case '.':
2334       ignore = 1;
2335       break;
2336     default:
2337       SvREFCNT_dec(result);
2338       return (NULL);
2339     }
2340     s++;
2341   }
2342   *(out++) = '\0';
2343   SvCUR_set(result, out - result_c);
2344   return (result);
2345 }
2346
2347 /* pnum must be '\0' terminated */
2348 STATIC int
2349 S_div128(pTHX_ SV *pnum, bool *done)
2350 {
2351     STRLEN len;
2352     char * const s = SvPV(pnum, len);
2353     char *t = s;
2354     int m = 0;
2355
2356     PERL_ARGS_ASSERT_DIV128;
2357
2358     *done = 1;
2359     while (*t) {
2360         const int i = m * 10 + (*t - '0');
2361         const int r = (i >> 7); /* r < 10 */
2362         m = i & 0x7F;
2363         if (r) {
2364             *done = 0;
2365         }
2366         *(t++) = '0' + r;
2367     }
2368     *(t++) = '\0';
2369     SvCUR_set(pnum, (STRLEN) (t - s));
2370     return (m);
2371 }
2372
2373 /*
2374 =for apidoc packlist
2375
2376 The engine implementing pack() Perl function.
2377
2378 =cut
2379 */
2380
2381 void
2382 Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist )
2383 {
2384     dVAR;
2385     tempsym_t sym;
2386
2387     PERL_ARGS_ASSERT_PACKLIST;
2388
2389     TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
2390
2391     /* We're going to do changes through SvPVX(cat). Make sure it's valid.
2392        Also make sure any UTF8 flag is loaded */
2393     SvPV_force_nolen(cat);
2394     if (DO_UTF8(cat))
2395         sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8;
2396
2397     (void)pack_rec( cat, &sym, beglist, endlist );
2398 }
2399
2400 /* like sv_utf8_upgrade, but also repoint the group start markers */
2401 STATIC void
2402 marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) {
2403     STRLEN len;
2404     tempsym_t *group;
2405     const char *from_ptr, *from_start, *from_end, **marks, **m;
2406     char *to_start, *to_ptr;
2407
2408     if (SvUTF8(sv)) return;
2409
2410     from_start = SvPVX_const(sv);
2411     from_end = from_start + SvCUR(sv);
2412     for (from_ptr = from_start; from_ptr < from_end; from_ptr++)
2413         if (!NATIVE_IS_INVARIANT(*from_ptr)) break;
2414     if (from_ptr == from_end) {
2415         /* Simple case: no character needs to be changed */
2416         SvUTF8_on(sv);
2417         return;
2418     }
2419
2420     len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1;
2421     Newx(to_start, len, char);
2422     Copy(from_start, to_start, from_ptr-from_start, char);
2423     to_ptr = to_start + (from_ptr-from_start);
2424
2425     Newx(marks, sym_ptr->level+2, const char *);
2426     for (group=sym_ptr; group; group = group->previous)
2427         marks[group->level] = from_start + group->strbeg;
2428     marks[sym_ptr->level+1] = from_end+1;
2429     for (m = marks; *m < from_ptr; m++)
2430         *m = to_start + (*m-from_start);
2431
2432     for (;from_ptr < from_end; from_ptr++) {
2433         while (*m == from_ptr) *m++ = to_ptr;
2434         to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr);
2435     }
2436     *to_ptr = 0;
2437
2438     while (*m == from_ptr) *m++ = to_ptr;
2439     if (m != marks + sym_ptr->level+1) {
2440         Safefree(marks);
2441         Safefree(to_start);
2442         Perl_croak(aTHX_ "Assertion: marks beyond string end");
2443     }
2444     for (group=sym_ptr; group; group = group->previous)
2445         group->strbeg = marks[group->level] - to_start;
2446     Safefree(marks);
2447
2448     if (SvOOK(sv)) {
2449         if (SvIVX(sv)) {
2450             SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2451             from_start -= SvIVX(sv);
2452             SvIV_set(sv, 0);
2453         }
2454         SvFLAGS(sv) &= ~SVf_OOK;
2455     }
2456     if (SvLEN(sv) != 0)
2457         Safefree(from_start);
2458     SvPV_set(sv, to_start);
2459     SvCUR_set(sv, to_ptr - to_start);
2460     SvLEN_set(sv, len);
2461     SvUTF8_on(sv);
2462 }
2463
2464 /* Exponential string grower. Makes string extension effectively O(n)
2465    needed says how many extra bytes we need (not counting the final '\0')
2466    Only grows the string if there is an actual lack of space
2467 */
2468 STATIC char *
2469 S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) {
2470     const STRLEN cur = SvCUR(sv);
2471     const STRLEN len = SvLEN(sv);
2472     STRLEN extend;
2473
2474     PERL_ARGS_ASSERT_SV_EXP_GROW;
2475
2476     if (len - cur > needed) return SvPVX(sv);
2477     extend = needed > len ? needed : len;
2478     return SvGROW(sv, len+extend+1);
2479 }
2480
2481 STATIC
2482 SV **
2483 S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
2484 {
2485     dVAR;
2486     tempsym_t lookahead;
2487     I32 items  = endlist - beglist;
2488     bool found = next_symbol(symptr);
2489     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
2490     bool warn_utf8 = ckWARN(WARN_UTF8);
2491
2492     PERL_ARGS_ASSERT_PACK_REC;
2493
2494     if (symptr->level == 0 && found && symptr->code == 'U') {
2495         marked_upgrade(aTHX_ cat, symptr);
2496         symptr->flags |= FLAG_DO_UTF8;
2497         utf8 = 0;
2498     }
2499     symptr->strbeg = SvCUR(cat);
2500
2501     while (found) {
2502         SV *fromstr;
2503         STRLEN fromlen;
2504         I32 len;
2505         SV *lengthcode = NULL;
2506         I32 datumtype = symptr->code;
2507         howlen_t howlen = symptr->howlen;
2508         char *start = SvPVX(cat);
2509         char *cur   = start + SvCUR(cat);
2510
2511 #define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2512
2513         switch (howlen) {
2514           case e_star:
2515             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ?
2516                 0 : items;
2517             break;
2518           default:
2519             /* e_no_len and e_number */
2520             len = symptr->length;
2521             break;
2522         }
2523
2524         if (len) {
2525             packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
2526
2527             if (props && !(props & PACK_SIZE_UNPREDICTABLE)) {
2528                 /* We can process this letter. */
2529                 STRLEN size = props & PACK_SIZE_MASK;
2530                 GROWING(utf8, cat, start, cur, (STRLEN) len * size);
2531             }
2532         }
2533
2534         /* Look ahead for next symbol. Do we have code/code? */
2535         lookahead = *symptr;
2536         found = next_symbol(&lookahead);
2537         if (symptr->flags & FLAG_SLASH) {
2538             IV count;
2539             if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack");
2540             if (strchr("aAZ", lookahead.code)) {
2541                 if (lookahead.howlen == e_number) count = lookahead.length;
2542                 else {
2543                     if (items > 0) {
2544                         if (SvGAMAGIC(*beglist)) {
2545                             /* Avoid reading the active data more than once
2546                                by copying it to a temporary.  */
2547                             STRLEN len;
2548                             const char *const pv = SvPV_const(*beglist, len);
2549                             SV *const temp
2550                                 = newSVpvn_flags(pv, len,
2551                                                  SVs_TEMP | SvUTF8(*beglist));
2552                             *beglist = temp;
2553                         }
2554                         count = DO_UTF8(*beglist) ?
2555                             sv_len_utf8(*beglist) : sv_len(*beglist);
2556                     }
2557                     else count = 0;
2558                     if (lookahead.code == 'Z') count++;
2559                 }
2560             } else {
2561                 if (lookahead.howlen == e_number && lookahead.length < items)
2562                     count = lookahead.length;
2563                 else count = items;
2564             }
2565             lookahead.howlen = e_number;
2566             lookahead.length = count;
2567             lengthcode = sv_2mortal(newSViv(count));
2568         }
2569
2570         /* Code inside the switch must take care to properly update
2571            cat (CUR length and '\0' termination) if it updated *cur and
2572            doesn't simply leave using break */
2573         switch(TYPE_NO_ENDIANNESS(datumtype)) {
2574         default:
2575             Perl_croak(aTHX_ "Invalid type '%c' in pack",
2576                        (int) TYPE_NO_MODIFIERS(datumtype));
2577         case '%':
2578             Perl_croak(aTHX_ "'%%' may not be used in pack");
2579         {
2580             char *from;
2581 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2582         case '.' | TYPE_IS_SHRIEKING:
2583 #endif
2584         case '.':
2585             if (howlen == e_star) from = start;
2586             else if (len == 0) from = cur;
2587             else {
2588                 tempsym_t *group = symptr;
2589
2590                 while (--len && group) group = group->previous;
2591                 from = group ? start + group->strbeg : start;
2592             }
2593             fromstr = NEXTFROM;
2594             len = SvIV(fromstr);
2595             goto resize;
2596 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2597         case '@' | TYPE_IS_SHRIEKING:
2598 #endif
2599         case '@':
2600             from = start + symptr->strbeg;
2601           resize:
2602 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2603             if (utf8  && !(datumtype & TYPE_IS_SHRIEKING))
2604 #else /* PERL_PACK_CAN_SHRIEKSIGN */
2605             if (utf8)
2606 #endif
2607                 if (len >= 0) {
2608                     while (len && from < cur) {
2609                         from += UTF8SKIP(from);
2610                         len--;
2611                     }
2612                     if (from > cur)
2613                         Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2614                     if (len) {
2615                         /* Here we know from == cur */
2616                       grow:
2617                         GROWING(0, cat, start, cur, len);
2618                         Zero(cur, len, char);
2619                         cur += len;
2620                     } else if (from < cur) {
2621                         len = cur - from;
2622                         goto shrink;
2623                     } else goto no_change;
2624                 } else {
2625                     cur = from;
2626                     len = -len;
2627                     goto utf8_shrink;
2628                 }
2629             else {
2630                 len -= cur - from;
2631                 if (len > 0) goto grow;
2632                 if (len == 0) goto no_change;
2633                 len = -len;
2634                 goto shrink;
2635             }
2636             break;
2637         }
2638         case '(': {
2639             tempsym_t savsym = *symptr;
2640             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2641             symptr->flags |= group_modifiers;
2642             symptr->patend = savsym.grpend;
2643             symptr->level++;
2644             symptr->previous = &lookahead;
2645             while (len--) {
2646                 U32 was_utf8;
2647                 if (utf8) symptr->flags |=  FLAG_PARSE_UTF8;
2648                 else      symptr->flags &= ~FLAG_PARSE_UTF8;
2649                 was_utf8 = SvUTF8(cat);
2650                 symptr->patptr = savsym.grpbeg;
2651                 beglist = pack_rec(cat, symptr, beglist, endlist);
2652                 if (SvUTF8(cat) != was_utf8)
2653                     /* This had better be an upgrade while in utf8==0 mode */
2654                     utf8 = 1;
2655
2656                 if (savsym.howlen == e_star && beglist == endlist)
2657                     break;              /* No way to continue */
2658             }
2659             items = endlist - beglist;
2660             lookahead.flags  = symptr->flags & ~group_modifiers;
2661             goto no_change;
2662         }
2663         case 'X' | TYPE_IS_SHRIEKING:
2664             if (!len)                   /* Avoid division by 0 */
2665                 len = 1;
2666             if (utf8) {
2667                 char *hop, *last;
2668                 I32 l = len;
2669                 hop = last = start;
2670                 while (hop < cur) {
2671                     hop += UTF8SKIP(hop);
2672                     if (--l == 0) {
2673                         last = hop;
2674                         l = len;
2675                     }
2676                 }
2677                 if (last > cur)
2678                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2679                 cur = last;
2680                 break;
2681             }
2682             len = (cur-start) % len;
2683             /* FALL THROUGH */
2684         case 'X':
2685             if (utf8) {
2686                 if (len < 1) goto no_change;
2687               utf8_shrink:
2688                 while (len > 0) {
2689                     if (cur <= start)
2690                         Perl_croak(aTHX_ "'%c' outside of string in pack",
2691                                    (int) TYPE_NO_MODIFIERS(datumtype));
2692                     while (--cur, UTF8_IS_CONTINUATION(*cur)) {
2693                         if (cur <= start)
2694                             Perl_croak(aTHX_ "'%c' outside of string in pack",
2695                                        (int) TYPE_NO_MODIFIERS(datumtype));
2696                     }
2697                     len--;
2698                 }
2699             } else {
2700               shrink:
2701                 if (cur - start < len)
2702                     Perl_croak(aTHX_ "'%c' outside of string in pack",
2703                                (int) TYPE_NO_MODIFIERS(datumtype));
2704                 cur -= len;
2705             }
2706             if (cur < start+symptr->strbeg) {
2707                 /* Make sure group starts don't point into the void */
2708                 tempsym_t *group;
2709                 const STRLEN length = cur-start;
2710                 for (group = symptr;
2711                      group && length < group->strbeg;
2712                      group = group->previous) group->strbeg = length;
2713                 lookahead.strbeg = length;
2714             }
2715             break;
2716         case 'x' | TYPE_IS_SHRIEKING: {
2717             I32 ai32;
2718             if (!len)                   /* Avoid division by 0 */
2719                 len = 1;
2720             if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len;
2721             else      ai32 = (cur - start) % len;
2722             if (ai32 == 0) goto no_change;
2723             len -= ai32;
2724         }
2725         /* FALL THROUGH */
2726         case 'x':
2727             goto grow;
2728         case 'A':
2729         case 'Z':
2730         case 'a': {
2731             const char *aptr;
2732
2733             fromstr = NEXTFROM;
2734             aptr = SvPV_const(fromstr, fromlen);
2735             if (DO_UTF8(fromstr)) {
2736                 const char *end, *s;
2737
2738                 if (!utf8 && !SvUTF8(cat)) {
2739                     marked_upgrade(aTHX_ cat, symptr);
2740                     lookahead.flags |= FLAG_DO_UTF8;
2741                     lookahead.strbeg = symptr->strbeg;
2742                     utf8 = 1;
2743                     start = SvPVX(cat);
2744                     cur = start + SvCUR(cat);
2745                 }
2746                 if (howlen == e_star) {
2747                     if (utf8) goto string_copy;
2748                     len = fromlen+1;
2749                 }
2750                 s = aptr;
2751                 end = aptr + fromlen;
2752                 fromlen = datumtype == 'Z' ? len-1 : len;
2753                 while ((I32) fromlen > 0 && s < end) {
2754                     s += UTF8SKIP(s);
2755                     fromlen--;
2756                 }
2757                 if (s > end)
2758                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2759                 if (utf8) {
2760                     len = fromlen;
2761                     if (datumtype == 'Z') len++;
2762                     fromlen = s-aptr;
2763                     len += fromlen;
2764
2765                     goto string_copy;
2766                 }
2767                 fromlen = len - fromlen;
2768                 if (datumtype == 'Z') fromlen--;
2769                 if (howlen == e_star) {
2770                     len = fromlen;
2771                     if (datumtype == 'Z') len++;
2772                 }
2773                 GROWING(0, cat, start, cur, len);
2774                 if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
2775                                   datumtype | TYPE_IS_PACK))
2776                     Perl_croak(aTHX_ "Perl bug: predicted utf8 length not available");
2777                 cur += fromlen;
2778                 len -= fromlen;
2779             } else if (utf8) {
2780                 if (howlen == e_star) {
2781                     len = fromlen;
2782                     if (datumtype == 'Z') len++;
2783                 }
2784                 if (len <= (I32) fromlen) {
2785                     fromlen = len;
2786                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2787                 }
2788                 /* assumes a byte expands to at most UTF8_EXPAND bytes on
2789                    upgrade, so:
2790                    expected_length <= from_len*UTF8_EXPAND + (len-from_len) */
2791                 GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len);
2792                 len -= fromlen;
2793                 while (fromlen > 0) {
2794                     cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr);
2795                     aptr++;
2796                     fromlen--;
2797                 }
2798             } else {
2799               string_copy:
2800                 if (howlen == e_star) {
2801                     len = fromlen;
2802                     if (datumtype == 'Z') len++;
2803                 }
2804                 if (len <= (I32) fromlen) {
2805                     fromlen = len;
2806                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2807                 }
2808                 GROWING(0, cat, start, cur, len);
2809                 Copy(aptr, cur, fromlen, char);
2810                 cur += fromlen;
2811                 len -= fromlen;
2812             }
2813             memset(cur, datumtype == 'A' ? ' ' : '\0', len);
2814             cur += len;
2815             break;
2816         }
2817         case 'B':
2818         case 'b': {
2819             const char *str, *end;
2820             I32 l, field_len;
2821             U8 bits;
2822             bool utf8_source;
2823             U32 utf8_flags;
2824
2825             fromstr = NEXTFROM;
2826             str = SvPV_const(fromstr, fromlen);
2827             end = str + fromlen;
2828             if (DO_UTF8(fromstr)) {
2829                 utf8_source = TRUE;
2830                 utf8_flags  = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2831             } else {
2832                 utf8_source = FALSE;
2833                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2834             }
2835             if (howlen == e_star) len = fromlen;
2836             field_len = (len+7)/8;
2837             GROWING(utf8, cat, start, cur, field_len);
2838             if (len > (I32)fromlen) len = fromlen;
2839             bits = 0;
2840             l = 0;
2841             if (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                         bits |= val & 1;
2847                     } else bits |= *str++ & 1;
2848                     if (l & 7) bits <<= 1;
2849                     else {
2850                         PUSH_BYTE(utf8, cur, bits);
2851                         bits = 0;
2852                     }
2853                 }
2854             else
2855                 /* datumtype == 'b' */
2856                 while (l++ < len) {
2857                     if (utf8_source) {
2858                         UV val = 0;
2859                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2860                         if (val & 1) bits |= 0x80;
2861                     } else if (*str++ & 1)
2862                         bits |= 0x80;
2863                     if (l & 7) bits >>= 1;
2864                     else {
2865                         PUSH_BYTE(utf8, cur, bits);
2866                         bits = 0;
2867                     }
2868                 }
2869             l--;
2870             if (l & 7) {
2871                 if (datumtype == 'B')
2872                     bits <<= 7 - (l & 7);
2873                 else
2874                     bits >>= 7 - (l & 7);
2875                 PUSH_BYTE(utf8, cur, bits);
2876                 l += 7;
2877             }
2878             /* Determine how many chars are left in the requested field */
2879             l /= 8;
2880             if (howlen == e_star) field_len = 0;
2881             else field_len -= l;
2882             Zero(cur, field_len, char);
2883             cur += field_len;
2884             break;
2885         }
2886         case 'H':
2887         case 'h': {
2888             const char *str, *end;
2889             I32 l, field_len;
2890             U8 bits;
2891             bool utf8_source;
2892             U32 utf8_flags;
2893
2894             fromstr = NEXTFROM;
2895             str = SvPV_const(fromstr, fromlen);
2896             end = str + fromlen;
2897             if (DO_UTF8(fromstr)) {
2898                 utf8_source = TRUE;
2899                 utf8_flags  = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2900             } else {
2901                 utf8_source = FALSE;
2902                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2903             }
2904             if (howlen == e_star) len = fromlen;
2905             field_len = (len+1)/2;
2906             GROWING(utf8, cat, start, cur, field_len);
2907             if (!utf8 && len > (I32)fromlen) len = fromlen;
2908             bits = 0;
2909             l = 0;
2910             if (datumtype == 'H')
2911                 while (l++ < len) {
2912                     if (utf8_source) {
2913                         UV val = 0;
2914                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2915                         if (val < 256 && isALPHA(val))
2916                             bits |= (val + 9) & 0xf;
2917                         else
2918                             bits |= val & 0xf;
2919                     } else if (isALPHA(*str))
2920                         bits |= (*str++ + 9) & 0xf;
2921                     else
2922                         bits |= *str++ & 0xf;
2923                     if (l & 1) bits <<= 4;
2924                     else {
2925                         PUSH_BYTE(utf8, cur, bits);
2926                         bits = 0;
2927                     }
2928                 }
2929             else
2930                 while (l++ < len) {
2931                     if (utf8_source) {
2932                         UV val = 0;
2933                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2934                         if (val < 256 && isALPHA(val))
2935                             bits |= ((val + 9) & 0xf) << 4;
2936                         else
2937                             bits |= (val & 0xf) << 4;
2938                     } else if (isALPHA(*str))
2939                         bits |= ((*str++ + 9) & 0xf) << 4;
2940                     else
2941                         bits |= (*str++ & 0xf) << 4;
2942                     if (l & 1) bits >>= 4;
2943                     else {
2944                         PUSH_BYTE(utf8, cur, bits);
2945                         bits = 0;
2946                     }
2947                 }
2948             l--;
2949             if (l & 1) {
2950                 PUSH_BYTE(utf8, cur, bits);
2951                 l++;
2952             }
2953             /* Determine how many chars are left in the requested field */
2954             l /= 2;
2955             if (howlen == e_star) field_len = 0;
2956             else field_len -= l;
2957             Zero(cur, field_len, char);
2958             cur += field_len;
2959             break;
2960         }
2961         case 'c':
2962             while (len-- > 0) {
2963                 IV aiv;
2964                 fromstr = NEXTFROM;
2965                 aiv = SvIV(fromstr);
2966                 if ((-128 > aiv || aiv > 127) &&
2967                     ckWARN(WARN_PACK))
2968                     Perl_warner(aTHX_ packWARN(WARN_PACK),
2969                                 "Character in 'c' format wrapped in pack");
2970                 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2971             }
2972             break;
2973         case 'C':
2974             if (len == 0) {
2975                 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
2976                 break;
2977             }
2978             while (len-- > 0) {
2979                 IV aiv;
2980                 fromstr = NEXTFROM;
2981                 aiv = SvIV(fromstr);
2982                 if ((0 > aiv || aiv > 0xff) &&
2983                     ckWARN(WARN_PACK))
2984                     Perl_warner(aTHX_ packWARN(WARN_PACK),
2985                                 "Character in 'C' format wrapped in pack");
2986                 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2987             }
2988             break;
2989         case 'W': {
2990             char *end;
2991             U8 in_bytes = (U8)IN_BYTES;
2992
2993             end = start+SvLEN(cat)-1;
2994             if (utf8) end -= UTF8_MAXLEN-1;
2995             while (len-- > 0) {
2996                 UV auv;
2997                 fromstr = NEXTFROM;
2998                 auv = SvUV(fromstr);
2999                 if (in_bytes) auv = auv % 0x100;
3000                 if (utf8) {
3001                   W_utf8:
3002                     if (cur > end) {
3003                         *cur = '\0';
3004                         SvCUR_set(cat, cur - start);
3005
3006                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
3007                         end = start+SvLEN(cat)-UTF8_MAXLEN;
3008                     }
3009                     cur = (char *) uvuni_to_utf8_flags((U8 *) cur,
3010                                                        NATIVE_TO_UNI(auv),
3011                                                        warn_utf8 ?
3012                                                        0 : UNICODE_ALLOW_ANY);
3013                 } else {
3014                     if (auv >= 0x100) {
3015                         if (!SvUTF8(cat)) {
3016                             *cur = '\0';
3017                             SvCUR_set(cat, cur - start);
3018                             marked_upgrade(aTHX_ cat, symptr);
3019                             lookahead.flags |= FLAG_DO_UTF8;
3020                             lookahead.strbeg = symptr->strbeg;
3021                             utf8 = 1;
3022                             start = SvPVX(cat);
3023                             cur = start + SvCUR(cat);
3024                             end = start+SvLEN(cat)-UTF8_MAXLEN;
3025                             goto W_utf8;
3026                         }
3027                         if (ckWARN(WARN_PACK))
3028                             Perl_warner(aTHX_ packWARN(WARN_PACK),
3029                                         "Character in 'W' format wrapped in pack");
3030                         auv &= 0xff;
3031                     }
3032                     if (cur >= end) {
3033                         *cur = '\0';
3034                         SvCUR_set(cat, cur - start);
3035                         GROWING(0, cat, start, cur, len+1);
3036                         end = start+SvLEN(cat)-1;
3037                     }
3038                     *(U8 *) cur++ = (U8)auv;
3039                 }
3040             }
3041             break;
3042         }
3043         case 'U': {
3044             char *end;
3045
3046             if (len == 0) {
3047                 if (!(symptr->flags & FLAG_DO_UTF8)) {
3048                     marked_upgrade(aTHX_ cat, symptr);
3049                     lookahead.flags |= FLAG_DO_UTF8;
3050                     lookahead.strbeg = symptr->strbeg;
3051                 }
3052                 utf8 = 0;
3053                 goto no_change;
3054             }
3055
3056             end = start+SvLEN(cat);
3057             if (!utf8) end -= UTF8_MAXLEN;
3058             while (len-- > 0) {
3059                 UV auv;
3060                 fromstr = NEXTFROM;
3061                 auv = SvUV(fromstr);
3062                 if (utf8) {
3063                     U8 buffer[UTF8_MAXLEN], *endb;
3064                     endb = uvuni_to_utf8_flags(buffer, auv,
3065                                                warn_utf8 ?
3066                                                0 : UNICODE_ALLOW_ANY);
3067                     if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
3068                         *cur = '\0';
3069                         SvCUR_set(cat, cur - start);
3070                         GROWING(0, cat, start, cur,
3071                                 len+(endb-buffer)*UTF8_EXPAND);
3072                         end = start+SvLEN(cat);
3073                     }
3074                     cur = bytes_to_uni(buffer, endb-buffer, cur);
3075                 } else {
3076                     if (cur >= end) {
3077                         *cur = '\0';
3078                         SvCUR_set(cat, cur - start);
3079                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
3080                         end = start+SvLEN(cat)-UTF8_MAXLEN;
3081                     }
3082                     cur = (char *) uvuni_to_utf8_flags((U8 *) cur, auv,
3083                                                        warn_utf8 ?
3084                                                        0 : UNICODE_ALLOW_ANY);
3085                 }
3086             }
3087             break;
3088         }
3089         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
3090         case 'f':
3091             while (len-- > 0) {
3092                 float afloat;
3093                 NV anv;
3094                 fromstr = NEXTFROM;
3095                 anv = SvNV(fromstr);
3096 #ifdef __VOS__
3097                 /* VOS does not automatically map a floating-point overflow
3098                    during conversion from double to float into infinity, so we
3099                    do it by hand.  This code should either be generalized for
3100                    any OS that needs it, or removed if and when VOS implements
3101                    posix-976 (suggestion to support mapping to infinity).
3102                    Paul.Green@stratus.com 02-04-02.  */
3103 {
3104 extern const float _float_constants[];
3105                 if (anv > FLT_MAX)
3106                     afloat = _float_constants[0];   /* single prec. inf. */
3107                 else if (anv < -FLT_MAX)
3108                     afloat = _float_constants[0];   /* single prec. inf. */
3109                 else afloat = (float) anv;
3110 }
3111 #else /* __VOS__ */
3112 # if defined(VMS) && !defined(__IEEE_FP)
3113                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
3114                  * on Alpha; fake it if we don't have them.
3115                  */
3116                 if (anv > FLT_MAX)
3117                     afloat = FLT_MAX;
3118                 else if (anv < -FLT_MAX)
3119                     afloat = -FLT_MAX;
3120                 else afloat = (float)anv;
3121 # else
3122                 afloat = (float)anv;
3123 # endif
3124 #endif /* __VOS__ */
3125                 DO_BO_PACK_N(afloat, float);
3126                 PUSH_VAR(utf8, cur, afloat);
3127             }
3128             break;
3129         case 'd':
3130             while (len-- > 0) {
3131                 double adouble;
3132                 NV anv;
3133                 fromstr = NEXTFROM;
3134                 anv = SvNV(fromstr);
3135 #ifdef __VOS__
3136                 /* VOS does not automatically map a floating-point overflow
3137                    during conversion from long double to double into infinity,
3138                    so we do it by hand.  This code should either be generalized
3139                    for any OS that needs it, or removed if and when VOS
3140                    implements posix-976 (suggestion to support mapping to
3141                    infinity).  Paul.Green@stratus.com 02-04-02.  */
3142 {
3143 extern const double _double_constants[];
3144                 if (anv > DBL_MAX)
3145                     adouble = _double_constants[0];   /* double prec. inf. */
3146                 else if (anv < -DBL_MAX)
3147                     adouble = _double_constants[0];   /* double prec. inf. */
3148                 else adouble = (double) anv;
3149 }
3150 #else /* __VOS__ */
3151 # if defined(VMS) && !defined(__IEEE_FP)
3152                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
3153                  * on Alpha; fake it if we don't have them.
3154                  */
3155                 if (anv > DBL_MAX)
3156                     adouble = DBL_MAX;
3157                 else if (anv < -DBL_MAX)
3158                     adouble = -DBL_MAX;
3159                 else adouble = (double)anv;
3160 # else
3161                 adouble = (double)anv;
3162 # endif
3163 #endif /* __VOS__ */
3164                 DO_BO_PACK_N(adouble, double);
3165                 PUSH_VAR(utf8, cur, adouble);
3166             }
3167             break;
3168         case 'F': {
3169             NV anv;
3170             Zero(&anv, 1, NV); /* can be long double with unused bits */
3171             while (len-- > 0) {
3172                 fromstr = NEXTFROM;
3173                 anv = SvNV(fromstr);
3174                 DO_BO_PACK_N(anv, NV);
3175                 PUSH_VAR(utf8, cur, anv);
3176             }
3177             break;
3178         }
3179 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
3180         case 'D': {
3181             long double aldouble;
3182             /* long doubles can have unused bits, which may be nonzero */
3183             Zero(&aldouble, 1, long double);
3184             while (len-- > 0) {
3185                 fromstr = NEXTFROM;
3186                 aldouble = (long double)SvNV(fromstr);
3187                 DO_BO_PACK_N(aldouble, long double);
3188                 PUSH_VAR(utf8, cur, aldouble);
3189             }
3190             break;
3191         }
3192 #endif
3193 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3194         case 'n' | TYPE_IS_SHRIEKING:
3195 #endif
3196         case 'n':
3197             while (len-- > 0) {
3198                 I16 ai16;
3199                 fromstr = NEXTFROM;
3200                 ai16 = (I16)SvIV(fromstr);
3201 #ifdef HAS_HTONS
3202                 ai16 = PerlSock_htons(ai16);
3203 #endif
3204                 PUSH16(utf8, cur, &ai16);
3205             }
3206             break;
3207 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3208         case 'v' | TYPE_IS_SHRIEKING:
3209 #endif
3210         case 'v':
3211             while (len-- > 0) {
3212                 I16 ai16;
3213                 fromstr = NEXTFROM;
3214                 ai16 = (I16)SvIV(fromstr);
3215 #ifdef HAS_HTOVS
3216                 ai16 = htovs(ai16);
3217 #endif
3218                 PUSH16(utf8, cur, &ai16);
3219             }
3220             break;
3221         case 'S' | TYPE_IS_SHRIEKING:
3222 #if SHORTSIZE != SIZE16
3223             while (len-- > 0) {
3224                 unsigned short aushort;
3225                 fromstr = NEXTFROM;
3226                 aushort = SvUV(fromstr);
3227                 DO_BO_PACK(aushort, s);
3228                 PUSH_VAR(utf8, cur, aushort);
3229             }
3230             break;
3231 #else
3232             /* Fall through! */
3233 #endif
3234         case 'S':
3235             while (len-- > 0) {
3236                 U16 au16;
3237                 fromstr = NEXTFROM;
3238                 au16 = (U16)SvUV(fromstr);
3239                 DO_BO_PACK(au16, 16);
3240                 PUSH16(utf8, cur, &au16);
3241             }
3242             break;
3243         case 's' | TYPE_IS_SHRIEKING:
3244 #if SHORTSIZE != SIZE16
3245             while (len-- > 0) {
3246                 short ashort;
3247                 fromstr = NEXTFROM;
3248                 ashort = SvIV(fromstr);
3249                 DO_BO_PACK(ashort, s);
3250                 PUSH_VAR(utf8, cur, ashort);
3251             }
3252             break;
3253 #else
3254             /* Fall through! */
3255 #endif
3256         case 's':
3257             while (len-- > 0) {
3258                 I16 ai16;
3259                 fromstr = NEXTFROM;
3260                 ai16 = (I16)SvIV(fromstr);
3261                 DO_BO_PACK(ai16, 16);
3262                 PUSH16(utf8, cur, &ai16);
3263             }
3264             break;
3265         case 'I':
3266         case 'I' | TYPE_IS_SHRIEKING:
3267             while (len-- > 0) {
3268                 unsigned int auint;
3269                 fromstr = NEXTFROM;
3270                 auint = SvUV(fromstr);
3271                 DO_BO_PACK(auint, i);
3272                 PUSH_VAR(utf8, cur, auint);
3273             }
3274             break;
3275         case 'j':
3276             while (len-- > 0) {
3277                 IV aiv;
3278                 fromstr = NEXTFROM;
3279                 aiv = SvIV(fromstr);
3280 #if IVSIZE == INTSIZE
3281                 DO_BO_PACK(aiv, i);
3282 #elif IVSIZE == LONGSIZE
3283                 DO_BO_PACK(aiv, l);
3284 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
3285                 DO_BO_PACK(aiv, 64);
3286 #else
3287                 Perl_croak(aTHX_ "'j' not supported on this platform");
3288 #endif
3289                 PUSH_VAR(utf8, cur, aiv);
3290             }
3291             break;
3292         case 'J':
3293             while (len-- > 0) {
3294                 UV auv;
3295                 fromstr = NEXTFROM;
3296                 auv = SvUV(fromstr);
3297 #if UVSIZE == INTSIZE
3298                 DO_BO_PACK(auv, i);
3299 #elif UVSIZE == LONGSIZE
3300                 DO_BO_PACK(auv, l);
3301 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
3302                 DO_BO_PACK(auv, 64);
3303 #else
3304                 Perl_croak(aTHX_ "'J' not supported on this platform");
3305 #endif
3306                 PUSH_VAR(utf8, cur, auv);
3307             }
3308             break;
3309         case 'w':
3310             while (len-- > 0) {
3311                 NV anv;
3312                 fromstr = NEXTFROM;
3313                 anv = SvNV(fromstr);
3314
3315                 if (anv < 0) {
3316                     *cur = '\0';
3317                     SvCUR_set(cat, cur - start);
3318                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
3319                 }
3320
3321                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
3322                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
3323                    any negative IVs will have already been got by the croak()
3324                    above. IOK is untrue for fractions, so we test them
3325                    against UV_MAX_P1.  */
3326                 if (SvIOK(fromstr) || anv < UV_MAX_P1) {
3327                     char   buf[(sizeof(UV)*CHAR_BIT)/7+1];
3328                     char  *in = buf + sizeof(buf);
3329                     UV     auv = SvUV(fromstr);
3330
3331                     do {
3332                         *--in = (char)((auv & 0x7f) | 0x80);
3333                         auv >>= 7;
3334                     } while (auv);
3335                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3336                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3337                                        in, (buf + sizeof(buf)) - in);
3338                 } else if (SvPOKp(fromstr))
3339                     goto w_string;
3340                 else if (SvNOKp(fromstr)) {
3341                     /* 10**NV_MAX_10_EXP is the largest power of 10
3342                        so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
3343                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
3344                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
3345                        And with that many bytes only Inf can overflow.
3346                        Some C compilers are strict about integral constant
3347                        expressions so we conservatively divide by a slightly
3348                        smaller integer instead of multiplying by the exact
3349                        floating-point value.
3350                     */
3351 #ifdef NV_MAX_10_EXP
3352                     /* char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
3353                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
3354 #else
3355                     /* char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
3356                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
3357 #endif
3358                     char  *in = buf + sizeof(buf);
3359
3360                     anv = Perl_floor(anv);
3361                     do {
3362                         const NV next = Perl_floor(anv / 128);
3363                         if (in <= buf)  /* this cannot happen ;-) */
3364                             Perl_croak(aTHX_ "Cannot compress integer in pack");
3365                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
3366                         anv = next;
3367                     } while (anv > 0);
3368                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3369                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3370                                        in, (buf + sizeof(buf)) - in);
3371                 } else {
3372                     const char     *from;
3373                     char           *result, *in;
3374                     SV             *norm;
3375                     STRLEN          len;
3376                     bool            done;
3377
3378                   w_string:
3379                     /* Copy string and check for compliance */
3380                     from = SvPV_const(fromstr, len);
3381                     if ((norm = is_an_int(from, len)) == NULL)
3382                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
3383
3384                     Newx(result, len, char);
3385                     in = result + len;
3386                     done = FALSE;
3387                     while (!done) *--in = div128(norm, &done) | 0x80;
3388                     result[len - 1] &= 0x7F; /* clear continue bit */
3389                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3390                                        in, (result + len) - in);
3391                     Safefree(result);
3392                     SvREFCNT_dec(norm); /* free norm */
3393                 }
3394             }
3395             break;
3396         case 'i':
3397         case 'i' | TYPE_IS_SHRIEKING:
3398             while (len-- > 0) {
3399                 int aint;
3400                 fromstr = NEXTFROM;
3401                 aint = SvIV(fromstr);
3402                 DO_BO_PACK(aint, i);
3403                 PUSH_VAR(utf8, cur, aint);
3404             }
3405             break;
3406 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3407         case 'N' | TYPE_IS_SHRIEKING:
3408 #endif
3409         case 'N':
3410             while (len-- > 0) {
3411                 U32 au32;
3412                 fromstr = NEXTFROM;
3413                 au32 = SvUV(fromstr);
3414 #ifdef HAS_HTONL
3415                 au32 = PerlSock_htonl(au32);
3416 #endif
3417                 PUSH32(utf8, cur, &au32);
3418             }
3419             break;
3420 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3421         case 'V' | TYPE_IS_SHRIEKING:
3422 #endif
3423         case 'V':
3424             while (len-- > 0) {
3425                 U32 au32;
3426                 fromstr = NEXTFROM;
3427                 au32 = SvUV(fromstr);
3428 #ifdef HAS_HTOVL
3429                 au32 = htovl(au32);
3430 #endif
3431                 PUSH32(utf8, cur, &au32);
3432             }
3433             break;
3434         case 'L' | TYPE_IS_SHRIEKING:
3435 #if LONGSIZE != SIZE32
3436             while (len-- > 0) {
3437                 unsigned long aulong;
3438                 fromstr = NEXTFROM;
3439                 aulong = SvUV(fromstr);
3440                 DO_BO_PACK(aulong, l);
3441                 PUSH_VAR(utf8, cur, aulong);
3442             }
3443             break;
3444 #else
3445             /* Fall though! */
3446 #endif
3447         case 'L':
3448             while (len-- > 0) {
3449                 U32 au32;
3450                 fromstr = NEXTFROM;
3451                 au32 = SvUV(fromstr);
3452                 DO_BO_PACK(au32, 32);
3453                 PUSH32(utf8, cur, &au32);
3454             }
3455             break;
3456         case 'l' | TYPE_IS_SHRIEKING:
3457 #if LONGSIZE != SIZE32
3458             while (len-- > 0) {
3459                 long along;
3460                 fromstr = NEXTFROM;
3461                 along = SvIV(fromstr);
3462                 DO_BO_PACK(along, l);
3463                 PUSH_VAR(utf8, cur, along);
3464             }
3465             break;
3466 #else
3467             /* Fall though! */
3468 #endif
3469         case 'l':
3470             while (len-- > 0) {
3471                 I32 ai32;
3472                 fromstr = NEXTFROM;
3473                 ai32 = SvIV(fromstr);
3474                 DO_BO_PACK(ai32, 32);
3475                 PUSH32(utf8, cur, &ai32);
3476             }
3477             break;
3478 #ifdef HAS_QUAD
3479         case 'Q':
3480             while (len-- > 0) {
3481                 Uquad_t auquad;
3482                 fromstr = NEXTFROM;
3483                 auquad = (Uquad_t) SvUV(fromstr);
3484                 DO_BO_PACK(auquad, 64);
3485                 PUSH_VAR(utf8, cur, auquad);
3486             }
3487             break;
3488         case 'q':
3489             while (len-- > 0) {
3490                 Quad_t aquad;
3491                 fromstr = NEXTFROM;
3492                 aquad = (Quad_t)SvIV(fromstr);
3493                 DO_BO_PACK(aquad, 64);
3494                 PUSH_VAR(utf8, cur, aquad);
3495             }
3496             break;
3497 #endif /* HAS_QUAD */
3498         case 'P':
3499             len = 1;            /* assume SV is correct length */
3500             GROWING(utf8, cat, start, cur, sizeof(char *));
3501             /* Fall through! */
3502         case 'p':
3503             while (len-- > 0) {
3504                 const char *aptr;
3505
3506                 fromstr = NEXTFROM;
3507                 SvGETMAGIC(fromstr);
3508                 if (!SvOK(fromstr)) aptr = NULL;
3509                 else {
3510                     /* XXX better yet, could spirit away the string to
3511                      * a safe spot and hang on to it until the result
3512                      * of pack() (and all copies of the result) are
3513                      * gone.
3514                      */
3515                     if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
3516                              !SvREADONLY(fromstr))) && ckWARN(WARN_PACK)) {
3517                         Perl_warner(aTHX_ packWARN(WARN_PACK),
3518                                     "Attempt to pack pointer to temporary value");
3519                     }
3520                     if (SvPOK(fromstr) || SvNIOK(fromstr))
3521                         aptr = SvPV_nomg_const_nolen(fromstr);
3522                     else
3523                         aptr = SvPV_force_flags_nolen(fromstr, 0);
3524                 }
3525                 DO_BO_PACK_PC(aptr);
3526                 PUSH_VAR(utf8, cur, aptr);
3527             }
3528             break;
3529         case 'u': {
3530             const char *aptr, *aend;
3531             bool from_utf8;
3532
3533             fromstr = NEXTFROM;
3534             if (len <= 2) len = 45;
3535             else len = len / 3 * 3;
3536             if (len >= 64) {
3537                 if (ckWARN(WARN_PACK))
3538                     Perl_warner(aTHX_ packWARN(WARN_PACK),
3539                             "Field too wide in 'u' format in pack");
3540                 len = 63;
3541             }
3542             aptr = SvPV_const(fromstr, fromlen);
3543             from_utf8 = DO_UTF8(fromstr);
3544             if (from_utf8) {
3545                 aend = aptr + fromlen;
3546                 fromlen = sv_len_utf8(fromstr);
3547             } else aend = NULL; /* Unused, but keep compilers happy */
3548             GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2);
3549             while (fromlen > 0) {
3550                 U8 *end;
3551                 I32 todo;
3552                 U8 hunk[1+63/3*4+1];
3553
3554                 if ((I32)fromlen > len)
3555                     todo = len;
3556                 else
3557                     todo = fromlen;
3558                 if (from_utf8) {
3559                     char buffer[64];
3560                     if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo,
3561                                       'u' | TYPE_IS_PACK)) {
3562                         *cur = '\0';
3563                         SvCUR_set(cat, cur - start);
3564                         Perl_croak(aTHX_ "Assertion: string is shorter than advertised");
3565                     }
3566                     end = doencodes(hunk, buffer, todo);
3567                 } else {
3568                     end = doencodes(hunk, aptr, todo);
3569                     aptr += todo;
3570                 }
3571                 PUSH_BYTES(utf8, cur, hunk, end-hunk);
3572                 fromlen -= todo;
3573             }
3574             break;
3575         }
3576         }
3577         *cur = '\0';
3578         SvCUR_set(cat, cur - start);
3579       no_change:
3580         *symptr = lookahead;
3581     }
3582     return beglist;
3583 }
3584 #undef NEXTFROM
3585
3586
3587 PP(pp_pack)
3588 {
3589     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3590     register SV *cat = TARG;
3591     STRLEN fromlen;
3592     SV *pat_sv = *++MARK;
3593     register const char *pat = SvPV_const(pat_sv, fromlen);
3594     register const char *patend = pat + fromlen;
3595
3596     MARK++;
3597     sv_setpvs(cat, "");
3598     SvUTF8_off(cat);
3599
3600     packlist(cat, pat, patend, MARK, SP + 1);
3601
3602     SvSETMAGIC(cat);
3603     SP = ORIGMARK;
3604     PUSHs(cat);
3605     RETURN;
3606 }
3607
3608 /*
3609  * Local variables:
3610  * c-indentation-style: bsd
3611  * c-basic-offset: 4
3612  * indent-tabs-mode: t
3613  * End:
3614  *
3615  * ex: set ts=8 sts=4 sw=4 noet:
3616  */