pp_pack.c

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