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             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(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 = { 0 };
1119
1120     if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8;
1121     else if (need_utf8(pat, patend)) {
1122         /* We probably should try to avoid this in case a scalar context call
1123            wouldn't get to the "U0" */
1124         STRLEN len = strend - s;
1125         s = (char *) bytes_to_utf8((U8 *) s, &len);
1126         SAVEFREEPV(s);
1127         strend = s + len;
1128         flags |= FLAG_DO_UTF8;
1129     }
1130
1131     if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8))
1132         flags |= FLAG_PARSE_UTF8;
1133
1134     sym.patptr = pat;
1135     sym.patend = patend;
1136     sym.flags  = flags;
1137
1138     return unpack_rec(&sym, s, s, strend, NULL );
1139 }
1140
1141 /*
1142 =for apidoc unpackstring
1143
1144 The engine implementing unpack() Perl function. C<unpackstring> puts the
1145 extracted list items on the stack and returns the number of elements.
1146 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
1147
1148 =cut */
1149
1150 I32
1151 Perl_unpackstring(pTHX_ char *pat, char *patend, char *s, char *strend, U32 flags)
1152 {
1153     tempsym_t sym = { 0 };
1154
1155     if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8;
1156     else if (need_utf8(pat, patend)) {
1157         /* We probably should try to avoid this in case a scalar context call
1158            wouldn't get to the "U0" */
1159         STRLEN len = strend - s;
1160         s = (char *) bytes_to_utf8((U8 *) s, &len);
1161         SAVEFREEPV(s);
1162         strend = s + len;
1163         flags |= FLAG_DO_UTF8;
1164     }
1165
1166     if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8))
1167         flags |= FLAG_PARSE_UTF8;
1168
1169     sym.patptr = pat;
1170     sym.patend = patend;
1171     sym.flags  = flags;
1172
1173     return unpack_rec(&sym, s, s, strend, NULL );
1174 }
1175
1176 STATIC
1177 I32
1178 S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char **new_s )
1179 {
1180     dSP;
1181     SV *sv;
1182     I32 start_sp_offset = SP - PL_stack_base;
1183     howlen_t howlen;
1184
1185     I32 checksum = 0;
1186     UV cuv = 0;
1187     NV cdouble = 0.0;
1188     const int bits_in_uv = CHAR_BIT * sizeof(cuv);
1189     bool beyond = FALSE;
1190     bool explicit_length;
1191     bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
1192     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
1193     symptr->strbeg = s - strbeg;
1194
1195     while (next_symbol(symptr)) {
1196         packprops_t props;
1197         I32 len, ai32;
1198         I32 datumtype = symptr->code;
1199         /* do first one only unless in list context
1200            / is implemented by unpacking the count, then popping it from the
1201            stack, so must check that we're not in the middle of a /  */
1202         if ( unpack_only_one
1203              && (SP - PL_stack_base == start_sp_offset + 1)
1204              && (datumtype != '/') )   /* XXX can this be omitted */
1205             break;
1206
1207         switch (howlen = symptr->howlen) {
1208           case e_star:
1209             len = strend - strbeg;      /* long enough */
1210             break;
1211           default:
1212             /* e_no_len and e_number */
1213             len = symptr->length;
1214             break;
1215         }
1216
1217         explicit_length = TRUE;
1218       redo_switch:
1219         beyond = s >= strend;
1220
1221         props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
1222         if (props) {
1223             /* props nonzero means we can process this letter. */
1224             long size = props & PACK_SIZE_MASK;
1225             long howmany = (strend - s) / size;
1226             if (len > howmany)
1227                 len = howmany;
1228
1229             if (!checksum || (props & PACK_SIZE_CANNOT_CSUM)) {
1230                 if (len && unpack_only_one) len = 1;
1231                 EXTEND(SP, len);
1232                 EXTEND_MORTAL(len);
1233             }
1234         }
1235
1236         switch(TYPE_NO_ENDIANNESS(datumtype)) {
1237         default:
1238             Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
1239
1240         case '%':
1241             if (howlen == e_no_len)
1242                 len = 16;               /* len is not specified */
1243             checksum = len;
1244             cuv = 0;
1245             cdouble = 0;
1246             continue;
1247             break;
1248         case '(':
1249         {
1250             tempsym_t savsym = *symptr;
1251             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
1252             symptr->flags |= group_modifiers;
1253             symptr->patend = savsym.grpend;
1254             symptr->previous = &savsym;
1255             symptr->level++;
1256             PUTBACK;
1257             while (len--) {
1258                 symptr->patptr = savsym.grpbeg;
1259                 if (utf8) symptr->flags |=  FLAG_PARSE_UTF8;
1260                 else      symptr->flags &= ~FLAG_PARSE_UTF8;
1261                 unpack_rec(symptr, s, strbeg, strend, &s);
1262                 if (s == strend && savsym.howlen == e_star)
1263                     break; /* No way to continue */
1264             }
1265             SPAGAIN;
1266             savsym.flags = symptr->flags & ~group_modifiers;
1267             *symptr = savsym;
1268             break;
1269         }
1270 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1271         case '.' | TYPE_IS_SHRIEKING:
1272 #endif
1273         case '.': {
1274             char *from;
1275             SV *sv;
1276 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1277             bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING);
1278 #else /* PERL_PACK_CAN_SHRIEKSIGN */
1279             bool u8 = utf8;
1280 #endif
1281             if (howlen == e_star) from = strbeg;
1282             else if (len <= 0) from = s;
1283             else {
1284                 tempsym_t *group = symptr;
1285
1286                 while (--len && group) group = group->previous;
1287                 from = group ? strbeg + group->strbeg : strbeg;
1288             }
1289             sv = from <= s ?
1290                 newSVuv(  u8 ? (UV) utf8_length((const U8*)from, (const U8*)s) : (UV) (s-from)) :
1291                 newSViv(-(u8 ? (IV) utf8_length((const U8*)s, (const U8*)from) : (IV) (from-s)));
1292             XPUSHs(sv_2mortal(sv));
1293             break;
1294         }
1295 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1296         case '@' | TYPE_IS_SHRIEKING:
1297 #endif
1298         case '@':
1299             s = strbeg + symptr->strbeg;
1300 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1301             if (utf8  && !(datumtype & TYPE_IS_SHRIEKING))
1302 #else /* PERL_PACK_CAN_SHRIEKSIGN */
1303             if (utf8)
1304 #endif
1305             {
1306                 while (len > 0) {
1307                     if (s >= strend)
1308                         Perl_croak(aTHX_ "'@' outside of string in unpack");
1309                     s += UTF8SKIP(s);
1310                     len--;
1311                 }
1312                 if (s > strend)
1313                     Perl_croak(aTHX_ "'@' outside of string with malformed UTF-8 in unpack");
1314             } else {
1315                 if (strend-s < len)
1316                     Perl_croak(aTHX_ "'@' outside of string in unpack");
1317                 s += len;
1318             }
1319             break;
1320         case 'X' | TYPE_IS_SHRIEKING:
1321             if (!len)                   /* Avoid division by 0 */
1322                 len = 1;
1323             if (utf8) {
1324                 char *hop, *last;
1325                 I32 l = len;
1326                 hop = last = strbeg;
1327                 while (hop < s) {
1328                     hop += UTF8SKIP(hop);
1329                     if (--l == 0) {
1330                         last = hop;
1331                         l = len;
1332                     }
1333                 }
1334                 if (last > s)
1335                     Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1336                 s = last;
1337                 break;
1338             }
1339             len = (s - strbeg) % len;
1340             /* FALL THROUGH */
1341         case 'X':
1342             if (utf8) {
1343                 while (len > 0) {
1344                     if (s <= strbeg)
1345                         Perl_croak(aTHX_ "'X' outside of string in unpack");
1346                     while (--s, UTF8_IS_CONTINUATION(*s)) {
1347                         if (s <= strbeg)
1348                             Perl_croak(aTHX_ "'X' outside of string in unpack");
1349                     }
1350                     len--;
1351                 }
1352             } else {
1353                 if (len > s - strbeg)
1354                     Perl_croak(aTHX_ "'X' outside of string in unpack" );
1355                 s -= len;
1356             }
1357             break;
1358         case 'x' | TYPE_IS_SHRIEKING:
1359             if (!len)                   /* Avoid division by 0 */
1360                 len = 1;
1361             if (utf8) ai32 = utf8_length((U8 *) strbeg, (U8 *) s) % len;
1362             else      ai32 = (s - strbeg)                         % len;
1363             if (ai32 == 0) break;
1364             len -= ai32;
1365             /* FALL THROUGH */
1366         case 'x':
1367             if (utf8) {
1368                 while (len>0) {
1369                     if (s >= strend)
1370                         Perl_croak(aTHX_ "'x' outside of string in unpack");
1371                     s += UTF8SKIP(s);
1372                     len--;
1373                 }
1374             } else {
1375                 if (len > strend - s)
1376                     Perl_croak(aTHX_ "'x' outside of string in unpack");
1377                 s += len;
1378             }
1379             break;
1380         case '/':
1381             Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1382             break;
1383         case 'A':
1384         case 'Z':
1385         case 'a':
1386             if (checksum) {
1387                 /* Preliminary length estimate is assumed done in 'W' */
1388                 if (len > strend - s) len = strend - s;
1389                 goto W_checksum;
1390             }
1391             if (utf8) {
1392                 I32 l;
1393                 char *hop;
1394                 for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) {
1395                     if (hop >= strend) {
1396                         if (hop > strend)
1397                             Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1398                         break;
1399                     }
1400                 }
1401                 if (hop > strend)
1402                     Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1403                 len = hop - s;
1404             } else if (len > strend - s)
1405                 len = strend - s;
1406
1407             if (datumtype == 'Z') {
1408                 /* 'Z' strips stuff after first null */
1409                 char *ptr, *end;
1410                 end = s + len;
1411                 for (ptr = s; ptr < end; ptr++) if (*ptr == 0) break;
1412                 sv = newSVpvn(s, ptr-s);
1413                 if (howlen == e_star) /* exact for 'Z*' */
1414                     len = ptr-s + (ptr != strend ? 1 : 0);
1415             } else if (datumtype == 'A') {
1416                 /* 'A' strips both nulls and spaces */
1417                 char *ptr;
1418                 if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) {
1419                     for (ptr = s+len-1; ptr >= s; ptr--)
1420                         if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) &&
1421                             !is_utf8_space((U8 *) ptr)) break;
1422                     if (ptr >= s) ptr += UTF8SKIP(ptr);
1423                     else ptr++;
1424                     if (ptr > s+len)
1425                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1426                 } else {
1427                     for (ptr = s+len-1; ptr >= s; ptr--)
1428                         if (*ptr != 0 && !isSPACE(*ptr)) break;
1429                     ptr++;
1430                 }
1431                 sv = newSVpvn(s, ptr-s);
1432             } else sv = newSVpvn(s, len);
1433
1434             if (utf8) {
1435                 SvUTF8_on(sv);
1436                 /* Undo any upgrade done due to need_utf8() */
1437                 if (!(symptr->flags & FLAG_WAS_UTF8))
1438                     sv_utf8_downgrade(sv, 0);
1439             }
1440             XPUSHs(sv_2mortal(sv));
1441             s += len;
1442             break;
1443         case 'B':
1444         case 'b': {
1445             char *str;
1446             if (howlen == e_star || len > (strend - s) * 8)
1447                 len = (strend - s) * 8;
1448             if (checksum) {
1449                 if (!PL_bitcount) {
1450                     int bits;
1451                     Newz(601, PL_bitcount, 256, char);
1452                     for (bits = 1; bits < 256; bits++) {
1453                         if (bits & 1)   PL_bitcount[bits]++;
1454                         if (bits & 2)   PL_bitcount[bits]++;
1455                         if (bits & 4)   PL_bitcount[bits]++;
1456                         if (bits & 8)   PL_bitcount[bits]++;
1457                         if (bits & 16)  PL_bitcount[bits]++;
1458                         if (bits & 32)  PL_bitcount[bits]++;
1459                         if (bits & 64)  PL_bitcount[bits]++;
1460                         if (bits & 128) PL_bitcount[bits]++;
1461                     }
1462                 }
1463                 if (utf8)
1464                     while (len >= 8 && s < strend) {
1465                         cuv += PL_bitcount[uni_to_byte(aTHX_ &s, strend, datumtype)];
1466                         len -= 8;
1467                     }
1468                 else
1469                     while (len >= 8) {
1470                         cuv += PL_bitcount[*(U8 *)s++];
1471                         len -= 8;
1472                     }
1473                 if (len && s < strend) {
1474                     U8 bits;
1475                     bits = SHIFT_BYTE(utf8, s, strend, datumtype);
1476                     if (datumtype == 'b')
1477                         while (len-- > 0) {
1478                             if (bits & 1) cuv++;
1479                             bits >>= 1;
1480                         }
1481                     else
1482                         while (len-- > 0) {
1483                             if (bits & 0x80) cuv++;
1484                             bits <<= 1;
1485                         }
1486                 }
1487                 break;
1488             }
1489
1490             sv = sv_2mortal(NEWSV(35, len ? len : 1));
1491             SvPOK_on(sv);
1492             str = SvPVX(sv);
1493             if (datumtype == 'b') {
1494                 U8 bits = 0;
1495                 ai32 = len;
1496                 for (len = 0; len < ai32; len++) {
1497                     if (len & 7) bits >>= 1;
1498                     else if (utf8) {
1499                         if (s >= strend) break;
1500                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1501                     } else bits = *(U8 *) s++;
1502                     *str++ = bits & 1 ? '1' : '0';
1503                 }
1504             } else {
1505                 U8 bits = 0;
1506                 ai32 = len;
1507                 for (len = 0; len < ai32; len++) {
1508                     if (len & 7) bits <<= 1;
1509                     else if (utf8) {
1510                         if (s >= strend) break;
1511                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1512                     } else bits = *(U8 *) s++;
1513                     *str++ = bits & 0x80 ? '1' : '0';
1514                 }
1515             }
1516             *str = '\0';
1517             SvCUR_set(sv, str - SvPVX(sv));
1518             XPUSHs(sv);
1519             break;
1520         }
1521         case 'H':
1522         case 'h': {
1523             char *str;
1524             /* Preliminary length estimate, acceptable for utf8 too */
1525             if (howlen == e_star || len > (strend - s) * 2)
1526                 len = (strend - s) * 2;
1527             sv = sv_2mortal(NEWSV(35, len ? len : 1));
1528             SvPOK_on(sv);
1529             str = SvPVX(sv);
1530             if (datumtype == 'h') {
1531                 U8 bits = 0;
1532                 ai32 = len;
1533                 for (len = 0; len < ai32; len++) {
1534                     if (len & 1) bits >>= 4;
1535                     else if (utf8) {
1536                         if (s >= strend) break;
1537                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1538                     } else bits = * (U8 *) s++;
1539                     *str++ = PL_hexdigit[bits & 15];
1540                 }
1541             } else {
1542                 U8 bits = 0;
1543                 ai32 = len;
1544                 for (len = 0; len < ai32; len++) {
1545                     if (len & 1) bits <<= 4;
1546                     else if (utf8) {
1547                         if (s >= strend) break;
1548                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1549                     } else bits = *(U8 *) s++;
1550                     *str++ = PL_hexdigit[(bits >> 4) & 15];
1551                 }
1552             }
1553             *str = '\0';
1554             SvCUR_set(sv, str - SvPVX(sv));
1555             XPUSHs(sv);
1556             break;
1557         }
1558         case 'c':
1559             while (len-- > 0) {
1560                 int aint = SHIFT_BYTE(utf8, s, strend, datumtype);
1561                 if (aint >= 128)        /* fake up signed chars */
1562                     aint -= 256;
1563                 if (!checksum)
1564                     PUSHs(sv_2mortal(newSViv((IV)aint)));
1565                 else if (checksum > bits_in_uv)
1566                     cdouble += (NV)aint;
1567                 else
1568                     cuv += aint;
1569             }
1570             break;
1571         case 'C':
1572         case 'W':
1573           W_checksum:
1574             if (len == 0) {
1575                 if (explicit_length && datumtype == 'C')
1576                     /* Switch to "character" mode */
1577                     utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
1578                 break;
1579             }
1580             if (datumtype == 'C' ?
1581                  (symptr->flags & FLAG_DO_UTF8) &&
1582                 !(symptr->flags & FLAG_WAS_UTF8) : utf8) {
1583                 while (len-- > 0 && s < strend) {
1584                     UV val;
1585                     STRLEN retlen;
1586                     val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
1587                                          ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1588                     if (retlen == (STRLEN) -1 || retlen == 0)
1589                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1590                     s += retlen;
1591                     if (!checksum)
1592                         PUSHs(sv_2mortal(newSVuv((UV) val)));
1593                     else if (checksum > bits_in_uv)
1594                         cdouble += (NV) val;
1595                     else
1596                         cuv += val;
1597                 }
1598             } else if (!checksum)
1599                 while (len-- > 0) {
1600                     U8 ch = *(U8 *) s++;
1601                     PUSHs(sv_2mortal(newSVuv((UV) ch)));
1602             }
1603             else if (checksum > bits_in_uv)
1604                 while (len-- > 0) cdouble += (NV) *(U8 *) s++;
1605             else
1606                 while (len-- > 0) cuv += *(U8 *) s++;
1607             break;
1608         case 'U':
1609             if (len == 0) {
1610                 if (explicit_length) {
1611                     /* Switch to "bytes in UTF-8" mode */
1612                     if (symptr->flags & FLAG_DO_UTF8) utf8 = 0;
1613                     else
1614                         /* Should be impossible due to the need_utf8() test */
1615                         Perl_croak(aTHX_ "U0 mode on a byte string");
1616                 }
1617                 break;
1618             }
1619             if (len > strend - s) len = strend - s;
1620             if (!checksum) {
1621                 if (len && unpack_only_one) len = 1;
1622                 EXTEND(SP, len);
1623                 EXTEND_MORTAL(len);
1624             }
1625             while (len-- > 0 && s < strend) {
1626                 STRLEN retlen;
1627                 UV auv;
1628                 if (utf8) {
1629                     U8 result[UTF8_MAXLEN];
1630                     char *ptr;
1631                     STRLEN len;
1632                     ptr = s;
1633                     /* Bug: warns about bad utf8 even if we are short on bytes
1634                        and will break out of the loop */
1635                     if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) result, 1,
1636                                       'U'))
1637                         break;
1638                     len = UTF8SKIP(result);
1639                     if (!uni_to_bytes(aTHX_ &ptr, strend,
1640                                       (char *) &result[1], len-1, 'U')) break;
1641                     auv = utf8n_to_uvuni(result, len, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
1642                     s = ptr;
1643                 } else {
1644                     auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
1645                     if (retlen == (STRLEN) -1 || retlen == 0)
1646                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1647                     s += retlen;
1648                 }
1649                 if (!checksum)
1650                     PUSHs(sv_2mortal(newSVuv((UV) auv)));
1651                 else if (checksum > bits_in_uv)
1652                     cdouble += (NV) auv;
1653                 else
1654                     cuv += auv;
1655             }
1656             break;
1657         case 's' | TYPE_IS_SHRIEKING:
1658 #if SHORTSIZE != SIZE16
1659             while (len-- > 0) {
1660                 short ashort;
1661                 SHIFT_VAR(utf8, s, strend, ashort, datumtype);
1662                 DO_BO_UNPACK(ashort, s);
1663                 if (!checksum)
1664                     PUSHs(sv_2mortal(newSViv((IV)ashort)));
1665                 else if (checksum > bits_in_uv)
1666                     cdouble += (NV)ashort;
1667                 else
1668                     cuv += ashort;
1669             }
1670             break;
1671 #else
1672             /* Fallthrough! */
1673 #endif
1674         case 's':
1675             while (len-- > 0) {
1676                 I16 ai16;
1677
1678 #if U16SIZE > SIZE16
1679                 ai16 = 0;
1680 #endif
1681                 SHIFT16(utf8, s, strend, &ai16, datumtype);
1682                 DO_BO_UNPACK(ai16, 16);
1683 #if U16SIZE > SIZE16
1684                 if (ai16 > 32767)
1685                     ai16 -= 65536;
1686 #endif
1687                 if (!checksum)
1688                     PUSHs(sv_2mortal(newSViv((IV)ai16)));
1689                 else if (checksum > bits_in_uv)
1690                     cdouble += (NV)ai16;
1691                 else
1692                     cuv += ai16;
1693             }
1694             break;
1695         case 'S' | TYPE_IS_SHRIEKING:
1696 #if SHORTSIZE != SIZE16
1697             while (len-- > 0) {
1698                 unsigned short aushort;
1699                 SHIFT_VAR(utf8, s, strend, aushort, datumtype);
1700                 DO_BO_UNPACK(aushort, s);
1701                 if (!checksum)
1702                     PUSHs(sv_2mortal(newSVuv((UV) aushort)));
1703                 else if (checksum > bits_in_uv)
1704                     cdouble += (NV)aushort;
1705                 else
1706                     cuv += aushort;
1707             }
1708             break;
1709 #else
1710             /* Fallhrough! */
1711 #endif
1712         case 'v':
1713         case 'n':
1714         case 'S':
1715             while (len-- > 0) {
1716                 U16 au16;
1717 #if U16SIZE > SIZE16
1718                 au16 = 0;
1719 #endif
1720                 SHIFT16(utf8, s, strend, &au16, datumtype);
1721                 DO_BO_UNPACK(au16, 16);
1722 #ifdef HAS_NTOHS
1723                 if (datumtype == 'n')
1724                     au16 = PerlSock_ntohs(au16);
1725 #endif
1726 #ifdef HAS_VTOHS
1727                 if (datumtype == 'v')
1728                     au16 = vtohs(au16);
1729 #endif
1730                 if (!checksum)
1731                     PUSHs(sv_2mortal(newSVuv((UV)au16)));
1732                 else if (checksum > bits_in_uv)
1733                     cdouble += (NV) au16;
1734                 else
1735                     cuv += au16;
1736             }
1737             break;
1738 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1739         case 'v' | TYPE_IS_SHRIEKING:
1740         case 'n' | TYPE_IS_SHRIEKING:
1741             while (len-- > 0) {
1742                 I16 ai16;
1743 # if U16SIZE > SIZE16
1744                 ai16 = 0;
1745 # endif
1746                 SHIFT16(utf8, s, strend, &ai16, datumtype);
1747 # ifdef HAS_NTOHS
1748                 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1749                     ai16 = (I16) PerlSock_ntohs((U16) ai16);
1750 # endif /* HAS_NTOHS */
1751 # ifdef HAS_VTOHS
1752                 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1753                     ai16 = (I16) vtohs((U16) ai16);
1754 # endif /* HAS_VTOHS */
1755                 if (!checksum)
1756                     PUSHs(sv_2mortal(newSViv((IV)ai16)));
1757                 else if (checksum > bits_in_uv)
1758                     cdouble += (NV) ai16;
1759                 else
1760                     cuv += ai16;
1761             }
1762             break;
1763 #endif /* PERL_PACK_CAN_SHRIEKSIGN */
1764         case 'i':
1765         case 'i' | TYPE_IS_SHRIEKING:
1766             while (len-- > 0) {
1767                 int aint;
1768                 SHIFT_VAR(utf8, s, strend, aint, datumtype);
1769                 DO_BO_UNPACK(aint, i);
1770                 if (!checksum)
1771                     PUSHs(sv_2mortal(newSViv((IV)aint)));
1772                 else if (checksum > bits_in_uv)
1773                     cdouble += (NV)aint;
1774                 else
1775                     cuv += aint;
1776             }
1777             break;
1778         case 'I':
1779         case 'I' | TYPE_IS_SHRIEKING:
1780             while (len-- > 0) {
1781                 unsigned int auint;
1782                 SHIFT_VAR(utf8, s, strend, auint, datumtype);
1783                 DO_BO_UNPACK(auint, i);
1784                 if (!checksum)
1785                     PUSHs(sv_2mortal(newSVuv((UV)auint)));
1786                 else if (checksum > bits_in_uv)
1787                     cdouble += (NV)auint;
1788                 else
1789                     cuv += auint;
1790             }
1791             break;
1792         case 'j':
1793             while (len-- > 0) {
1794                 IV aiv;
1795                 SHIFT_VAR(utf8, s, strend, aiv, datumtype);
1796 #if IVSIZE == INTSIZE
1797                 DO_BO_UNPACK(aiv, i);
1798 #elif IVSIZE == LONGSIZE
1799                 DO_BO_UNPACK(aiv, l);
1800 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1801                 DO_BO_UNPACK(aiv, 64);
1802 #else
1803                 Perl_croak(aTHX_ "'j' not supported on this platform");
1804 #endif
1805                 if (!checksum)
1806                     PUSHs(sv_2mortal(newSViv(aiv)));
1807                 else if (checksum > bits_in_uv)
1808                     cdouble += (NV)aiv;
1809                 else
1810                     cuv += aiv;
1811             }
1812             break;
1813         case 'J':
1814             while (len-- > 0) {
1815                 UV auv;
1816                 SHIFT_VAR(utf8, s, strend, auv, datumtype);
1817 #if IVSIZE == INTSIZE
1818                 DO_BO_UNPACK(auv, i);
1819 #elif IVSIZE == LONGSIZE
1820                 DO_BO_UNPACK(auv, l);
1821 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1822                 DO_BO_UNPACK(auv, 64);
1823 #else
1824                 Perl_croak(aTHX_ "'J' not supported on this platform");
1825 #endif
1826                 if (!checksum)
1827                     PUSHs(sv_2mortal(newSVuv(auv)));
1828                 else if (checksum > bits_in_uv)
1829                     cdouble += (NV)auv;
1830                 else
1831                     cuv += auv;
1832             }
1833             break;
1834         case 'l' | TYPE_IS_SHRIEKING:
1835 #if LONGSIZE != SIZE32
1836             while (len-- > 0) {
1837                 long along;
1838                 SHIFT_VAR(utf8, s, strend, along, datumtype);
1839                 DO_BO_UNPACK(along, l);
1840                 if (!checksum)
1841                     PUSHs(sv_2mortal(newSViv((IV)along)));
1842                 else if (checksum > bits_in_uv)
1843                     cdouble += (NV)along;
1844                 else
1845                     cuv += along;
1846             }
1847             break;
1848 #else
1849             /* Fallthrough! */
1850 #endif
1851         case 'l':
1852             while (len-- > 0) {
1853                 I32 ai32;
1854 #if U32SIZE > SIZE32
1855                 ai32 = 0;
1856 #endif
1857                 SHIFT32(utf8, s, strend, &ai32, datumtype);
1858                 DO_BO_UNPACK(ai32, 32);
1859 #if U32SIZE > SIZE32
1860                 if (ai32 > 2147483647) ai32 -= 4294967296;
1861 #endif
1862                 if (!checksum)
1863                     PUSHs(sv_2mortal(newSViv((IV)ai32)));
1864                 else if (checksum > bits_in_uv)
1865                     cdouble += (NV)ai32;
1866                 else
1867                     cuv += ai32;
1868             }
1869             break;
1870         case 'L' | TYPE_IS_SHRIEKING:
1871 #if LONGSIZE != SIZE32
1872             while (len-- > 0) {
1873                 unsigned long aulong;
1874                 SHIFT_VAR(utf8, s, strend, aulong, datumtype);
1875                 DO_BO_UNPACK(aulong, l);
1876                 if (!checksum)
1877                     PUSHs(sv_2mortal(newSVuv((UV)aulong)));
1878                 else if (checksum > bits_in_uv)
1879                     cdouble += (NV)aulong;
1880                 else
1881                     cuv += aulong;
1882             }
1883             break;
1884 #else
1885             /* Fall through! */
1886 #endif
1887         case 'V':
1888         case 'N':
1889         case 'L':
1890             while (len-- > 0) {
1891                 U32 au32;
1892 #if U32SIZE > SIZE32
1893                 au32 = 0;
1894 #endif
1895                 SHIFT32(utf8, s, strend, &au32, datumtype);
1896                 DO_BO_UNPACK(au32, 32);
1897 #ifdef HAS_NTOHL
1898                 if (datumtype == 'N')
1899                     au32 = PerlSock_ntohl(au32);
1900 #endif
1901 #ifdef HAS_VTOHL
1902                 if (datumtype == 'V')
1903                     au32 = vtohl(au32);
1904 #endif
1905                 if (!checksum)
1906                     PUSHs(sv_2mortal(newSVuv((UV)au32)));
1907                 else if (checksum > bits_in_uv)
1908                     cdouble += (NV)au32;
1909                 else
1910                     cuv += au32;
1911             }
1912             break;
1913 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1914         case 'V' | TYPE_IS_SHRIEKING:
1915         case 'N' | TYPE_IS_SHRIEKING:
1916             while (len-- > 0) {
1917                 I32 ai32;
1918 # if U32SIZE > SIZE32
1919                 ai32 = 0;
1920 # endif
1921                 SHIFT32(utf8, s, strend, &ai32, datumtype);
1922 # ifdef HAS_NTOHL
1923                 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1924                     ai32 = (I32)PerlSock_ntohl((U32)ai32);
1925 # endif
1926 # ifdef HAS_VTOHL
1927                 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1928                     ai32 = (I32)vtohl((U32)ai32);
1929 # endif
1930                 if (!checksum)
1931                     PUSHs(sv_2mortal(newSViv((IV)ai32)));
1932                 else if (checksum > bits_in_uv)
1933                     cdouble += (NV)ai32;
1934                 else
1935                     cuv += ai32;
1936             }
1937             break;
1938 #endif /* PERL_PACK_CAN_SHRIEKSIGN */
1939         case 'p':
1940             while (len-- > 0) {
1941                 char *aptr;
1942                 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
1943                 DO_BO_UNPACK_PC(aptr);
1944                 /* newSVpv generates undef if aptr is NULL */
1945                 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1946             }
1947             break;
1948         case 'w':
1949             {
1950                 UV auv = 0;
1951                 U32 bytes = 0;
1952
1953                 while (len > 0 && s < strend) {
1954                     U8 ch;
1955                     ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1956                     auv = (auv << 7) | (ch & 0x7f);
1957                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1958                     if (ch < 0x80) {
1959                         bytes = 0;
1960                         PUSHs(sv_2mortal(newSVuv(auv)));
1961                         len--;
1962                         auv = 0;
1963                         continue;
1964                     }
1965                     if (++bytes >= sizeof(UV)) {        /* promote to string */
1966                         char *t;
1967                         STRLEN n_a;
1968
1969                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1970                         while (s < strend) {
1971                             ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1972                             sv = mul128(sv, (U8)(ch & 0x7f));
1973                             if (!(ch & 0x80)) {
1974                                 bytes = 0;
1975                                 break;
1976                             }
1977                         }
1978                         t = SvPV(sv, n_a);
1979                         while (*t == '0')
1980                             t++;
1981                         sv_chop(sv, t);
1982                         PUSHs(sv_2mortal(sv));
1983                         len--;
1984                         auv = 0;
1985                     }
1986                 }
1987                 if ((s >= strend) && bytes)
1988                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1989             }
1990             break;
1991         case 'P':
1992             if (symptr->howlen == e_star)
1993                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1994             EXTEND(SP, 1);
1995             if (sizeof(char*) <= strend - s) {
1996                 char *aptr;
1997                 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
1998                 DO_BO_UNPACK_PC(aptr);
1999                 /* newSVpvn generates undef if aptr is NULL */
2000                 PUSHs(sv_2mortal(newSVpvn(aptr, len)));
2001             }
2002             break;
2003 #ifdef HAS_QUAD
2004         case 'q':
2005             while (len-- > 0) {
2006                 Quad_t aquad;
2007                 SHIFT_VAR(utf8, s, strend, aquad, datumtype);
2008                 DO_BO_UNPACK(aquad, 64);
2009                 if (!checksum)
2010                     PUSHs(sv_2mortal(aquad >= IV_MIN && aquad <= IV_MAX ?
2011                                      newSViv((IV)aquad) : newSVnv((NV)aquad)));
2012                 else if (checksum > bits_in_uv)
2013                     cdouble += (NV)aquad;
2014                 else
2015                     cuv += aquad;
2016             }
2017             break;
2018         case 'Q':
2019             while (len-- > 0) {
2020                 Uquad_t auquad;
2021                 SHIFT_VAR(utf8, s, strend, auquad, datumtype);
2022                 DO_BO_UNPACK(auquad, 64);
2023                 if (!checksum)
2024                     PUSHs(sv_2mortal(auquad <= UV_MAX ?
2025                                      newSVuv((UV)auquad):newSVnv((NV)auquad)));
2026                 else if (checksum > bits_in_uv)
2027                     cdouble += (NV)auquad;
2028                 else
2029                     cuv += auquad;
2030             }
2031             break;
2032 #endif /* HAS_QUAD */
2033         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
2034         case 'f':
2035             while (len-- > 0) {
2036                 float afloat;
2037                 SHIFT_VAR(utf8, s, strend, afloat, datumtype);
2038                 DO_BO_UNPACK_N(afloat, float);
2039                 if (!checksum)
2040                     PUSHs(sv_2mortal(newSVnv((NV)afloat)));
2041                 else
2042                     cdouble += afloat;
2043             }
2044             break;
2045         case 'd':
2046             while (len-- > 0) {
2047                 double adouble;
2048                 SHIFT_VAR(utf8, s, strend, adouble, datumtype);
2049                 DO_BO_UNPACK_N(adouble, double);
2050                 if (!checksum)
2051                     PUSHs(sv_2mortal(newSVnv((NV)adouble)));
2052                 else
2053                     cdouble += adouble;
2054             }
2055             break;
2056         case 'F':
2057             while (len-- > 0) {
2058                 NV anv;
2059                 SHIFT_VAR(utf8, s, strend, anv, datumtype);
2060                 DO_BO_UNPACK_N(anv, NV);
2061                 if (!checksum)
2062                     PUSHs(sv_2mortal(newSVnv(anv)));
2063                 else
2064                     cdouble += anv;
2065             }
2066             break;
2067 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2068         case 'D':
2069             while (len-- > 0) {
2070                 long double aldouble;
2071                 SHIFT_VAR(utf8, s, strend, aldouble, datumtype);
2072                 DO_BO_UNPACK_N(aldouble, long double);
2073                 if (!checksum)
2074                     PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
2075                 else
2076                     cdouble += aldouble;
2077             }
2078             break;
2079 #endif
2080         case 'u':
2081             /* MKS:
2082              * Initialise the decode mapping.  By using a table driven
2083              * algorithm, the code will be character-set independent
2084              * (and just as fast as doing character arithmetic)
2085              */
2086             if (PL_uudmap['M'] == 0) {
2087                 int i;
2088
2089                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
2090                     PL_uudmap[(U8)PL_uuemap[i]] = i;
2091                 /*
2092                  * Because ' ' and '`' map to the same value,
2093                  * we need to decode them both the same.
2094                  */
2095                 PL_uudmap[' '] = 0;
2096             }
2097             {
2098                 STRLEN l = (STRLEN) (strend - s) * 3 / 4;
2099                 sv = sv_2mortal(NEWSV(42, l));
2100                 if (l) SvPOK_on(sv);
2101             }
2102             if (utf8) {
2103                 while (next_uni_uu(aTHX_ &s, strend, &len)) {
2104                     I32 a, b, c, d;
2105                     char hunk[4];
2106
2107                     hunk[3] = '\0';
2108                     while (len > 0) {
2109                         next_uni_uu(aTHX_ &s, strend, &a);
2110                         next_uni_uu(aTHX_ &s, strend, &b);
2111                         next_uni_uu(aTHX_ &s, strend, &c);
2112                         next_uni_uu(aTHX_ &s, strend, &d);
2113                         hunk[0] = (char)((a << 2) | (b >> 4));
2114                         hunk[1] = (char)((b << 4) | (c >> 2));
2115                         hunk[2] = (char)((c << 6) | d);
2116                         sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
2117                         len -= 3;
2118                     }
2119                     if (s < strend) {
2120                         if (*s == '\n') s++;
2121                         else {
2122                             /* possible checksum byte */
2123                             char *skip = s+UTF8SKIP(s);
2124                             if (skip < strend && *skip == '\n') s = skip+1;
2125                         }
2126                     }
2127                 }
2128             } else {
2129                 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
2130                     I32 a, b, c, d;
2131                     char hunk[4];
2132
2133                     hunk[3] = '\0';
2134                     len = PL_uudmap[*(U8*)s++] & 077;
2135                     while (len > 0) {
2136                         if (s < strend && ISUUCHAR(*s))
2137                             a = PL_uudmap[*(U8*)s++] & 077;
2138                         else
2139                             a = 0;
2140                         if (s < strend && ISUUCHAR(*s))
2141                             b = PL_uudmap[*(U8*)s++] & 077;
2142                         else
2143                             b = 0;
2144                         if (s < strend && ISUUCHAR(*s))
2145                             c = PL_uudmap[*(U8*)s++] & 077;
2146                         else
2147                             c = 0;
2148                         if (s < strend && ISUUCHAR(*s))
2149                             d = PL_uudmap[*(U8*)s++] & 077;
2150                         else
2151                             d = 0;
2152                         hunk[0] = (char)((a << 2) | (b >> 4));
2153                         hunk[1] = (char)((b << 4) | (c >> 2));
2154                         hunk[2] = (char)((c << 6) | d);
2155                         sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
2156                         len -= 3;
2157                     }
2158                     if (*s == '\n')
2159                         s++;
2160                     else        /* possible checksum byte */
2161                         if (s + 1 < strend && s[1] == '\n')
2162                             s += 2;
2163                 }
2164             }
2165             XPUSHs(sv);
2166             break;
2167         }
2168
2169         if (checksum) {
2170             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
2171               (checksum > bits_in_uv &&
2172                strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
2173                 NV trouble, anv;
2174
2175                 anv = (NV) (1 << (checksum & 15));
2176                 while (checksum >= 16) {
2177                     checksum -= 16;
2178                     anv *= 65536.0;
2179                 }
2180                 while (cdouble < 0.0)
2181                     cdouble += anv;
2182                 cdouble = Perl_modf(cdouble / anv, &trouble) * anv;
2183                 sv = newSVnv(cdouble);
2184             }
2185             else {
2186                 if (checksum < bits_in_uv) {
2187                     UV mask = ((UV)1 << checksum) - 1;
2188                     cuv &= mask;
2189                 }
2190                 sv = newSVuv(cuv);
2191             }
2192             XPUSHs(sv_2mortal(sv));
2193             checksum = 0;
2194         }
2195
2196         if (symptr->flags & FLAG_SLASH){
2197             if (SP - PL_stack_base - start_sp_offset <= 0)
2198                 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
2199             if( next_symbol(symptr) ){
2200               if( symptr->howlen == e_number )
2201                 Perl_croak(aTHX_ "Count after length/code in unpack" );
2202               if( beyond ){
2203                 /* ...end of char buffer then no decent length available */
2204                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
2205               } else {
2206                 /* take top of stack (hope it's numeric) */
2207                 len = POPi;
2208                 if( len < 0 )
2209                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
2210               }
2211             } else {
2212                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
2213             }
2214             datumtype = symptr->code;
2215             explicit_length = FALSE;
2216             goto redo_switch;
2217         }
2218     }
2219
2220     if (new_s)
2221         *new_s = s;
2222     PUTBACK;
2223     return SP - PL_stack_base - start_sp_offset;
2224 }
2225
2226 PP(pp_unpack)
2227 {
2228     dSP;
2229     dPOPPOPssrl;
2230     I32 gimme = GIMME_V;
2231     STRLEN llen;
2232     STRLEN rlen;
2233     char *pat = SvPV(left,  llen);
2234     char *s   = SvPV(right, rlen);
2235     char *strend = s + rlen;
2236     char *patend = pat + llen;
2237     I32 cnt;
2238
2239     PUTBACK;
2240     cnt = unpackstring(pat, patend, s, strend,
2241                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
2242                      | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0));
2243
2244     SPAGAIN;
2245     if ( !cnt && gimme == G_SCALAR )
2246        PUSHs(&PL_sv_undef);
2247     RETURN;
2248 }
2249
2250 STATIC U8 *
2251 doencodes(U8 *h, char *s, I32 len)
2252 {
2253     *h++ = PL_uuemap[len];
2254     while (len > 2) {
2255         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
2256         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))];
2257         *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
2258         *h++ = PL_uuemap[(077 & (s[2] & 077))];
2259         s += 3;
2260         len -= 3;
2261     }
2262     if (len > 0) {
2263         char r = (len > 1 ? s[1] : '\0');
2264         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
2265         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))];
2266         *h++ = PL_uuemap[(077 & ((r << 2) & 074))];
2267         *h++ = PL_uuemap[0];
2268     }
2269     *h++ = '\n';
2270     return h;
2271 }
2272
2273 STATIC SV *
2274 S_is_an_int(pTHX_ char *s, STRLEN l)
2275 {
2276   STRLEN         n_a;
2277   SV             *result = newSVpvn(s, l);
2278   char           *result_c = SvPV(result, n_a); /* convenience */
2279   char           *out = result_c;
2280   bool            skip = 1;
2281   bool            ignore = 0;
2282
2283   while (*s) {
2284     switch (*s) {
2285     case ' ':
2286       break;
2287     case '+':
2288       if (!skip) {
2289         SvREFCNT_dec(result);
2290         return (NULL);
2291       }
2292       break;
2293     case '0':
2294     case '1':
2295     case '2':
2296     case '3':
2297     case '4':
2298     case '5':
2299     case '6':
2300     case '7':
2301     case '8':
2302     case '9':
2303       skip = 0;
2304       if (!ignore) {
2305         *(out++) = *s;
2306       }
2307       break;
2308     case '.':
2309       ignore = 1;
2310       break;
2311     default:
2312       SvREFCNT_dec(result);
2313       return (NULL);
2314     }
2315     s++;
2316   }
2317   *(out++) = '\0';
2318   SvCUR_set(result, out - result_c);
2319   return (result);
2320 }
2321
2322 /* pnum must be '\0' terminated */
2323 STATIC int
2324 S_div128(pTHX_ SV *pnum, bool *done)
2325 {
2326   STRLEN          len;
2327   char           *s = SvPV(pnum, len);
2328   int             m = 0;
2329   int             r = 0;
2330   char           *t = s;
2331
2332   *done = 1;
2333   while (*t) {
2334     int             i;
2335
2336     i = m * 10 + (*t - '0');
2337     m = i & 0x7F;
2338     r = (i >> 7);               /* r < 10 */
2339     if (r) {
2340       *done = 0;
2341     }
2342     *(t++) = '0' + r;
2343   }
2344   *(t++) = '\0';
2345   SvCUR_set(pnum, (STRLEN) (t - s));
2346   return (m);
2347 }
2348
2349
2350
2351 /*
2352 =for apidoc pack_cat
2353
2354 The engine implementing pack() Perl function. Note: parameters next_in_list and
2355 flags are not used. This call should not be used; use packlist instead.
2356
2357 =cut */
2358
2359
2360 void
2361 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
2362 {
2363     tempsym_t sym = { 0 };
2364     sym.patptr = pat;
2365     sym.patend = patend;
2366     sym.flags  = FLAG_PACK;
2367
2368     (void)pack_rec( cat, &sym, beglist, endlist );
2369 }
2370
2371
2372 /*
2373 =for apidoc packlist
2374
2375 The engine implementing pack() Perl function.
2376
2377 =cut */
2378
2379
2380 void
2381 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
2382 {
2383     STRLEN no_len;
2384     tempsym_t sym = { 0 };
2385
2386     sym.patptr = pat;
2387     sym.patend = patend;
2388     sym.flags  = FLAG_PACK;
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(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     SvPVX(sv) = to_start;
2456     SvCUR(sv) = to_ptr - to_start;
2457     SvLEN(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                 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(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(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(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(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(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(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(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(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 */