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