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