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