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 /*
  40  * Offset for integer pack/unpack.
  41  *
  42  * On architectures where I16 and I32 aren't really 16 and 32 bits,
  43  * which for now are all Crays, pack and unpack have to play games.
  44  */
  45
  46 /*
  47  * These values are required for portability of pack() output.
  48  * If they're not right on your machine, then pack() and unpack()
  49  * wouldn't work right anyway; you'll need to apply the Cray hack.
  50  * (I'd like to check them with #if, but you can't use sizeof() in
  51  * the preprocessor.)  --???
  52  */
  53 /*
  54     The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
  55     defines are now in config.h.  --Andy Dougherty  April 1998
  56  */
  57 #define SIZE16 2
  58 #define SIZE32 4
  59
  60 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
  61    --jhi Feb 1999 */
  62
  63 #if U16SIZE > SIZE16 || U32SIZE > SIZE32
  64 #  if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678    /* little-endian */
  65 #    define OFF16(p)    (char*)(p)
  66 #    define OFF32(p)    (char*)(p)
  67 #  else
  68 #    if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321  /* big-endian */
  69 #      define OFF16(p)  ((char*)(p) + (sizeof(U16) - SIZE16))
  70 #      define OFF32(p)  ((char*)(p) + (sizeof(U32) - SIZE32))
  71 #    else
  72        }}}} bad cray byte order
  73 #    endif
  74 #  endif
  75 #  define COPY16(s,p)  (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
  76 #  define COPY32(s,p)  (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
  77 #  define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
  78 #  define CAT16(sv,p)  sv_catpvn(sv, OFF16(p), SIZE16)
  79 #  define CAT32(sv,p)  sv_catpvn(sv, OFF32(p), SIZE32)
  80 #else
  81 #  define COPY16(s,p)  Copy(s, p, SIZE16, char)
  82 #  define COPY32(s,p)  Copy(s, p, SIZE32, char)
  83 #  define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
  84 #  define CAT16(sv,p)  sv_catpvn(sv, (char*)(p), SIZE16)
  85 #  define CAT32(sv,p)  sv_catpvn(sv, (char*)(p), SIZE32)
  86 #endif
  87
  88 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
  89 #define MAX_SUB_TEMPLATE_LEVEL 100
  90
  91 /* flags (note that type modifiers can also be used as flags!) */
  92 #define FLAG_UNPACK_ONLY_ONE  0x10
  93 #define FLAG_UNPACK_DO_UTF8   0x08
  94 #define FLAG_SLASH            0x04
  95 #define FLAG_COMMA            0x02
  96 #define FLAG_PACK             0x01
  97
  98 STATIC SV *
  99 S_mul128(pTHX_ SV *sv, U8 m)
 100 {
 101   STRLEN          len;
 102   char           *s = SvPV(sv, len);
 103   char           *t;
 104   U32             i = 0;
 105
 106   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
 107     SV             *tmpNew = newSVpvn("0000000000", 10);
 108
 109     sv_catsv(tmpNew, sv);
 110     SvREFCNT_dec(sv);           /* free old sv */
 111     sv = tmpNew;
 112     s = SvPV(sv, len);
 113   }
 114   t = s + len - 1;
 115   while (!*t)                   /* trailing '\0'? */
 116     t--;
 117   while (t > s) {
 118     i = ((*t - '0') << 7) + m;
 119     *(t--) = '0' + (char)(i % 10);
 120     m = (char)(i / 10);
 121   }
 122   return (sv);
 123 }
 124
 125 /* Explosives and implosives. */
 126
 127 #if 'I' == 73 && 'J' == 74
 128 /* On an ASCII/ISO kind of system */
 129 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
 130 #else
 131 /*
 132   Some other sort of character set - use memchr() so we don't match
 133   the null byte.
 134  */
 135 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
 136 #endif
 137
 138 /* type modifiers */
 139 #define TYPE_IS_SHRIEKING       0x100
 140 #define TYPE_IS_BIG_ENDIAN      0x200
 141 #define TYPE_IS_LITTLE_ENDIAN   0x400
 142 #define TYPE_ENDIANNESS_MASK    (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
 143 #define TYPE_MODIFIERS(t)       ((t) & ~0xFF)
 144 #define TYPE_NO_MODIFIERS(t)    ((t) & 0xFF)
 145
 146 #ifdef PERL_PACK_CAN_SHRIEKSIGN
 147 #define SHRIEKING_ALLOWED_TYPES "sSiIlLxXnNvV"
 148 #else
 149 #define SHRIEKING_ALLOWED_TYPES "sSiIlLxX"
 150 #endif
 151
 152 #ifndef PERL_PACK_CAN_BYTEORDER
 153 /* Put "can't" first because it is shorter  */
 154 # define TYPE_ENDIANNESS(t)     0
 155 # define TYPE_NO_ENDIANNESS(t)  (t)
 156
 157 # define ENDIANNESS_ALLOWED_TYPES   ""
 158
 159 # define DO_BO_UNPACK(var, type)
 160 # define DO_BO_PACK(var, type)
 161 # define DO_BO_UNPACK_PTR(var, type, pre_cast)
 162 # define DO_BO_PACK_PTR(var, type, pre_cast)
 163 # define DO_BO_UNPACK_N(var, type)
 164 # define DO_BO_PACK_N(var, type)
 165 # define DO_BO_UNPACK_P(var)
 166 # define DO_BO_PACK_P(var)
 167
 168 #else
 169
 170 # define TYPE_ENDIANNESS(t)     ((t) & TYPE_ENDIANNESS_MASK)
 171 # define TYPE_NO_ENDIANNESS(t)  ((t) & ~TYPE_ENDIANNESS_MASK)
 172
 173 # define ENDIANNESS_ALLOWED_TYPES   "sSiIlLqQjJfFdDpP("
 174
 175 # define DO_BO_UNPACK(var, type)                                              \
 176         STMT_START {                                                          \
 177           switch (TYPE_ENDIANNESS(datumtype)) {                               \
 178             case TYPE_IS_BIG_ENDIAN:    var = my_betoh ## type (var); break;  \
 179             case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break;  \
 180             default: break;                                                   \
 181           }                                                                   \
 182         } STMT_END
 183
 184 # define DO_BO_PACK(var, type)                                                \
 185         STMT_START {                                                          \
 186           switch (TYPE_ENDIANNESS(datumtype)) {                               \
 187             case TYPE_IS_BIG_ENDIAN:    var = my_htobe ## type (var); break;  \
 188             case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break;  \
 189             default: break;                                                   \
 190           }                                                                   \
 191         } STMT_END
 192
 193 # define DO_BO_UNPACK_PTR(var, type, pre_cast)                                \
 194         STMT_START {                                                          \
 195           switch (TYPE_ENDIANNESS(datumtype)) {                               \
 196             case TYPE_IS_BIG_ENDIAN:                                          \
 197               var = (void *) my_betoh ## type ((pre_cast) var);               \
 198               break;                                                          \
 199             case TYPE_IS_LITTLE_ENDIAN:                                       \
 200               var = (void *) my_letoh ## type ((pre_cast) var);               \
 201               break;                                                          \
 202             default:                                                          \
 203               break;                                                          \
 204           }                                                                   \
 205         } STMT_END
 206
 207 # define DO_BO_PACK_PTR(var, type, pre_cast)                                  \
 208         STMT_START {                                                          \
 209           switch (TYPE_ENDIANNESS(datumtype)) {                               \
 210             case TYPE_IS_BIG_ENDIAN:                                          \
 211               var = (void *) my_htobe ## type ((pre_cast) var);               \
 212               break;                                                          \
 213             case TYPE_IS_LITTLE_ENDIAN:                                       \
 214               var = (void *) my_htole ## type ((pre_cast) var);               \
 215               break;                                                          \
 216             default:                                                          \
 217               break;                                                          \
 218           }                                                                   \
 219         } STMT_END
 220
 221 # define BO_CANT_DOIT(action, type)                                           \
 222         STMT_START {                                                          \
 223           switch (TYPE_ENDIANNESS(datumtype)) {                               \
 224              case TYPE_IS_BIG_ENDIAN:                                         \
 225                Perl_croak(aTHX_ "Can't %s big-endian %ss on this "            \
 226                                 "platform", #action, #type);                  \
 227                break;                                                         \
 228              case TYPE_IS_LITTLE_ENDIAN:                                      \
 229                Perl_croak(aTHX_ "Can't %s little-endian %ss on this "         \
 230                                 "platform", #action, #type);                  \
 231                break;                                                         \
 232              default:                                                         \
 233                break;                                                         \
 234            }                                                                  \
 235          } STMT_END
 236
 237 # if PTRSIZE == INTSIZE
 238 #  define DO_BO_UNPACK_P(var)   DO_BO_UNPACK_PTR(var, i, int)
 239 #  define DO_BO_PACK_P(var)     DO_BO_PACK_PTR(var, i, int)
 240 # elif PTRSIZE == LONGSIZE
 241 #  define DO_BO_UNPACK_P(var)   DO_BO_UNPACK_PTR(var, l, long)
 242 #  define DO_BO_PACK_P(var)     DO_BO_PACK_PTR(var, l, long)
 243 # else
 244 #  define DO_BO_UNPACK_P(var)   BO_CANT_DOIT(unpack, pointer)
 245 #  define DO_BO_PACK_P(var)     BO_CANT_DOIT(pack, pointer)
 246 # endif
 247
 248 # if defined(my_htolen) && defined(my_letohn) && \
 249     defined(my_htoben) && defined(my_betohn)
 250 #  define DO_BO_UNPACK_N(var, type)                                           \
 251          STMT_START {                                                         \
 252            switch (TYPE_ENDIANNESS(datumtype)) {                              \
 253              case TYPE_IS_BIG_ENDIAN:    my_betohn(&var, sizeof(type)); break;\
 254              case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
 255              default: break;                                                  \
 256            }                                                                  \
 257          } STMT_END
 258
 259 #  define DO_BO_PACK_N(var, type)                                             \
 260          STMT_START {                                                         \
 261            switch (TYPE_ENDIANNESS(datumtype)) {                              \
 262              case TYPE_IS_BIG_ENDIAN:    my_htoben(&var, sizeof(type)); break;\
 263              case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
 264              default: break;                                                  \
 265            }                                                                  \
 266          } STMT_END
 267 # else
 268 #  define DO_BO_UNPACK_N(var, type)     BO_CANT_DOIT(unpack, type)
 269 #  define DO_BO_PACK_N(var, type)       BO_CANT_DOIT(pack, type)
 270 # endif
 271
 272 #endif
 273
 274 #define PACK_SIZE_CANNOT_CSUM           0x80
 275 #define PACK_SIZE_SPARE                 0x40
 276 #define PACK_SIZE_MASK                  0x3F
 277
 278
 279 struct packsize_t {
 280     const unsigned char *array;
 281     int first;
 282     int size;
 283 };
 284
 285 #define PACK_SIZE_NORMAL 0
 286 #define PACK_SIZE_SHRIEKING 1
 287
 288 /* These tables are regenerated by genpacksizetables.pl (and then hand pasted
 289    in).  You're unlikely ever to need to regenerate them.  */
 290 #if 'J'-'I' == 1
 291 /* ASCII */
 292 unsigned char size_normal[53] = {
 293   /* C */ sizeof(unsigned char),
 294 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
 295   /* D */ LONG_DOUBLESIZE,
 296 #else
 297   0,
 298 #endif
 299   0,
 300   /* F */ NVSIZE,
 301   0, 0,
 302   /* I */ sizeof(unsigned int),
 303   /* J */ UVSIZE,
 304   0,
 305   /* L */ SIZE32,
 306   0,
 307   /* N */ SIZE32,
 308   0, 0,
 309 #if defined(HAS_QUAD)
 310   /* Q */ sizeof(Uquad_t),
 311 #else
 312   0,
 313 #endif
 314   0,
 315   /* S */ SIZE16,
 316   0,
 317   /* U */ sizeof(char),
 318   /* V */ SIZE32,
 319   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 320   /* c */ sizeof(char),
 321   /* d */ sizeof(double),
 322   0,
 323   /* f */ sizeof(float),
 324   0, 0,
 325   /* i */ sizeof(int),
 326   /* j */ IVSIZE,
 327   0,
 328   /* l */ SIZE32,
 329   0,
 330   /* n */ SIZE16,
 331   0,
 332   /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM,
 333 #if defined(HAS_QUAD)
 334   /* q */ sizeof(Quad_t),
 335 #else
 336   0,
 337 #endif
 338   0,
 339   /* s */ SIZE16,
 340   0, 0,
 341   /* v */ SIZE16,
 342   /* w */ sizeof(char) | PACK_SIZE_CANNOT_CSUM,
 343 };
 344 unsigned char size_shrieking[46] = {
 345   /* I */ sizeof(unsigned int),
 346   0, 0,
 347   /* L */ sizeof(unsigned long),
 348   0,
 349 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
 350   /* N */ SIZE32,
 351 #else
 352   0,
 353 #endif
 354   0, 0, 0, 0,
 355   /* S */ sizeof(unsigned short),
 356   0, 0,
 357 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
 358   /* V */ SIZE32,
 359 #else
 360   0,
 361 #endif
 362   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 363   /* i */ sizeof(int),
 364   0, 0,
 365   /* l */ sizeof(long),
 366   0,
 367 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
 368   /* n */ SIZE16,
 369 #else
 370   0,
 371 #endif
 372   0, 0, 0, 0,
 373   /* s */ sizeof(short),
 374   0, 0,
 375 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
 376   /* v */ SIZE16
 377 #else
 378   0
 379 #endif
 380 };
 381 struct packsize_t packsize[2] = {
 382   {size_normal, 67, 53},
 383   {size_shrieking, 73, 46}
 384 };
 385 #else
 386 /* EBCDIC (or bust) */
 387 unsigned char size_normal[99] = {
 388   /* c */ sizeof(char),
 389   /* d */ sizeof(double),
 390   0,
 391   /* f */ sizeof(float),
 392   0, 0,
 393   /* i */ sizeof(int),
 394   0, 0, 0, 0, 0, 0, 0,
 395   /* j */ IVSIZE,
 396   0,
 397   /* l */ SIZE32,
 398   0,
 399   /* n */ SIZE16,
 400   0,
 401   /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM,
 402 #if defined(HAS_QUAD)
 403   /* q */ sizeof(Quad_t),
 404 #else
 405   0,
 406 #endif
 407   0, 0, 0, 0, 0, 0, 0, 0, 0,
 408   /* s */ SIZE16,
 409   0, 0,
 410   /* v */ SIZE16,
 411   /* w */ sizeof(char) | PACK_SIZE_CANNOT_CSUM,
 412   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,
 413   0, 0,
 414   /* C */ sizeof(unsigned char),
 415 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
 416   /* D */ LONG_DOUBLESIZE,
 417 #else
 418   0,
 419 #endif
 420   0,
 421   /* F */ NVSIZE,
 422   0, 0,
 423   /* I */ sizeof(unsigned int),
 424   0, 0, 0, 0, 0, 0, 0,
 425   /* J */ UVSIZE,
 426   0,
 427   /* L */ SIZE32,
 428   0,
 429   /* N */ SIZE32,
 430   0, 0,
 431 #if defined(HAS_QUAD)
 432   /* Q */ sizeof(Uquad_t),
 433 #else
 434   0,
 435 #endif
 436   0, 0, 0, 0, 0, 0, 0, 0, 0,
 437   /* S */ SIZE16,
 438   0,
 439   /* U */ sizeof(char),
 440   /* V */ SIZE32,
 441 };
 442 unsigned char size_shrieking[93] = {
 443   /* i */ sizeof(int),
 444   0, 0, 0, 0, 0, 0, 0, 0, 0,
 445   /* l */ sizeof(long),
 446   0,
 447 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
 448   /* n */ SIZE16,
 449 #else
 450   0,
 451 #endif
 452   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 453   /* s */ sizeof(short),
 454   0, 0,
 455 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
 456   /* v */ SIZE16,
 457 #else
 458   0,
 459 #endif
 460   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,
 461   0, 0, 0, 0, 0, 0, 0, 0, 0,
 462   /* I */ sizeof(unsigned int),
 463   0, 0, 0, 0, 0, 0, 0, 0, 0,
 464   /* L */ sizeof(unsigned long),
 465   0,
 466 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
 467   /* N */ SIZE32,
 468 #else
 469   0,
 470 #endif
 471   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 472   /* S */ sizeof(unsigned short),
 473   0, 0,
 474 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
 475   /* V */ SIZE32
 476 #else
 477   0
 478 #endif
 479 };
 480 struct packsize_t packsize[2] = {
 481   {size_normal, 131, 99},
 482   {size_shrieking, 137, 93}
 483 };
 484 #endif
 485
 486
 487 /* Returns the sizeof() struct described by pat */
 488 STATIC I32
 489 S_measure_struct(pTHX_ register tempsym_t* symptr)
 490 {
 491     register I32 len = 0;
 492     register I32 total = 0;
 493     int star;
 494
 495     register int size;
 496
 497     while (next_symbol(symptr)) {
 498         int which = (symptr->code & TYPE_IS_SHRIEKING)
 499             ? PACK_SIZE_SHRIEKING : PACK_SIZE_NORMAL;
 500         int offset
 501             = TYPE_NO_MODIFIERS(symptr->code) - packsize[which].first;
 502
 503         switch( symptr->howlen ){
 504         case e_no_len:
 505         case e_number:
 506             len = symptr->length;
 507             break;
 508         case e_star:
 509             Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
 510                        symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 511             break;
 512         }
 513
 514         if ((offset >= 0) && (offset < packsize[which].size))
 515             size = packsize[which].array[offset] & PACK_SIZE_MASK;
 516         else
 517             size = 0;
 518
 519         if (!size) {
 520             /* endianness doesn't influence the size of a type */
 521             switch(TYPE_NO_ENDIANNESS(symptr->code)) {
 522             default:
 523                 Perl_croak(aTHX_ "Invalid type '%c' in %s",
 524                            (int)TYPE_NO_MODIFIERS(symptr->code),
 525                            symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 526             case '@':
 527             case '/':
 528             case 'U':                   /* XXXX Is it correct? */
 529             case 'w':
 530             case 'u':
 531                 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
 532                            (int)symptr->code,
 533                            symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 534             case '%':
 535                 size = 0;
 536                 break;
 537             case '(':
 538                 {
 539                     tempsym_t savsym = *symptr;
 540                     symptr->patptr = savsym.grpbeg;
 541                     symptr->patend = savsym.grpend;
 542                     /* XXXX Theoretically, we need to measure many times at
 543                        different positions, since the subexpression may contain
 544                        alignment commands, but be not of aligned length.
 545                        Need to detect this and croak().  */
 546                     size = measure_struct(symptr);
 547                     *symptr = savsym;
 548                     break;
 549                 }
 550             case 'X' | TYPE_IS_SHRIEKING:
 551                 /* XXXX Is this useful?  Then need to treat MEASURE_BACKWARDS.
 552                  */
 553                 if (!len)               /* Avoid division by 0 */
 554                     len = 1;
 555                 len = total % len;      /* Assumed: the start is aligned. */
 556                 /* FALL THROUGH */
 557             case 'X':
 558                 size = -1;
 559                 if (total < len)
 560                     Perl_croak(aTHX_ "'X' outside of string in %s",
 561                                symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 562                 break;
 563             case 'x' | TYPE_IS_SHRIEKING:
 564                 if (!len)               /* Avoid division by 0 */
 565                     len = 1;
 566                 star = total % len;     /* Assumed: the start is aligned. */
 567                 if (star)               /* Other portable ways? */
 568                     len = len - star;
 569                 else
 570                     len = 0;
 571                 /* FALL THROUGH */
 572             case 'x':
 573             case 'A':
 574             case 'Z':
 575             case 'a':
 576             case 'c':
 577             case 'C':
 578                 size = 1;
 579                 break;
 580             case 'B':
 581             case 'b':
 582                 len = (len + 7)/8;
 583                 size = 1;
 584                 break;
 585             case 'H':
 586             case 'h':
 587                 len = (len + 1)/2;
 588                 size = 1;
 589                 break;
 590
 591             case 'P':
 592                 len = 1;
 593                 size = sizeof(char*);
 594                 break;
 595             }
 596         }
 597         total += len * size;
 598     }
 599     return total;
 600 }
 601
 602
 603 /* locate matching closing parenthesis or bracket
 604  * returns char pointer to char after match, or NULL
 605  */
 606 STATIC char *
 607 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
 608 {
 609     while (patptr < patend) {
 610         char c = *patptr++;
 611
 612         if (isSPACE(c))
 613             continue;
 614         else if (c == ender)
 615             return patptr-1;
 616         else if (c == '#') {
 617             while (patptr < patend && *patptr != '\n')
 618                 patptr++;
 619             continue;
 620         } else if (c == '(')
 621             patptr = group_end(patptr, patend, ')') + 1;
 622         else if (c == '[')
 623             patptr = group_end(patptr, patend, ']') + 1;
 624     }
 625     Perl_croak(aTHX_ "No group ending character '%c' found in template",
 626                ender);
 627     return 0;
 628 }
 629
 630
 631 /* Convert unsigned decimal number to binary.
 632  * Expects a pointer to the first digit and address of length variable
 633  * Advances char pointer to 1st non-digit char and returns number
 634  */
 635 STATIC char *
 636 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
 637 {
 638   I32 len = *patptr++ - '0';
 639   while (isDIGIT(*patptr)) {
 640     if (len >= 0x7FFFFFFF/10)
 641       Perl_croak(aTHX_ "pack/unpack repeat count overflow");
 642     len = (len * 10) + (*patptr++ - '0');
 643   }
 644   *lenptr = len;
 645   return patptr;
 646 }
 647
 648 /* The marvellous template parsing routine: Using state stored in *symptr,
 649  * locates next template code and count
 650  */
 651 STATIC bool
 652 S_next_symbol(pTHX_ register tempsym_t* symptr )
 653 {
 654   register char* patptr = symptr->patptr;
 655   register char* patend = symptr->patend;
 656
 657   symptr->flags &= ~FLAG_SLASH;
 658
 659   while (patptr < patend) {
 660     if (isSPACE(*patptr))
 661       patptr++;
 662     else if (*patptr == '#') {
 663       patptr++;
 664       while (patptr < patend && *patptr != '\n')
 665         patptr++;
 666       if (patptr < patend)
 667         patptr++;
 668     } else {
 669       /* We should have found a template code */
 670       I32 code = *patptr++ & 0xFF;
 671       U32 inherited_modifiers = 0;
 672
 673       if (code == ','){ /* grandfather in commas but with a warning */
 674         if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
 675           symptr->flags |= FLAG_COMMA;
 676           Perl_warner(aTHX_ packWARN(WARN_UNPACK),
 677                       "Invalid type ',' in %s",
 678                       symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 679         }
 680         continue;
 681       }
 682
 683       /* for '(', skip to ')' */
 684       if (code == '(') {
 685         if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
 686           Perl_croak(aTHX_ "()-group starts with a count in %s",
 687                      symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 688         symptr->grpbeg = patptr;
 689         patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
 690         if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
 691           Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
 692                      symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 693       }
 694
 695       /* look for group modifiers to inherit */
 696       if (TYPE_ENDIANNESS(symptr->flags)) {
 697         if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
 698           inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
 699       }
 700
 701       /* look for modifiers */
 702       while (patptr < patend) {
 703         const char *allowed;
 704         I32 modifier = 0;
 705         switch (*patptr) {
 706           case '!':
 707             modifier = TYPE_IS_SHRIEKING;
 708             allowed = SHRIEKING_ALLOWED_TYPES;
 709             break;
 710 #ifdef PERL_PACK_CAN_BYTEORDER
 711           case '>':
 712             modifier = TYPE_IS_BIG_ENDIAN;
 713             allowed = ENDIANNESS_ALLOWED_TYPES;
 714             break;
 715           case '<':
 716             modifier = TYPE_IS_LITTLE_ENDIAN;
 717             allowed = ENDIANNESS_ALLOWED_TYPES;
 718             break;
 719 #endif
 720           default:
 721             break;
 722         }
 723
 724         if (modifier == 0)
 725           break;
 726
 727         if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
 728           Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
 729                      allowed, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 730
 731         if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
 732           Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
 733                      (int) TYPE_NO_MODIFIERS(code),
 734                      symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 735         else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
 736                  TYPE_ENDIANNESS_MASK)
 737           Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
 738                      *patptr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 739
 740         if (ckWARN(WARN_UNPACK)) {
 741           if (code & modifier)
 742             Perl_warner(aTHX_ packWARN(WARN_UNPACK),
 743                         "Duplicate modifier '%c' after '%c' in %s",
 744                         *patptr, (int) TYPE_NO_MODIFIERS(code),
 745                         symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 746         }
 747
 748         code |= modifier;
 749         patptr++;
 750       }
 751
 752       /* inherit modifiers */
 753       code |= inherited_modifiers;
 754
 755       /* look for count and/or / */
 756       if (patptr < patend) {
 757         if (isDIGIT(*patptr)) {
 758           patptr = get_num( patptr, &symptr->length );
 759           symptr->howlen = e_number;
 760
 761         } else if (*patptr == '*') {
 762           patptr++;
 763           symptr->howlen = e_star;
 764
 765         } else if (*patptr == '[') {
 766           char* lenptr = ++patptr;
 767           symptr->howlen = e_number;
 768           patptr = group_end( patptr, patend, ']' ) + 1;
 769           /* what kind of [] is it? */
 770           if (isDIGIT(*lenptr)) {
 771             lenptr = get_num( lenptr, &symptr->length );
 772             if( *lenptr != ']' )
 773               Perl_croak(aTHX_ "Malformed integer in [] in %s",
 774                          symptr->flags & FLAG_PACK ? "pack" : "unpack");
 775           } else {
 776             tempsym_t savsym = *symptr;
 777             symptr->patend = patptr-1;
 778             symptr->patptr = lenptr;
 779             savsym.length = measure_struct(symptr);
 780             *symptr = savsym;
 781           }
 782         } else {
 783           symptr->howlen = e_no_len;
 784           symptr->length = 1;
 785         }
 786
 787         /* try to find / */
 788         while (patptr < patend) {
 789           if (isSPACE(*patptr))
 790             patptr++;
 791           else if (*patptr == '#') {
 792             patptr++;
 793             while (patptr < patend && *patptr != '\n')
 794               patptr++;
 795             if (patptr < patend)
 796               patptr++;
 797           } else {
 798             if (*patptr == '/') {
 799               symptr->flags |= FLAG_SLASH;
 800               patptr++;
 801               if (patptr < patend &&
 802                   (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
 803                 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
 804                            symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 805             }
 806             break;
 807           }
 808         }
 809       } else {
 810         /* at end - no count, no / */
 811         symptr->howlen = e_no_len;
 812         symptr->length = 1;
 813       }
 814
 815       symptr->code = code;
 816       symptr->patptr = patptr;
 817       return TRUE;
 818     }
 819   }
 820   symptr->patptr = patptr;
 821   return FALSE;
 822 }
 823
 824 /*
 825 =for apidoc unpack_str
 826
 827 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
 828 and ocnt are not used. This call should not be used, use unpackstring instead.
 829
 830 =cut */
 831
 832 I32
 833 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
 834 {
 835     tempsym_t sym = { 0 };
 836     sym.patptr = pat;
 837     sym.patend = patend;
 838     sym.flags  = flags;
 839
 840     return unpack_rec(&sym, s, s, strend, NULL );
 841 }
 842
 843 /*
 844 =for apidoc unpackstring
 845
 846 The engine implementing unpack() Perl function. C<unpackstring> puts the
 847 extracted list items on the stack and returns the number of elements.
 848 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
 849
 850 =cut */
 851
 852 I32
 853 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
 854 {
 855     tempsym_t sym = { 0 };
 856     sym.patptr = pat;
 857     sym.patend = patend;
 858     sym.flags  = flags;
 859
 860     return unpack_rec(&sym, s, s, strend, NULL );
 861 }
 862
 863 STATIC
 864 I32
 865 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
 866 {
 867     dSP;
 868     I32 datumtype;
 869     register I32 len = 0;
 870     register I32 bits = 0;
 871     register char *str;
 872     SV *sv;
 873     I32 start_sp_offset = SP - PL_stack_base;
 874     howlen_t howlen;
 875
 876     /* These must not be in registers: */
 877     I16 ai16;
 878     U16 au16;
 879     I32 ai32;
 880     U32 au32;
 881 #ifdef HAS_QUAD
 882     Quad_t aquad;
 883     Uquad_t auquad;
 884 #endif
 885 #if SHORTSIZE != SIZE16
 886     short ashort;
 887     unsigned short aushort;
 888 #endif
 889     int aint;
 890     unsigned int auint;
 891     long along;
 892 #if LONGSIZE != SIZE32
 893     unsigned long aulong;
 894 #endif
 895     char *aptr;
 896     float afloat;
 897     double adouble;
 898 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
 899     long double aldouble;
 900 #endif
 901     IV aiv;
 902     UV auv;
 903     NV anv;
 904
 905     I32 checksum = 0;
 906     UV cuv = 0;
 907     NV cdouble = 0.0;
 908     const int bits_in_uv = 8 * sizeof(cuv);
 909     char* strrelbeg = s;
 910     bool beyond = FALSE;
 911     bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
 912
 913     while (next_symbol(symptr)) {
 914         datumtype = symptr->code;
 915         /* do first one only unless in list context
 916            / is implemented by unpacking the count, then poping it from the
 917            stack, so must check that we're not in the middle of a /  */
 918         if ( unpack_only_one
 919              && (SP - PL_stack_base == start_sp_offset + 1)
 920              && (datumtype != '/') )   /* XXX can this be omitted */
 921             break;
 922
 923         switch( howlen = symptr->howlen ){
 924         case e_no_len:
 925         case e_number:
 926             len = symptr->length;
 927             break;
 928         case e_star:
 929             len = strend - strbeg;      /* long enough */
 930             break;
 931         }
 932
 933       redo_switch:
 934         beyond = s >= strend;
 935         {
 936             int which = (symptr->code & TYPE_IS_SHRIEKING)
 937                 ? PACK_SIZE_SHRIEKING : PACK_SIZE_NORMAL;
 938             const int rawtype = TYPE_NO_MODIFIERS(datumtype);
 939             int offset = rawtype - packsize[which].first;
 940
 941             if (offset >= 0 && offset < packsize[which].size) {
 942                 /* Data about this template letter  */
 943                 unsigned char data = packsize[which].array[offset];
 944
 945                 if (data) {
 946                     /* data nonzero means we can process this letter.  */
 947                     long size = data & PACK_SIZE_MASK;
 948                     long howmany = (strend - s) / size;
 949                     if (len > howmany)
 950                         len = howmany;
 951
 952                     /* In the old code, 'p' was the only type without shortcut
 953                        code to curtail unpacking to only one.  As far as I can
 954                        see the only point of retaining this anomaly is to make
 955                        code such as $_ = unpack "p2", pack "pI", "Hi", 2
 956                        continue to segfault. ie, it probably should be
 957                        construed as a bug.
 958                     */
 959
 960                     if (!checksum || (data & PACK_SIZE_CANNOT_CSUM)) {
 961                         if (len && unpack_only_one &&
 962                             rawtype != 'p')
 963                             len = 1;
 964                         EXTEND(SP, len);
 965                         EXTEND_MORTAL(len);
 966                     }
 967                 }
 968             }
 969         }
 970         switch(TYPE_NO_ENDIANNESS(datumtype)) {
 971         default:
 972             Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
 973
 974         case '%':
 975             if (howlen == e_no_len)
 976                 len = 16;               /* len is not specified */
 977             checksum = len;
 978             cuv = 0;
 979             cdouble = 0;
 980             continue;
 981             break;
 982         case '(':
 983         {
 984             char *ss = s;               /* Move from register */
 985             tempsym_t savsym = *symptr;
 986             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
 987             symptr->flags |= group_modifiers;
 988             symptr->patend = savsym.grpend;
 989             symptr->level++;
 990             PUTBACK;
 991             while (len--) {
 992                 symptr->patptr = savsym.grpbeg;
 993                 unpack_rec(symptr, ss, strbeg, strend, &ss );
 994                 if (ss == strend && savsym.howlen == e_star)
 995                     break; /* No way to continue */
 996             }
 997             SPAGAIN;
 998             s = ss;
 999             symptr->flags &= ~group_modifiers;
1000             savsym.flags = symptr->flags;
1001             *symptr = savsym;
1002             break;
1003         }
1004         case '@':
1005             if (len > strend - strrelbeg)
1006                 Perl_croak(aTHX_ "'@' outside of string in unpack");
1007             s = strrelbeg + len;
1008             break;
1009         case 'X' | TYPE_IS_SHRIEKING:
1010             if (!len)                   /* Avoid division by 0 */
1011                 len = 1;
1012             len = (s - strbeg) % len;
1013             /* FALL THROUGH */
1014         case 'X':
1015             if (len > s - strbeg)
1016                 Perl_croak(aTHX_ "'X' outside of string in unpack" );
1017             s -= len;
1018             break;
1019         case 'x' | TYPE_IS_SHRIEKING:
1020             if (!len)                   /* Avoid division by 0 */
1021                 len = 1;
1022             aint = (s - strbeg) % len;
1023             if (aint)                   /* Other portable ways? */
1024                 len = len - aint;
1025             else
1026                 len = 0;
1027             /* FALL THROUGH */
1028         case 'x':
1029             if (len > strend - s)
1030                 Perl_croak(aTHX_ "'x' outside of string in unpack");
1031             s += len;
1032             break;
1033         case '/':
1034             Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1035             break;
1036         case 'A':
1037         case 'Z':
1038         case 'a':
1039             if (len > strend - s)
1040                 len = strend - s;
1041             if (checksum)
1042                 goto uchar_checksum;
1043             sv = newSVpvn(s, len);
1044             if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
1045                 aptr = s;       /* borrow register */
1046                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
1047                     s = SvPVX(sv);
1048                     while (*s)
1049                         s++;
1050                     if (howlen == e_star) /* exact for 'Z*' */
1051                         len = s - SvPVX(sv) + 1;
1052                 }
1053                 else {          /* 'A' strips both nulls and spaces */
1054                     s = SvPVX(sv) + len - 1;
1055                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
1056                         s--;
1057                     *++s = '\0';
1058                 }
1059                 SvCUR_set(sv, s - SvPVX(sv));
1060                 s = aptr;       /* unborrow register */
1061             }
1062             s += len;
1063             XPUSHs(sv_2mortal(sv));
1064             break;
1065         case 'B':
1066         case 'b':
1067             if (howlen == e_star || len > (strend - s) * 8)
1068                 len = (strend - s) * 8;
1069             if (checksum) {
1070                 if (!PL_bitcount) {
1071                     Newz(601, PL_bitcount, 256, char);
1072                     for (bits = 1; bits < 256; bits++) {
1073                         if (bits & 1)   PL_bitcount[bits]++;
1074                         if (bits & 2)   PL_bitcount[bits]++;
1075                         if (bits & 4)   PL_bitcount[bits]++;
1076                         if (bits & 8)   PL_bitcount[bits]++;
1077                         if (bits & 16)  PL_bitcount[bits]++;
1078                         if (bits & 32)  PL_bitcount[bits]++;
1079                         if (bits & 64)  PL_bitcount[bits]++;
1080                         if (bits & 128) PL_bitcount[bits]++;
1081                     }
1082                 }
1083                 while (len >= 8) {
1084                     cuv += PL_bitcount[*(unsigned char*)s++];
1085                     len -= 8;
1086                 }
1087                 if (len) {
1088                     bits = *s++;
1089                     if (datumtype == 'b') {
1090                         while (len-- > 0) {
1091                             if (bits & 1) cuv++;
1092                             bits >>= 1;
1093                         }
1094                     }
1095                     else {
1096                         while (len-- > 0) {
1097                             if (bits & 128) cuv++;
1098                             bits <<= 1;
1099                         }
1100                     }
1101                 }
1102                 break;
1103             }
1104             sv = NEWSV(35, len + 1);
1105             SvCUR_set(sv, len);
1106             SvPOK_on(sv);
1107             str = SvPVX(sv);
1108             if (datumtype == 'b') {
1109                 aint = len;
1110                 for (len = 0; len < aint; len++) {
1111                     if (len & 7)                /*SUPPRESS 595*/
1112                         bits >>= 1;
1113                     else
1114                         bits = *s++;
1115                     *str++ = '0' + (bits & 1);
1116                 }
1117             }
1118             else {
1119                 aint = len;
1120                 for (len = 0; len < aint; len++) {
1121                     if (len & 7)
1122                         bits <<= 1;
1123                     else
1124                         bits = *s++;
1125                     *str++ = '0' + ((bits & 128) != 0);
1126                 }
1127             }
1128             *str = '\0';
1129             XPUSHs(sv_2mortal(sv));
1130             break;
1131         case 'H':
1132         case 'h':
1133             if (howlen == e_star || len > (strend - s) * 2)
1134                 len = (strend - s) * 2;
1135             sv = NEWSV(35, len + 1);
1136             SvCUR_set(sv, len);
1137             SvPOK_on(sv);
1138             str = SvPVX(sv);
1139             if (datumtype == 'h') {
1140                 aint = len;
1141                 for (len = 0; len < aint; len++) {
1142                     if (len & 1)
1143                         bits >>= 4;
1144                     else
1145                         bits = *s++;
1146                     *str++ = PL_hexdigit[bits & 15];
1147                 }
1148             }
1149             else {
1150                 aint = len;
1151                 for (len = 0; len < aint; len++) {
1152                     if (len & 1)
1153                         bits <<= 4;
1154                     else
1155                         bits = *s++;
1156                     *str++ = PL_hexdigit[(bits >> 4) & 15];
1157                 }
1158             }
1159             *str = '\0';
1160             XPUSHs(sv_2mortal(sv));
1161             break;
1162         case 'c':
1163             while (len-- > 0) {
1164                 aint = *s++;
1165                 if (aint >= 128)        /* fake up signed chars */
1166                     aint -= 256;
1167                 if (!checksum) {
1168                     PUSHs(sv_2mortal(newSViv((IV)aint)));
1169                 }
1170                 else if (checksum > bits_in_uv)
1171                     cdouble += (NV)aint;
1172                 else
1173                     cuv += aint;
1174             }
1175             break;
1176         case 'C':
1177         unpack_C: /* unpack U will jump here if not UTF-8 */
1178             if (len == 0) {
1179                 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
1180                 break;
1181             }
1182             if (checksum) {
1183               uchar_checksum:
1184                 while (len-- > 0) {
1185                     auint = *s++ & 255;
1186                     cuv += auint;
1187                 }
1188             }
1189             else {
1190                 while (len-- > 0) {
1191                     auint = *s++ & 255;
1192                     PUSHs(sv_2mortal(newSViv((IV)auint)));
1193                 }
1194             }
1195             break;
1196         case 'U':
1197             if (len == 0) {
1198                 symptr->flags |= FLAG_UNPACK_DO_UTF8;
1199                 break;
1200             }
1201             if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
1202                  goto unpack_C;
1203             while (len-- > 0 && s < strend) {
1204                 STRLEN alen;
1205                 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1206                 along = alen;
1207                 s += along;
1208                 if (!checksum) {
1209                     PUSHs(sv_2mortal(newSVuv((UV)auint)));
1210                 }
1211                 else if (checksum > bits_in_uv)
1212                     cdouble += (NV)auint;
1213                 else
1214                     cuv += auint;
1215             }
1216             break;
1217         case 's' | TYPE_IS_SHRIEKING:
1218 #if SHORTSIZE != SIZE16
1219             while (len-- > 0) {
1220                 COPYNN(s, &ashort, sizeof(short));
1221                 DO_BO_UNPACK(ashort, s);
1222                 s += sizeof(short);
1223                 if (!checksum) {
1224                     PUSHs(sv_2mortal(newSViv((IV)ashort)));
1225                 }
1226                 else if (checksum > bits_in_uv)
1227                     cdouble += (NV)ashort;
1228                 else
1229                     cuv += ashort;
1230             }
1231             break;
1232 #else
1233             /* Fallthrough! */
1234 #endif
1235         case 's':
1236             while (len-- > 0) {
1237                 COPY16(s, &ai16);
1238                 DO_BO_UNPACK(ai16, 16);
1239 #if U16SIZE > SIZE16
1240                 if (ai16 > 32767)
1241                     ai16 -= 65536;
1242 #endif
1243                 s += SIZE16;
1244                 if (!checksum) {
1245                     PUSHs(sv_2mortal(newSViv((IV)ai16)));
1246                 }
1247                 else if (checksum > bits_in_uv)
1248                     cdouble += (NV)ai16;
1249                 else
1250                     cuv += ai16;
1251             }
1252             break;
1253         case 'S' | TYPE_IS_SHRIEKING:
1254 #if SHORTSIZE != SIZE16
1255             while (len-- > 0) {
1256                 COPYNN(s, &aushort, sizeof(unsigned short));
1257                 DO_BO_UNPACK(aushort, s);
1258                 s += sizeof(unsigned short);
1259                 if (!checksum) {
1260                     PUSHs(sv_2mortal(newSViv((UV)aushort)));
1261                 }
1262                 else if (checksum > bits_in_uv)
1263                     cdouble += (NV)aushort;
1264                 else
1265                     cuv += aushort;
1266             }
1267             break;
1268 #else
1269             /* Fallhrough! */
1270 #endif
1271         case 'v':
1272         case 'n':
1273         case 'S':
1274             while (len-- > 0) {
1275                 COPY16(s, &au16);
1276                 DO_BO_UNPACK(au16, 16);
1277                 s += SIZE16;
1278 #ifdef HAS_NTOHS
1279                 if (datumtype == 'n')
1280                     au16 = PerlSock_ntohs(au16);
1281 #endif
1282 #ifdef HAS_VTOHS
1283                 if (datumtype == 'v')
1284                     au16 = vtohs(au16);
1285 #endif
1286                 if (!checksum) {
1287                     PUSHs(sv_2mortal(newSViv((UV)au16)));
1288                 }
1289                 else if (checksum > bits_in_uv)
1290                     cdouble += (NV)au16;
1291                 else
1292                     cuv += au16;
1293             }
1294             break;
1295 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1296         case 'v' | TYPE_IS_SHRIEKING:
1297         case 'n' | TYPE_IS_SHRIEKING:
1298             while (len-- > 0) {
1299                 COPY16(s, &ai16);
1300                 s += SIZE16;
1301 #ifdef HAS_NTOHS
1302                 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1303                     ai16 = (I16)PerlSock_ntohs((U16)ai16);
1304 #endif
1305 #ifdef HAS_VTOHS
1306                 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1307                     ai16 = (I16)vtohs((U16)ai16);
1308 #endif
1309                 if (!checksum) {
1310                     PUSHs(sv_2mortal(newSViv((IV)ai16)));
1311                 }
1312                 else if (checksum > bits_in_uv)
1313                     cdouble += (NV)ai16;
1314                 else
1315                     cuv += ai16;
1316             }
1317             break;
1318 #endif
1319         case 'i':
1320         case 'i' | TYPE_IS_SHRIEKING:
1321             while (len-- > 0) {
1322                 Copy(s, &aint, 1, int);
1323                 DO_BO_UNPACK(aint, i);
1324                 s += sizeof(int);
1325                 if (!checksum) {
1326                     PUSHs(sv_2mortal(newSViv((IV)aint)));
1327                 }
1328                 else if (checksum > bits_in_uv)
1329                     cdouble += (NV)aint;
1330                 else
1331                     cuv += aint;
1332             }
1333             break;
1334         case 'I':
1335         case 'I' | TYPE_IS_SHRIEKING:
1336             while (len-- > 0) {
1337                 Copy(s, &auint, 1, unsigned int);
1338                 DO_BO_UNPACK(auint, i);
1339                 s += sizeof(unsigned int);
1340                 if (!checksum) {
1341                     PUSHs(sv_2mortal(newSVuv((UV)auint)));
1342                 }
1343                 else if (checksum > bits_in_uv)
1344                     cdouble += (NV)auint;
1345                 else
1346                     cuv += auint;
1347             }
1348             break;
1349         case 'j':
1350             while (len-- > 0) {
1351                 Copy(s, &aiv, 1, IV);
1352 #if IVSIZE == INTSIZE
1353                 DO_BO_UNPACK(aiv, i);
1354 #elif IVSIZE == LONGSIZE
1355                 DO_BO_UNPACK(aiv, l);
1356 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1357                 DO_BO_UNPACK(aiv, 64);
1358 #endif
1359                 s += IVSIZE;
1360                 if (!checksum) {
1361                     PUSHs(sv_2mortal(newSViv(aiv)));
1362                 }
1363                 else if (checksum > bits_in_uv)
1364                     cdouble += (NV)aiv;
1365                 else
1366                     cuv += aiv;
1367             }
1368             break;
1369         case 'J':
1370             while (len-- > 0) {
1371                 Copy(s, &auv, 1, UV);
1372 #if UVSIZE == INTSIZE
1373                 DO_BO_UNPACK(auv, i);
1374 #elif UVSIZE == LONGSIZE
1375                 DO_BO_UNPACK(auv, l);
1376 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1377                 DO_BO_UNPACK(auv, 64);
1378 #endif
1379                 s += UVSIZE;
1380                 if (!checksum) {
1381                     PUSHs(sv_2mortal(newSVuv(auv)));
1382                 }
1383                 else if (checksum > bits_in_uv)
1384                     cdouble += (NV)auv;
1385                 else
1386                     cuv += auv;
1387             }
1388             break;
1389         case 'l' | TYPE_IS_SHRIEKING:
1390 #if LONGSIZE != SIZE32
1391             while (len-- > 0) {
1392                 COPYNN(s, &along, sizeof(long));
1393                 DO_BO_UNPACK(along, l);
1394                 s += sizeof(long);
1395                 if (!checksum) {
1396                     PUSHs(sv_2mortal(newSViv((IV)along)));
1397                 }
1398                 else if (checksum > bits_in_uv)
1399                     cdouble += (NV)along;
1400                 else
1401                     cuv += along;
1402             }
1403             break;
1404 #else
1405             /* Fallthrough! */
1406 #endif
1407         case 'l':
1408             while (len-- > 0) {
1409                 COPY32(s, &ai32);
1410                 DO_BO_UNPACK(ai32, 32);
1411 #if U32SIZE > SIZE32
1412                 if (ai32 > 2147483647)
1413                     ai32 -= 4294967296;
1414 #endif
1415                 s += SIZE32;
1416                 if (!checksum) {
1417                     PUSHs(sv_2mortal(newSViv((IV)ai32)));
1418                 }
1419                 else if (checksum > bits_in_uv)
1420                     cdouble += (NV)ai32;
1421                 else
1422                     cuv += ai32;
1423             }
1424             break;
1425         case 'L' | TYPE_IS_SHRIEKING:
1426 #if LONGSIZE != SIZE32
1427             while (len-- > 0) {
1428                 COPYNN(s, &aulong, sizeof(unsigned long));
1429                 DO_BO_UNPACK(aulong, l);
1430                 s += sizeof(unsigned long);
1431                 if (!checksum) {
1432                     PUSHs(sv_2mortal(newSVuv((UV)aulong)));
1433                 }
1434                 else if (checksum > bits_in_uv)
1435                     cdouble += (NV)aulong;
1436                 else
1437                     cuv += aulong;
1438             }
1439             break;
1440 #else
1441             /* Fall through! */
1442 #endif
1443         case 'V':
1444         case 'N':
1445         case 'L':
1446             while (len-- > 0) {
1447                 COPY32(s, &au32);
1448                 DO_BO_UNPACK(au32, 32);
1449                 s += SIZE32;
1450 #ifdef HAS_NTOHL
1451                 if (datumtype == 'N')
1452                     au32 = PerlSock_ntohl(au32);
1453 #endif
1454 #ifdef HAS_VTOHL
1455                 if (datumtype == 'V')
1456                     au32 = vtohl(au32);
1457 #endif
1458                  if (!checksum) {
1459                      PUSHs(sv_2mortal(newSVuv((UV)au32)));
1460                  }
1461                  else if (checksum > bits_in_uv)
1462                      cdouble += (NV)au32;
1463                  else
1464                      cuv += au32;
1465             }
1466             break;
1467 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1468         case 'V' | TYPE_IS_SHRIEKING:
1469         case 'N' | TYPE_IS_SHRIEKING:
1470             while (len-- > 0) {
1471                 COPY32(s, &ai32);
1472                 s += SIZE32;
1473 #ifdef HAS_NTOHL
1474                 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1475                     ai32 = (I32)PerlSock_ntohl((U32)ai32);
1476 #endif
1477 #ifdef HAS_VTOHL
1478                 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1479                     ai32 = (I32)vtohl((U32)ai32);
1480 #endif
1481                 if (!checksum) {
1482                     PUSHs(sv_2mortal(newSViv((IV)ai32)));
1483                 }
1484                 else if (checksum > bits_in_uv)
1485                     cdouble += (NV)ai32;
1486                 else
1487                     cuv += ai32;
1488             }
1489             break;
1490 #endif
1491         case 'p':
1492             while (len-- > 0) {
1493                 assert (sizeof(char*) <= strend - s);
1494                 Copy(s, &aptr, 1, char*);
1495                 DO_BO_UNPACK_P(aptr);
1496                 s += sizeof(char*);
1497                 /* newSVpv generates undef if aptr is NULL */
1498                 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1499             }
1500             break;
1501         case 'w':
1502             {
1503                 UV auv = 0;
1504                 U32 bytes = 0;
1505
1506                 while ((len > 0) && (s < strend)) {
1507                     auv = (auv << 7) | (*s & 0x7f);
1508                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1509                     if ((U8)(*s++) < 0x80) {
1510                         bytes = 0;
1511                         PUSHs(sv_2mortal(newSVuv(auv)));
1512                         len--;
1513                         auv = 0;
1514                     }
1515                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
1516                         char *t;
1517                         STRLEN n_a;
1518
1519                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1520                         while (s < strend) {
1521                             sv = mul128(sv, (U8)(*s & 0x7f));
1522                             if (!(*s++ & 0x80)) {
1523                                 bytes = 0;
1524                                 break;
1525                             }
1526                         }
1527                         t = SvPV(sv, n_a);
1528                         while (*t == '0')
1529                             t++;
1530                         sv_chop(sv, t);
1531                         PUSHs(sv_2mortal(sv));
1532                         len--;
1533                         auv = 0;
1534                     }
1535                 }
1536                 if ((s >= strend) && bytes)
1537                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1538             }
1539             break;
1540         case 'P':
1541             if (symptr->howlen == e_star)
1542                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1543             EXTEND(SP, 1);
1544             if (sizeof(char*) > strend - s)
1545                 break;
1546             else {
1547                 Copy(s, &aptr, 1, char*);
1548                 DO_BO_UNPACK_P(aptr);
1549                 s += sizeof(char*);
1550             }
1551             /* newSVpvn generates undef if aptr is NULL */
1552             PUSHs(sv_2mortal(newSVpvn(aptr, len)));
1553             break;
1554 #ifdef HAS_QUAD
1555         case 'q':
1556             while (len-- > 0) {
1557                 assert (s + sizeof(Quad_t) <= strend);
1558                 Copy(s, &aquad, 1, Quad_t);
1559                 DO_BO_UNPACK(aquad, 64);
1560                 s += sizeof(Quad_t);
1561                 if (!checksum) {
1562                     PUSHs(sv_2mortal((aquad >= IV_MIN && aquad <= IV_MAX) ?
1563                                      newSViv((IV)aquad) : newSVnv((NV)aquad)));
1564                 }
1565                 else if (checksum > bits_in_uv)
1566                     cdouble += (NV)aquad;
1567                 else
1568                     cuv += aquad;
1569             }
1570             break;
1571         case 'Q':
1572             while (len-- > 0) {
1573                 assert (s + sizeof(Uquad_t) <= strend);
1574                 Copy(s, &auquad, 1, Uquad_t);
1575                 DO_BO_UNPACK(auquad, 64);
1576                 s += sizeof(Uquad_t);
1577                 if (!checksum) {
1578                     PUSHs(sv_2mortal((auquad <= UV_MAX) ?
1579                                      newSVuv((UV)auquad) : newSVnv((NV)auquad)));
1580                 }
1581                 else if (checksum > bits_in_uv)
1582                     cdouble += (NV)auquad;
1583                 else
1584                     cuv += auquad;
1585             }
1586             break;
1587 #endif
1588         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1589         case 'f':
1590             while (len-- > 0) {
1591                 Copy(s, &afloat, 1, float);
1592                 DO_BO_UNPACK_N(afloat, float);
1593                 s += sizeof(float);
1594                 if (!checksum) {
1595                     PUSHs(sv_2mortal(newSVnv((NV)afloat)));
1596                 }
1597                 else {
1598                     cdouble += afloat;
1599                 }
1600             }
1601             break;
1602         case 'd':
1603             while (len-- > 0) {
1604                 Copy(s, &adouble, 1, double);
1605                 DO_BO_UNPACK_N(adouble, double);
1606                 s += sizeof(double);
1607                 if (!checksum) {
1608                     PUSHs(sv_2mortal(newSVnv((NV)adouble)));
1609                 }
1610                 else {
1611                     cdouble += adouble;
1612                 }
1613             }
1614             break;
1615         case 'F':
1616             while (len-- > 0) {
1617                 Copy(s, &anv, 1, NV);
1618                 DO_BO_UNPACK_N(anv, NV);
1619                 s += NVSIZE;
1620                 if (!checksum) {
1621                     PUSHs(sv_2mortal(newSVnv(anv)));
1622                 }
1623                 else {
1624                     cdouble += anv;
1625                 }
1626             }
1627             break;
1628 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1629         case 'D':
1630             while (len-- > 0) {
1631                 Copy(s, &aldouble, 1, long double);
1632                 DO_BO_UNPACK_N(aldouble, long double);
1633                 s += LONG_DOUBLESIZE;
1634                 if (!checksum) {
1635                     PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
1636                 }
1637                 else {cdouble += aldouble;
1638                 }
1639             }
1640             break;
1641 #endif
1642         case 'u':
1643             /* MKS:
1644              * Initialise the decode mapping.  By using a table driven
1645              * algorithm, the code will be character-set independent
1646              * (and just as fast as doing character arithmetic)
1647              */
1648             if (PL_uudmap['M'] == 0) {
1649                 int i;
1650
1651                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1652                     PL_uudmap[(U8)PL_uuemap[i]] = i;
1653                 /*
1654                  * Because ' ' and '`' map to the same value,
1655                  * we need to decode them both the same.
1656                  */
1657                 PL_uudmap[' '] = 0;
1658             }
1659
1660             along = (strend - s) * 3 / 4;
1661             sv = NEWSV(42, along);
1662             if (along)
1663                 SvPOK_on(sv);
1664             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1665                 I32 a, b, c, d;
1666                 char hunk[4];
1667
1668                 hunk[3] = '\0';
1669                 len = PL_uudmap[*(U8*)s++] & 077;
1670                 while (len > 0) {
1671                     if (s < strend && ISUUCHAR(*s))
1672                         a = PL_uudmap[*(U8*)s++] & 077;
1673                     else
1674                         a = 0;
1675                     if (s < strend && ISUUCHAR(*s))
1676                         b = PL_uudmap[*(U8*)s++] & 077;
1677                     else
1678                         b = 0;
1679                     if (s < strend && ISUUCHAR(*s))
1680                         c = PL_uudmap[*(U8*)s++] & 077;
1681                     else
1682                         c = 0;
1683                     if (s < strend && ISUUCHAR(*s))
1684                         d = PL_uudmap[*(U8*)s++] & 077;
1685                     else
1686                         d = 0;
1687                     hunk[0] = (char)((a << 2) | (b >> 4));
1688                     hunk[1] = (char)((b << 4) | (c >> 2));
1689                     hunk[2] = (char)((c << 6) | d);
1690                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1691                     len -= 3;
1692                 }
1693                 if (*s == '\n')
1694                     s++;
1695                 else    /* possible checksum byte */
1696                     if (s + 1 < strend && s[1] == '\n')
1697                         s += 2;
1698             }
1699             XPUSHs(sv_2mortal(sv));
1700             break;
1701         }
1702
1703         if (checksum) {
1704             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1705               (checksum > bits_in_uv &&
1706                strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1707                 NV trouble;
1708
1709                 adouble = (NV) (1 << (checksum & 15));
1710                 while (checksum >= 16) {
1711                     checksum -= 16;
1712                     adouble *= 65536.0;
1713                 }
1714                 while (cdouble < 0.0)
1715                     cdouble += adouble;
1716                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1717                 sv = newSVnv(cdouble);
1718             }
1719             else {
1720                 if (checksum < bits_in_uv) {
1721                     UV mask = ((UV)1 << checksum) - 1;
1722                     cuv &= mask;
1723                 }
1724                 sv = newSVuv(cuv);
1725             }
1726             XPUSHs(sv_2mortal(sv));
1727             checksum = 0;
1728         }
1729
1730         if (symptr->flags & FLAG_SLASH){
1731             if (SP - PL_stack_base - start_sp_offset <= 0)
1732                 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1733             if( next_symbol(symptr) ){
1734               if( symptr->howlen == e_number )
1735                 Perl_croak(aTHX_ "Count after length/code in unpack" );
1736               if( beyond ){
1737                 /* ...end of char buffer then no decent length available */
1738                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1739               } else {
1740                 /* take top of stack (hope it's numeric) */
1741                 len = POPi;
1742                 if( len < 0 )
1743                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
1744               }
1745             } else {
1746                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1747             }
1748             datumtype = symptr->code;
1749             goto redo_switch;
1750         }
1751     }
1752
1753     if (new_s)
1754         *new_s = s;
1755     PUTBACK;
1756     return SP - PL_stack_base - start_sp_offset;
1757 }
1758
1759 PP(pp_unpack)
1760 {
1761     dSP;
1762     dPOPPOPssrl;
1763     I32 gimme = GIMME_V;
1764     STRLEN llen;
1765     STRLEN rlen;
1766     register char *pat = SvPV(left, llen);
1767 #ifdef PACKED_IS_OCTETS
1768     /* Packed side is assumed to be octets - so force downgrade if it
1769        has been UTF-8 encoded by accident
1770      */
1771     register char *s = SvPVbyte(right, rlen);
1772 #else
1773     register char *s = SvPV(right, rlen);
1774 #endif
1775     char *strend = s + rlen;
1776     register char *patend = pat + llen;
1777     register I32 cnt;
1778
1779     PUTBACK;
1780     cnt = unpackstring(pat, patend, s, strend,
1781                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1782                      | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1783
1784     SPAGAIN;
1785     if ( !cnt && gimme == G_SCALAR )
1786        PUSHs(&PL_sv_undef);
1787     RETURN;
1788 }
1789
1790 STATIC void
1791 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1792 {
1793     char hunk[5];
1794
1795     *hunk = PL_uuemap[len];
1796     sv_catpvn(sv, hunk, 1);
1797     hunk[4] = '\0';
1798     while (len > 2) {
1799         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1800         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1801         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1802         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1803         sv_catpvn(sv, hunk, 4);
1804         s += 3;
1805         len -= 3;
1806     }
1807     if (len > 0) {
1808         char r = (len > 1 ? s[1] : '\0');
1809         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1810         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1811         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1812         hunk[3] = PL_uuemap[0];
1813         sv_catpvn(sv, hunk, 4);
1814     }
1815     sv_catpvn(sv, "\n", 1);
1816 }
1817
1818 STATIC SV *
1819 S_is_an_int(pTHX_ char *s, STRLEN l)
1820 {
1821   STRLEN         n_a;
1822   SV             *result = newSVpvn(s, l);
1823   char           *result_c = SvPV(result, n_a); /* convenience */
1824   char           *out = result_c;
1825   bool            skip = 1;
1826   bool            ignore = 0;
1827
1828   while (*s) {
1829     switch (*s) {
1830     case ' ':
1831       break;
1832     case '+':
1833       if (!skip) {
1834         SvREFCNT_dec(result);
1835         return (NULL);
1836       }
1837       break;
1838     case '0':
1839     case '1':
1840     case '2':
1841     case '3':
1842     case '4':
1843     case '5':
1844     case '6':
1845     case '7':
1846     case '8':
1847     case '9':
1848       skip = 0;
1849       if (!ignore) {
1850         *(out++) = *s;
1851       }
1852       break;
1853     case '.':
1854       ignore = 1;
1855       break;
1856     default:
1857       SvREFCNT_dec(result);
1858       return (NULL);
1859     }
1860     s++;
1861   }
1862   *(out++) = '\0';
1863   SvCUR_set(result, out - result_c);
1864   return (result);
1865 }
1866
1867 /* pnum must be '\0' terminated */
1868 STATIC int
1869 S_div128(pTHX_ SV *pnum, bool *done)
1870 {
1871   STRLEN          len;
1872   char           *s = SvPV(pnum, len);
1873   int             m = 0;
1874   int             r = 0;
1875   char           *t = s;
1876
1877   *done = 1;
1878   while (*t) {
1879     int             i;
1880
1881     i = m * 10 + (*t - '0');
1882     m = i & 0x7F;
1883     r = (i >> 7);               /* r < 10 */
1884     if (r) {
1885       *done = 0;
1886     }
1887     *(t++) = '0' + r;
1888   }
1889   *(t++) = '\0';
1890   SvCUR_set(pnum, (STRLEN) (t - s));
1891   return (m);
1892 }
1893
1894
1895
1896 /*
1897 =for apidoc pack_cat
1898
1899 The engine implementing pack() Perl function. Note: parameters next_in_list and
1900 flags are not used. This call should not be used; use packlist instead.
1901
1902 =cut */
1903
1904
1905 void
1906 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1907 {
1908     tempsym_t sym = { 0 };
1909     sym.patptr = pat;
1910     sym.patend = patend;
1911     sym.flags  = FLAG_PACK;
1912
1913     (void)pack_rec( cat, &sym, beglist, endlist );
1914 }
1915
1916
1917 /*
1918 =for apidoc packlist
1919
1920 The engine implementing pack() Perl function.
1921
1922 =cut */
1923
1924
1925 void
1926 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1927 {
1928     tempsym_t sym = { 0 };
1929     sym.patptr = pat;
1930     sym.patend = patend;
1931     sym.flags  = FLAG_PACK;
1932
1933     (void)pack_rec( cat, &sym, beglist, endlist );
1934 }
1935
1936
1937 STATIC
1938 SV **
1939 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1940 {
1941     register I32 items;
1942     STRLEN fromlen;
1943     register I32 len = 0;
1944     SV *fromstr;
1945     /*SUPPRESS 442*/
1946     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1947     static char *space10 = "          ";
1948     bool found;
1949
1950     /* These must not be in registers: */
1951     char achar;
1952     I16 ai16;
1953     U16 au16;
1954     I32 ai32;
1955     U32 au32;
1956 #ifdef HAS_QUAD
1957     Quad_t aquad;
1958     Uquad_t auquad;
1959 #endif
1960 #if SHORTSIZE != SIZE16
1961     short ashort;
1962     unsigned short aushort;
1963 #endif
1964     int aint;
1965     unsigned int auint;
1966 #if LONGSIZE != SIZE32
1967     long along;
1968     unsigned long aulong;
1969 #endif
1970     char *aptr;
1971     float afloat;
1972     double adouble;
1973 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1974     long double aldouble;
1975 #endif
1976     IV aiv;
1977     UV auv;
1978     NV anv;
1979
1980     int strrelbeg = SvCUR(cat);
1981     tempsym_t lookahead;
1982
1983     items = endlist - beglist;
1984     found = next_symbol( symptr );
1985
1986 #ifndef PACKED_IS_OCTETS
1987     if (symptr->level == 0 && found && symptr->code == 'U' ){
1988         SvUTF8_on(cat);
1989     }
1990 #endif
1991
1992     while (found) {
1993         SV *lengthcode = Nullsv;
1994 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1995
1996         I32 datumtype = symptr->code;
1997         howlen_t howlen;
1998
1999         switch( howlen = symptr->howlen ){
2000         case e_no_len:
2001         case e_number:
2002             len = symptr->length;
2003             break;
2004         case e_star:
2005             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
2006             break;
2007         }
2008
2009         /* Look ahead for next symbol. Do we have code/code? */
2010         lookahead = *symptr;
2011         found = next_symbol(&lookahead);
2012         if ( symptr->flags & FLAG_SLASH ) {
2013             if (found){
2014                 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2015                      e_star != lookahead.howlen )
2016                     Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2017                 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
2018                                                    ? *beglist : &PL_sv_no)
2019                                            + (lookahead.code == 'Z' ? 1 : 0)));
2020             } else {
2021                 Perl_croak(aTHX_ "Code missing after '/' in pack");
2022             }
2023         }
2024
2025         switch(TYPE_NO_ENDIANNESS(datumtype)) {
2026         default:
2027             Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
2028         case '%':
2029             Perl_croak(aTHX_ "'%%' may not be used in pack");
2030         case '@':
2031             len += strrelbeg - SvCUR(cat);
2032             if (len > 0)
2033                 goto grow;
2034             len = -len;
2035             if (len > 0)
2036                 goto shrink;
2037             break;
2038         case '(':
2039         {
2040             tempsym_t savsym = *symptr;
2041             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2042             symptr->flags |= group_modifiers;
2043             symptr->patend = savsym.grpend;
2044             symptr->level++;
2045             while (len--) {
2046                 symptr->patptr = savsym.grpbeg;
2047                 beglist = pack_rec(cat, symptr, beglist, endlist );
2048                 if (savsym.howlen == e_star && beglist == endlist)
2049                     break;              /* No way to continue */
2050             }
2051             symptr->flags &= ~group_modifiers;
2052             lookahead.flags = symptr->flags;
2053             *symptr = savsym;
2054             break;
2055         }
2056         case 'X' | TYPE_IS_SHRIEKING:
2057             if (!len)                   /* Avoid division by 0 */
2058                 len = 1;
2059             len = (SvCUR(cat)) % len;
2060             /* FALL THROUGH */
2061         case 'X':
2062           shrink:
2063             if ((I32)SvCUR(cat) < len)
2064                 Perl_croak(aTHX_ "'X' outside of string in pack");
2065             SvCUR(cat) -= len;
2066             *SvEND(cat) = '\0';
2067             break;
2068         case 'x' | TYPE_IS_SHRIEKING:
2069             if (!len)                   /* Avoid division by 0 */
2070                 len = 1;
2071             aint = (SvCUR(cat)) % len;
2072             if (aint)                   /* Other portable ways? */
2073                 len = len - aint;
2074             else
2075                 len = 0;
2076             /* FALL THROUGH */
2077
2078         case 'x':
2079           grow:
2080             while (len >= 10) {
2081                 sv_catpvn(cat, null10, 10);
2082                 len -= 10;
2083             }
2084             sv_catpvn(cat, null10, len);
2085             break;
2086         case 'A':
2087         case 'Z':
2088         case 'a':
2089             fromstr = NEXTFROM;
2090             aptr = SvPV(fromstr, fromlen);
2091             if (howlen == e_star) {
2092                 len = fromlen;
2093                 if (datumtype == 'Z')
2094                     ++len;
2095             }
2096             if ((I32)fromlen >= len) {
2097                 sv_catpvn(cat, aptr, len);
2098                 if (datumtype == 'Z')
2099                     *(SvEND(cat)-1) = '\0';
2100             }
2101             else {
2102                 sv_catpvn(cat, aptr, fromlen);
2103                 len -= fromlen;
2104                 if (datumtype == 'A') {
2105                     while (len >= 10) {
2106                         sv_catpvn(cat, space10, 10);
2107                         len -= 10;
2108                     }
2109                     sv_catpvn(cat, space10, len);
2110                 }
2111                 else {
2112                     while (len >= 10) {
2113                         sv_catpvn(cat, null10, 10);
2114                         len -= 10;
2115                     }
2116                     sv_catpvn(cat, null10, len);
2117                 }
2118             }
2119             break;
2120         case 'B':
2121         case 'b':
2122             {
2123                 register char *str;
2124                 I32 saveitems;
2125
2126                 fromstr = NEXTFROM;
2127                 saveitems = items;
2128                 str = SvPV(fromstr, fromlen);
2129                 if (howlen == e_star)
2130                     len = fromlen;
2131                 aint = SvCUR(cat);
2132                 SvCUR(cat) += (len+7)/8;
2133                 SvGROW(cat, SvCUR(cat) + 1);
2134                 aptr = SvPVX(cat) + aint;
2135                 if (len > (I32)fromlen)
2136                     len = fromlen;
2137                 aint = len;
2138                 items = 0;
2139                 if (datumtype == 'B') {
2140                     for (len = 0; len++ < aint;) {
2141                         items |= *str++ & 1;
2142                         if (len & 7)
2143                             items <<= 1;
2144                         else {
2145                             *aptr++ = items & 0xff;
2146                             items = 0;
2147                         }
2148                     }
2149                 }
2150                 else {
2151                     for (len = 0; len++ < aint;) {
2152                         if (*str++ & 1)
2153                             items |= 128;
2154                         if (len & 7)
2155                             items >>= 1;
2156                         else {
2157                             *aptr++ = items & 0xff;
2158                             items = 0;
2159                         }
2160                     }
2161                 }
2162                 if (aint & 7) {
2163                     if (datumtype == 'B')
2164                         items <<= 7 - (aint & 7);
2165                     else
2166                         items >>= 7 - (aint & 7);
2167                     *aptr++ = items & 0xff;
2168                 }
2169                 str = SvPVX(cat) + SvCUR(cat);
2170                 while (aptr <= str)
2171                     *aptr++ = '\0';
2172
2173                 items = saveitems;
2174             }
2175             break;
2176         case 'H':
2177         case 'h':
2178             {
2179                 register char *str;
2180                 I32 saveitems;
2181
2182                 fromstr = NEXTFROM;
2183                 saveitems = items;
2184                 str = SvPV(fromstr, fromlen);
2185                 if (howlen == e_star)
2186                     len = fromlen;
2187                 aint = SvCUR(cat);
2188                 SvCUR(cat) += (len+1)/2;
2189                 SvGROW(cat, SvCUR(cat) + 1);
2190                 aptr = SvPVX(cat) + aint;
2191                 if (len > (I32)fromlen)
2192                     len = fromlen;
2193                 aint = len;
2194                 items = 0;
2195                 if (datumtype == 'H') {
2196                     for (len = 0; len++ < aint;) {
2197                         if (isALPHA(*str))
2198                             items |= ((*str++ & 15) + 9) & 15;
2199                         else
2200                             items |= *str++ & 15;
2201                         if (len & 1)
2202                             items <<= 4;
2203                         else {
2204                             *aptr++ = items & 0xff;
2205                             items = 0;
2206                         }
2207                     }
2208                 }
2209                 else {
2210                     for (len = 0; len++ < aint;) {
2211                         if (isALPHA(*str))
2212                             items |= (((*str++ & 15) + 9) & 15) << 4;
2213                         else
2214                             items |= (*str++ & 15) << 4;
2215                         if (len & 1)
2216                             items >>= 4;
2217                         else {
2218                             *aptr++ = items & 0xff;
2219                             items = 0;
2220                         }
2221                     }
2222                 }
2223                 if (aint & 1)
2224                     *aptr++ = items & 0xff;
2225                 str = SvPVX(cat) + SvCUR(cat);
2226                 while (aptr <= str)
2227                     *aptr++ = '\0';
2228
2229                 items = saveitems;
2230             }
2231             break;
2232         case 'C':
2233         case 'c':
2234             while (len-- > 0) {
2235                 fromstr = NEXTFROM;
2236                 switch (TYPE_NO_MODIFIERS(datumtype)) {
2237                 case 'C':
2238                     aint = SvIV(fromstr);
2239                     if ((aint < 0 || aint > 255) &&
2240                         ckWARN(WARN_PACK))
2241                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2242                                     "Character in 'C' format wrapped in pack");
2243                     achar = aint & 255;
2244                     sv_catpvn(cat, &achar, sizeof(char));
2245                     break;
2246                 case 'c':
2247                     aint = SvIV(fromstr);
2248                     if ((aint < -128 || aint > 127) &&
2249                         ckWARN(WARN_PACK))
2250                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2251                                     "Character in 'c' format wrapped in pack" );
2252                     achar = aint & 255;
2253                     sv_catpvn(cat, &achar, sizeof(char));
2254                     break;
2255                 }
2256             }
2257             break;
2258         case 'U':
2259             while (len-- > 0) {
2260                 fromstr = NEXTFROM;
2261                 auint = UNI_TO_NATIVE(SvUV(fromstr));
2262                 SvGROW(cat, SvCUR(cat) + UTF8_MAXBYTES + 1);
2263                 SvCUR_set(cat,
2264                           (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2265                                                      auint,
2266                                                      ckWARN(WARN_UTF8) ?
2267                                                      0 : UNICODE_ALLOW_ANY)
2268                           - SvPVX(cat));
2269             }
2270             *SvEND(cat) = '\0';
2271             break;
2272         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2273         case 'f':
2274             while (len-- > 0) {
2275                 fromstr = NEXTFROM;
2276 #ifdef __VOS__
2277 /* VOS does not automatically map a floating-point overflow
2278    during conversion from double to float into infinity, so we
2279    do it by hand.  This code should either be generalized for
2280    any OS that needs it, or removed if and when VOS implements
2281    posix-976 (suggestion to support mapping to infinity).
2282    Paul.Green@stratus.com 02-04-02.  */
2283                 if (SvNV(fromstr) > FLT_MAX)
2284                      afloat = _float_constants[0];   /* single prec. inf. */
2285                 else if (SvNV(fromstr) < -FLT_MAX)
2286                      afloat = _float_constants[0];   /* single prec. inf. */
2287                 else afloat = (float)SvNV(fromstr);
2288 #else
2289 # if defined(VMS) && !defined(__IEEE_FP)
2290 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2291  * on Alpha; fake it if we don't have them.
2292  */
2293                 if (SvNV(fromstr) > FLT_MAX)
2294                      afloat = FLT_MAX;
2295                 else if (SvNV(fromstr) < -FLT_MAX)
2296                      afloat = -FLT_MAX;
2297                 else afloat = (float)SvNV(fromstr);
2298 # else
2299                 afloat = (float)SvNV(fromstr);
2300 # endif
2301 #endif
2302                 DO_BO_PACK_N(afloat, float);
2303                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2304             }
2305             break;
2306         case 'd':
2307             while (len-- > 0) {
2308                 fromstr = NEXTFROM;
2309 #ifdef __VOS__
2310 /* VOS does not automatically map a floating-point overflow
2311    during conversion from long double to double into infinity,
2312    so we do it by hand.  This code should either be generalized
2313    for any OS that needs it, or removed if and when VOS
2314    implements posix-976 (suggestion to support mapping to
2315    infinity).  Paul.Green@stratus.com 02-04-02.  */
2316                 if (SvNV(fromstr) > DBL_MAX)
2317                      adouble = _double_constants[0];   /* double prec. inf. */
2318                 else if (SvNV(fromstr) < -DBL_MAX)
2319                      adouble = _double_constants[0];   /* double prec. inf. */
2320                 else adouble = (double)SvNV(fromstr);
2321 #else
2322 # if defined(VMS) && !defined(__IEEE_FP)
2323 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2324  * on Alpha; fake it if we don't have them.
2325  */
2326                 if (SvNV(fromstr) > DBL_MAX)
2327                      adouble = DBL_MAX;
2328                 else if (SvNV(fromstr) < -DBL_MAX)
2329                      adouble = -DBL_MAX;
2330                 else adouble = (double)SvNV(fromstr);
2331 # else
2332                 adouble = (double)SvNV(fromstr);
2333 # endif
2334 #endif
2335                 DO_BO_PACK_N(adouble, double);
2336                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2337             }
2338             break;
2339         case 'F':
2340             Zero(&anv, 1, NV); /* can be long double with unused bits */
2341             while (len-- > 0) {
2342                 fromstr = NEXTFROM;
2343                 anv = SvNV(fromstr);
2344                 DO_BO_PACK_N(anv, NV);
2345                 sv_catpvn(cat, (char *)&anv, NVSIZE);
2346             }
2347             break;
2348 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2349         case 'D':
2350             /* long doubles can have unused bits, which may be nonzero */
2351             Zero(&aldouble, 1, long double);
2352             while (len-- > 0) {
2353                 fromstr = NEXTFROM;
2354                 aldouble = (long double)SvNV(fromstr);
2355                 DO_BO_PACK_N(aldouble, long double);
2356                 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2357             }
2358             break;
2359 #endif
2360 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2361         case 'n' | TYPE_IS_SHRIEKING:
2362 #endif
2363         case 'n':
2364             while (len-- > 0) {
2365                 fromstr = NEXTFROM;
2366                 ai16 = (I16)SvIV(fromstr);
2367 #ifdef HAS_HTONS
2368                 ai16 = PerlSock_htons(ai16);
2369 #endif
2370                 CAT16(cat, &ai16);
2371             }
2372             break;
2373 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2374         case 'v' | TYPE_IS_SHRIEKING:
2375 #endif
2376         case 'v':
2377             while (len-- > 0) {
2378                 fromstr = NEXTFROM;
2379                 ai16 = (I16)SvIV(fromstr);
2380 #ifdef HAS_HTOVS
2381                 ai16 = htovs(ai16);
2382 #endif
2383                 CAT16(cat, &ai16);
2384             }
2385             break;
2386         case 'S' | TYPE_IS_SHRIEKING:
2387 #if SHORTSIZE != SIZE16
2388             {
2389                 while (len-- > 0) {
2390                     fromstr = NEXTFROM;
2391                     aushort = SvUV(fromstr);
2392                     DO_BO_PACK(aushort, s);
2393                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2394                 }
2395             }
2396             break;
2397 #else
2398             /* Fall through! */
2399 #endif
2400         case 'S':
2401             {
2402                 while (len-- > 0) {
2403                     fromstr = NEXTFROM;
2404                     au16 = (U16)SvUV(fromstr);
2405                     DO_BO_PACK(au16, 16);
2406                     CAT16(cat, &au16);
2407                 }
2408
2409             }
2410             break;
2411         case 's' | TYPE_IS_SHRIEKING:
2412 #if SHORTSIZE != SIZE16
2413             {
2414                 while (len-- > 0) {
2415                     fromstr = NEXTFROM;
2416                     ashort = SvIV(fromstr);
2417                     DO_BO_PACK(ashort, s);
2418                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
2419                 }
2420             }
2421             break;
2422 #else
2423             /* Fall through! */
2424 #endif
2425         case 's':
2426             while (len-- > 0) {
2427                 fromstr = NEXTFROM;
2428                 ai16 = (I16)SvIV(fromstr);
2429                 DO_BO_PACK(ai16, 16);
2430                 CAT16(cat, &ai16);
2431             }
2432             break;
2433         case 'I':
2434         case 'I' | TYPE_IS_SHRIEKING:
2435             while (len-- > 0) {
2436                 fromstr = NEXTFROM;
2437                 auint = SvUV(fromstr);
2438                 DO_BO_PACK(auint, i);
2439                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2440             }
2441             break;
2442         case 'j':
2443             while (len-- > 0) {
2444                 fromstr = NEXTFROM;
2445                 aiv = SvIV(fromstr);
2446 #if IVSIZE == INTSIZE
2447                 DO_BO_PACK(aiv, i);
2448 #elif IVSIZE == LONGSIZE
2449                 DO_BO_PACK(aiv, l);
2450 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2451                 DO_BO_PACK(aiv, 64);
2452 #endif
2453                 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2454             }
2455             break;
2456         case 'J':
2457             while (len-- > 0) {
2458                 fromstr = NEXTFROM;
2459                 auv = SvUV(fromstr);
2460 #if UVSIZE == INTSIZE
2461                 DO_BO_PACK(auv, i);
2462 #elif UVSIZE == LONGSIZE
2463                 DO_BO_PACK(auv, l);
2464 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2465                 DO_BO_PACK(auv, 64);
2466 #endif
2467                 sv_catpvn(cat, (char*)&auv, UVSIZE);
2468             }
2469             break;
2470         case 'w':
2471             while (len-- > 0) {
2472                 fromstr = NEXTFROM;
2473                 anv = SvNV(fromstr);
2474
2475                 if (anv < 0)
2476                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2477
2478                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2479                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2480                    any negative IVs will have already been got by the croak()
2481                    above. IOK is untrue for fractions, so we test them
2482                    against UV_MAX_P1.  */
2483                 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2484                 {
2485                     char   buf[(sizeof(UV)*8)/7+1];
2486                     char  *in = buf + sizeof(buf);
2487                     UV     auv = SvUV(fromstr);
2488
2489                     do {
2490                         *--in = (char)((auv & 0x7f) | 0x80);
2491                         auv >>= 7;
2492                     } while (auv);
2493                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2494                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2495                 }
2496                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
2497                     char           *from, *result, *in;
2498                     SV             *norm;
2499                     STRLEN          len;
2500                     bool            done;
2501
2502                     /* Copy string and check for compliance */
2503                     from = SvPV(fromstr, len);
2504                     if ((norm = is_an_int(from, len)) == NULL)
2505                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2506
2507                     New('w', result, len, char);
2508                     in = result + len;
2509                     done = FALSE;
2510                     while (!done)
2511                         *--in = div128(norm, &done) | 0x80;
2512                     result[len - 1] &= 0x7F; /* clear continue bit */
2513                     sv_catpvn(cat, in, (result + len) - in);
2514                     Safefree(result);
2515                     SvREFCNT_dec(norm); /* free norm */
2516                 }
2517                 else if (SvNOKp(fromstr)) {
2518                     /* 10**NV_MAX_10_EXP is the largest power of 10
2519                        so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2520                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2521                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2522                        And with that many bytes only Inf can overflow.
2523                        Some C compilers are strict about integral constant
2524                        expressions so we conservatively divide by a slightly
2525                        smaller integer instead of multiplying by the exact
2526                        floating-point value.
2527                     */
2528 #ifdef NV_MAX_10_EXP
2529 /*                  char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2530                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2531 #else
2532 /*                  char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2533                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2534 #endif
2535                     char  *in = buf + sizeof(buf);
2536
2537                     anv = Perl_floor(anv);
2538                     do {
2539                         NV next = Perl_floor(anv / 128);
2540                         if (in <= buf)  /* this cannot happen ;-) */
2541                             Perl_croak(aTHX_ "Cannot compress integer in pack");
2542                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2543                         anv = next;
2544                     } while (anv > 0);
2545                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2546                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2547                 }
2548                 else {
2549                     char           *from, *result, *in;
2550                     SV             *norm;
2551                     STRLEN          len;
2552                     bool            done;
2553
2554                     /* Copy string and check for compliance */
2555                     from = SvPV(fromstr, len);
2556                     if ((norm = is_an_int(from, len)) == NULL)
2557                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2558
2559                     New('w', result, len, char);
2560                     in = result + len;
2561                     done = FALSE;
2562                     while (!done)
2563                         *--in = div128(norm, &done) | 0x80;
2564                     result[len - 1] &= 0x7F; /* clear continue bit */
2565                     sv_catpvn(cat, in, (result + len) - in);
2566                     Safefree(result);
2567                     SvREFCNT_dec(norm); /* free norm */
2568                }
2569             }
2570             break;
2571         case 'i':
2572         case 'i' | TYPE_IS_SHRIEKING:
2573             while (len-- > 0) {
2574                 fromstr = NEXTFROM;
2575                 aint = SvIV(fromstr);
2576                 DO_BO_PACK(aint, i);
2577                 sv_catpvn(cat, (char*)&aint, sizeof(int));
2578             }
2579             break;
2580 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2581         case 'N' | TYPE_IS_SHRIEKING:
2582 #endif
2583         case 'N':
2584             while (len-- > 0) {
2585                 fromstr = NEXTFROM;
2586                 au32 = SvUV(fromstr);
2587 #ifdef HAS_HTONL
2588                 au32 = PerlSock_htonl(au32);
2589 #endif
2590                 CAT32(cat, &au32);
2591             }
2592             break;
2593 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2594         case 'V' | TYPE_IS_SHRIEKING:
2595 #endif
2596         case 'V':
2597             while (len-- > 0) {
2598                 fromstr = NEXTFROM;
2599                 au32 = SvUV(fromstr);
2600 #ifdef HAS_HTOVL
2601                 au32 = htovl(au32);
2602 #endif
2603                 CAT32(cat, &au32);
2604             }
2605             break;
2606         case 'L' | TYPE_IS_SHRIEKING:
2607 #if LONGSIZE != SIZE32
2608             {
2609                 while (len-- > 0) {
2610                     fromstr = NEXTFROM;
2611                     aulong = SvUV(fromstr);
2612                     DO_BO_PACK(aulong, l);
2613                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2614                 }
2615             }
2616             break;
2617 #else
2618             /* Fall though! */
2619 #endif
2620         case 'L':
2621             {
2622                 while (len-- > 0) {
2623                     fromstr = NEXTFROM;
2624                     au32 = SvUV(fromstr);
2625                     DO_BO_PACK(au32, 32);
2626                     CAT32(cat, &au32);
2627                 }
2628             }
2629             break;
2630         case 'l' | TYPE_IS_SHRIEKING:
2631 #if LONGSIZE != SIZE32
2632             {
2633                 while (len-- > 0) {
2634                     fromstr = NEXTFROM;
2635                     along = SvIV(fromstr);
2636                     DO_BO_PACK(along, l);
2637                     sv_catpvn(cat, (char *)&along, sizeof(long));
2638                 }
2639             }
2640             break;
2641 #else
2642             /* Fall though! */
2643 #endif
2644         case 'l':
2645             while (len-- > 0) {
2646                 fromstr = NEXTFROM;
2647                 ai32 = SvIV(fromstr);
2648                 DO_BO_PACK(ai32, 32);
2649                 CAT32(cat, &ai32);
2650             }
2651             break;
2652 #ifdef HAS_QUAD
2653         case 'Q':
2654             while (len-- > 0) {
2655                 fromstr = NEXTFROM;
2656                 auquad = (Uquad_t)SvUV(fromstr);
2657                 DO_BO_PACK(auquad, 64);
2658                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2659             }
2660             break;
2661         case 'q':
2662             while (len-- > 0) {
2663                 fromstr = NEXTFROM;
2664                 aquad = (Quad_t)SvIV(fromstr);
2665                 DO_BO_PACK(aquad, 64);
2666                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2667             }
2668             break;
2669 #endif
2670         case 'P':
2671             len = 1;            /* assume SV is correct length */
2672             /* Fall through! */
2673         case 'p':
2674             while (len-- > 0) {
2675                 fromstr = NEXTFROM;
2676                 if (fromstr == &PL_sv_undef)
2677                     aptr = NULL;
2678                 else {
2679                     STRLEN n_a;
2680                     /* XXX better yet, could spirit away the string to
2681                      * a safe spot and hang on to it until the result
2682                      * of pack() (and all copies of the result) are
2683                      * gone.
2684                      */
2685                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2686                                                 || (SvPADTMP(fromstr)
2687                                                     && !SvREADONLY(fromstr))))
2688                     {
2689                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2690                                 "Attempt to pack pointer to temporary value");
2691                     }
2692                     if (SvPOK(fromstr) || SvNIOK(fromstr))
2693                         aptr = SvPV(fromstr,n_a);
2694                     else
2695                         aptr = SvPV_force(fromstr,n_a);
2696                 }
2697                 DO_BO_PACK_P(aptr);
2698                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2699             }
2700             break;
2701         case 'u':
2702             fromstr = NEXTFROM;
2703             aptr = SvPV(fromstr, fromlen);
2704             SvGROW(cat, fromlen * 4 / 3);
2705             if (len <= 2)
2706                 len = 45;
2707             else
2708                 len = len / 3 * 3;
2709             while (fromlen > 0) {
2710                 I32 todo;
2711
2712                 if ((I32)fromlen > len)
2713                     todo = len;
2714                 else
2715                     todo = fromlen;
2716                 doencodes(cat, aptr, todo);
2717                 fromlen -= todo;
2718                 aptr += todo;
2719             }
2720             break;
2721         }
2722         *symptr = lookahead;
2723     }
2724     return beglist;
2725 }
2726 #undef NEXTFROM
2727
2728
2729 PP(pp_pack)
2730 {
2731     dSP; dMARK; dORIGMARK; dTARGET;
2732     register SV *cat = TARG;
2733     STRLEN fromlen;
2734     register char *pat = SvPVx(*++MARK, fromlen);
2735     register char *patend = pat + fromlen;
2736
2737     MARK++;
2738     sv_setpvn(cat, "", 0);
2739
2740     packlist(cat, pat, patend, MARK, SP + 1);
2741
2742     SvSETMAGIC(cat);
2743     SP = ORIGMARK;
2744     PUSHs(cat);
2745     RETURN;
2746 }
2747
2748 /*
2749  * Local variables:
2750  * c-indentation-style: bsd
2751  * c-basic-offset: 4
2752  * indent-tabs-mode: t
2753  * End:
2754  *
2755  * vim: shiftwidth=4:
2756 */