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