pp_pack.c

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