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