pp_pack.c

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