pp_pack.c

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