pp_pack.c

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