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