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