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