pp_pack.c

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