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