pp_pack.c

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