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