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                 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1421                     ai16 = (I16) PerlSock_ntohs((U16) ai16);
1422                 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1423                     ai16 = (I16) vtohs((U16) ai16);
1424                 if (!checksum)
1425                     mPUSHi(ai16);
1426                 else if (checksum > bits_in_uv)
1427                     cdouble += (NV) ai16;
1428                 else
1429                     cuv += ai16;
1430             }
1431             break;
1432         case 'i':
1433         case 'i' | TYPE_IS_SHRIEKING:
1434             while (len-- > 0) {
1435                 int aint;
1436                 SHIFT_VAR(utf8, s, strend, aint, datumtype);
1437                 DO_BO_UNPACK(aint);
1438                 if (!checksum)
1439                     mPUSHi(aint);
1440                 else if (checksum > bits_in_uv)
1441                     cdouble += (NV)aint;
1442                 else
1443                     cuv += aint;
1444             }
1445             break;
1446         case 'I':
1447         case 'I' | TYPE_IS_SHRIEKING:
1448             while (len-- > 0) {
1449                 unsigned int auint;
1450                 SHIFT_VAR(utf8, s, strend, auint, datumtype);
1451                 DO_BO_UNPACK(auint);
1452                 if (!checksum)
1453                     mPUSHu(auint);
1454                 else if (checksum > bits_in_uv)
1455                     cdouble += (NV)auint;
1456                 else
1457                     cuv += auint;
1458             }
1459             break;
1460         case 'j':
1461             while (len-- > 0) {
1462                 IV aiv;
1463                 SHIFT_VAR(utf8, s, strend, aiv, datumtype);
1464                 DO_BO_UNPACK(aiv);
1465                 if (!checksum)
1466                     mPUSHi(aiv);
1467                 else if (checksum > bits_in_uv)
1468                     cdouble += (NV)aiv;
1469                 else
1470                     cuv += aiv;
1471             }
1472             break;
1473         case 'J':
1474             while (len-- > 0) {
1475                 UV auv;
1476                 SHIFT_VAR(utf8, s, strend, auv, datumtype);
1477                 DO_BO_UNPACK(auv);
1478                 if (!checksum)
1479                     mPUSHu(auv);
1480                 else if (checksum > bits_in_uv)
1481                     cdouble += (NV)auv;
1482                 else
1483                     cuv += auv;
1484             }
1485             break;
1486         case 'l' | TYPE_IS_SHRIEKING:
1487 #if LONGSIZE != SIZE32
1488             while (len-- > 0) {
1489                 long along;
1490                 SHIFT_VAR(utf8, s, strend, along, datumtype);
1491                 DO_BO_UNPACK(along);
1492                 if (!checksum)
1493                     mPUSHi(along);
1494                 else if (checksum > bits_in_uv)
1495                     cdouble += (NV)along;
1496                 else
1497                     cuv += along;
1498             }
1499             break;
1500 #else
1501             /* Fallthrough! */
1502 #endif
1503         case 'l':
1504             while (len-- > 0) {
1505                 I32 ai32;
1506 #if U32SIZE > SIZE32
1507                 ai32 = 0;
1508 #endif
1509                 SHIFT32(utf8, s, strend, &ai32, datumtype);
1510                 DO_BO_UNPACK(ai32);
1511 #if U32SIZE > SIZE32
1512                 if (ai32 > 2147483647) ai32 -= 4294967296;
1513 #endif
1514                 if (!checksum)
1515                     mPUSHi(ai32);
1516                 else if (checksum > bits_in_uv)
1517                     cdouble += (NV)ai32;
1518                 else
1519                     cuv += ai32;
1520             }
1521             break;
1522         case 'L' | TYPE_IS_SHRIEKING:
1523 #if LONGSIZE != SIZE32
1524             while (len-- > 0) {
1525                 unsigned long aulong;
1526                 SHIFT_VAR(utf8, s, strend, aulong, datumtype);
1527                 DO_BO_UNPACK(aulong);
1528                 if (!checksum)
1529                     mPUSHu(aulong);
1530                 else if (checksum > bits_in_uv)
1531                     cdouble += (NV)aulong;
1532                 else
1533                     cuv += aulong;
1534             }
1535             break;
1536 #else
1537             /* Fall through! */
1538 #endif
1539         case 'V':
1540         case 'N':
1541         case 'L':
1542             while (len-- > 0) {
1543                 U32 au32;
1544 #if U32SIZE > SIZE32
1545                 au32 = 0;
1546 #endif
1547                 SHIFT32(utf8, s, strend, &au32, datumtype);
1548                 DO_BO_UNPACK(au32);
1549                 if (datumtype == 'N')
1550                     au32 = PerlSock_ntohl(au32);
1551                 if (datumtype == 'V')
1552                     au32 = vtohl(au32);
1553                 if (!checksum)
1554                     mPUSHu(au32);
1555                 else if (checksum > bits_in_uv)
1556                     cdouble += (NV)au32;
1557                 else
1558                     cuv += au32;
1559             }
1560             break;
1561         case 'V' | TYPE_IS_SHRIEKING:
1562         case 'N' | TYPE_IS_SHRIEKING:
1563             while (len-- > 0) {
1564                 I32 ai32;
1565 #if U32SIZE > SIZE32
1566                 ai32 = 0;
1567 #endif
1568                 SHIFT32(utf8, s, strend, &ai32, datumtype);
1569                 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1570                     ai32 = (I32)PerlSock_ntohl((U32)ai32);
1571                 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1572                     ai32 = (I32)vtohl((U32)ai32);
1573                 if (!checksum)
1574                     mPUSHi(ai32);
1575                 else if (checksum > bits_in_uv)
1576                     cdouble += (NV)ai32;
1577                 else
1578                     cuv += ai32;
1579             }
1580             break;
1581         case 'p':
1582             while (len-- > 0) {
1583                 const char *aptr;
1584                 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
1585                 DO_BO_UNPACK(aptr);
1586                 /* newSVpv generates undef if aptr is NULL */
1587                 mPUSHs(newSVpv(aptr, 0));
1588             }
1589             break;
1590         case 'w':
1591             {
1592                 UV auv = 0;
1593                 U32 bytes = 0;
1594
1595                 while (len > 0 && s < strend) {
1596                     U8 ch;
1597                     ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1598                     auv = (auv << 7) | (ch & 0x7f);
1599                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1600                     if (ch < 0x80) {
1601                         bytes = 0;
1602                         mPUSHu(auv);
1603                         len--;
1604                         auv = 0;
1605                         continue;
1606                     }
1607                     if (++bytes >= sizeof(UV)) {        /* promote to string */
1608                         const char *t;
1609
1610                         sv = Perl_newSVpvf(aTHX_ "%.*"UVuf, (int)TYPE_DIGITS(UV), auv);
1611                         while (s < strend) {
1612                             ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1613                             sv = mul128(sv, (U8)(ch & 0x7f));
1614                             if (!(ch & 0x80)) {
1615                                 bytes = 0;
1616                                 break;
1617                             }
1618                         }
1619                         t = SvPV_nolen_const(sv);
1620                         while (*t == '0')
1621                             t++;
1622                         sv_chop(sv, t);
1623                         mPUSHs(sv);
1624                         len--;
1625                         auv = 0;
1626                     }
1627                 }
1628                 if ((s >= strend) && bytes)
1629                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1630             }
1631             break;
1632         case 'P':
1633             if (symptr->howlen == e_star)
1634                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1635             EXTEND(SP, 1);
1636             if (s + sizeof(char*) <= strend) {
1637                 char *aptr;
1638                 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
1639                 DO_BO_UNPACK(aptr);
1640                 /* newSVpvn generates undef if aptr is NULL */
1641                 PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP));
1642             }
1643             break;
1644 #ifdef HAS_QUAD
1645         case 'q':
1646             while (len-- > 0) {
1647                 Quad_t aquad;
1648                 SHIFT_VAR(utf8, s, strend, aquad, datumtype);
1649                 DO_BO_UNPACK(aquad);
1650                 if (!checksum)
1651                     mPUSHs(aquad >= IV_MIN && aquad <= IV_MAX ?
1652                            newSViv((IV)aquad) : newSVnv((NV)aquad));
1653                 else if (checksum > bits_in_uv)
1654                     cdouble += (NV)aquad;
1655                 else
1656                     cuv += aquad;
1657             }
1658             break;
1659         case 'Q':
1660             while (len-- > 0) {
1661                 Uquad_t auquad;
1662                 SHIFT_VAR(utf8, s, strend, auquad, datumtype);
1663                 DO_BO_UNPACK(auquad);
1664                 if (!checksum)
1665                     mPUSHs(auquad <= UV_MAX ?
1666                            newSVuv((UV)auquad) : newSVnv((NV)auquad));
1667                 else if (checksum > bits_in_uv)
1668                     cdouble += (NV)auquad;
1669                 else
1670                     cuv += auquad;
1671             }
1672             break;
1673 #endif /* HAS_QUAD */
1674         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1675         case 'f':
1676             while (len-- > 0) {
1677                 float afloat;
1678                 SHIFT_VAR(utf8, s, strend, afloat, datumtype);
1679                 DO_BO_UNPACK(afloat);
1680                 if (!checksum)
1681                     mPUSHn(afloat);
1682                 else
1683                     cdouble += afloat;
1684             }
1685             break;
1686         case 'd':
1687             while (len-- > 0) {
1688                 double adouble;
1689                 SHIFT_VAR(utf8, s, strend, adouble, datumtype);
1690                 DO_BO_UNPACK(adouble);
1691                 if (!checksum)
1692                     mPUSHn(adouble);
1693                 else
1694                     cdouble += adouble;
1695             }
1696             break;
1697         case 'F':
1698             while (len-- > 0) {
1699                 NV_bytes anv;
1700                 SHIFT_BYTES(utf8, s, strend, anv.bytes, sizeof(anv.bytes), datumtype);
1701                 DO_BO_UNPACK(anv.nv);
1702                 if (!checksum)
1703                     mPUSHn(anv.nv);
1704                 else
1705                     cdouble += anv.nv;
1706             }
1707             break;
1708 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1709         case 'D':
1710             while (len-- > 0) {
1711                 ld_bytes aldouble;
1712                 SHIFT_BYTES(utf8, s, strend, aldouble.bytes, sizeof(aldouble.bytes), datumtype);
1713                 DO_BO_UNPACK(aldouble.ld);
1714                 if (!checksum)
1715                     mPUSHn(aldouble.ld);
1716                 else
1717                     cdouble += aldouble.ld;
1718             }
1719             break;
1720 #endif
1721         case 'u':
1722             if (!checksum) {
1723                 const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
1724                 sv = sv_2mortal(newSV(l));
1725                 if (l) SvPOK_on(sv);
1726             }
1727             if (utf8) {
1728                 while (next_uni_uu(aTHX_ &s, strend, &len)) {
1729                     I32 a, b, c, d;
1730                     char hunk[3];
1731
1732                     while (len > 0) {
1733                         next_uni_uu(aTHX_ &s, strend, &a);
1734                         next_uni_uu(aTHX_ &s, strend, &b);
1735                         next_uni_uu(aTHX_ &s, strend, &c);
1736                         next_uni_uu(aTHX_ &s, strend, &d);
1737                         hunk[0] = (char)((a << 2) | (b >> 4));
1738                         hunk[1] = (char)((b << 4) | (c >> 2));
1739                         hunk[2] = (char)((c << 6) | d);
1740                         if (!checksum)
1741                             sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1742                         len -= 3;
1743                     }
1744                     if (s < strend) {
1745                         if (*s == '\n') {
1746                             s++;
1747                         }
1748                         else {
1749                             /* possible checksum byte */
1750                             const char *skip = s+UTF8SKIP(s);
1751                             if (skip < strend && *skip == '\n')
1752                                 s = skip+1;
1753                         }
1754                     }
1755                 }
1756             } else {
1757                 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1758                     I32 a, b, c, d;
1759                     char hunk[3];
1760
1761                     len = PL_uudmap[*(U8*)s++] & 077;
1762                     while (len > 0) {
1763                         if (s < strend && ISUUCHAR(*s))
1764                             a = PL_uudmap[*(U8*)s++] & 077;
1765                         else
1766                             a = 0;
1767                         if (s < strend && ISUUCHAR(*s))
1768                             b = PL_uudmap[*(U8*)s++] & 077;
1769                         else
1770                             b = 0;
1771                         if (s < strend && ISUUCHAR(*s))
1772                             c = PL_uudmap[*(U8*)s++] & 077;
1773                         else
1774                             c = 0;
1775                         if (s < strend && ISUUCHAR(*s))
1776                             d = PL_uudmap[*(U8*)s++] & 077;
1777                         else
1778                             d = 0;
1779                         hunk[0] = (char)((a << 2) | (b >> 4));
1780                         hunk[1] = (char)((b << 4) | (c >> 2));
1781                         hunk[2] = (char)((c << 6) | d);
1782                         if (!checksum)
1783                             sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1784                         len -= 3;
1785                     }
1786                     if (*s == '\n')
1787                         s++;
1788                     else        /* possible checksum byte */
1789                         if (s + 1 < strend && s[1] == '\n')
1790                             s += 2;
1791                 }
1792             }
1793             if (!checksum)
1794                 XPUSHs(sv);
1795             break;
1796         }
1797
1798         if (checksum) {
1799             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1800               (checksum > bits_in_uv &&
1801                strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1802                 NV trouble, anv;
1803
1804                 anv = (NV) (1 << (checksum & 15));
1805                 while (checksum >= 16) {
1806                     checksum -= 16;
1807                     anv *= 65536.0;
1808                 }
1809                 while (cdouble < 0.0)
1810                     cdouble += anv;
1811                 cdouble = Perl_modf(cdouble / anv, &trouble) * anv;
1812                 sv = newSVnv(cdouble);
1813             }
1814             else {
1815                 if (checksum < bits_in_uv) {
1816                     UV mask = ((UV)1 << checksum) - 1;
1817                     cuv &= mask;
1818                 }
1819                 sv = newSVuv(cuv);
1820             }
1821             mXPUSHs(sv);
1822             checksum = 0;
1823         }
1824
1825         if (symptr->flags & FLAG_SLASH){
1826             if (SP - PL_stack_base - start_sp_offset <= 0)
1827                 break;
1828             if( next_symbol(symptr) ){
1829               if( symptr->howlen == e_number )
1830                 Perl_croak(aTHX_ "Count after length/code in unpack" );
1831               if( beyond ){
1832                 /* ...end of char buffer then no decent length available */
1833                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1834               } else {
1835                 /* take top of stack (hope it's numeric) */
1836                 len = POPi;
1837                 if( len < 0 )
1838                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
1839               }
1840             } else {
1841                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1842             }
1843             datumtype = symptr->code;
1844             explicit_length = FALSE;
1845             goto redo_switch;
1846         }
1847     }
1848
1849     if (new_s)
1850         *new_s = s;
1851     PUTBACK;
1852     return SP - PL_stack_base - start_sp_offset;
1853 }
1854
1855 PP(pp_unpack)
1856 {
1857     dVAR;
1858     dSP;
1859     dPOPPOPssrl;
1860     I32 gimme = GIMME_V;
1861     STRLEN llen;
1862     STRLEN rlen;
1863     const char *pat = SvPV_const(left,  llen);
1864     const char *s   = SvPV_const(right, rlen);
1865     const char *strend = s + rlen;
1866     const char *patend = pat + llen;
1867     I32 cnt;
1868
1869     PUTBACK;
1870     cnt = unpackstring(pat, patend, s, strend,
1871                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1872                      | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0));
1873
1874     SPAGAIN;
1875     if ( !cnt && gimme == G_SCALAR )
1876        PUSHs(&PL_sv_undef);
1877     RETURN;
1878 }
1879
1880 STATIC U8 *
1881 doencodes(U8 *h, const char *s, I32 len)
1882 {
1883     *h++ = PL_uuemap[len];
1884     while (len > 2) {
1885         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
1886         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))];
1887         *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1888         *h++ = PL_uuemap[(077 & (s[2] & 077))];
1889         s += 3;
1890         len -= 3;
1891     }
1892     if (len > 0) {
1893         const char r = (len > 1 ? s[1] : '\0');
1894         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
1895         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))];
1896         *h++ = PL_uuemap[(077 & ((r << 2) & 074))];
1897         *h++ = PL_uuemap[0];
1898     }
1899     *h++ = '\n';
1900     return h;
1901 }
1902
1903 STATIC SV *
1904 S_is_an_int(pTHX_ const char *s, STRLEN l)
1905 {
1906   SV *result = newSVpvn(s, l);
1907   char *const result_c = SvPV_nolen(result);    /* convenience */
1908   char *out = result_c;
1909   bool skip = 1;
1910   bool ignore = 0;
1911
1912   PERL_ARGS_ASSERT_IS_AN_INT;
1913
1914   while (*s) {
1915     switch (*s) {
1916     case ' ':
1917       break;
1918     case '+':
1919       if (!skip) {
1920         SvREFCNT_dec(result);
1921         return (NULL);
1922       }
1923       break;
1924     case '0':
1925     case '1':
1926     case '2':
1927     case '3':
1928     case '4':
1929     case '5':
1930     case '6':
1931     case '7':
1932     case '8':
1933     case '9':
1934       skip = 0;
1935       if (!ignore) {
1936         *(out++) = *s;
1937       }
1938       break;
1939     case '.':
1940       ignore = 1;
1941       break;
1942     default:
1943       SvREFCNT_dec(result);
1944       return (NULL);
1945     }
1946     s++;
1947   }
1948   *(out++) = '\0';
1949   SvCUR_set(result, out - result_c);
1950   return (result);
1951 }
1952
1953 /* pnum must be '\0' terminated */
1954 STATIC int
1955 S_div128(pTHX_ SV *pnum, bool *done)
1956 {
1957     STRLEN len;
1958     char * const s = SvPV(pnum, len);
1959     char *t = s;
1960     int m = 0;
1961
1962     PERL_ARGS_ASSERT_DIV128;
1963
1964     *done = 1;
1965     while (*t) {
1966         const int i = m * 10 + (*t - '0');
1967         const int r = (i >> 7); /* r < 10 */
1968         m = i & 0x7F;
1969         if (r) {
1970             *done = 0;
1971         }
1972         *(t++) = '0' + r;
1973     }
1974     *(t++) = '\0';
1975     SvCUR_set(pnum, (STRLEN) (t - s));
1976     return (m);
1977 }
1978
1979 /*
1980 =for apidoc packlist
1981
1982 The engine implementing pack() Perl function.
1983
1984 =cut
1985 */
1986
1987 void
1988 Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist )
1989 {
1990     dVAR;
1991     tempsym_t sym;
1992
1993     PERL_ARGS_ASSERT_PACKLIST;
1994
1995     TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
1996
1997     /* We're going to do changes through SvPVX(cat). Make sure it's valid.
1998        Also make sure any UTF8 flag is loaded */
1999     SvPV_force_nolen(cat);
2000     if (DO_UTF8(cat))
2001         sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8;
2002
2003     (void)pack_rec( cat, &sym, beglist, endlist );
2004 }
2005
2006 /* like sv_utf8_upgrade, but also repoint the group start markers */
2007 STATIC void
2008 marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) {
2009     STRLEN len;
2010     tempsym_t *group;
2011     const char *from_ptr, *from_start, *from_end, **marks, **m;
2012     char *to_start, *to_ptr;
2013
2014     if (SvUTF8(sv)) return;
2015
2016     from_start = SvPVX_const(sv);
2017     from_end = from_start + SvCUR(sv);
2018     for (from_ptr = from_start; from_ptr < from_end; from_ptr++)
2019         if (!NATIVE_IS_INVARIANT(*from_ptr)) break;
2020     if (from_ptr == from_end) {
2021         /* Simple case: no character needs to be changed */
2022         SvUTF8_on(sv);
2023         return;
2024     }
2025
2026     len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1;
2027     Newx(to_start, len, char);
2028     Copy(from_start, to_start, from_ptr-from_start, char);
2029     to_ptr = to_start + (from_ptr-from_start);
2030
2031     Newx(marks, sym_ptr->level+2, const char *);
2032     for (group=sym_ptr; group; group = group->previous)
2033         marks[group->level] = from_start + group->strbeg;
2034     marks[sym_ptr->level+1] = from_end+1;
2035     for (m = marks; *m < from_ptr; m++)
2036         *m = to_start + (*m-from_start);
2037
2038     for (;from_ptr < from_end; from_ptr++) {
2039         while (*m == from_ptr) *m++ = to_ptr;
2040         to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr);
2041     }
2042     *to_ptr = 0;
2043
2044     while (*m == from_ptr) *m++ = to_ptr;
2045     if (m != marks + sym_ptr->level+1) {
2046         Safefree(marks);
2047         Safefree(to_start);
2048         Perl_croak(aTHX_ "panic: marks beyond string end, m=%p, marks=%p, "
2049                    "level=%d", m, marks, sym_ptr->level);
2050     }
2051     for (group=sym_ptr; group; group = group->previous)
2052         group->strbeg = marks[group->level] - to_start;
2053     Safefree(marks);
2054
2055     if (SvOOK(sv)) {
2056         if (SvIVX(sv)) {
2057             SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2058             from_start -= SvIVX(sv);
2059             SvIV_set(sv, 0);
2060         }
2061         SvFLAGS(sv) &= ~SVf_OOK;
2062     }
2063     if (SvLEN(sv) != 0)
2064         Safefree(from_start);
2065     SvPV_set(sv, to_start);
2066     SvCUR_set(sv, to_ptr - to_start);
2067     SvLEN_set(sv, len);
2068     SvUTF8_on(sv);
2069 }
2070
2071 /* Exponential string grower. Makes string extension effectively O(n)
2072    needed says how many extra bytes we need (not counting the final '\0')
2073    Only grows the string if there is an actual lack of space
2074 */
2075 STATIC char *
2076 S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) {
2077     const STRLEN cur = SvCUR(sv);
2078     const STRLEN len = SvLEN(sv);
2079     STRLEN extend;
2080
2081     PERL_ARGS_ASSERT_SV_EXP_GROW;
2082
2083     if (len - cur > needed) return SvPVX(sv);
2084     extend = needed > len ? needed : len;
2085     return SvGROW(sv, len+extend+1);
2086 }
2087
2088 STATIC
2089 SV **
2090 S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
2091 {
2092     dVAR;
2093     tempsym_t lookahead;
2094     I32 items  = endlist - beglist;
2095     bool found = next_symbol(symptr);
2096     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
2097     bool warn_utf8 = ckWARN(WARN_UTF8);
2098
2099     PERL_ARGS_ASSERT_PACK_REC;
2100
2101     if (symptr->level == 0 && found && symptr->code == 'U') {
2102         marked_upgrade(aTHX_ cat, symptr);
2103         symptr->flags |= FLAG_DO_UTF8;
2104         utf8 = 0;
2105     }
2106     symptr->strbeg = SvCUR(cat);
2107
2108     while (found) {
2109         SV *fromstr;
2110         STRLEN fromlen;
2111         I32 len;
2112         SV *lengthcode = NULL;
2113         I32 datumtype = symptr->code;
2114         howlen_t howlen = symptr->howlen;
2115         char *start = SvPVX(cat);
2116         char *cur   = start + SvCUR(cat);
2117         bool needs_swap;
2118
2119 #define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2120
2121         switch (howlen) {
2122           case e_star:
2123             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ?
2124                 0 : items;
2125             break;
2126           default:
2127             /* e_no_len and e_number */
2128             len = symptr->length;
2129             break;
2130         }
2131
2132         if (len) {
2133             packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
2134
2135             if (props && !(props & PACK_SIZE_UNPREDICTABLE)) {
2136                 /* We can process this letter. */
2137                 STRLEN size = props & PACK_SIZE_MASK;
2138                 GROWING(utf8, cat, start, cur, (STRLEN) len * size);
2139             }
2140         }
2141
2142         /* Look ahead for next symbol. Do we have code/code? */
2143         lookahead = *symptr;
2144         found = next_symbol(&lookahead);
2145         if (symptr->flags & FLAG_SLASH) {
2146             IV count;
2147             if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack");
2148             if (strchr("aAZ", lookahead.code)) {
2149                 if (lookahead.howlen == e_number) count = lookahead.length;
2150                 else {
2151                     if (items > 0) {
2152                         count = sv_len_utf8(*beglist);
2153                     }
2154                     else count = 0;
2155                     if (lookahead.code == 'Z') count++;
2156                 }
2157             } else {
2158                 if (lookahead.howlen == e_number && lookahead.length < items)
2159                     count = lookahead.length;
2160                 else count = items;
2161             }
2162             lookahead.howlen = e_number;
2163             lookahead.length = count;
2164             lengthcode = sv_2mortal(newSViv(count));
2165         }
2166
2167         needs_swap = NEEDS_SWAP(datumtype);
2168
2169         /* Code inside the switch must take care to properly update
2170            cat (CUR length and '\0' termination) if it updated *cur and
2171            doesn't simply leave using break */
2172         switch(TYPE_NO_ENDIANNESS(datumtype)) {
2173         default:
2174             Perl_croak(aTHX_ "Invalid type '%c' in pack",
2175                        (int) TYPE_NO_MODIFIERS(datumtype));
2176         case '%':
2177             Perl_croak(aTHX_ "'%%' may not be used in pack");
2178         {
2179             char *from;
2180         case '.' | TYPE_IS_SHRIEKING:
2181         case '.':
2182             if (howlen == e_star) from = start;
2183             else if (len == 0) from = cur;
2184             else {
2185                 tempsym_t *group = symptr;
2186
2187                 while (--len && group) group = group->previous;
2188                 from = group ? start + group->strbeg : start;
2189             }
2190             fromstr = NEXTFROM;
2191             len = SvIV(fromstr);
2192             goto resize;
2193         case '@' | TYPE_IS_SHRIEKING:
2194         case '@':
2195             from = start + symptr->strbeg;
2196           resize:
2197             if (utf8  && !(datumtype & TYPE_IS_SHRIEKING))
2198                 if (len >= 0) {
2199                     while (len && from < cur) {
2200                         from += UTF8SKIP(from);
2201                         len--;
2202                     }
2203                     if (from > cur)
2204                         Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2205                     if (len) {
2206                         /* Here we know from == cur */
2207                       grow:
2208                         GROWING(0, cat, start, cur, len);
2209                         Zero(cur, len, char);
2210                         cur += len;
2211                     } else if (from < cur) {
2212                         len = cur - from;
2213                         goto shrink;
2214                     } else goto no_change;
2215                 } else {
2216                     cur = from;
2217                     len = -len;
2218                     goto utf8_shrink;
2219                 }
2220             else {
2221                 len -= cur - from;
2222                 if (len > 0) goto grow;
2223                 if (len == 0) goto no_change;
2224                 len = -len;
2225                 goto shrink;
2226             }
2227             break;
2228         }
2229         case '(': {
2230             tempsym_t savsym = *symptr;
2231             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2232             symptr->flags |= group_modifiers;
2233             symptr->patend = savsym.grpend;
2234             symptr->level++;
2235             symptr->previous = &lookahead;
2236             while (len--) {
2237                 U32 was_utf8;
2238                 if (utf8) symptr->flags |=  FLAG_PARSE_UTF8;
2239                 else      symptr->flags &= ~FLAG_PARSE_UTF8;
2240                 was_utf8 = SvUTF8(cat);
2241                 symptr->patptr = savsym.grpbeg;
2242                 beglist = pack_rec(cat, symptr, beglist, endlist);
2243                 if (SvUTF8(cat) != was_utf8)
2244                     /* This had better be an upgrade while in utf8==0 mode */
2245                     utf8 = 1;
2246
2247                 if (savsym.howlen == e_star && beglist == endlist)
2248                     break;              /* No way to continue */
2249             }
2250             items = endlist - beglist;
2251             lookahead.flags  = symptr->flags & ~group_modifiers;
2252             goto no_change;
2253         }
2254         case 'X' | TYPE_IS_SHRIEKING:
2255             if (!len)                   /* Avoid division by 0 */
2256                 len = 1;
2257             if (utf8) {
2258                 char *hop, *last;
2259                 I32 l = len;
2260                 hop = last = start;
2261                 while (hop < cur) {
2262                     hop += UTF8SKIP(hop);
2263                     if (--l == 0) {
2264                         last = hop;
2265                         l = len;
2266                     }
2267                 }
2268                 if (last > cur)
2269                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2270                 cur = last;
2271                 break;
2272             }
2273             len = (cur-start) % len;
2274             /* FALL THROUGH */
2275         case 'X':
2276             if (utf8) {
2277                 if (len < 1) goto no_change;
2278               utf8_shrink:
2279                 while (len > 0) {
2280                     if (cur <= start)
2281                         Perl_croak(aTHX_ "'%c' outside of string in pack",
2282                                    (int) TYPE_NO_MODIFIERS(datumtype));
2283                     while (--cur, UTF8_IS_CONTINUATION(*cur)) {
2284                         if (cur <= start)
2285                             Perl_croak(aTHX_ "'%c' outside of string in pack",
2286                                        (int) TYPE_NO_MODIFIERS(datumtype));
2287                     }
2288                     len--;
2289                 }
2290             } else {
2291               shrink:
2292                 if (cur - start < len)
2293                     Perl_croak(aTHX_ "'%c' outside of string in pack",
2294                                (int) TYPE_NO_MODIFIERS(datumtype));
2295                 cur -= len;
2296             }
2297             if (cur < start+symptr->strbeg) {
2298                 /* Make sure group starts don't point into the void */
2299                 tempsym_t *group;
2300                 const STRLEN length = cur-start;
2301                 for (group = symptr;
2302                      group && length < group->strbeg;
2303                      group = group->previous) group->strbeg = length;
2304                 lookahead.strbeg = length;
2305             }
2306             break;
2307         case 'x' | TYPE_IS_SHRIEKING: {
2308             I32 ai32;
2309             if (!len)                   /* Avoid division by 0 */
2310                 len = 1;
2311             if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len;
2312             else      ai32 = (cur - start) % len;
2313             if (ai32 == 0) goto no_change;
2314             len -= ai32;
2315         }
2316         /* FALL THROUGH */
2317         case 'x':
2318             goto grow;
2319         case 'A':
2320         case 'Z':
2321         case 'a': {
2322             const char *aptr;
2323
2324             fromstr = NEXTFROM;
2325             aptr = SvPV_const(fromstr, fromlen);
2326             if (DO_UTF8(fromstr)) {
2327                 const char *end, *s;
2328
2329                 if (!utf8 && !SvUTF8(cat)) {
2330                     marked_upgrade(aTHX_ cat, symptr);
2331                     lookahead.flags |= FLAG_DO_UTF8;
2332                     lookahead.strbeg = symptr->strbeg;
2333                     utf8 = 1;
2334                     start = SvPVX(cat);
2335                     cur = start + SvCUR(cat);
2336                 }
2337                 if (howlen == e_star) {
2338                     if (utf8) goto string_copy;
2339                     len = fromlen+1;
2340                 }
2341                 s = aptr;
2342                 end = aptr + fromlen;
2343                 fromlen = datumtype == 'Z' ? len-1 : len;
2344                 while ((I32) fromlen > 0 && s < end) {
2345                     s += UTF8SKIP(s);
2346                     fromlen--;
2347                 }
2348                 if (s > end)
2349                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2350                 if (utf8) {
2351                     len = fromlen;
2352                     if (datumtype == 'Z') len++;
2353                     fromlen = s-aptr;
2354                     len += fromlen;
2355
2356                     goto string_copy;
2357                 }
2358                 fromlen = len - fromlen;
2359                 if (datumtype == 'Z') fromlen--;
2360                 if (howlen == e_star) {
2361                     len = fromlen;
2362                     if (datumtype == 'Z') len++;
2363                 }
2364                 GROWING(0, cat, start, cur, len);
2365                 if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
2366                                   datumtype | TYPE_IS_PACK))
2367                     Perl_croak(aTHX_ "panic: predicted utf8 length not available, "
2368                                "for '%c', aptr=%p end=%p cur=%p, fromlen=%"UVuf,
2369                                (int)datumtype, aptr, end, cur, (UV)fromlen);
2370                 cur += fromlen;
2371                 len -= fromlen;
2372             } else if (utf8) {
2373                 if (howlen == e_star) {
2374                     len = fromlen;
2375                     if (datumtype == 'Z') len++;
2376                 }
2377                 if (len <= (I32) fromlen) {
2378                     fromlen = len;
2379                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2380                 }
2381                 /* assumes a byte expands to at most UTF8_EXPAND bytes on
2382                    upgrade, so:
2383                    expected_length <= from_len*UTF8_EXPAND + (len-from_len) */
2384                 GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len);
2385                 len -= fromlen;
2386                 while (fromlen > 0) {
2387                     cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr);
2388                     aptr++;
2389                     fromlen--;
2390                 }
2391             } else {
2392               string_copy:
2393                 if (howlen == e_star) {
2394                     len = fromlen;
2395                     if (datumtype == 'Z') len++;
2396                 }
2397                 if (len <= (I32) fromlen) {
2398                     fromlen = len;
2399                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2400                 }
2401                 GROWING(0, cat, start, cur, len);
2402                 Copy(aptr, cur, fromlen, char);
2403                 cur += fromlen;
2404                 len -= fromlen;
2405             }
2406             memset(cur, datumtype == 'A' ? ' ' : '\0', len);
2407             cur += len;
2408             SvTAINT(cat);
2409             break;
2410         }
2411         case 'B':
2412         case 'b': {
2413             const char *str, *end;
2414             I32 l, field_len;
2415             U8 bits;
2416             bool utf8_source;
2417             U32 utf8_flags;
2418
2419             fromstr = NEXTFROM;
2420             str = SvPV_const(fromstr, fromlen);
2421             end = str + fromlen;
2422             if (DO_UTF8(fromstr)) {
2423                 utf8_source = TRUE;
2424                 utf8_flags  = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2425             } else {
2426                 utf8_source = FALSE;
2427                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2428             }
2429             if (howlen == e_star) len = fromlen;
2430             field_len = (len+7)/8;
2431             GROWING(utf8, cat, start, cur, field_len);
2432             if (len > (I32)fromlen) len = fromlen;
2433             bits = 0;
2434             l = 0;
2435             if (datumtype == 'B')
2436                 while (l++ < len) {
2437                     if (utf8_source) {
2438                         UV val = 0;
2439                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2440                         bits |= val & 1;
2441                     } else bits |= *str++ & 1;
2442                     if (l & 7) bits <<= 1;
2443                     else {
2444                         PUSH_BYTE(utf8, cur, bits);
2445                         bits = 0;
2446                     }
2447                 }
2448             else
2449                 /* datumtype == 'b' */
2450                 while (l++ < len) {
2451                     if (utf8_source) {
2452                         UV val = 0;
2453                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2454                         if (val & 1) bits |= 0x80;
2455                     } else if (*str++ & 1)
2456                         bits |= 0x80;
2457                     if (l & 7) bits >>= 1;
2458                     else {
2459                         PUSH_BYTE(utf8, cur, bits);
2460                         bits = 0;
2461                     }
2462                 }
2463             l--;
2464             if (l & 7) {
2465                 if (datumtype == 'B')
2466                     bits <<= 7 - (l & 7);
2467                 else
2468                     bits >>= 7 - (l & 7);
2469                 PUSH_BYTE(utf8, cur, bits);
2470                 l += 7;
2471             }
2472             /* Determine how many chars are left in the requested field */
2473             l /= 8;
2474             if (howlen == e_star) field_len = 0;
2475             else field_len -= l;
2476             Zero(cur, field_len, char);
2477             cur += field_len;
2478             break;
2479         }
2480         case 'H':
2481         case 'h': {
2482             const char *str, *end;
2483             I32 l, field_len;
2484             U8 bits;
2485             bool utf8_source;
2486             U32 utf8_flags;
2487
2488             fromstr = NEXTFROM;
2489             str = SvPV_const(fromstr, fromlen);
2490             end = str + fromlen;
2491             if (DO_UTF8(fromstr)) {
2492                 utf8_source = TRUE;
2493                 utf8_flags  = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2494             } else {
2495                 utf8_source = FALSE;
2496                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2497             }
2498             if (howlen == e_star) len = fromlen;
2499             field_len = (len+1)/2;
2500             GROWING(utf8, cat, start, cur, field_len);
2501             if (!utf8 && len > (I32)fromlen) len = fromlen;
2502             bits = 0;
2503             l = 0;
2504             if (datumtype == 'H')
2505                 while (l++ < len) {
2506                     if (utf8_source) {
2507                         UV val = 0;
2508                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2509                         if (val < 256 && isALPHA(val))
2510                             bits |= (val + 9) & 0xf;
2511                         else
2512                             bits |= val & 0xf;
2513                     } else if (isALPHA(*str))
2514                         bits |= (*str++ + 9) & 0xf;
2515                     else
2516                         bits |= *str++ & 0xf;
2517                     if (l & 1) bits <<= 4;
2518                     else {
2519                         PUSH_BYTE(utf8, cur, bits);
2520                         bits = 0;
2521                     }
2522                 }
2523             else
2524                 while (l++ < len) {
2525                     if (utf8_source) {
2526                         UV val = 0;
2527                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2528                         if (val < 256 && isALPHA(val))
2529                             bits |= ((val + 9) & 0xf) << 4;
2530                         else
2531                             bits |= (val & 0xf) << 4;
2532                     } else if (isALPHA(*str))
2533                         bits |= ((*str++ + 9) & 0xf) << 4;
2534                     else
2535                         bits |= (*str++ & 0xf) << 4;
2536                     if (l & 1) bits >>= 4;
2537                     else {
2538                         PUSH_BYTE(utf8, cur, bits);
2539                         bits = 0;
2540                     }
2541                 }
2542             l--;
2543             if (l & 1) {
2544                 PUSH_BYTE(utf8, cur, bits);
2545                 l++;
2546             }
2547             /* Determine how many chars are left in the requested field */
2548             l /= 2;
2549             if (howlen == e_star) field_len = 0;
2550             else field_len -= l;
2551             Zero(cur, field_len, char);
2552             cur += field_len;
2553             break;
2554         }
2555         case 'c':
2556             while (len-- > 0) {
2557                 IV aiv;
2558                 fromstr = NEXTFROM;
2559                 aiv = SvIV(fromstr);
2560                 if ((-128 > aiv || aiv > 127))
2561                     Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2562                                    "Character in 'c' format wrapped in pack");
2563                 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2564             }
2565             break;
2566         case 'C':
2567             if (len == 0) {
2568                 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
2569                 break;
2570             }
2571             while (len-- > 0) {
2572                 IV aiv;
2573                 fromstr = NEXTFROM;
2574                 aiv = SvIV(fromstr);
2575                 if ((0 > aiv || aiv > 0xff))
2576                     Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2577                                    "Character in 'C' format wrapped in pack");
2578                 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2579             }
2580             break;
2581         case 'W': {
2582             char *end;
2583             U8 in_bytes = (U8)IN_BYTES;
2584
2585             end = start+SvLEN(cat)-1;
2586             if (utf8) end -= UTF8_MAXLEN-1;
2587             while (len-- > 0) {
2588                 UV auv;
2589                 fromstr = NEXTFROM;
2590                 auv = SvUV(fromstr);
2591                 if (in_bytes) auv = auv % 0x100;
2592                 if (utf8) {
2593                   W_utf8:
2594                     if (cur > end) {
2595                         *cur = '\0';
2596                         SvCUR_set(cat, cur - start);
2597
2598                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2599                         end = start+SvLEN(cat)-UTF8_MAXLEN;
2600                     }
2601                     cur = (char *) uvuni_to_utf8_flags((U8 *) cur,
2602                                                        NATIVE_TO_UNI(auv),
2603                                                        warn_utf8 ?
2604                                                        0 : UNICODE_ALLOW_ANY);
2605                 } else {
2606                     if (auv >= 0x100) {
2607                         if (!SvUTF8(cat)) {
2608                             *cur = '\0';
2609                             SvCUR_set(cat, cur - start);
2610                             marked_upgrade(aTHX_ cat, symptr);
2611                             lookahead.flags |= FLAG_DO_UTF8;
2612                             lookahead.strbeg = symptr->strbeg;
2613                             utf8 = 1;
2614                             start = SvPVX(cat);
2615                             cur = start + SvCUR(cat);
2616                             end = start+SvLEN(cat)-UTF8_MAXLEN;
2617                             goto W_utf8;
2618                         }
2619                         Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2620                                        "Character in 'W' format wrapped in pack");
2621                         auv &= 0xff;
2622                     }
2623                     if (cur >= end) {
2624                         *cur = '\0';
2625                         SvCUR_set(cat, cur - start);
2626                         GROWING(0, cat, start, cur, len+1);
2627                         end = start+SvLEN(cat)-1;
2628                     }
2629                     *(U8 *) cur++ = (U8)auv;
2630                 }
2631             }
2632             break;
2633         }
2634         case 'U': {
2635             char *end;
2636
2637             if (len == 0) {
2638                 if (!(symptr->flags & FLAG_DO_UTF8)) {
2639                     marked_upgrade(aTHX_ cat, symptr);
2640                     lookahead.flags |= FLAG_DO_UTF8;
2641                     lookahead.strbeg = symptr->strbeg;
2642                 }
2643                 utf8 = 0;
2644                 goto no_change;
2645             }
2646
2647             end = start+SvLEN(cat);
2648             if (!utf8) end -= UTF8_MAXLEN;
2649             while (len-- > 0) {
2650                 UV auv;
2651                 fromstr = NEXTFROM;
2652                 auv = SvUV(fromstr);
2653                 if (utf8) {
2654                     U8 buffer[UTF8_MAXLEN], *endb;
2655                     endb = uvuni_to_utf8_flags(buffer, auv,
2656                                                warn_utf8 ?
2657                                                0 : UNICODE_ALLOW_ANY);
2658                     if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
2659                         *cur = '\0';
2660                         SvCUR_set(cat, cur - start);
2661                         GROWING(0, cat, start, cur,
2662                                 len+(endb-buffer)*UTF8_EXPAND);
2663                         end = start+SvLEN(cat);
2664                     }
2665                     cur = bytes_to_uni(buffer, endb-buffer, cur);
2666                 } else {
2667                     if (cur >= end) {
2668                         *cur = '\0';
2669                         SvCUR_set(cat, cur - start);
2670                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2671                         end = start+SvLEN(cat)-UTF8_MAXLEN;
2672                     }
2673                     cur = (char *) uvuni_to_utf8_flags((U8 *) cur, auv,
2674                                                        warn_utf8 ?
2675                                                        0 : UNICODE_ALLOW_ANY);
2676                 }
2677             }
2678             break;
2679         }
2680         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2681         case 'f':
2682             while (len-- > 0) {
2683                 float afloat;
2684                 NV anv;
2685                 fromstr = NEXTFROM;
2686                 anv = SvNV(fromstr);
2687 # if defined(VMS) && !defined(_IEEE_FP)
2688                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2689                  * on Alpha; fake it if we don't have them.
2690                  */
2691                 if (anv > FLT_MAX)
2692                     afloat = FLT_MAX;
2693                 else if (anv < -FLT_MAX)
2694                     afloat = -FLT_MAX;
2695                 else afloat = (float)anv;
2696 # else
2697                 afloat = (float)anv;
2698 # endif
2699                 DO_BO_PACK(afloat);
2700                 PUSH_VAR(utf8, cur, afloat);
2701             }
2702             break;
2703         case 'd':
2704             while (len-- > 0) {
2705                 double adouble;
2706                 NV anv;
2707                 fromstr = NEXTFROM;
2708                 anv = SvNV(fromstr);
2709 # if defined(VMS) && !defined(_IEEE_FP)
2710                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2711                  * on Alpha; fake it if we don't have them.
2712                  */
2713                 if (anv > DBL_MAX)
2714                     adouble = DBL_MAX;
2715                 else if (anv < -DBL_MAX)
2716                     adouble = -DBL_MAX;
2717                 else adouble = (double)anv;
2718 # else
2719                 adouble = (double)anv;
2720 # endif
2721                 DO_BO_PACK(adouble);
2722                 PUSH_VAR(utf8, cur, adouble);
2723             }
2724             break;
2725         case 'F': {
2726             NV_bytes anv;
2727             Zero(&anv, 1, NV); /* can be long double with unused bits */
2728             while (len-- > 0) {
2729                 fromstr = NEXTFROM;
2730 #ifdef __GNUC__
2731                 /* to work round a gcc/x86 bug; don't use SvNV */
2732                 anv.nv = sv_2nv(fromstr);
2733 #else
2734                 anv.nv = SvNV(fromstr);
2735 #endif
2736                 DO_BO_PACK(anv);
2737                 PUSH_BYTES(utf8, cur, anv.bytes, sizeof(anv.bytes));
2738             }
2739             break;
2740         }
2741 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2742         case 'D': {
2743             ld_bytes aldouble;
2744             /* long doubles can have unused bits, which may be nonzero */
2745             Zero(&aldouble, 1, long double);
2746             while (len-- > 0) {
2747                 fromstr = NEXTFROM;
2748 #  ifdef __GNUC__
2749                 /* to work round a gcc/x86 bug; don't use SvNV */
2750                 aldouble.ld = (long double)sv_2nv(fromstr);
2751 #  else
2752                 aldouble.ld = (long double)SvNV(fromstr);
2753 #  endif
2754                 DO_BO_PACK(aldouble);
2755                 PUSH_BYTES(utf8, cur, aldouble.bytes, sizeof(aldouble.bytes));
2756             }
2757             break;
2758         }
2759 #endif
2760         case 'n' | TYPE_IS_SHRIEKING:
2761         case 'n':
2762             while (len-- > 0) {
2763                 I16 ai16;
2764                 fromstr = NEXTFROM;
2765                 ai16 = (I16)SvIV(fromstr);
2766                 ai16 = PerlSock_htons(ai16);
2767                 PUSH16(utf8, cur, &ai16);
2768             }
2769             break;
2770         case 'v' | TYPE_IS_SHRIEKING:
2771         case 'v':
2772             while (len-- > 0) {
2773                 I16 ai16;
2774                 fromstr = NEXTFROM;
2775                 ai16 = (I16)SvIV(fromstr);
2776                 ai16 = htovs(ai16);
2777                 PUSH16(utf8, cur, &ai16);
2778             }
2779             break;
2780         case 'S' | TYPE_IS_SHRIEKING:
2781 #if SHORTSIZE != SIZE16
2782             while (len-- > 0) {
2783                 unsigned short aushort;
2784                 fromstr = NEXTFROM;
2785                 aushort = SvUV(fromstr);
2786                 DO_BO_PACK(aushort);
2787                 PUSH_VAR(utf8, cur, aushort);
2788             }
2789             break;
2790 #else
2791             /* Fall through! */
2792 #endif
2793         case 'S':
2794             while (len-- > 0) {
2795                 U16 au16;
2796                 fromstr = NEXTFROM;
2797                 au16 = (U16)SvUV(fromstr);
2798                 DO_BO_PACK(au16);
2799                 PUSH16(utf8, cur, &au16);
2800             }
2801             break;
2802         case 's' | TYPE_IS_SHRIEKING:
2803 #if SHORTSIZE != SIZE16
2804             while (len-- > 0) {
2805                 short ashort;
2806                 fromstr = NEXTFROM;
2807                 ashort = SvIV(fromstr);
2808                 DO_BO_PACK(ashort);
2809                 PUSH_VAR(utf8, cur, ashort);
2810             }
2811             break;
2812 #else
2813             /* Fall through! */
2814 #endif
2815         case 's':
2816             while (len-- > 0) {
2817                 I16 ai16;
2818                 fromstr = NEXTFROM;
2819                 ai16 = (I16)SvIV(fromstr);
2820                 DO_BO_PACK(ai16);
2821                 PUSH16(utf8, cur, &ai16);
2822             }
2823             break;
2824         case 'I':
2825         case 'I' | TYPE_IS_SHRIEKING:
2826             while (len-- > 0) {
2827                 unsigned int auint;
2828                 fromstr = NEXTFROM;
2829                 auint = SvUV(fromstr);
2830                 DO_BO_PACK(auint);
2831                 PUSH_VAR(utf8, cur, auint);
2832             }
2833             break;
2834         case 'j':
2835             while (len-- > 0) {
2836                 IV aiv;
2837                 fromstr = NEXTFROM;
2838                 aiv = SvIV(fromstr);
2839                 DO_BO_PACK(aiv);
2840                 PUSH_VAR(utf8, cur, aiv);
2841             }
2842             break;
2843         case 'J':
2844             while (len-- > 0) {
2845                 UV auv;
2846                 fromstr = NEXTFROM;
2847                 auv = SvUV(fromstr);
2848                 DO_BO_PACK(auv);
2849                 PUSH_VAR(utf8, cur, auv);
2850             }
2851             break;
2852         case 'w':
2853             while (len-- > 0) {
2854                 NV anv;
2855                 fromstr = NEXTFROM;
2856                 anv = SvNV(fromstr);
2857
2858                 if (anv < 0) {
2859                     *cur = '\0';
2860                     SvCUR_set(cat, cur - start);
2861                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2862                 }
2863
2864                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2865                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2866                    any negative IVs will have already been got by the croak()
2867                    above. IOK is untrue for fractions, so we test them
2868                    against UV_MAX_P1.  */
2869                 if (SvIOK(fromstr) || anv < UV_MAX_P1) {
2870                     char   buf[(sizeof(UV)*CHAR_BIT)/7+1];
2871                     char  *in = buf + sizeof(buf);
2872                     UV     auv = SvUV(fromstr);
2873
2874                     do {
2875                         *--in = (char)((auv & 0x7f) | 0x80);
2876                         auv >>= 7;
2877                     } while (auv);
2878                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2879                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
2880                                        in, (buf + sizeof(buf)) - in);
2881                 } else if (SvPOKp(fromstr))
2882                     goto w_string;
2883                 else if (SvNOKp(fromstr)) {
2884                     /* 10**NV_MAX_10_EXP is the largest power of 10
2885                        so 10**(NV_MAX_10_EXP+1) is definitely unrepresentable
2886                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2887                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2888                        And with that many bytes only Inf can overflow.
2889                        Some C compilers are strict about integral constant
2890                        expressions so we conservatively divide by a slightly
2891                        smaller integer instead of multiplying by the exact
2892                        floating-point value.
2893                     */
2894 #ifdef NV_MAX_10_EXP
2895                     /* char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2896                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2897 #else
2898                     /* char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2899                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2900 #endif
2901                     char  *in = buf + sizeof(buf);
2902
2903                     anv = Perl_floor(anv);
2904                     do {
2905                         const NV next = Perl_floor(anv / 128);
2906                         if (in <= buf)  /* this cannot happen ;-) */
2907                             Perl_croak(aTHX_ "Cannot compress integer in pack");
2908                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2909                         anv = next;
2910                     } while (anv > 0);
2911                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2912                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
2913                                        in, (buf + sizeof(buf)) - in);
2914                 } else {
2915                     const char     *from;
2916                     char           *result, *in;
2917                     SV             *norm;
2918                     STRLEN          len;
2919                     bool            done;
2920
2921                   w_string:
2922                     /* Copy string and check for compliance */
2923                     from = SvPV_const(fromstr, len);
2924                     if ((norm = is_an_int(from, len)) == NULL)
2925                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2926
2927                     Newx(result, len, char);
2928                     in = result + len;
2929                     done = FALSE;
2930                     while (!done) *--in = div128(norm, &done) | 0x80;
2931                     result[len - 1] &= 0x7F; /* clear continue bit */
2932                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
2933                                        in, (result + len) - in);
2934                     Safefree(result);
2935                     SvREFCNT_dec(norm); /* free norm */
2936                 }
2937             }
2938             break;
2939         case 'i':
2940         case 'i' | TYPE_IS_SHRIEKING:
2941             while (len-- > 0) {
2942                 int aint;
2943                 fromstr = NEXTFROM;
2944                 aint = SvIV(fromstr);
2945                 DO_BO_PACK(aint);
2946                 PUSH_VAR(utf8, cur, aint);
2947             }
2948             break;
2949         case 'N' | TYPE_IS_SHRIEKING:
2950         case 'N':
2951             while (len-- > 0) {
2952                 U32 au32;
2953                 fromstr = NEXTFROM;
2954                 au32 = SvUV(fromstr);
2955                 au32 = PerlSock_htonl(au32);
2956                 PUSH32(utf8, cur, &au32);
2957             }
2958             break;
2959         case 'V' | TYPE_IS_SHRIEKING:
2960         case 'V':
2961             while (len-- > 0) {
2962                 U32 au32;
2963                 fromstr = NEXTFROM;
2964                 au32 = SvUV(fromstr);
2965                 au32 = htovl(au32);
2966                 PUSH32(utf8, cur, &au32);
2967             }
2968             break;
2969         case 'L' | TYPE_IS_SHRIEKING:
2970 #if LONGSIZE != SIZE32
2971             while (len-- > 0) {
2972                 unsigned long aulong;
2973                 fromstr = NEXTFROM;
2974                 aulong = SvUV(fromstr);
2975                 DO_BO_PACK(aulong);
2976                 PUSH_VAR(utf8, cur, aulong);
2977             }
2978             break;
2979 #else
2980             /* Fall though! */
2981 #endif
2982         case 'L':
2983             while (len-- > 0) {
2984                 U32 au32;
2985                 fromstr = NEXTFROM;
2986                 au32 = SvUV(fromstr);
2987                 DO_BO_PACK(au32);
2988                 PUSH32(utf8, cur, &au32);
2989             }
2990             break;
2991         case 'l' | TYPE_IS_SHRIEKING:
2992 #if LONGSIZE != SIZE32
2993             while (len-- > 0) {
2994                 long along;
2995                 fromstr = NEXTFROM;
2996                 along = SvIV(fromstr);
2997                 DO_BO_PACK(along);
2998                 PUSH_VAR(utf8, cur, along);
2999             }
3000             break;
3001 #else
3002             /* Fall though! */
3003 #endif
3004         case 'l':
3005             while (len-- > 0) {
3006                 I32 ai32;
3007                 fromstr = NEXTFROM;
3008                 ai32 = SvIV(fromstr);
3009                 DO_BO_PACK(ai32);
3010                 PUSH32(utf8, cur, &ai32);
3011             }
3012             break;
3013 #ifdef HAS_QUAD
3014         case 'Q':
3015             while (len-- > 0) {
3016                 Uquad_t auquad;
3017                 fromstr = NEXTFROM;
3018                 auquad = (Uquad_t) SvUV(fromstr);
3019                 DO_BO_PACK(auquad);
3020                 PUSH_VAR(utf8, cur, auquad);
3021             }
3022             break;
3023         case 'q':
3024             while (len-- > 0) {
3025                 Quad_t aquad;
3026                 fromstr = NEXTFROM;
3027                 aquad = (Quad_t)SvIV(fromstr);
3028                 DO_BO_PACK(aquad);
3029                 PUSH_VAR(utf8, cur, aquad);
3030             }
3031             break;
3032 #endif /* HAS_QUAD */
3033         case 'P':
3034             len = 1;            /* assume SV is correct length */
3035             GROWING(utf8, cat, start, cur, sizeof(char *));
3036             /* Fall through! */
3037         case 'p':
3038             while (len-- > 0) {
3039                 const char *aptr;
3040
3041                 fromstr = NEXTFROM;
3042                 SvGETMAGIC(fromstr);
3043                 if (!SvOK(fromstr)) aptr = NULL;
3044                 else {
3045                     /* XXX better yet, could spirit away the string to
3046                      * a safe spot and hang on to it until the result
3047                      * of pack() (and all copies of the result) are
3048                      * gone.
3049                      */
3050                     if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
3051                              !SvREADONLY(fromstr)))) {
3052                         Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3053                                        "Attempt to pack pointer to temporary value");
3054                     }
3055                     if (SvPOK(fromstr) || SvNIOK(fromstr))
3056                         aptr = SvPV_nomg_const_nolen(fromstr);
3057                     else
3058                         aptr = SvPV_force_flags_nolen(fromstr, 0);
3059                 }
3060                 DO_BO_PACK(aptr);
3061                 PUSH_VAR(utf8, cur, aptr);
3062             }
3063             break;
3064         case 'u': {
3065             const char *aptr, *aend;
3066             bool from_utf8;
3067
3068             fromstr = NEXTFROM;
3069             if (len <= 2) len = 45;
3070             else len = len / 3 * 3;
3071             if (len >= 64) {
3072                 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3073                                "Field too wide in 'u' format in pack");
3074                 len = 63;
3075             }
3076             aptr = SvPV_const(fromstr, fromlen);
3077             from_utf8 = DO_UTF8(fromstr);
3078             if (from_utf8) {
3079                 aend = aptr + fromlen;
3080                 fromlen = sv_len_utf8_nomg(fromstr);
3081             } else aend = NULL; /* Unused, but keep compilers happy */
3082             GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2);
3083             while (fromlen > 0) {
3084                 U8 *end;
3085                 I32 todo;
3086                 U8 hunk[1+63/3*4+1];
3087
3088                 if ((I32)fromlen > len)
3089                     todo = len;
3090                 else
3091                     todo = fromlen;
3092                 if (from_utf8) {
3093                     char buffer[64];
3094                     if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo,
3095                                       'u' | TYPE_IS_PACK)) {
3096                         *cur = '\0';
3097                         SvCUR_set(cat, cur - start);
3098                         Perl_croak(aTHX_ "panic: string is shorter than advertised, "
3099                                    "aptr=%p, aend=%p, buffer=%p, todo=%ld",
3100                                    aptr, aend, buffer, (long) todo);
3101                     }
3102                     end = doencodes(hunk, buffer, todo);
3103                 } else {
3104                     end = doencodes(hunk, aptr, todo);
3105                     aptr += todo;
3106                 }
3107                 PUSH_BYTES(utf8, cur, hunk, end-hunk);
3108                 fromlen -= todo;
3109             }
3110             break;
3111         }
3112         }
3113         *cur = '\0';
3114         SvCUR_set(cat, cur - start);
3115       no_change:
3116         *symptr = lookahead;
3117     }
3118     return beglist;
3119 }
3120 #undef NEXTFROM
3121
3122
3123 PP(pp_pack)
3124 {
3125     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3126     SV *cat = TARG;
3127     STRLEN fromlen;
3128     SV *pat_sv = *++MARK;
3129     const char *pat = SvPV_const(pat_sv, fromlen);
3130     const char *patend = pat + fromlen;
3131
3132     MARK++;
3133     sv_setpvs(cat, "");
3134     SvUTF8_off(cat);
3135
3136     packlist(cat, pat, patend, MARK, SP + 1);
3137
3138     SvSETMAGIC(cat);
3139     SP = ORIGMARK;
3140     PUSHs(cat);
3141     RETURN;
3142 }
3143
3144 /*
3145  * Local variables:
3146  * c-indentation-style: bsd
3147  * c-basic-offset: 4
3148  * indent-tabs-mode: nil
3149  * End:
3150  *
3151  * ex: set ts=8 sts=4 sw=4 et:
3152  */