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   const char *allowed = "";
 944
 945   symptr->flags &= ~FLAG_SLASH;
 946
 947   while (patptr < patend) {
 948     if (isSPACE(*patptr))
 949       patptr++;
 950     else if (*patptr == '#') {
 951       patptr++;
 952       while (patptr < patend && *patptr != '\n')
 953         patptr++;
 954       if (patptr < patend)
 955         patptr++;
 956     } else {
 957       /* We should have found a template code */
 958       I32 code = *patptr++ & 0xFF;
 959       U32 inherited_modifiers = 0;
 960
 961       if (code == ','){ /* grandfather in commas but with a warning */
 962         if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
 963           symptr->flags |= FLAG_COMMA;
 964           Perl_warner(aTHX_ packWARN(WARN_UNPACK),
 965                       "Invalid type ',' in %s", _action( symptr ) );
 966         }
 967         continue;
 968       }
 969
 970       /* for '(', skip to ')' */
 971       if (code == '(') {
 972         if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
 973           Perl_croak(aTHX_ "()-group starts with a count in %s",
 974                         _action( symptr ) );
 975         symptr->grpbeg = patptr;
 976         patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
 977         if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
 978           Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
 979                         _action( symptr ) );
 980       }
 981
 982       /* look for group modifiers to inherit */
 983       if (TYPE_ENDIANNESS(symptr->flags)) {
 984         if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
 985           inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
 986       }
 987
 988       /* look for modifiers */
 989       while (patptr < patend) {
 990         I32 modifier = 0;
 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             break;
1008         }
1009
1010         if (modifier == 0)
1011           break;
1012
1013         if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
1014           Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
1015                         allowed, _action( symptr ) );
1016
1017         if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
1018           Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
1019                      (int) TYPE_NO_MODIFIERS(code), _action( symptr ) );
1020         else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
1021                  TYPE_ENDIANNESS_MASK)
1022           Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
1023                      *patptr, _action( symptr ) );
1024
1025         if (ckWARN(WARN_UNPACK)) {
1026           if (code & modifier)
1027             Perl_warner(aTHX_ packWARN(WARN_UNPACK),
1028                         "Duplicate modifier '%c' after '%c' in %s",
1029                         *patptr, (int) TYPE_NO_MODIFIERS(code),
1030                         _action( symptr ) );
1031         }
1032
1033         code |= modifier;
1034         patptr++;
1035       }
1036
1037       /* inherit modifiers */
1038       code |= inherited_modifiers;
1039
1040       /* look for count and/or / */
1041       if (patptr < patend) {
1042         if (isDIGIT(*patptr)) {
1043           patptr = get_num( patptr, &symptr->length );
1044           symptr->howlen = e_number;
1045
1046         } else if (*patptr == '*') {
1047           patptr++;
1048           symptr->howlen = e_star;
1049
1050         } else if (*patptr == '[') {
1051           const char* lenptr = ++patptr;
1052           symptr->howlen = e_number;
1053           patptr = group_end( patptr, patend, ']' ) + 1;
1054           /* what kind of [] is it? */
1055           if (isDIGIT(*lenptr)) {
1056             lenptr = get_num( lenptr, &symptr->length );
1057             if( *lenptr != ']' )
1058               Perl_croak(aTHX_ "Malformed integer in [] in %s",
1059                             _action( symptr ) );
1060           } else {
1061             tempsym_t savsym = *symptr;
1062             symptr->patend = patptr-1;
1063             symptr->patptr = lenptr;
1064             savsym.length = measure_struct(symptr);
1065             *symptr = savsym;
1066           }
1067         } else {
1068           symptr->howlen = e_no_len;
1069           symptr->length = 1;
1070         }
1071
1072         /* try to find / */
1073         while (patptr < patend) {
1074           if (isSPACE(*patptr))
1075             patptr++;
1076           else if (*patptr == '#') {
1077             patptr++;
1078             while (patptr < patend && *patptr != '\n')
1079               patptr++;
1080             if (patptr < patend)
1081               patptr++;
1082           } else {
1083             if (*patptr == '/') {
1084               symptr->flags |= FLAG_SLASH;
1085               patptr++;
1086               if (patptr < patend &&
1087                   (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
1088                 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
1089                             _action( symptr ) );
1090             }
1091             break;
1092           }
1093         }
1094       } else {
1095         /* at end - no count, no / */
1096         symptr->howlen = e_no_len;
1097         symptr->length = 1;
1098       }
1099
1100       symptr->code = code;
1101       symptr->patptr = patptr;
1102       return TRUE;
1103     }
1104   }
1105   symptr->patptr = patptr;
1106   return FALSE;
1107 }
1108
1109 /*
1110    There is no way to cleanly handle the case where we should process the
1111    string per byte in its upgraded form while it's really in downgraded form
1112    (e.g. estimates like strend-s as an upper bound for the number of
1113    characters left wouldn't work). So if we foresee the need of this
1114    (pattern starts with U or contains U0), we want to work on the encoded
1115    version of the string. Users are advised to upgrade their pack string
1116    themselves if they need to do a lot of unpacks like this on it
1117 */
1118 /* XXX These can be const */
1119 STATIC bool
1120 need_utf8(const char *pat, const char *patend)
1121 {
1122     bool first = TRUE;
1123     while (pat < patend) {
1124         if (pat[0] == '#') {
1125             pat++;
1126             pat = (const char *) memchr(pat, '\n', patend-pat);
1127             if (!pat) return FALSE;
1128         } else if (pat[0] == 'U') {
1129             if (first || pat[1] == '0') return TRUE;
1130         } else first = FALSE;
1131         pat++;
1132     }
1133     return FALSE;
1134 }
1135
1136 STATIC char
1137 first_symbol(const char *pat, const char *patend) {
1138     while (pat < patend) {
1139         if (pat[0] != '#') return pat[0];
1140         pat++;
1141         pat = (const char *) memchr(pat, '\n', patend-pat);
1142         if (!pat) return 0;
1143         pat++;
1144     }
1145     return 0;
1146 }
1147
1148 /*
1149 =for apidoc unpack_str
1150
1151 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
1152 and ocnt are not used. This call should not be used, use unpackstring instead.
1153
1154 =cut */
1155
1156 I32
1157 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)
1158 {
1159     tempsym_t sym;
1160     (void)strbeg;
1161     (void)new_s;
1162     (void)ocnt;
1163
1164     if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8;
1165     else if (need_utf8(pat, patend)) {
1166         /* We probably should try to avoid this in case a scalar context call
1167            wouldn't get to the "U0" */
1168         STRLEN len = strend - s;
1169         s = (char *) bytes_to_utf8((U8 *) s, &len);
1170         SAVEFREEPV(s);
1171         strend = s + len;
1172         flags |= FLAG_DO_UTF8;
1173     }
1174
1175     if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8))
1176         flags |= FLAG_PARSE_UTF8;
1177
1178     TEMPSYM_INIT(&sym, pat, patend, flags);
1179
1180     return unpack_rec(&sym, s, s, strend, NULL );
1181 }
1182
1183 /*
1184 =for apidoc unpackstring
1185
1186 The engine implementing unpack() Perl function. C<unpackstring> puts the
1187 extracted list items on the stack and returns the number of elements.
1188 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
1189
1190 =cut */
1191
1192 I32
1193 Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, const char *strend, U32 flags)
1194 {
1195     tempsym_t sym;
1196
1197     if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8;
1198     else if (need_utf8(pat, patend)) {
1199         /* We probably should try to avoid this in case a scalar context call
1200            wouldn't get to the "U0" */
1201         STRLEN len = strend - s;
1202         s = (char *) bytes_to_utf8((U8 *) s, &len);
1203         SAVEFREEPV(s);
1204         strend = s + len;
1205         flags |= FLAG_DO_UTF8;
1206     }
1207
1208     if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8))
1209         flags |= FLAG_PARSE_UTF8;
1210
1211     TEMPSYM_INIT(&sym, pat, patend, flags);
1212
1213     return unpack_rec(&sym, s, s, strend, NULL );
1214 }
1215
1216 STATIC
1217 I32
1218 S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s )
1219 {
1220     dVAR; dSP;
1221     SV *sv;
1222     const I32 start_sp_offset = SP - PL_stack_base;
1223     howlen_t howlen;
1224
1225     I32 checksum = 0;
1226     UV cuv = 0;
1227     NV cdouble = 0.0;
1228     const int bits_in_uv = CHAR_BIT * sizeof(cuv);
1229     bool beyond = FALSE;
1230     bool explicit_length;
1231     const bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
1232     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
1233     symptr->strbeg = s - strbeg;
1234
1235     while (next_symbol(symptr)) {
1236         packprops_t props;
1237         I32 len;
1238         I32 datumtype = symptr->code;
1239         /* do first one only unless in list context
1240            / is implemented by unpacking the count, then popping it from the
1241            stack, so must check that we're not in the middle of a /  */
1242         if ( unpack_only_one
1243              && (SP - PL_stack_base == start_sp_offset + 1)
1244              && (datumtype != '/') )   /* XXX can this be omitted */
1245             break;
1246
1247         switch (howlen = symptr->howlen) {
1248           case e_star:
1249             len = strend - strbeg;      /* long enough */
1250             break;
1251           default:
1252             /* e_no_len and e_number */
1253             len = symptr->length;
1254             break;
1255         }
1256
1257         explicit_length = TRUE;
1258       redo_switch:
1259         beyond = s >= strend;
1260
1261         props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
1262         if (props) {
1263             /* props nonzero means we can process this letter. */
1264             const long size = props & PACK_SIZE_MASK;
1265             const long howmany = (strend - s) / size;
1266             if (len > howmany)
1267                 len = howmany;
1268
1269             if (!checksum || (props & PACK_SIZE_CANNOT_CSUM)) {
1270                 if (len && unpack_only_one) len = 1;
1271                 EXTEND(SP, len);
1272                 EXTEND_MORTAL(len);
1273             }
1274         }
1275
1276         switch(TYPE_NO_ENDIANNESS(datumtype)) {
1277         default:
1278             Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
1279
1280         case '%':
1281             if (howlen == e_no_len)
1282                 len = 16;               /* len is not specified */
1283             checksum = len;
1284             cuv = 0;
1285             cdouble = 0;
1286             continue;
1287             break;
1288         case '(':
1289         {
1290             tempsym_t savsym = *symptr;
1291             const U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
1292             symptr->flags |= group_modifiers;
1293             symptr->patend = savsym.grpend;
1294             symptr->previous = &savsym;
1295             symptr->level++;
1296             PUTBACK;
1297             while (len--) {
1298                 symptr->patptr = savsym.grpbeg;
1299                 if (utf8) symptr->flags |=  FLAG_PARSE_UTF8;
1300                 else      symptr->flags &= ~FLAG_PARSE_UTF8;
1301                 unpack_rec(symptr, s, strbeg, strend, &s);
1302                 if (s == strend && savsym.howlen == e_star)
1303                     break; /* No way to continue */
1304             }
1305             SPAGAIN;
1306             savsym.flags = symptr->flags & ~group_modifiers;
1307             *symptr = savsym;
1308             break;
1309         }
1310 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1311         case '.' | TYPE_IS_SHRIEKING:
1312 #endif
1313         case '.': {
1314             const char *from;
1315             SV *sv;
1316 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1317             const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING);
1318 #else /* PERL_PACK_CAN_SHRIEKSIGN */
1319             const bool u8 = utf8;
1320 #endif
1321             if (howlen == e_star) from = strbeg;
1322             else if (len <= 0) from = s;
1323             else {
1324                 tempsym_t *group = symptr;
1325
1326                 while (--len && group) group = group->previous;
1327                 from = group ? strbeg + group->strbeg : strbeg;
1328             }
1329             sv = from <= s ?
1330                 newSVuv(  u8 ? (UV) utf8_length((const U8*)from, (const U8*)s) : (UV) (s-from)) :
1331                 newSViv(-(u8 ? (IV) utf8_length((const U8*)s, (const U8*)from) : (IV) (from-s)));
1332             XPUSHs(sv_2mortal(sv));
1333             break;
1334         }
1335 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1336         case '@' | TYPE_IS_SHRIEKING:
1337 #endif
1338         case '@':
1339             s = strbeg + symptr->strbeg;
1340 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1341             if (utf8  && !(datumtype & TYPE_IS_SHRIEKING))
1342 #else /* PERL_PACK_CAN_SHRIEKSIGN */
1343             if (utf8)
1344 #endif
1345             {
1346                 while (len > 0) {
1347                     if (s >= strend)
1348                         Perl_croak(aTHX_ "'@' outside of string in unpack");
1349                     s += UTF8SKIP(s);
1350                     len--;
1351                 }
1352                 if (s > strend)
1353                     Perl_croak(aTHX_ "'@' outside of string with malformed UTF-8 in unpack");
1354             } else {
1355                 if (strend-s < len)
1356                     Perl_croak(aTHX_ "'@' outside of string in unpack");
1357                 s += len;
1358             }
1359             break;
1360         case 'X' | TYPE_IS_SHRIEKING:
1361             if (!len)                   /* Avoid division by 0 */
1362                 len = 1;
1363             if (utf8) {
1364                 const char *hop, *last;
1365                 I32 l = len;
1366                 hop = last = strbeg;
1367                 while (hop < s) {
1368                     hop += UTF8SKIP(hop);
1369                     if (--l == 0) {
1370                         last = hop;
1371                         l = len;
1372                     }
1373                 }
1374                 if (last > s)
1375                     Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1376                 s = last;
1377                 break;
1378             }
1379             len = (s - strbeg) % len;
1380             /* FALL THROUGH */
1381         case 'X':
1382             if (utf8) {
1383                 while (len > 0) {
1384                     if (s <= strbeg)
1385                         Perl_croak(aTHX_ "'X' outside of string in unpack");
1386                     while (--s, UTF8_IS_CONTINUATION(*s)) {
1387                         if (s <= strbeg)
1388                             Perl_croak(aTHX_ "'X' outside of string in unpack");
1389                     }
1390                     len--;
1391                 }
1392             } else {
1393                 if (len > s - strbeg)
1394                     Perl_croak(aTHX_ "'X' outside of string in unpack" );
1395                 s -= len;
1396             }
1397             break;
1398         case 'x' | TYPE_IS_SHRIEKING: {
1399             I32 ai32;
1400             if (!len)                   /* Avoid division by 0 */
1401                 len = 1;
1402             if (utf8) ai32 = utf8_length((U8 *) strbeg, (U8 *) s) % len;
1403             else      ai32 = (s - strbeg)                         % len;
1404             if (ai32 == 0) break;
1405             len -= ai32;
1406             }
1407             /* FALL THROUGH */
1408         case 'x':
1409             if (utf8) {
1410                 while (len>0) {
1411                     if (s >= strend)
1412                         Perl_croak(aTHX_ "'x' outside of string in unpack");
1413                     s += UTF8SKIP(s);
1414                     len--;
1415                 }
1416             } else {
1417                 if (len > strend - s)
1418                     Perl_croak(aTHX_ "'x' outside of string in unpack");
1419                 s += len;
1420             }
1421             break;
1422         case '/':
1423             Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1424             break;
1425         case 'A':
1426         case 'Z':
1427         case 'a':
1428             if (checksum) {
1429                 /* Preliminary length estimate is assumed done in 'W' */
1430                 if (len > strend - s) len = strend - s;
1431                 goto W_checksum;
1432             }
1433             if (utf8) {
1434                 I32 l;
1435                 const char *hop;
1436                 for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) {
1437                     if (hop >= strend) {
1438                         if (hop > strend)
1439                             Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1440                         break;
1441                     }
1442                 }
1443                 if (hop > strend)
1444                     Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1445                 len = hop - s;
1446             } else if (len > strend - s)
1447                 len = strend - s;
1448
1449             if (datumtype == 'Z') {
1450                 /* 'Z' strips stuff after first null */
1451                 const char *ptr, *end;
1452                 end = s + len;
1453                 for (ptr = s; ptr < end; ptr++) if (*ptr == 0) break;
1454                 sv = newSVpvn(s, ptr-s);
1455                 if (howlen == e_star) /* exact for 'Z*' */
1456                     len = ptr-s + (ptr != strend ? 1 : 0);
1457             } else if (datumtype == 'A') {
1458                 /* 'A' strips both nulls and spaces */
1459                 const char *ptr;
1460                 if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) {
1461                     for (ptr = s+len-1; ptr >= s; ptr--)
1462                         if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) &&
1463                             !is_utf8_space((U8 *) ptr)) break;
1464                     if (ptr >= s) ptr += UTF8SKIP(ptr);
1465                     else ptr++;
1466                     if (ptr > s+len)
1467                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1468                 } else {
1469                     for (ptr = s+len-1; ptr >= s; ptr--)
1470                         if (*ptr != 0 && !isSPACE(*ptr)) break;
1471                     ptr++;
1472                 }
1473                 sv = newSVpvn(s, ptr-s);
1474             } else sv = newSVpvn(s, len);
1475
1476             if (utf8) {
1477                 SvUTF8_on(sv);
1478                 /* Undo any upgrade done due to need_utf8() */
1479                 if (!(symptr->flags & FLAG_WAS_UTF8))
1480                     sv_utf8_downgrade(sv, 0);
1481             }
1482             XPUSHs(sv_2mortal(sv));
1483             s += len;
1484             break;
1485         case 'B':
1486         case 'b': {
1487             char *str;
1488             if (howlen == e_star || len > (strend - s) * 8)
1489                 len = (strend - s) * 8;
1490             if (checksum) {
1491                 if (!PL_bitcount) {
1492                     int bits;
1493                     Newz(601, PL_bitcount, 256, char);
1494                     for (bits = 1; bits < 256; bits++) {
1495                         if (bits & 1)   PL_bitcount[bits]++;
1496                         if (bits & 2)   PL_bitcount[bits]++;
1497                         if (bits & 4)   PL_bitcount[bits]++;
1498                         if (bits & 8)   PL_bitcount[bits]++;
1499                         if (bits & 16)  PL_bitcount[bits]++;
1500                         if (bits & 32)  PL_bitcount[bits]++;
1501                         if (bits & 64)  PL_bitcount[bits]++;
1502                         if (bits & 128) PL_bitcount[bits]++;
1503                     }
1504                 }
1505                 if (utf8)
1506                     while (len >= 8 && s < strend) {
1507                         cuv += PL_bitcount[uni_to_byte(aTHX_ &s, strend, datumtype)];
1508                         len -= 8;
1509                     }
1510                 else
1511                     while (len >= 8) {
1512                         cuv += PL_bitcount[*(U8 *)s++];
1513                         len -= 8;
1514                     }
1515                 if (len && s < strend) {
1516                     U8 bits;
1517                     bits = SHIFT_BYTE(utf8, s, strend, datumtype);
1518                     if (datumtype == 'b')
1519                         while (len-- > 0) {
1520                             if (bits & 1) cuv++;
1521                             bits >>= 1;
1522                         }
1523                     else
1524                         while (len-- > 0) {
1525                             if (bits & 0x80) cuv++;
1526                             bits <<= 1;
1527                         }
1528                 }
1529                 break;
1530             }
1531
1532             sv = sv_2mortal(NEWSV(35, len ? len : 1));
1533             SvPOK_on(sv);
1534             str = SvPVX(sv);
1535             if (datumtype == 'b') {
1536                 U8 bits = 0;
1537                 const I32 ai32 = len;
1538                 for (len = 0; len < ai32; len++) {
1539                     if (len & 7) bits >>= 1;
1540                     else if (utf8) {
1541                         if (s >= strend) break;
1542                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1543                     } else bits = *(U8 *) s++;
1544                     *str++ = bits & 1 ? '1' : '0';
1545                 }
1546             } else {
1547                 U8 bits = 0;
1548                 const I32 ai32 = len;
1549                 for (len = 0; len < ai32; len++) {
1550                     if (len & 7) bits <<= 1;
1551                     else if (utf8) {
1552                         if (s >= strend) break;
1553                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1554                     } else bits = *(U8 *) s++;
1555                     *str++ = bits & 0x80 ? '1' : '0';
1556                 }
1557             }
1558             *str = '\0';
1559             SvCUR_set(sv, str - SvPVX(sv));
1560             XPUSHs(sv);
1561             break;
1562         }
1563         case 'H':
1564         case 'h': {
1565             char *str;
1566             /* Preliminary length estimate, acceptable for utf8 too */
1567             if (howlen == e_star || len > (strend - s) * 2)
1568                 len = (strend - s) * 2;
1569             sv = sv_2mortal(NEWSV(35, len ? len : 1));
1570             SvPOK_on(sv);
1571             str = SvPVX(sv);
1572             if (datumtype == 'h') {
1573                 U8 bits = 0;
1574                 I32 ai32 = len;
1575                 for (len = 0; len < ai32; len++) {
1576                     if (len & 1) bits >>= 4;
1577                     else if (utf8) {
1578                         if (s >= strend) break;
1579                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1580                     } else bits = * (U8 *) s++;
1581                     *str++ = PL_hexdigit[bits & 15];
1582                 }
1583             } else {
1584                 U8 bits = 0;
1585                 const I32 ai32 = len;
1586                 for (len = 0; len < ai32; len++) {
1587                     if (len & 1) bits <<= 4;
1588                     else if (utf8) {
1589                         if (s >= strend) break;
1590                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1591                     } else bits = *(U8 *) s++;
1592                     *str++ = PL_hexdigit[(bits >> 4) & 15];
1593                 }
1594             }
1595             *str = '\0';
1596             SvCUR_set(sv, str - SvPVX(sv));
1597             XPUSHs(sv);
1598             break;
1599         }
1600         case 'c':
1601             while (len-- > 0) {
1602                 int aint = SHIFT_BYTE(utf8, s, strend, datumtype);
1603                 if (aint >= 128)        /* fake up signed chars */
1604                     aint -= 256;
1605                 if (!checksum)
1606                     PUSHs(sv_2mortal(newSViv((IV)aint)));
1607                 else if (checksum > bits_in_uv)
1608                     cdouble += (NV)aint;
1609                 else
1610                     cuv += aint;
1611             }
1612             break;
1613         case 'C':
1614         case 'W':
1615           W_checksum:
1616             if (len == 0) {
1617                 if (explicit_length && datumtype == 'C')
1618                     /* Switch to "character" mode */
1619                     utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
1620                 break;
1621             }
1622             if (datumtype == 'C' ?
1623                  (symptr->flags & FLAG_DO_UTF8) &&
1624                 !(symptr->flags & FLAG_WAS_UTF8) : utf8) {
1625                 while (len-- > 0 && s < strend) {
1626                     STRLEN retlen;
1627                     const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
1628                                          ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1629                     if (retlen == (STRLEN) -1 || retlen == 0)
1630                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1631                     s += retlen;
1632                     if (!checksum)
1633                         PUSHs(sv_2mortal(newSVuv((UV) val)));
1634                     else if (checksum > bits_in_uv)
1635                         cdouble += (NV) val;
1636                     else
1637                         cuv += val;
1638                 }
1639             } else if (!checksum)
1640                 while (len-- > 0) {
1641                     const U8 ch = *(U8 *) s++;
1642                     PUSHs(sv_2mortal(newSVuv((UV) ch)));
1643             }
1644             else if (checksum > bits_in_uv)
1645                 while (len-- > 0) cdouble += (NV) *(U8 *) s++;
1646             else
1647                 while (len-- > 0) cuv += *(U8 *) s++;
1648             break;
1649         case 'U':
1650             if (len == 0) {
1651                 if (explicit_length) {
1652                     /* Switch to "bytes in UTF-8" mode */
1653                     if (symptr->flags & FLAG_DO_UTF8) utf8 = 0;
1654                     else
1655                         /* Should be impossible due to the need_utf8() test */
1656                         Perl_croak(aTHX_ "U0 mode on a byte string");
1657                 }
1658                 break;
1659             }
1660             if (len > strend - s) len = strend - s;
1661             if (!checksum) {
1662                 if (len && unpack_only_one) len = 1;
1663                 EXTEND(SP, len);
1664                 EXTEND_MORTAL(len);
1665             }
1666             while (len-- > 0 && s < strend) {
1667                 STRLEN retlen;
1668                 UV auv;
1669                 if (utf8) {
1670                     U8 result[UTF8_MAXLEN];
1671                     const char *ptr = s;
1672                     STRLEN len;
1673                     /* Bug: warns about bad utf8 even if we are short on bytes
1674                        and will break out of the loop */
1675                     if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) result, 1,
1676                                       'U'))
1677                         break;
1678                     len = UTF8SKIP(result);
1679                     if (!uni_to_bytes(aTHX_ &ptr, strend,
1680                                       (char *) &result[1], len-1, 'U')) break;
1681                     auv = utf8n_to_uvuni(result, len, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
1682                     s = ptr;
1683                 } else {
1684                     auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
1685                     if (retlen == (STRLEN) -1 || retlen == 0)
1686                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1687                     s += retlen;
1688                 }
1689                 if (!checksum)
1690                     PUSHs(sv_2mortal(newSVuv((UV) auv)));
1691                 else if (checksum > bits_in_uv)
1692                     cdouble += (NV) auv;
1693                 else
1694                     cuv += auv;
1695             }
1696             break;
1697         case 's' | TYPE_IS_SHRIEKING:
1698 #if SHORTSIZE != SIZE16
1699             while (len-- > 0) {
1700                 short ashort;
1701                 SHIFT_VAR(utf8, s, strend, ashort, datumtype);
1702                 DO_BO_UNPACK(ashort, s);
1703                 if (!checksum)
1704                     PUSHs(sv_2mortal(newSViv((IV)ashort)));
1705                 else if (checksum > bits_in_uv)
1706                     cdouble += (NV)ashort;
1707                 else
1708                     cuv += ashort;
1709             }
1710             break;
1711 #else
1712             /* Fallthrough! */
1713 #endif
1714         case 's':
1715             while (len-- > 0) {
1716                 I16 ai16;
1717
1718 #if U16SIZE > SIZE16
1719                 ai16 = 0;
1720 #endif
1721                 SHIFT16(utf8, s, strend, &ai16, datumtype);
1722                 DO_BO_UNPACK(ai16, 16);
1723 #if U16SIZE > SIZE16
1724                 if (ai16 > 32767)
1725                     ai16 -= 65536;
1726 #endif
1727                 if (!checksum)
1728                     PUSHs(sv_2mortal(newSViv((IV)ai16)));
1729                 else if (checksum > bits_in_uv)
1730                     cdouble += (NV)ai16;
1731                 else
1732                     cuv += ai16;
1733             }
1734             break;
1735         case 'S' | TYPE_IS_SHRIEKING:
1736 #if SHORTSIZE != SIZE16
1737             while (len-- > 0) {
1738                 unsigned short aushort;
1739                 SHIFT_VAR(utf8, s, strend, aushort, datumtype);
1740                 DO_BO_UNPACK(aushort, s);
1741                 if (!checksum)
1742                     PUSHs(sv_2mortal(newSVuv((UV) aushort)));
1743                 else if (checksum > bits_in_uv)
1744                     cdouble += (NV)aushort;
1745                 else
1746                     cuv += aushort;
1747             }
1748             break;
1749 #else
1750             /* Fallhrough! */
1751 #endif
1752         case 'v':
1753         case 'n':
1754         case 'S':
1755             while (len-- > 0) {
1756                 U16 au16;
1757 #if U16SIZE > SIZE16
1758                 au16 = 0;
1759 #endif
1760                 SHIFT16(utf8, s, strend, &au16, datumtype);
1761                 DO_BO_UNPACK(au16, 16);
1762 #ifdef HAS_NTOHS
1763                 if (datumtype == 'n')
1764                     au16 = PerlSock_ntohs(au16);
1765 #endif
1766 #ifdef HAS_VTOHS
1767                 if (datumtype == 'v')
1768                     au16 = vtohs(au16);
1769 #endif
1770                 if (!checksum)
1771                     PUSHs(sv_2mortal(newSVuv((UV)au16)));
1772                 else if (checksum > bits_in_uv)
1773                     cdouble += (NV) au16;
1774                 else
1775                     cuv += au16;
1776             }
1777             break;
1778 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1779         case 'v' | TYPE_IS_SHRIEKING:
1780         case 'n' | TYPE_IS_SHRIEKING:
1781             while (len-- > 0) {
1782                 I16 ai16;
1783 # if U16SIZE > SIZE16
1784                 ai16 = 0;
1785 # endif
1786                 SHIFT16(utf8, s, strend, &ai16, datumtype);
1787 # ifdef HAS_NTOHS
1788                 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1789                     ai16 = (I16) PerlSock_ntohs((U16) ai16);
1790 # endif /* HAS_NTOHS */
1791 # ifdef HAS_VTOHS
1792                 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1793                     ai16 = (I16) vtohs((U16) ai16);
1794 # endif /* HAS_VTOHS */
1795                 if (!checksum)
1796                     PUSHs(sv_2mortal(newSViv((IV)ai16)));
1797                 else if (checksum > bits_in_uv)
1798                     cdouble += (NV) ai16;
1799                 else
1800                     cuv += ai16;
1801             }
1802             break;
1803 #endif /* PERL_PACK_CAN_SHRIEKSIGN */
1804         case 'i':
1805         case 'i' | TYPE_IS_SHRIEKING:
1806             while (len-- > 0) {
1807                 int aint;
1808                 SHIFT_VAR(utf8, s, strend, aint, datumtype);
1809                 DO_BO_UNPACK(aint, i);
1810                 if (!checksum)
1811                     PUSHs(sv_2mortal(newSViv((IV)aint)));
1812                 else if (checksum > bits_in_uv)
1813                     cdouble += (NV)aint;
1814                 else
1815                     cuv += aint;
1816             }
1817             break;
1818         case 'I':
1819         case 'I' | TYPE_IS_SHRIEKING:
1820             while (len-- > 0) {
1821                 unsigned int auint;
1822                 SHIFT_VAR(utf8, s, strend, auint, datumtype);
1823                 DO_BO_UNPACK(auint, i);
1824                 if (!checksum)
1825                     PUSHs(sv_2mortal(newSVuv((UV)auint)));
1826                 else if (checksum > bits_in_uv)
1827                     cdouble += (NV)auint;
1828                 else
1829                     cuv += auint;
1830             }
1831             break;
1832         case 'j':
1833             while (len-- > 0) {
1834                 IV aiv;
1835                 SHIFT_VAR(utf8, s, strend, aiv, datumtype);
1836 #if IVSIZE == INTSIZE
1837                 DO_BO_UNPACK(aiv, i);
1838 #elif IVSIZE == LONGSIZE
1839                 DO_BO_UNPACK(aiv, l);
1840 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1841                 DO_BO_UNPACK(aiv, 64);
1842 #else
1843                 Perl_croak(aTHX_ "'j' not supported on this platform");
1844 #endif
1845                 if (!checksum)
1846                     PUSHs(sv_2mortal(newSViv(aiv)));
1847                 else if (checksum > bits_in_uv)
1848                     cdouble += (NV)aiv;
1849                 else
1850                     cuv += aiv;
1851             }
1852             break;
1853         case 'J':
1854             while (len-- > 0) {
1855                 UV auv;
1856                 SHIFT_VAR(utf8, s, strend, auv, datumtype);
1857 #if IVSIZE == INTSIZE
1858                 DO_BO_UNPACK(auv, i);
1859 #elif IVSIZE == LONGSIZE
1860                 DO_BO_UNPACK(auv, l);
1861 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1862                 DO_BO_UNPACK(auv, 64);
1863 #else
1864                 Perl_croak(aTHX_ "'J' not supported on this platform");
1865 #endif
1866                 if (!checksum)
1867                     PUSHs(sv_2mortal(newSVuv(auv)));
1868                 else if (checksum > bits_in_uv)
1869                     cdouble += (NV)auv;
1870                 else
1871                     cuv += auv;
1872             }
1873             break;
1874         case 'l' | TYPE_IS_SHRIEKING:
1875 #if LONGSIZE != SIZE32
1876             while (len-- > 0) {
1877                 long along;
1878                 SHIFT_VAR(utf8, s, strend, along, datumtype);
1879                 DO_BO_UNPACK(along, l);
1880                 if (!checksum)
1881                     PUSHs(sv_2mortal(newSViv((IV)along)));
1882                 else if (checksum > bits_in_uv)
1883                     cdouble += (NV)along;
1884                 else
1885                     cuv += along;
1886             }
1887             break;
1888 #else
1889             /* Fallthrough! */
1890 #endif
1891         case 'l':
1892             while (len-- > 0) {
1893                 I32 ai32;
1894 #if U32SIZE > SIZE32
1895                 ai32 = 0;
1896 #endif
1897                 SHIFT32(utf8, s, strend, &ai32, datumtype);
1898                 DO_BO_UNPACK(ai32, 32);
1899 #if U32SIZE > SIZE32
1900                 if (ai32 > 2147483647) ai32 -= 4294967296;
1901 #endif
1902                 if (!checksum)
1903                     PUSHs(sv_2mortal(newSViv((IV)ai32)));
1904                 else if (checksum > bits_in_uv)
1905                     cdouble += (NV)ai32;
1906                 else
1907                     cuv += ai32;
1908             }
1909             break;
1910         case 'L' | TYPE_IS_SHRIEKING:
1911 #if LONGSIZE != SIZE32
1912             while (len-- > 0) {
1913                 unsigned long aulong;
1914                 SHIFT_VAR(utf8, s, strend, aulong, datumtype);
1915                 DO_BO_UNPACK(aulong, l);
1916                 if (!checksum)
1917                     PUSHs(sv_2mortal(newSVuv((UV)aulong)));
1918                 else if (checksum > bits_in_uv)
1919                     cdouble += (NV)aulong;
1920                 else
1921                     cuv += aulong;
1922             }
1923             break;
1924 #else
1925             /* Fall through! */
1926 #endif
1927         case 'V':
1928         case 'N':
1929         case 'L':
1930             while (len-- > 0) {
1931                 U32 au32;
1932 #if U32SIZE > SIZE32
1933                 au32 = 0;
1934 #endif
1935                 SHIFT32(utf8, s, strend, &au32, datumtype);
1936                 DO_BO_UNPACK(au32, 32);
1937 #ifdef HAS_NTOHL
1938                 if (datumtype == 'N')
1939                     au32 = PerlSock_ntohl(au32);
1940 #endif
1941 #ifdef HAS_VTOHL
1942                 if (datumtype == 'V')
1943                     au32 = vtohl(au32);
1944 #endif
1945                 if (!checksum)
1946                     PUSHs(sv_2mortal(newSVuv((UV)au32)));
1947                 else if (checksum > bits_in_uv)
1948                     cdouble += (NV)au32;
1949                 else
1950                     cuv += au32;
1951             }
1952             break;
1953 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1954         case 'V' | TYPE_IS_SHRIEKING:
1955         case 'N' | TYPE_IS_SHRIEKING:
1956             while (len-- > 0) {
1957                 I32 ai32;
1958 # if U32SIZE > SIZE32
1959                 ai32 = 0;
1960 # endif
1961                 SHIFT32(utf8, s, strend, &ai32, datumtype);
1962 # ifdef HAS_NTOHL
1963                 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1964                     ai32 = (I32)PerlSock_ntohl((U32)ai32);
1965 # endif
1966 # ifdef HAS_VTOHL
1967                 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1968                     ai32 = (I32)vtohl((U32)ai32);
1969 # endif
1970                 if (!checksum)
1971                     PUSHs(sv_2mortal(newSViv((IV)ai32)));
1972                 else if (checksum > bits_in_uv)
1973                     cdouble += (NV)ai32;
1974                 else
1975                     cuv += ai32;
1976             }
1977             break;
1978 #endif /* PERL_PACK_CAN_SHRIEKSIGN */
1979         case 'p':
1980             while (len-- > 0) {
1981                 const char *aptr;
1982                 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
1983                 DO_BO_UNPACK_PC(aptr);
1984                 /* newSVpv generates undef if aptr is NULL */
1985                 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1986             }
1987             break;
1988         case 'w':
1989             {
1990                 UV auv = 0;
1991                 U32 bytes = 0;
1992
1993                 while (len > 0 && s < strend) {
1994                     U8 ch;
1995                     ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1996                     auv = (auv << 7) | (ch & 0x7f);
1997                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1998                     if (ch < 0x80) {
1999                         bytes = 0;
2000                         PUSHs(sv_2mortal(newSVuv(auv)));
2001                         len--;
2002                         auv = 0;
2003                         continue;
2004                     }
2005                     if (++bytes >= sizeof(UV)) {        /* promote to string */
2006                         char *t;
2007                         STRLEN n_a;
2008
2009                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
2010                         while (s < strend) {
2011                             ch = SHIFT_BYTE(utf8, s, strend, datumtype);
2012                             sv = mul128(sv, (U8)(ch & 0x7f));
2013                             if (!(ch & 0x80)) {
2014                                 bytes = 0;
2015                                 break;
2016                             }
2017                         }
2018                         t = SvPV(sv, n_a);
2019                         while (*t == '0')
2020                             t++;
2021                         sv_chop(sv, t);
2022                         PUSHs(sv_2mortal(sv));
2023                         len--;
2024                         auv = 0;
2025                     }
2026                 }
2027                 if ((s >= strend) && bytes)
2028                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
2029             }
2030             break;
2031         case 'P':
2032             if (symptr->howlen == e_star)
2033                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
2034             EXTEND(SP, 1);
2035             if (sizeof(char*) <= strend - s) {
2036                 char *aptr;
2037                 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
2038                 DO_BO_UNPACK_PC(aptr);
2039                 /* newSVpvn generates undef if aptr is NULL */
2040                 PUSHs(sv_2mortal(newSVpvn(aptr, len)));
2041             }
2042             break;
2043 #ifdef HAS_QUAD
2044         case 'q':
2045             while (len-- > 0) {
2046                 Quad_t aquad;
2047                 SHIFT_VAR(utf8, s, strend, aquad, datumtype);
2048                 DO_BO_UNPACK(aquad, 64);
2049                 if (!checksum)
2050                     PUSHs(sv_2mortal(aquad >= IV_MIN && aquad <= IV_MAX ?
2051                                      newSViv((IV)aquad) : newSVnv((NV)aquad)));
2052                 else if (checksum > bits_in_uv)
2053                     cdouble += (NV)aquad;
2054                 else
2055                     cuv += aquad;
2056             }
2057             break;
2058         case 'Q':
2059             while (len-- > 0) {
2060                 Uquad_t auquad;
2061                 SHIFT_VAR(utf8, s, strend, auquad, datumtype);
2062                 DO_BO_UNPACK(auquad, 64);
2063                 if (!checksum)
2064                     PUSHs(sv_2mortal(auquad <= UV_MAX ?
2065                                      newSVuv((UV)auquad):newSVnv((NV)auquad)));
2066                 else if (checksum > bits_in_uv)
2067                     cdouble += (NV)auquad;
2068                 else
2069                     cuv += auquad;
2070             }
2071             break;
2072 #endif /* HAS_QUAD */
2073         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
2074         case 'f':
2075             while (len-- > 0) {
2076                 float afloat;
2077                 SHIFT_VAR(utf8, s, strend, afloat, datumtype);
2078                 DO_BO_UNPACK_N(afloat, float);
2079                 if (!checksum)
2080                     PUSHs(sv_2mortal(newSVnv((NV)afloat)));
2081                 else
2082                     cdouble += afloat;
2083             }
2084             break;
2085         case 'd':
2086             while (len-- > 0) {
2087                 double adouble;
2088                 SHIFT_VAR(utf8, s, strend, adouble, datumtype);
2089                 DO_BO_UNPACK_N(adouble, double);
2090                 if (!checksum)
2091                     PUSHs(sv_2mortal(newSVnv((NV)adouble)));
2092                 else
2093                     cdouble += adouble;
2094             }
2095             break;
2096         case 'F':
2097             while (len-- > 0) {
2098                 NV anv;
2099                 SHIFT_VAR(utf8, s, strend, anv, datumtype);
2100                 DO_BO_UNPACK_N(anv, NV);
2101                 if (!checksum)
2102                     PUSHs(sv_2mortal(newSVnv(anv)));
2103                 else
2104                     cdouble += anv;
2105             }
2106             break;
2107 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2108         case 'D':
2109             while (len-- > 0) {
2110                 long double aldouble;
2111                 SHIFT_VAR(utf8, s, strend, aldouble, datumtype);
2112                 DO_BO_UNPACK_N(aldouble, long double);
2113                 if (!checksum)
2114                     PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
2115                 else
2116                     cdouble += aldouble;
2117             }
2118             break;
2119 #endif
2120         case 'u':
2121             /* MKS:
2122              * Initialise the decode mapping.  By using a table driven
2123              * algorithm, the code will be character-set independent
2124              * (and just as fast as doing character arithmetic)
2125              */
2126             if (PL_uudmap['M'] == 0) {
2127                 int i;
2128
2129                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
2130                     PL_uudmap[(U8)PL_uuemap[i]] = i;
2131                 /*
2132                  * Because ' ' and '`' map to the same value,
2133                  * we need to decode them both the same.
2134                  */
2135                 PL_uudmap[' '] = 0;
2136             }
2137             {
2138                 const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
2139                 sv = sv_2mortal(NEWSV(42, l));
2140                 if (l) SvPOK_on(sv);
2141             }
2142             if (utf8) {
2143                 while (next_uni_uu(aTHX_ &s, strend, &len)) {
2144                     I32 a, b, c, d;
2145                     char hunk[4];
2146
2147                     hunk[3] = '\0';
2148                     while (len > 0) {
2149                         next_uni_uu(aTHX_ &s, strend, &a);
2150                         next_uni_uu(aTHX_ &s, strend, &b);
2151                         next_uni_uu(aTHX_ &s, strend, &c);
2152                         next_uni_uu(aTHX_ &s, strend, &d);
2153                         hunk[0] = (char)((a << 2) | (b >> 4));
2154                         hunk[1] = (char)((b << 4) | (c >> 2));
2155                         hunk[2] = (char)((c << 6) | d);
2156                         sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
2157                         len -= 3;
2158                     }
2159                     if (s < strend) {
2160                         if (*s == '\n') {
2161                             s++;
2162                         }
2163                         else {
2164                             /* possible checksum byte */
2165                             const char *skip = s+UTF8SKIP(s);
2166                             if (skip < strend && *skip == '\n')
2167                                 s = skip+1;
2168                         }
2169                     }
2170                 }
2171             } else {
2172                 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
2173                     I32 a, b, c, d;
2174                     char hunk[4];
2175
2176                     hunk[3] = '\0';
2177                     len = PL_uudmap[*(U8*)s++] & 077;
2178                     while (len > 0) {
2179                         if (s < strend && ISUUCHAR(*s))
2180                             a = PL_uudmap[*(U8*)s++] & 077;
2181                         else
2182                             a = 0;
2183                         if (s < strend && ISUUCHAR(*s))
2184                             b = PL_uudmap[*(U8*)s++] & 077;
2185                         else
2186                             b = 0;
2187                         if (s < strend && ISUUCHAR(*s))
2188                             c = PL_uudmap[*(U8*)s++] & 077;
2189                         else
2190                             c = 0;
2191                         if (s < strend && ISUUCHAR(*s))
2192                             d = PL_uudmap[*(U8*)s++] & 077;
2193                         else
2194                             d = 0;
2195                         hunk[0] = (char)((a << 2) | (b >> 4));
2196                         hunk[1] = (char)((b << 4) | (c >> 2));
2197                         hunk[2] = (char)((c << 6) | d);
2198                         sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
2199                         len -= 3;
2200                     }
2201                     if (*s == '\n')
2202                         s++;
2203                     else        /* possible checksum byte */
2204                         if (s + 1 < strend && s[1] == '\n')
2205                             s += 2;
2206                 }
2207             }
2208             XPUSHs(sv);
2209             break;
2210         }
2211
2212         if (checksum) {
2213             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
2214               (checksum > bits_in_uv &&
2215                strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
2216                 NV trouble, anv;
2217
2218                 anv = (NV) (1 << (checksum & 15));
2219                 while (checksum >= 16) {
2220                     checksum -= 16;
2221                     anv *= 65536.0;
2222                 }
2223                 while (cdouble < 0.0)
2224                     cdouble += anv;
2225                 cdouble = Perl_modf(cdouble / anv, &trouble) * anv;
2226                 sv = newSVnv(cdouble);
2227             }
2228             else {
2229                 if (checksum < bits_in_uv) {
2230                     UV mask = ((UV)1 << checksum) - 1;
2231                     cuv &= mask;
2232                 }
2233                 sv = newSVuv(cuv);
2234             }
2235             XPUSHs(sv_2mortal(sv));
2236             checksum = 0;
2237         }
2238
2239         if (symptr->flags & FLAG_SLASH){
2240             if (SP - PL_stack_base - start_sp_offset <= 0)
2241                 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
2242             if( next_symbol(symptr) ){
2243               if( symptr->howlen == e_number )
2244                 Perl_croak(aTHX_ "Count after length/code in unpack" );
2245               if( beyond ){
2246                 /* ...end of char buffer then no decent length available */
2247                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
2248               } else {
2249                 /* take top of stack (hope it's numeric) */
2250                 len = POPi;
2251                 if( len < 0 )
2252                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
2253               }
2254             } else {
2255                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
2256             }
2257             datumtype = symptr->code;
2258             explicit_length = FALSE;
2259             goto redo_switch;
2260         }
2261     }
2262
2263     if (new_s)
2264         *new_s = s;
2265     PUTBACK;
2266     return SP - PL_stack_base - start_sp_offset;
2267 }
2268
2269 PP(pp_unpack)
2270 {
2271     dSP;
2272     dPOPPOPssrl;
2273     I32 gimme = GIMME_V;
2274     STRLEN llen;
2275     STRLEN rlen;
2276     const char *pat = SvPV(left,  llen);
2277     const char *s   = SvPV(right, rlen);
2278     const char *strend = s + rlen;
2279     const char *patend = pat + llen;
2280     I32 cnt;
2281
2282     PUTBACK;
2283     cnt = unpackstring(pat, patend, s, strend,
2284                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
2285                      | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0));
2286
2287     SPAGAIN;
2288     if ( !cnt && gimme == G_SCALAR )
2289        PUSHs(&PL_sv_undef);
2290     RETURN;
2291 }
2292
2293 STATIC U8 *
2294 doencodes(U8 *h, const char *s, I32 len)
2295 {
2296     *h++ = PL_uuemap[len];
2297     while (len > 2) {
2298         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
2299         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))];
2300         *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
2301         *h++ = PL_uuemap[(077 & (s[2] & 077))];
2302         s += 3;
2303         len -= 3;
2304     }
2305     if (len > 0) {
2306         const char r = (len > 1 ? s[1] : '\0');
2307         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
2308         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))];
2309         *h++ = PL_uuemap[(077 & ((r << 2) & 074))];
2310         *h++ = PL_uuemap[0];
2311     }
2312     *h++ = '\n';
2313     return h;
2314 }
2315
2316 STATIC SV *
2317 S_is_an_int(pTHX_ const char *s, STRLEN l)
2318 {
2319   STRLEN         n_a;
2320   SV             *result = newSVpvn(s, l);
2321   char           *result_c = SvPV(result, n_a); /* convenience */
2322   char           *out = result_c;
2323   bool            skip = 1;
2324   bool            ignore = 0;
2325
2326   while (*s) {
2327     switch (*s) {
2328     case ' ':
2329       break;
2330     case '+':
2331       if (!skip) {
2332         SvREFCNT_dec(result);
2333         return (NULL);
2334       }
2335       break;
2336     case '0':
2337     case '1':
2338     case '2':
2339     case '3':
2340     case '4':
2341     case '5':
2342     case '6':
2343     case '7':
2344     case '8':
2345     case '9':
2346       skip = 0;
2347       if (!ignore) {
2348         *(out++) = *s;
2349       }
2350       break;
2351     case '.':
2352       ignore = 1;
2353       break;
2354     default:
2355       SvREFCNT_dec(result);
2356       return (NULL);
2357     }
2358     s++;
2359   }
2360   *(out++) = '\0';
2361   SvCUR_set(result, out - result_c);
2362   return (result);
2363 }
2364
2365 /* pnum must be '\0' terminated */
2366 STATIC int
2367 S_div128(pTHX_ SV *pnum, bool *done)
2368 {
2369   STRLEN          len;
2370   char           *s = SvPV(pnum, len);
2371   int             m = 0;
2372   int             r = 0;
2373   char           *t = s;
2374
2375   *done = 1;
2376   while (*t) {
2377     const int i = m * 10 + (*t - '0');
2378     m = i & 0x7F;
2379     r = (i >> 7);               /* r < 10 */
2380     if (r) {
2381       *done = 0;
2382     }
2383     *(t++) = '0' + r;
2384   }
2385   *(t++) = '\0';
2386   SvCUR_set(pnum, (STRLEN) (t - s));
2387   return (m);
2388 }
2389
2390 /*
2391 =for apidoc pack_cat
2392
2393 The engine implementing pack() Perl function. Note: parameters next_in_list and
2394 flags are not used. This call should not be used; use packlist instead.
2395
2396 =cut */
2397
2398
2399 void
2400 Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
2401 {
2402     tempsym_t sym;
2403     (void)next_in_list;
2404     (void)flags;
2405
2406     TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
2407
2408     (void)pack_rec( cat, &sym, beglist, endlist );
2409 }
2410
2411
2412 /*
2413 =for apidoc packlist
2414
2415 The engine implementing pack() Perl function.
2416
2417 =cut */
2418
2419
2420 void
2421 Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist )
2422 {
2423     STRLEN no_len;
2424     tempsym_t sym;
2425
2426     TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
2427
2428     /* We're going to do changes through SvPVX(cat). Make sure it's valid.
2429        Also make sure any UTF8 flag is loaded */
2430     SvPV_force(cat, no_len);
2431     if (DO_UTF8(cat)) sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8;
2432
2433     (void)pack_rec( cat, &sym, beglist, endlist );
2434 }
2435
2436 /* like sv_utf8_upgrade, but also repoint the group start markers */
2437 STATIC void
2438 marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) {
2439     STRLEN len;
2440     tempsym_t *group;
2441     const char *from_ptr, *from_start, *from_end, **marks, **m;
2442     char *to_start, *to_ptr;
2443
2444     if (SvUTF8(sv)) return;
2445
2446     from_start = SvPVX(sv);
2447     from_end = from_start + SvCUR(sv);
2448     for (from_ptr = from_start; from_ptr < from_end; from_ptr++)
2449         if (!NATIVE_IS_INVARIANT(*from_ptr)) break;
2450     if (from_ptr == from_end) {
2451         /* Simple case: no character needs to be changed */
2452         SvUTF8_on(sv);
2453         return;
2454     }
2455
2456     len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1;
2457     New('U', to_start, len, char);
2458     Copy(from_start, to_start, from_ptr-from_start, char);
2459     to_ptr = to_start + (from_ptr-from_start);
2460
2461     New('U', marks, sym_ptr->level+2, const char *);
2462     for (group=sym_ptr; group; group = group->previous)
2463         marks[group->level] = from_start + group->strbeg;
2464     marks[sym_ptr->level+1] = from_end+1;
2465     for (m = marks; *m < from_ptr; m++)
2466         *m = to_start + (*m-from_start);
2467
2468     for (;from_ptr < from_end; from_ptr++) {
2469         while (*m == from_ptr) *m++ = to_ptr;
2470         to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr);
2471     }
2472     *to_ptr = 0;
2473
2474     while (*m == from_ptr) *m++ = to_ptr;
2475     if (m != marks + sym_ptr->level+1) {
2476         Safefree(marks);
2477         Safefree(to_start);
2478         Perl_croak(aTHX_ "Assertion: marks beyond string end");
2479     }
2480     for (group=sym_ptr; group; group = group->previous)
2481         group->strbeg = marks[group->level] - to_start;
2482     Safefree(marks);
2483
2484     if (SvOOK(sv)) {
2485         if (SvIVX(sv)) {
2486             SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2487             from_start -= SvIVX(sv);
2488             SvIV_set(sv, 0);
2489         }
2490         SvFLAGS(sv) &= ~SVf_OOK;
2491     }
2492     if (SvLEN(sv) != 0)
2493         Safefree(from_start);
2494     SvPV_set(sv, to_start);
2495     SvCUR_set(sv, to_ptr - to_start);
2496     SvLEN_set(sv, len);
2497     SvUTF8_on(sv);
2498 }
2499
2500 /* Exponential string grower. Makes string extension effectively O(n)
2501    needed says how many extra bytes we need (not counting the final '\0')
2502    Only grows the string if there is an actual lack of space
2503 */
2504 STATIC char *
2505 sv_exp_grow(pTHX_ SV *sv, STRLEN needed) {
2506     const STRLEN cur = SvCUR(sv);
2507     const STRLEN len = SvLEN(sv);
2508     STRLEN extend;
2509     if (len - cur > needed) return SvPVX(sv);
2510     extend = needed > len ? needed : len;
2511     return SvGROW(sv, len+extend+1);
2512 }
2513
2514 STATIC
2515 SV **
2516 S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
2517 {
2518     tempsym_t lookahead;
2519     I32 items  = endlist - beglist;
2520     bool found = next_symbol(symptr);
2521     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
2522
2523     if (symptr->level == 0 && found && symptr->code == 'U') {
2524         marked_upgrade(aTHX_ cat, symptr);
2525         symptr->flags |= FLAG_DO_UTF8;
2526         utf8 = 0;
2527     }
2528     symptr->strbeg = SvCUR(cat);
2529
2530     while (found) {
2531         SV *fromstr;
2532         STRLEN fromlen;
2533         I32 len;
2534         SV *lengthcode = Nullsv;
2535         I32 datumtype = symptr->code;
2536         howlen_t howlen = symptr->howlen;
2537         char *start = SvPVX(cat);
2538         char *cur   = start + SvCUR(cat);
2539
2540 #define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2541
2542         switch (howlen) {
2543           case e_star:
2544             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ?
2545                 0 : items;
2546             break;
2547           default:
2548             /* e_no_len and e_number */
2549             len = symptr->length;
2550             break;
2551         }
2552
2553         if (len) {
2554             packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
2555
2556             if (props && !(props & PACK_SIZE_UNPREDICTABLE)) {
2557                 /* We can process this letter. */
2558                 STRLEN size = props & PACK_SIZE_MASK;
2559                 GROWING(utf8, cat, start, cur, (STRLEN) len * size);
2560             }
2561         }
2562
2563         /* Look ahead for next symbol. Do we have code/code? */
2564         lookahead = *symptr;
2565         found = next_symbol(&lookahead);
2566         if (symptr->flags & FLAG_SLASH) {
2567             IV count;
2568             if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack");
2569             if (strchr("aAZ", lookahead.code)) {
2570                 if (lookahead.howlen == e_number) count = lookahead.length;
2571                 else {
2572                     if (items > 0)
2573                         count = DO_UTF8(*beglist) ?
2574                             sv_len_utf8(*beglist) : sv_len(*beglist);
2575                     else count = 0;
2576                     if (lookahead.code == 'Z') count++;
2577                 }
2578             } else {
2579                 if (lookahead.howlen == e_number && lookahead.length < items)
2580                     count = lookahead.length;
2581                 else count = items;
2582             }
2583             lookahead.howlen = e_number;
2584             lookahead.length = count;
2585             lengthcode = sv_2mortal(newSViv(count));
2586         }
2587
2588         /* Code inside the switch must take care to properly update
2589            cat (CUR length and '\0' termination) if it updated *cur and
2590            doesn't simply leave using break */
2591         switch(TYPE_NO_ENDIANNESS(datumtype)) {
2592         default:
2593             Perl_croak(aTHX_ "Invalid type '%c' in pack",
2594                        (int) TYPE_NO_MODIFIERS(datumtype));
2595         case '%':
2596             Perl_croak(aTHX_ "'%%' may not be used in pack");
2597         {
2598             char *from;
2599 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2600         case '.' | TYPE_IS_SHRIEKING:
2601 #endif
2602         case '.':
2603             if (howlen == e_star) from = start;
2604             else if (len == 0) from = cur;
2605             else {
2606                 tempsym_t *group = symptr;
2607
2608                 while (--len && group) group = group->previous;
2609                 from = group ? start + group->strbeg : start;
2610             }
2611             fromstr = NEXTFROM;
2612             len = SvIV(fromstr);
2613             goto resize;
2614 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2615         case '@' | TYPE_IS_SHRIEKING:
2616 #endif
2617         case '@':
2618             from = start + symptr->strbeg;
2619           resize:
2620 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2621             if (utf8  && !(datumtype & TYPE_IS_SHRIEKING))
2622 #else /* PERL_PACK_CAN_SHRIEKSIGN */
2623             if (utf8)
2624 #endif
2625                 if (len >= 0) {
2626                     while (len && from < cur) {
2627                         from += UTF8SKIP(from);
2628                         len--;
2629                     }
2630                     if (from > cur)
2631                         Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2632                     if (len) {
2633                         /* Here we know from == cur */
2634                       grow:
2635                         GROWING(0, cat, start, cur, len);
2636                         Zero(cur, len, char);
2637                         cur += len;
2638                     } else if (from < cur) {
2639                         len = cur - from;
2640                         goto shrink;
2641                     } else goto no_change;
2642                 } else {
2643                     cur = from;
2644                     len = -len;
2645                     goto utf8_shrink;
2646                 }
2647             else {
2648                 len -= cur - from;
2649                 if (len > 0) goto grow;
2650                 if (len == 0) goto no_change;
2651                 len = -len;
2652                 goto shrink;
2653             }
2654             break;
2655         }
2656         case '(': {
2657             tempsym_t savsym = *symptr;
2658             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2659             symptr->flags |= group_modifiers;
2660             symptr->patend = savsym.grpend;
2661             symptr->level++;
2662             symptr->previous = &lookahead;
2663             while (len--) {
2664                 U32 was_utf8;
2665                 if (utf8) symptr->flags |=  FLAG_PARSE_UTF8;
2666                 else      symptr->flags &= ~FLAG_PARSE_UTF8;
2667                 was_utf8 = SvUTF8(cat);
2668                 symptr->patptr = savsym.grpbeg;
2669                 beglist = pack_rec(cat, symptr, beglist, endlist);
2670                 if (SvUTF8(cat) != was_utf8)
2671                     /* This had better be an upgrade while in utf8==0 mode */
2672                     utf8 = 1;
2673
2674                 if (savsym.howlen == e_star && beglist == endlist)
2675                     break;              /* No way to continue */
2676             }
2677             lookahead.flags  = symptr->flags & ~group_modifiers;
2678             goto no_change;
2679         }
2680         case 'X' | TYPE_IS_SHRIEKING:
2681             if (!len)                   /* Avoid division by 0 */
2682                 len = 1;
2683             if (utf8) {
2684                 char *hop, *last;
2685                 I32 l = len;
2686                 hop = last = start;
2687                 while (hop < cur) {
2688                     hop += UTF8SKIP(hop);
2689                     if (--l == 0) {
2690                         last = hop;
2691                         l = len;
2692                     }
2693                 }
2694                 if (last > cur)
2695                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2696                 cur = last;
2697                 break;
2698             }
2699             len = (cur-start) % len;
2700             /* FALL THROUGH */
2701         case 'X':
2702             if (utf8) {
2703                 if (len < 1) goto no_change;
2704               utf8_shrink:
2705                 while (len > 0) {
2706                     if (cur <= start)
2707                         Perl_croak(aTHX_ "'%c' outside of string in pack",
2708                                    (int) TYPE_NO_MODIFIERS(datumtype));
2709                     while (--cur, UTF8_IS_CONTINUATION(*cur)) {
2710                         if (cur <= start)
2711                             Perl_croak(aTHX_ "'%c' outside of string in pack",
2712                                        (int) TYPE_NO_MODIFIERS(datumtype));
2713                     }
2714                     len--;
2715                 }
2716             } else {
2717               shrink:
2718                 if (cur - start < len)
2719                     Perl_croak(aTHX_ "'%c' outside of string in pack",
2720                                (int) TYPE_NO_MODIFIERS(datumtype));
2721                 cur -= len;
2722             }
2723             if (cur < start+symptr->strbeg) {
2724                 /* Make sure group starts don't point into the void */
2725                 tempsym_t *group;
2726                 const STRLEN length = cur-start;
2727                 for (group = symptr;
2728                      group && length < group->strbeg;
2729                      group = group->previous) group->strbeg = length;
2730                 lookahead.strbeg = length;
2731             }
2732             break;
2733         case 'x' | TYPE_IS_SHRIEKING: {
2734             I32 ai32;
2735             if (!len)                   /* Avoid division by 0 */
2736                 len = 1;
2737             if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len;
2738             else      ai32 = (cur - start) % len;
2739             if (ai32 == 0) goto no_change;
2740             len -= ai32;
2741         }
2742         /* FALL THROUGH */
2743         case 'x':
2744             goto grow;
2745         case 'A':
2746         case 'Z':
2747         case 'a': {
2748             const char *aptr;
2749
2750             fromstr = NEXTFROM;
2751             aptr = SvPV(fromstr, fromlen);
2752             if (DO_UTF8(fromstr)) {
2753                 const char *end, *s;
2754
2755                 if (!utf8 && !SvUTF8(cat)) {
2756                     marked_upgrade(aTHX_ cat, symptr);
2757                     lookahead.flags |= FLAG_DO_UTF8;
2758                     lookahead.strbeg = symptr->strbeg;
2759                     utf8 = 1;
2760                     start = SvPVX(cat);
2761                     cur = start + SvCUR(cat);
2762                 }
2763                 if (howlen == e_star) {
2764                     if (utf8) goto string_copy;
2765                     len = fromlen+1;
2766                 }
2767                 s = aptr;
2768                 end = aptr + fromlen;
2769                 fromlen = datumtype == 'Z' ? len-1 : len;
2770                 while ((I32) fromlen > 0 && s < end) {
2771                     s += UTF8SKIP(s);
2772                     fromlen--;
2773                 }
2774                 if (s > end)
2775                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2776                 if (utf8) {
2777                     len = fromlen;
2778                     if (datumtype == 'Z') len++;
2779                     fromlen = s-aptr;
2780                     len += fromlen;
2781
2782                     goto string_copy;
2783                 }
2784                 fromlen = len - fromlen;
2785                 if (datumtype == 'Z') fromlen--;
2786                 if (howlen == e_star) {
2787                     len = fromlen;
2788                     if (datumtype == 'Z') len++;
2789                 }
2790                 GROWING(0, cat, start, cur, len);
2791                 if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
2792                                   datumtype | TYPE_IS_PACK))
2793                     Perl_croak(aTHX_ "Perl bug: predicted utf8 length not available");
2794                 cur += fromlen;
2795                 len -= fromlen;
2796             } else if (utf8) {
2797                 if (howlen == e_star) {
2798                     len = fromlen;
2799                     if (datumtype == 'Z') len++;
2800                 }
2801                 if (len <= (I32) fromlen) {
2802                     fromlen = len;
2803                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2804                 }
2805                 /* assumes a byte expands to at most UTF8_EXPAND bytes on
2806                    upgrade, so:
2807                    expected_length <= from_len*UTF8_EXPAND + (len-from_len) */
2808                 GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len);
2809                 len -= fromlen;
2810                 while (fromlen > 0) {
2811                     cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr);
2812                     aptr++;
2813                     fromlen--;
2814                 }
2815             } else {
2816               string_copy:
2817                 if (howlen == e_star) {
2818                     len = fromlen;
2819                     if (datumtype == 'Z') len++;
2820                 }
2821                 if (len <= (I32) fromlen) {
2822                     fromlen = len;
2823                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2824                 }
2825                 GROWING(0, cat, start, cur, len);
2826                 Copy(aptr, cur, fromlen, char);
2827                 cur += fromlen;
2828                 len -= fromlen;
2829             }
2830             memset(cur, datumtype == 'A' ? ' ' : '\0', len);
2831             cur += len;
2832             break;
2833         }
2834         case 'B':
2835         case 'b': {
2836             char *str, *end;
2837             I32 l, field_len;
2838             U8 bits;
2839             bool utf8_source;
2840             U32 utf8_flags;
2841
2842             fromstr = NEXTFROM;
2843             str = SvPV(fromstr, fromlen);
2844             end = str + fromlen;
2845             if (DO_UTF8(fromstr)) {
2846                 utf8_source = TRUE;
2847                 utf8_flags  = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
2848             } else {
2849                 utf8_source = FALSE;
2850                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2851             }
2852             if (howlen == e_star) len = fromlen;
2853             field_len = (len+7)/8;
2854             GROWING(utf8, cat, start, cur, field_len);
2855             if (len > (I32)fromlen) len = fromlen;
2856             bits = 0;
2857             l = 0;
2858             if (datumtype == 'B')
2859                 while (l++ < len) {
2860                     if (utf8_source) {
2861                         UV val;
2862                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2863                         bits |= val & 1;
2864                     } else bits |= *str++ & 1;
2865                     if (l & 7) bits <<= 1;
2866                     else {
2867                         PUSH_BYTE(utf8, cur, bits);
2868                         bits = 0;
2869                     }
2870                 }
2871             else
2872                 /* datumtype == 'b' */
2873                 while (l++ < len) {
2874                     if (utf8_source) {
2875                         UV val;
2876                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2877                         if (val & 1) bits |= 0x80;
2878                     } else if (*str++ & 1)
2879                         bits |= 0x80;
2880                     if (l & 7) bits >>= 1;
2881                     else {
2882                         PUSH_BYTE(utf8, cur, bits);
2883                         bits = 0;
2884                     }
2885                 }
2886             l--;
2887             if (l & 7) {
2888                 if (datumtype == 'B')
2889                     bits <<= 7 - (l & 7);
2890                 else
2891                     bits >>= 7 - (l & 7);
2892                 PUSH_BYTE(utf8, cur, bits);
2893                 l += 7;
2894             }
2895             /* Determine how many chars are left in the requested field */
2896             l /= 8;
2897             if (howlen == e_star) field_len = 0;
2898             else field_len -= l;
2899             Zero(cur, field_len, char);
2900             cur += field_len;
2901             break;
2902         }
2903         case 'H':
2904         case 'h': {
2905             char *str, *end;
2906             I32 l, field_len;
2907             U8 bits;
2908             bool utf8_source;
2909             U32 utf8_flags;
2910
2911             fromstr = NEXTFROM;
2912             str = SvPV(fromstr, fromlen);
2913             end = str + fromlen;
2914             if (DO_UTF8(fromstr)) {
2915                 utf8_source = TRUE;
2916                 utf8_flags  = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
2917             } else {
2918                 utf8_source = FALSE;
2919                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2920             }
2921             if (howlen == e_star) len = fromlen;
2922             field_len = (len+1)/2;
2923             GROWING(utf8, cat, start, cur, field_len);
2924             if (!utf8 && len > (I32)fromlen) len = fromlen;
2925             bits = 0;
2926             l = 0;
2927             if (datumtype == 'H')
2928                 while (l++ < len) {
2929                     if (utf8_source) {
2930                         UV val;
2931                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2932                         if (val < 256 && isALPHA(val))
2933                             bits |= (val + 9) & 0xf;
2934                         else
2935                             bits |= val & 0xf;
2936                     } else if (isALPHA(*str))
2937                         bits |= (*str++ + 9) & 0xf;
2938                     else
2939                         bits |= *str++ & 0xf;
2940                     if (l & 1) bits <<= 4;
2941                     else {
2942                         PUSH_BYTE(utf8, cur, bits);
2943                         bits = 0;
2944                     }
2945                 }
2946             else
2947                 while (l++ < len) {
2948                     if (utf8_source) {
2949                         UV val;
2950                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2951                         if (val < 256 && isALPHA(val))
2952                             bits |= ((val + 9) & 0xf) << 4;
2953                         else
2954                             bits |= (val & 0xf) << 4;
2955                     } else if (isALPHA(*str))
2956                         bits |= ((*str++ + 9) & 0xf) << 4;
2957                     else
2958                         bits |= (*str++ & 0xf) << 4;
2959                     if (l & 1) bits >>= 4;
2960                     else {
2961                         PUSH_BYTE(utf8, cur, bits);
2962                         bits = 0;
2963                     }
2964                 }
2965             l--;
2966             if (l & 1) {
2967                 PUSH_BYTE(utf8, cur, bits);
2968                 l++;
2969             }
2970             /* Determine how many chars are left in the requested field */
2971             l /= 2;
2972             if (howlen == e_star) field_len = 0;
2973             else field_len -= l;
2974             Zero(cur, field_len, char);
2975             cur += field_len;
2976             break;
2977         }
2978         case 'c':
2979             while (len-- > 0) {
2980                 IV aiv;
2981                 fromstr = NEXTFROM;
2982                 aiv = SvIV(fromstr);
2983                 if ((-128 > aiv || aiv > 127) &&
2984                     ckWARN(WARN_PACK))
2985                     Perl_warner(aTHX_ packWARN(WARN_PACK),
2986                                 "Character in 'c' format wrapped in pack");
2987                 PUSH_BYTE(utf8, cur, aiv & 0xff);
2988             }
2989             break;
2990         case 'C':
2991             if (len == 0) {
2992                 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
2993                 break;
2994             }
2995             GROWING(0, cat, start, cur, len);
2996             while (len-- > 0) {
2997                 IV aiv;
2998                 fromstr = NEXTFROM;
2999                 aiv = SvIV(fromstr);
3000                 if ((0 > aiv || aiv > 0xff) &&
3001                     ckWARN(WARN_PACK))
3002                     Perl_warner(aTHX_ packWARN(WARN_PACK),
3003                                 "Character in 'C' format wrapped in pack");
3004                 *cur++ = aiv & 0xff;
3005             }
3006             break;
3007         case 'W': {
3008             char *end;
3009             U8 in_bytes = IN_BYTES;
3010
3011             end = start+SvLEN(cat)-1;
3012             if (utf8) end -= UTF8_MAXLEN-1;
3013             while (len-- > 0) {
3014                 UV auv;
3015                 fromstr = NEXTFROM;
3016                 auv = SvUV(fromstr);
3017                 if (in_bytes) auv = auv % 0x100;
3018                 if (utf8) {
3019                   W_utf8:
3020                     if (cur > end) {
3021                         *cur = '\0';
3022                         SvCUR_set(cat, cur - start);
3023
3024                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
3025                         end = start+SvLEN(cat)-UTF8_MAXLEN;
3026                     }
3027                     cur = (char *) uvuni_to_utf8_flags((U8 *) cur,
3028                                                        NATIVE_TO_UNI(auv),
3029                                                        ckWARN(WARN_UTF8) ?
3030                                                        0 : UNICODE_ALLOW_ANY);
3031                 } else {
3032                     if (auv >= 0x100) {
3033                         if (!SvUTF8(cat)) {
3034                             *cur = '\0';
3035                             SvCUR_set(cat, cur - start);
3036                             marked_upgrade(aTHX_ cat, symptr);
3037                             lookahead.flags |= FLAG_DO_UTF8;
3038                             lookahead.strbeg = symptr->strbeg;
3039                             utf8 = 1;
3040                             start = SvPVX(cat);
3041                             cur = start + SvCUR(cat);
3042                             end = start+SvLEN(cat)-UTF8_MAXLEN;
3043                             goto W_utf8;
3044                         }
3045                         if (ckWARN(WARN_PACK))
3046                             Perl_warner(aTHX_ packWARN(WARN_PACK),
3047                                         "Character in 'W' format wrapped in pack");
3048                         auv &= 0xff;
3049                     }
3050                     if (cur >= end) {
3051                         *cur = '\0';
3052                         SvCUR_set(cat, cur - start);
3053                         GROWING(0, cat, start, cur, len+1);
3054                         end = start+SvLEN(cat)-1;
3055                     }
3056                     *(U8 *) cur++ = (U8)auv;
3057                 }
3058             }
3059             break;
3060         }
3061         case 'U': {
3062             char *end;
3063
3064             if (len == 0) {
3065                 if (!(symptr->flags & FLAG_DO_UTF8)) {
3066                     marked_upgrade(aTHX_ cat, symptr);
3067                     lookahead.flags |= FLAG_DO_UTF8;
3068                     lookahead.strbeg = symptr->strbeg;
3069                 }
3070                 utf8 = 0;
3071                 goto no_change;
3072             }
3073
3074             end = start+SvLEN(cat);
3075             if (!utf8) end -= UTF8_MAXLEN;
3076             while (len-- > 0) {
3077                 UV auv;
3078                 fromstr = NEXTFROM;
3079                 auv = SvUV(fromstr);
3080                 if (utf8) {
3081                     U8 buffer[UTF8_MAXLEN], *endb;
3082                     endb = uvuni_to_utf8_flags(buffer, auv,
3083                                                ckWARN(WARN_UTF8) ?
3084                                                0 : UNICODE_ALLOW_ANY);
3085                     if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
3086                         *cur = '\0';
3087                         SvCUR_set(cat, cur - start);
3088                         GROWING(0, cat, start, cur,
3089                                 len+(endb-buffer)*UTF8_EXPAND);
3090                         end = start+SvLEN(cat);
3091                     }
3092                     bytes_to_uni(aTHX_ buffer, endb-buffer, &cur);
3093                 } else {
3094                     if (cur >= end) {
3095                         *cur = '\0';
3096                         SvCUR_set(cat, cur - start);
3097                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
3098                         end = start+SvLEN(cat)-UTF8_MAXLEN;
3099                     }
3100                     cur = (char *) uvuni_to_utf8_flags((U8 *) cur, auv,
3101                                                        ckWARN(WARN_UTF8) ?
3102                                                        0 : UNICODE_ALLOW_ANY);
3103                 }
3104             }
3105             break;
3106         }
3107         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
3108         case 'f':
3109             while (len-- > 0) {
3110                 float afloat;
3111                 NV anv;
3112                 fromstr = NEXTFROM;
3113                 anv = SvNV(fromstr);
3114 #ifdef __VOS__
3115                 /* VOS does not automatically map a floating-point overflow
3116                    during conversion from double to float into infinity, so we
3117                    do it by hand.  This code should either be generalized for
3118                    any OS that needs it, or removed if and when VOS implements
3119                    posix-976 (suggestion to support mapping to infinity).
3120                    Paul.Green@stratus.com 02-04-02.  */
3121                 if (anv > FLT_MAX)
3122                     afloat = _float_constants[0];   /* single prec. inf. */
3123                 else if (anv < -FLT_MAX)
3124                     afloat = _float_constants[0];   /* single prec. inf. */
3125                 else afloat = (float) anv;
3126 #else /* __VOS__ */
3127 # if defined(VMS) && !defined(__IEEE_FP)
3128                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
3129                  * on Alpha; fake it if we don't have them.
3130                  */
3131                 if (anv > FLT_MAX)
3132                     afloat = FLT_MAX;
3133                 else if (anv < -FLT_MAX)
3134                     afloat = -FLT_MAX;
3135                 else afloat = (float)anv;
3136 # else
3137                 afloat = (float)anv;
3138 # endif
3139 #endif /* __VOS__ */
3140                 DO_BO_PACK_N(afloat, float);
3141                 PUSH_VAR(utf8, cur, afloat);
3142             }
3143             break;
3144         case 'd':
3145             while (len-- > 0) {
3146                 double adouble;
3147                 NV anv;
3148                 fromstr = NEXTFROM;
3149                 anv = SvNV(fromstr);
3150 #ifdef __VOS__
3151                 /* VOS does not automatically map a floating-point overflow
3152                    during conversion from long double to double into infinity,
3153                    so we do it by hand.  This code should either be generalized
3154                    for any OS that needs it, or removed if and when VOS
3155                    implements posix-976 (suggestion to support mapping to
3156                    infinity).  Paul.Green@stratus.com 02-04-02.  */
3157                 if (anv > DBL_MAX)
3158                     adouble = _double_constants[0];   /* double prec. inf. */
3159                 else if (anv < -DBL_MAX)
3160                     adouble = _double_constants[0];   /* double prec. inf. */
3161                 else adouble = (double) anv;
3162 #else /* __VOS__ */
3163 # if defined(VMS) && !defined(__IEEE_FP)
3164                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
3165                  * on Alpha; fake it if we don't have them.
3166                  */
3167                 if (anv > DBL_MAX)
3168                     adouble = DBL_MAX;
3169                 else if (anv < -DBL_MAX)
3170                     adouble = -DBL_MAX;
3171                 else adouble = (double)anv;
3172 # else
3173                 adouble = (double)anv;
3174 # endif
3175 #endif /* __VOS__ */
3176                 DO_BO_PACK_N(adouble, double);
3177                 PUSH_VAR(utf8, cur, adouble);
3178             }
3179             break;
3180         case 'F': {
3181             NV anv;
3182             Zero(&anv, 1, NV); /* can be long double with unused bits */
3183             while (len-- > 0) {
3184                 fromstr = NEXTFROM;
3185                 anv = SvNV(fromstr);
3186                 DO_BO_PACK_N(anv, NV);
3187                 PUSH_VAR(utf8, cur, anv);
3188             }
3189             break;
3190         }
3191 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
3192         case 'D': {
3193             long double aldouble;
3194             /* long doubles can have unused bits, which may be nonzero */
3195             Zero(&aldouble, 1, long double);
3196             while (len-- > 0) {
3197                 fromstr = NEXTFROM;
3198                 aldouble = (long double)SvNV(fromstr);
3199                 DO_BO_PACK_N(aldouble, long double);
3200                 PUSH_VAR(utf8, cur, aldouble);
3201             }
3202             break;
3203         }
3204 #endif
3205 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3206         case 'n' | TYPE_IS_SHRIEKING:
3207 #endif
3208         case 'n':
3209             while (len-- > 0) {
3210                 I16 ai16;
3211                 fromstr = NEXTFROM;
3212                 ai16 = (I16)SvIV(fromstr);
3213 #ifdef HAS_HTONS
3214                 ai16 = PerlSock_htons(ai16);
3215 #endif
3216                 PUSH16(utf8, cur, &ai16);
3217             }
3218             break;
3219 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3220         case 'v' | TYPE_IS_SHRIEKING:
3221 #endif
3222         case 'v':
3223             while (len-- > 0) {
3224                 I16 ai16;
3225                 fromstr = NEXTFROM;
3226                 ai16 = (I16)SvIV(fromstr);
3227 #ifdef HAS_HTOVS
3228                 ai16 = htovs(ai16);
3229 #endif
3230                 PUSH16(utf8, cur, &ai16);
3231             }
3232             break;
3233         case 'S' | TYPE_IS_SHRIEKING:
3234 #if SHORTSIZE != SIZE16
3235             while (len-- > 0) {
3236                 unsigned short aushort;
3237                 fromstr = NEXTFROM;
3238                 aushort = SvUV(fromstr);
3239                 DO_BO_PACK(aushort, s);
3240                 PUSH_VAR(utf8, cur, aushort);
3241             }
3242             break;
3243 #else
3244             /* Fall through! */
3245 #endif
3246         case 'S':
3247             while (len-- > 0) {
3248                 U16 au16;
3249                 fromstr = NEXTFROM;
3250                 au16 = (U16)SvUV(fromstr);
3251                 DO_BO_PACK(au16, 16);
3252                 PUSH16(utf8, cur, &au16);
3253             }
3254             break;
3255         case 's' | TYPE_IS_SHRIEKING:
3256 #if SHORTSIZE != SIZE16
3257             while (len-- > 0) {
3258                 short ashort;
3259                 fromstr = NEXTFROM;
3260                 ashort = SvIV(fromstr);
3261                 DO_BO_PACK(ashort, s);
3262                 PUSH_VAR(utf8, cur, ashort);
3263             }
3264             break;
3265 #else
3266             /* Fall through! */
3267 #endif
3268         case 's':
3269             while (len-- > 0) {
3270                 I16 ai16;
3271                 fromstr = NEXTFROM;
3272                 ai16 = (I16)SvIV(fromstr);
3273                 DO_BO_PACK(ai16, 16);
3274                 PUSH16(utf8, cur, &ai16);
3275             }
3276             break;
3277         case 'I':
3278         case 'I' | TYPE_IS_SHRIEKING:
3279             while (len-- > 0) {
3280                 unsigned int auint;
3281                 fromstr = NEXTFROM;
3282                 auint = SvUV(fromstr);
3283                 DO_BO_PACK(auint, i);
3284                 PUSH_VAR(utf8, cur, auint);
3285             }
3286             break;
3287         case 'j':
3288             while (len-- > 0) {
3289                 IV aiv;
3290                 fromstr = NEXTFROM;
3291                 aiv = SvIV(fromstr);
3292 #if IVSIZE == INTSIZE
3293                 DO_BO_PACK(aiv, i);
3294 #elif IVSIZE == LONGSIZE
3295                 DO_BO_PACK(aiv, l);
3296 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
3297                 DO_BO_PACK(aiv, 64);
3298 #else
3299                 Perl_croak(aTHX_ "'j' not supported on this platform");
3300 #endif
3301                 PUSH_VAR(utf8, cur, aiv);
3302             }
3303             break;
3304         case 'J':
3305             while (len-- > 0) {
3306                 UV auv;
3307                 fromstr = NEXTFROM;
3308                 auv = SvUV(fromstr);
3309 #if UVSIZE == INTSIZE
3310                 DO_BO_PACK(auv, i);
3311 #elif UVSIZE == LONGSIZE
3312                 DO_BO_PACK(auv, l);
3313 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
3314                 DO_BO_PACK(auv, 64);
3315 #else
3316                 Perl_croak(aTHX_ "'J' not supported on this platform");
3317 #endif
3318                 PUSH_VAR(utf8, cur, auv);
3319             }
3320             break;
3321         case 'w':
3322             while (len-- > 0) {
3323                 NV anv;
3324                 fromstr = NEXTFROM;
3325                 anv = SvNV(fromstr);
3326
3327                 if (anv < 0) {
3328                     *cur = '\0';
3329                     SvCUR_set(cat, cur - start);
3330                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
3331                 }
3332
3333                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
3334                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
3335                    any negative IVs will have already been got by the croak()
3336                    above. IOK is untrue for fractions, so we test them
3337                    against UV_MAX_P1.  */
3338                 if (SvIOK(fromstr) || anv < UV_MAX_P1) {
3339                     char   buf[(sizeof(UV)*CHAR_BIT)/7+1];
3340                     char  *in = buf + sizeof(buf);
3341                     UV     auv = SvUV(fromstr);
3342
3343                     do {
3344                         *--in = (char)((auv & 0x7f) | 0x80);
3345                         auv >>= 7;
3346                     } while (auv);
3347                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3348                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3349                                        in, (buf + sizeof(buf)) - in);
3350                 } else if (SvPOKp(fromstr))
3351                     goto w_string;
3352                 else if (SvNOKp(fromstr)) {
3353                     /* 10**NV_MAX_10_EXP is the largest power of 10
3354                        so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
3355                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
3356                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
3357                        And with that many bytes only Inf can overflow.
3358                        Some C compilers are strict about integral constant
3359                        expressions so we conservatively divide by a slightly
3360                        smaller integer instead of multiplying by the exact
3361                        floating-point value.
3362                     */
3363 #ifdef NV_MAX_10_EXP
3364                     /* char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
3365                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
3366 #else
3367                     /* char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
3368                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
3369 #endif
3370                     char  *in = buf + sizeof(buf);
3371
3372                     anv = Perl_floor(anv);
3373                     do {
3374                         NV next = Perl_floor(anv / 128);
3375                         if (in <= buf)  /* this cannot happen ;-) */
3376                             Perl_croak(aTHX_ "Cannot compress integer in pack");
3377                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
3378                         anv = next;
3379                     } while (anv > 0);
3380                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3381                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3382                                        in, (buf + sizeof(buf)) - in);
3383                 } else {
3384                     char           *from, *result, *in;
3385                     SV             *norm;
3386                     STRLEN          len;
3387                     bool            done;
3388
3389                   w_string:
3390                     /* Copy string and check for compliance */
3391                     from = SvPV(fromstr, len);
3392                     if ((norm = is_an_int(from, len)) == NULL)
3393                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
3394
3395                     New('w', result, len, char);
3396                     in = result + len;
3397                     done = FALSE;
3398                     while (!done) *--in = div128(norm, &done) | 0x80;
3399                     result[len - 1] &= 0x7F; /* clear continue bit */
3400                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
3401                                        in, (result + len) - in);
3402                     Safefree(result);
3403                     SvREFCNT_dec(norm); /* free norm */
3404                 }
3405             }
3406             break;
3407         case 'i':
3408         case 'i' | TYPE_IS_SHRIEKING:
3409             while (len-- > 0) {
3410                 int aint;
3411                 fromstr = NEXTFROM;
3412                 aint = SvIV(fromstr);
3413                 DO_BO_PACK(aint, i);
3414                 PUSH_VAR(utf8, cur, aint);
3415             }
3416             break;
3417 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3418         case 'N' | TYPE_IS_SHRIEKING:
3419 #endif
3420         case 'N':
3421             while (len-- > 0) {
3422                 U32 au32;
3423                 fromstr = NEXTFROM;
3424                 au32 = SvUV(fromstr);
3425 #ifdef HAS_HTONL
3426                 au32 = PerlSock_htonl(au32);
3427 #endif
3428                 PUSH32(utf8, cur, &au32);
3429             }
3430             break;
3431 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3432         case 'V' | TYPE_IS_SHRIEKING:
3433 #endif
3434         case 'V':
3435             while (len-- > 0) {
3436                 U32 au32;
3437                 fromstr = NEXTFROM;
3438                 au32 = SvUV(fromstr);
3439 #ifdef HAS_HTOVL
3440                 au32 = htovl(au32);
3441 #endif
3442                 PUSH32(utf8, cur, &au32);
3443             }
3444             break;
3445         case 'L' | TYPE_IS_SHRIEKING:
3446 #if LONGSIZE != SIZE32
3447             while (len-- > 0) {
3448                 unsigned long aulong;
3449                 fromstr = NEXTFROM;
3450                 aulong = SvUV(fromstr);
3451                 DO_BO_PACK(aulong, l);
3452                 PUSH_VAR(utf8, cur, aulong);
3453             }
3454             break;
3455 #else
3456             /* Fall though! */
3457 #endif
3458         case 'L':
3459             while (len-- > 0) {
3460                 U32 au32;
3461                 fromstr = NEXTFROM;
3462                 au32 = SvUV(fromstr);
3463                 DO_BO_PACK(au32, 32);
3464                 PUSH32(utf8, cur, &au32);
3465             }
3466             break;
3467         case 'l' | TYPE_IS_SHRIEKING:
3468 #if LONGSIZE != SIZE32
3469             while (len-- > 0) {
3470                 long along;
3471                 fromstr = NEXTFROM;
3472                 along = SvIV(fromstr);
3473                 DO_BO_PACK(along, l);
3474                 PUSH_VAR(utf8, cur, along);
3475             }
3476             break;
3477 #else
3478             /* Fall though! */
3479 #endif
3480         case 'l':
3481             while (len-- > 0) {
3482                 I32 ai32;
3483                 fromstr = NEXTFROM;
3484                 ai32 = SvIV(fromstr);
3485                 DO_BO_PACK(ai32, 32);
3486                 PUSH32(utf8, cur, &ai32);
3487             }
3488             break;
3489 #ifdef HAS_QUAD
3490         case 'Q':
3491             while (len-- > 0) {
3492                 Uquad_t auquad;
3493                 fromstr = NEXTFROM;
3494                 auquad = (Uquad_t) SvUV(fromstr);
3495                 DO_BO_PACK(auquad, 64);
3496                 PUSH_VAR(utf8, cur, auquad);
3497             }
3498             break;
3499         case 'q':
3500             while (len-- > 0) {
3501                 Quad_t aquad;
3502                 fromstr = NEXTFROM;
3503                 aquad = (Quad_t)SvIV(fromstr);
3504                 DO_BO_PACK(aquad, 64);
3505                 PUSH_VAR(utf8, cur, aquad);
3506             }
3507             break;
3508 #endif /* HAS_QUAD */
3509         case 'P':
3510             len = 1;            /* assume SV is correct length */
3511             GROWING(utf8, cat, start, cur, sizeof(char *));
3512             /* Fall through! */
3513         case 'p':
3514             while (len-- > 0) {
3515                 char *aptr;
3516
3517                 fromstr = NEXTFROM;
3518                 SvGETMAGIC(fromstr);
3519                 if (!SvOK(fromstr)) aptr = NULL;
3520                 else {
3521                     STRLEN n_a;
3522                     /* XXX better yet, could spirit away the string to
3523                      * a safe spot and hang on to it until the result
3524                      * of pack() (and all copies of the result) are
3525                      * gone.
3526                      */
3527                     if (ckWARN(WARN_PACK) &&
3528                         (SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
3529                                              !SvREADONLY(fromstr)))) {
3530                         Perl_warner(aTHX_ packWARN(WARN_PACK),
3531                                     "Attempt to pack pointer to temporary value");
3532                     }
3533                     if (SvPOK(fromstr) || SvNIOK(fromstr))
3534                         aptr = SvPV_flags(fromstr, n_a, 0);
3535                     else
3536                         aptr = SvPV_force_flags(fromstr, n_a, 0);
3537                 }
3538                 DO_BO_PACK_PC(aptr);
3539                 PUSH_VAR(utf8, cur, aptr);
3540             }
3541             break;
3542         case 'u': {
3543             const char *aptr, *aend;
3544             bool from_utf8;
3545
3546             fromstr = NEXTFROM;
3547             if (len <= 2) len = 45;
3548             else len = len / 3 * 3;
3549             if (len >= 64) {
3550                 Perl_warner(aTHX_ packWARN(WARN_PACK),
3551                             "Field too wide in 'u' format in pack");
3552                 len = 63;
3553             }
3554             aptr = SvPV(fromstr, fromlen);
3555             from_utf8 = DO_UTF8(fromstr);
3556             if (from_utf8) {
3557                 aend = aptr + fromlen;
3558                 fromlen = sv_len_utf8(fromstr);
3559             } else aend = NULL; /* Unused, but keep compilers happy */
3560             GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2);
3561             while (fromlen > 0) {
3562                 U8 *end;
3563                 I32 todo;
3564                 U8 hunk[1+63/3*4+1];
3565
3566                 if ((I32)fromlen > len)
3567                     todo = len;
3568                 else
3569                     todo = fromlen;
3570                 if (from_utf8) {
3571                     char buffer[64];
3572                     if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo,
3573                                       'u' | TYPE_IS_PACK)) {
3574                         *cur = '\0';
3575                         SvCUR_set(cat, cur - start);
3576                         Perl_croak(aTHX_ "Assertion: string is shorter than advertised");
3577                     }
3578                     end = doencodes(hunk, buffer, todo);
3579                 } else {
3580                     end = doencodes(hunk, aptr, todo);
3581                     aptr += todo;
3582                 }
3583                 PUSH_BYTES(utf8, cur, hunk, end-hunk);
3584                 fromlen -= todo;
3585             }
3586             break;
3587         }
3588         }
3589         *cur = '\0';
3590         SvCUR_set(cat, cur - start);
3591       no_change:
3592         *symptr = lookahead;
3593     }
3594     return beglist;
3595 }
3596 #undef NEXTFROM
3597
3598
3599 PP(pp_pack)
3600 {
3601     dSP; dMARK; dORIGMARK; dTARGET;
3602     register SV *cat = TARG;
3603     STRLEN fromlen;
3604     register const char *pat = SvPVx(*++MARK, fromlen);
3605     register const char *patend = pat + fromlen;
3606
3607     MARK++;
3608     sv_setpvn(cat, "", 0);
3609     SvUTF8_off(cat);
3610
3611     packlist(cat, pat, patend, MARK, SP + 1);
3612
3613     SvSETMAGIC(cat);
3614     SP = ORIGMARK;
3615     PUSHs(cat);
3616     RETURN;
3617 }
3618
3619 /*
3620  * Local variables:
3621  * c-indentation-style: bsd
3622  * c-basic-offset: 4
3623  * indent-tabs-mode: t
3624  * End:
3625  *
3626  * vim: shiftwidth=4:
3627 */