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                     if (checksum > bits_in_uv)
1187                         cdouble += (NV)auint;
1188                     else
1189                         cuv += auint;
1190                 }
1191             }
1192             else {
1193                 while (len-- > 0) {
1194                     auint = *s++ & 255;
1195                     PUSHs(sv_2mortal(newSViv((IV)auint)));
1196                 }
1197             }
1198             break;
1199         case 'U':
1200             if (len == 0) {
1201                 symptr->flags |= FLAG_UNPACK_DO_UTF8;
1202                 break;
1203             }
1204             if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
1205                  goto unpack_C;
1206             while (len-- > 0 && s < strend) {
1207                 STRLEN alen;
1208                 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1209                 along = alen;
1210                 s += along;
1211                 if (!checksum) {
1212                     PUSHs(sv_2mortal(newSVuv((UV)auint)));
1213                 }
1214                 else if (checksum > bits_in_uv)
1215                     cdouble += (NV)auint;
1216                 else
1217                     cuv += auint;
1218             }
1219             break;
1220         case 's' | TYPE_IS_SHRIEKING:
1221 #if SHORTSIZE != SIZE16
1222             while (len-- > 0) {
1223                 COPYNN(s, &ashort, sizeof(short));
1224                 DO_BO_UNPACK(ashort, s);
1225                 s += sizeof(short);
1226                 if (!checksum) {
1227                     PUSHs(sv_2mortal(newSViv((IV)ashort)));
1228                 }
1229                 else if (checksum > bits_in_uv)
1230                     cdouble += (NV)ashort;
1231                 else
1232                     cuv += ashort;
1233             }
1234             break;
1235 #else
1236             /* Fallthrough! */
1237 #endif
1238         case 's':
1239             while (len-- > 0) {
1240                 COPY16(s, &ai16);
1241                 DO_BO_UNPACK(ai16, 16);
1242 #if U16SIZE > SIZE16
1243                 if (ai16 > 32767)
1244                     ai16 -= 65536;
1245 #endif
1246                 s += SIZE16;
1247                 if (!checksum) {
1248                     PUSHs(sv_2mortal(newSViv((IV)ai16)));
1249                 }
1250                 else if (checksum > bits_in_uv)
1251                     cdouble += (NV)ai16;
1252                 else
1253                     cuv += ai16;
1254             }
1255             break;
1256         case 'S' | TYPE_IS_SHRIEKING:
1257 #if SHORTSIZE != SIZE16
1258             while (len-- > 0) {
1259                 COPYNN(s, &aushort, sizeof(unsigned short));
1260                 DO_BO_UNPACK(aushort, s);
1261                 s += sizeof(unsigned short);
1262                 if (!checksum) {
1263                     PUSHs(sv_2mortal(newSViv((UV)aushort)));
1264                 }
1265                 else if (checksum > bits_in_uv)
1266                     cdouble += (NV)aushort;
1267                 else
1268                     cuv += aushort;
1269             }
1270             break;
1271 #else
1272             /* Fallhrough! */
1273 #endif
1274         case 'v':
1275         case 'n':
1276         case 'S':
1277             while (len-- > 0) {
1278                 COPY16(s, &au16);
1279                 DO_BO_UNPACK(au16, 16);
1280                 s += SIZE16;
1281 #ifdef HAS_NTOHS
1282                 if (datumtype == 'n')
1283                     au16 = PerlSock_ntohs(au16);
1284 #endif
1285 #ifdef HAS_VTOHS
1286                 if (datumtype == 'v')
1287                     au16 = vtohs(au16);
1288 #endif
1289                 if (!checksum) {
1290                     PUSHs(sv_2mortal(newSViv((UV)au16)));
1291                 }
1292                 else if (checksum > bits_in_uv)
1293                     cdouble += (NV)au16;
1294                 else
1295                     cuv += au16;
1296             }
1297             break;
1298 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1299         case 'v' | TYPE_IS_SHRIEKING:
1300         case 'n' | TYPE_IS_SHRIEKING:
1301             while (len-- > 0) {
1302                 COPY16(s, &ai16);
1303                 s += SIZE16;
1304 #ifdef HAS_NTOHS
1305                 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1306                     ai16 = (I16)PerlSock_ntohs((U16)ai16);
1307 #endif
1308 #ifdef HAS_VTOHS
1309                 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1310                     ai16 = (I16)vtohs((U16)ai16);
1311 #endif
1312                 if (!checksum) {
1313                     PUSHs(sv_2mortal(newSViv((IV)ai16)));
1314                 }
1315                 else if (checksum > bits_in_uv)
1316                     cdouble += (NV)ai16;
1317                 else
1318                     cuv += ai16;
1319             }
1320             break;
1321 #endif
1322         case 'i':
1323         case 'i' | TYPE_IS_SHRIEKING:
1324             while (len-- > 0) {
1325                 Copy(s, &aint, 1, int);
1326                 DO_BO_UNPACK(aint, i);
1327                 s += sizeof(int);
1328                 if (!checksum) {
1329                     PUSHs(sv_2mortal(newSViv((IV)aint)));
1330                 }
1331                 else if (checksum > bits_in_uv)
1332                     cdouble += (NV)aint;
1333                 else
1334                     cuv += aint;
1335             }
1336             break;
1337         case 'I':
1338         case 'I' | TYPE_IS_SHRIEKING:
1339             while (len-- > 0) {
1340                 Copy(s, &auint, 1, unsigned int);
1341                 DO_BO_UNPACK(auint, i);
1342                 s += sizeof(unsigned int);
1343                 if (!checksum) {
1344                     PUSHs(sv_2mortal(newSVuv((UV)auint)));
1345                 }
1346                 else if (checksum > bits_in_uv)
1347                     cdouble += (NV)auint;
1348                 else
1349                     cuv += auint;
1350             }
1351             break;
1352         case 'j':
1353             while (len-- > 0) {
1354                 Copy(s, &aiv, 1, IV);
1355 #if IVSIZE == INTSIZE
1356                 DO_BO_UNPACK(aiv, i);
1357 #elif IVSIZE == LONGSIZE
1358                 DO_BO_UNPACK(aiv, l);
1359 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1360                 DO_BO_UNPACK(aiv, 64);
1361 #endif
1362                 s += IVSIZE;
1363                 if (!checksum) {
1364                     PUSHs(sv_2mortal(newSViv(aiv)));
1365                 }
1366                 else if (checksum > bits_in_uv)
1367                     cdouble += (NV)aiv;
1368                 else
1369                     cuv += aiv;
1370             }
1371             break;
1372         case 'J':
1373             while (len-- > 0) {
1374                 Copy(s, &auv, 1, UV);
1375 #if UVSIZE == INTSIZE
1376                 DO_BO_UNPACK(auv, i);
1377 #elif UVSIZE == LONGSIZE
1378                 DO_BO_UNPACK(auv, l);
1379 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1380                 DO_BO_UNPACK(auv, 64);
1381 #endif
1382                 s += UVSIZE;
1383                 if (!checksum) {
1384                     PUSHs(sv_2mortal(newSVuv(auv)));
1385                 }
1386                 else if (checksum > bits_in_uv)
1387                     cdouble += (NV)auv;
1388                 else
1389                     cuv += auv;
1390             }
1391             break;
1392         case 'l' | TYPE_IS_SHRIEKING:
1393 #if LONGSIZE != SIZE32
1394             while (len-- > 0) {
1395                 COPYNN(s, &along, sizeof(long));
1396                 DO_BO_UNPACK(along, l);
1397                 s += sizeof(long);
1398                 if (!checksum) {
1399                     PUSHs(sv_2mortal(newSViv((IV)along)));
1400                 }
1401                 else if (checksum > bits_in_uv)
1402                     cdouble += (NV)along;
1403                 else
1404                     cuv += along;
1405             }
1406             break;
1407 #else
1408             /* Fallthrough! */
1409 #endif
1410         case 'l':
1411             while (len-- > 0) {
1412                 COPY32(s, &ai32);
1413                 DO_BO_UNPACK(ai32, 32);
1414 #if U32SIZE > SIZE32
1415                 if (ai32 > 2147483647)
1416                     ai32 -= 4294967296;
1417 #endif
1418                 s += SIZE32;
1419                 if (!checksum) {
1420                     PUSHs(sv_2mortal(newSViv((IV)ai32)));
1421                 }
1422                 else if (checksum > bits_in_uv)
1423                     cdouble += (NV)ai32;
1424                 else
1425                     cuv += ai32;
1426             }
1427             break;
1428         case 'L' | TYPE_IS_SHRIEKING:
1429 #if LONGSIZE != SIZE32
1430             while (len-- > 0) {
1431                 COPYNN(s, &aulong, sizeof(unsigned long));
1432                 DO_BO_UNPACK(aulong, l);
1433                 s += sizeof(unsigned long);
1434                 if (!checksum) {
1435                     PUSHs(sv_2mortal(newSVuv((UV)aulong)));
1436                 }
1437                 else if (checksum > bits_in_uv)
1438                     cdouble += (NV)aulong;
1439                 else
1440                     cuv += aulong;
1441             }
1442             break;
1443 #else
1444             /* Fall through! */
1445 #endif
1446         case 'V':
1447         case 'N':
1448         case 'L':
1449             while (len-- > 0) {
1450                 COPY32(s, &au32);
1451                 DO_BO_UNPACK(au32, 32);
1452                 s += SIZE32;
1453 #ifdef HAS_NTOHL
1454                 if (datumtype == 'N')
1455                     au32 = PerlSock_ntohl(au32);
1456 #endif
1457 #ifdef HAS_VTOHL
1458                 if (datumtype == 'V')
1459                     au32 = vtohl(au32);
1460 #endif
1461                  if (!checksum) {
1462                      PUSHs(sv_2mortal(newSVuv((UV)au32)));
1463                  }
1464                  else if (checksum > bits_in_uv)
1465                      cdouble += (NV)au32;
1466                  else
1467                      cuv += au32;
1468             }
1469             break;
1470 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1471         case 'V' | TYPE_IS_SHRIEKING:
1472         case 'N' | TYPE_IS_SHRIEKING:
1473             while (len-- > 0) {
1474                 COPY32(s, &ai32);
1475                 s += SIZE32;
1476 #ifdef HAS_NTOHL
1477                 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1478                     ai32 = (I32)PerlSock_ntohl((U32)ai32);
1479 #endif
1480 #ifdef HAS_VTOHL
1481                 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1482                     ai32 = (I32)vtohl((U32)ai32);
1483 #endif
1484                 if (!checksum) {
1485                     PUSHs(sv_2mortal(newSViv((IV)ai32)));
1486                 }
1487                 else if (checksum > bits_in_uv)
1488                     cdouble += (NV)ai32;
1489                 else
1490                     cuv += ai32;
1491             }
1492             break;
1493 #endif
1494         case 'p':
1495             while (len-- > 0) {
1496                 assert (sizeof(char*) <= strend - s);
1497                 Copy(s, &aptr, 1, char*);
1498                 DO_BO_UNPACK_P(aptr);
1499                 s += sizeof(char*);
1500                 /* newSVpv generates undef if aptr is NULL */
1501                 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1502             }
1503             break;
1504         case 'w':
1505             {
1506                 UV auv = 0;
1507                 U32 bytes = 0;
1508
1509                 while ((len > 0) && (s < strend)) {
1510                     auv = (auv << 7) | (*s & 0x7f);
1511                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1512                     if ((U8)(*s++) < 0x80) {
1513                         bytes = 0;
1514                         PUSHs(sv_2mortal(newSVuv(auv)));
1515                         len--;
1516                         auv = 0;
1517                     }
1518                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
1519                         char *t;
1520                         STRLEN n_a;
1521
1522                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1523                         while (s < strend) {
1524                             sv = mul128(sv, (U8)(*s & 0x7f));
1525                             if (!(*s++ & 0x80)) {
1526                                 bytes = 0;
1527                                 break;
1528                             }
1529                         }
1530                         t = SvPV(sv, n_a);
1531                         while (*t == '0')
1532                             t++;
1533                         sv_chop(sv, t);
1534                         PUSHs(sv_2mortal(sv));
1535                         len--;
1536                         auv = 0;
1537                     }
1538                 }
1539                 if ((s >= strend) && bytes)
1540                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1541             }
1542             break;
1543         case 'P':
1544             if (symptr->howlen == e_star)
1545                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1546             EXTEND(SP, 1);
1547             if (sizeof(char*) > strend - s)
1548                 break;
1549             else {
1550                 Copy(s, &aptr, 1, char*);
1551                 DO_BO_UNPACK_P(aptr);
1552                 s += sizeof(char*);
1553             }
1554             /* newSVpvn generates undef if aptr is NULL */
1555             PUSHs(sv_2mortal(newSVpvn(aptr, len)));
1556             break;
1557 #ifdef HAS_QUAD
1558         case 'q':
1559             while (len-- > 0) {
1560                 assert (s + sizeof(Quad_t) <= strend);
1561                 Copy(s, &aquad, 1, Quad_t);
1562                 DO_BO_UNPACK(aquad, 64);
1563                 s += sizeof(Quad_t);
1564                 if (!checksum) {
1565                     PUSHs(sv_2mortal((aquad >= IV_MIN && aquad <= IV_MAX) ?
1566                                      newSViv((IV)aquad) : newSVnv((NV)aquad)));
1567                 }
1568                 else if (checksum > bits_in_uv)
1569                     cdouble += (NV)aquad;
1570                 else
1571                     cuv += aquad;
1572             }
1573             break;
1574         case 'Q':
1575             while (len-- > 0) {
1576                 assert (s + sizeof(Uquad_t) <= strend);
1577                 Copy(s, &auquad, 1, Uquad_t);
1578                 DO_BO_UNPACK(auquad, 64);
1579                 s += sizeof(Uquad_t);
1580                 if (!checksum) {
1581                     PUSHs(sv_2mortal((auquad <= UV_MAX) ?
1582                                      newSVuv((UV)auquad) : newSVnv((NV)auquad)));
1583                 }
1584                 else if (checksum > bits_in_uv)
1585                     cdouble += (NV)auquad;
1586                 else
1587                     cuv += auquad;
1588             }
1589             break;
1590 #endif
1591         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1592         case 'f':
1593             while (len-- > 0) {
1594                 Copy(s, &afloat, 1, float);
1595                 DO_BO_UNPACK_N(afloat, float);
1596                 s += sizeof(float);
1597                 if (!checksum) {
1598                     PUSHs(sv_2mortal(newSVnv((NV)afloat)));
1599                 }
1600                 else {
1601                     cdouble += afloat;
1602                 }
1603             }
1604             break;
1605         case 'd':
1606             while (len-- > 0) {
1607                 Copy(s, &adouble, 1, double);
1608                 DO_BO_UNPACK_N(adouble, double);
1609                 s += sizeof(double);
1610                 if (!checksum) {
1611                     PUSHs(sv_2mortal(newSVnv((NV)adouble)));
1612                 }
1613                 else {
1614                     cdouble += adouble;
1615                 }
1616             }
1617             break;
1618         case 'F':
1619             while (len-- > 0) {
1620                 Copy(s, &anv, 1, NV);
1621                 DO_BO_UNPACK_N(anv, NV);
1622                 s += NVSIZE;
1623                 if (!checksum) {
1624                     PUSHs(sv_2mortal(newSVnv(anv)));
1625                 }
1626                 else {
1627                     cdouble += anv;
1628                 }
1629             }
1630             break;
1631 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1632         case 'D':
1633             while (len-- > 0) {
1634                 Copy(s, &aldouble, 1, long double);
1635                 DO_BO_UNPACK_N(aldouble, long double);
1636                 s += LONG_DOUBLESIZE;
1637                 if (!checksum) {
1638                     PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
1639                 }
1640                 else {cdouble += aldouble;
1641                 }
1642             }
1643             break;
1644 #endif
1645         case 'u':
1646             /* MKS:
1647              * Initialise the decode mapping.  By using a table driven
1648              * algorithm, the code will be character-set independent
1649              * (and just as fast as doing character arithmetic)
1650              */
1651             if (PL_uudmap['M'] == 0) {
1652                 int i;
1653
1654                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1655                     PL_uudmap[(U8)PL_uuemap[i]] = i;
1656                 /*
1657                  * Because ' ' and '`' map to the same value,
1658                  * we need to decode them both the same.
1659                  */
1660                 PL_uudmap[' '] = 0;
1661             }
1662
1663             along = (strend - s) * 3 / 4;
1664             sv = NEWSV(42, along);
1665             if (along)
1666                 SvPOK_on(sv);
1667             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1668                 I32 a, b, c, d;
1669                 char hunk[4];
1670
1671                 hunk[3] = '\0';
1672                 len = PL_uudmap[*(U8*)s++] & 077;
1673                 while (len > 0) {
1674                     if (s < strend && ISUUCHAR(*s))
1675                         a = PL_uudmap[*(U8*)s++] & 077;
1676                     else
1677                         a = 0;
1678                     if (s < strend && ISUUCHAR(*s))
1679                         b = PL_uudmap[*(U8*)s++] & 077;
1680                     else
1681                         b = 0;
1682                     if (s < strend && ISUUCHAR(*s))
1683                         c = PL_uudmap[*(U8*)s++] & 077;
1684                     else
1685                         c = 0;
1686                     if (s < strend && ISUUCHAR(*s))
1687                         d = PL_uudmap[*(U8*)s++] & 077;
1688                     else
1689                         d = 0;
1690                     hunk[0] = (char)((a << 2) | (b >> 4));
1691                     hunk[1] = (char)((b << 4) | (c >> 2));
1692                     hunk[2] = (char)((c << 6) | d);
1693                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1694                     len -= 3;
1695                 }
1696                 if (*s == '\n')
1697                     s++;
1698                 else    /* possible checksum byte */
1699                     if (s + 1 < strend && s[1] == '\n')
1700                         s += 2;
1701             }
1702             XPUSHs(sv_2mortal(sv));
1703             break;
1704         }
1705
1706         if (checksum) {
1707             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1708               (checksum > bits_in_uv &&
1709                strchr("cCsSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1710                 NV trouble;
1711
1712                 adouble = (NV) (1 << (checksum & 15));
1713                 while (checksum >= 16) {
1714                     checksum -= 16;
1715                     adouble *= 65536.0;
1716                 }
1717                 while (cdouble < 0.0)
1718                     cdouble += adouble;
1719                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1720                 sv = newSVnv(cdouble);
1721             }
1722             else {
1723                 if (checksum < bits_in_uv) {
1724                     UV mask = ((UV)1 << checksum) - 1;
1725                     cuv &= mask;
1726                 }
1727                 sv = newSVuv(cuv);
1728             }
1729             XPUSHs(sv_2mortal(sv));
1730             checksum = 0;
1731         }
1732
1733         if (symptr->flags & FLAG_SLASH){
1734             if (SP - PL_stack_base - start_sp_offset <= 0)
1735                 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1736             if( next_symbol(symptr) ){
1737               if( symptr->howlen == e_number )
1738                 Perl_croak(aTHX_ "Count after length/code in unpack" );
1739               if( beyond ){
1740                 /* ...end of char buffer then no decent length available */
1741                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1742               } else {
1743                 /* take top of stack (hope it's numeric) */
1744                 len = POPi;
1745                 if( len < 0 )
1746                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
1747               }
1748             } else {
1749                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1750             }
1751             datumtype = symptr->code;
1752             goto redo_switch;
1753         }
1754     }
1755
1756     if (new_s)
1757         *new_s = s;
1758     PUTBACK;
1759     return SP - PL_stack_base - start_sp_offset;
1760 }
1761
1762 PP(pp_unpack)
1763 {
1764     dSP;
1765     dPOPPOPssrl;
1766     I32 gimme = GIMME_V;
1767     STRLEN llen;
1768     STRLEN rlen;
1769     register char *pat = SvPV(left, llen);
1770 #ifdef PACKED_IS_OCTETS
1771     /* Packed side is assumed to be octets - so force downgrade if it
1772        has been UTF-8 encoded by accident
1773      */
1774     register char *s = SvPVbyte(right, rlen);
1775 #else
1776     register char *s = SvPV(right, rlen);
1777 #endif
1778     char *strend = s + rlen;
1779     register char *patend = pat + llen;
1780     register I32 cnt;
1781
1782     PUTBACK;
1783     cnt = unpackstring(pat, patend, s, strend,
1784                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1785                      | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1786
1787     SPAGAIN;
1788     if ( !cnt && gimme == G_SCALAR )
1789        PUSHs(&PL_sv_undef);
1790     RETURN;
1791 }
1792
1793 STATIC void
1794 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1795 {
1796     char hunk[5];
1797
1798     *hunk = PL_uuemap[len];
1799     sv_catpvn(sv, hunk, 1);
1800     hunk[4] = '\0';
1801     while (len > 2) {
1802         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1803         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1804         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1805         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1806         sv_catpvn(sv, hunk, 4);
1807         s += 3;
1808         len -= 3;
1809     }
1810     if (len > 0) {
1811         char r = (len > 1 ? s[1] : '\0');
1812         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1813         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1814         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1815         hunk[3] = PL_uuemap[0];
1816         sv_catpvn(sv, hunk, 4);
1817     }
1818     sv_catpvn(sv, "\n", 1);
1819 }
1820
1821 STATIC SV *
1822 S_is_an_int(pTHX_ char *s, STRLEN l)
1823 {
1824   STRLEN         n_a;
1825   SV             *result = newSVpvn(s, l);
1826   char           *result_c = SvPV(result, n_a); /* convenience */
1827   char           *out = result_c;
1828   bool            skip = 1;
1829   bool            ignore = 0;
1830
1831   while (*s) {
1832     switch (*s) {
1833     case ' ':
1834       break;
1835     case '+':
1836       if (!skip) {
1837         SvREFCNT_dec(result);
1838         return (NULL);
1839       }
1840       break;
1841     case '0':
1842     case '1':
1843     case '2':
1844     case '3':
1845     case '4':
1846     case '5':
1847     case '6':
1848     case '7':
1849     case '8':
1850     case '9':
1851       skip = 0;
1852       if (!ignore) {
1853         *(out++) = *s;
1854       }
1855       break;
1856     case '.':
1857       ignore = 1;
1858       break;
1859     default:
1860       SvREFCNT_dec(result);
1861       return (NULL);
1862     }
1863     s++;
1864   }
1865   *(out++) = '\0';
1866   SvCUR_set(result, out - result_c);
1867   return (result);
1868 }
1869
1870 /* pnum must be '\0' terminated */
1871 STATIC int
1872 S_div128(pTHX_ SV *pnum, bool *done)
1873 {
1874   STRLEN          len;
1875   char           *s = SvPV(pnum, len);
1876   int             m = 0;
1877   int             r = 0;
1878   char           *t = s;
1879
1880   *done = 1;
1881   while (*t) {
1882     int             i;
1883
1884     i = m * 10 + (*t - '0');
1885     m = i & 0x7F;
1886     r = (i >> 7);               /* r < 10 */
1887     if (r) {
1888       *done = 0;
1889     }
1890     *(t++) = '0' + r;
1891   }
1892   *(t++) = '\0';
1893   SvCUR_set(pnum, (STRLEN) (t - s));
1894   return (m);
1895 }
1896
1897
1898
1899 /*
1900 =for apidoc pack_cat
1901
1902 The engine implementing pack() Perl function. Note: parameters next_in_list and
1903 flags are not used. This call should not be used; use packlist instead.
1904
1905 =cut */
1906
1907
1908 void
1909 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1910 {
1911     tempsym_t sym = { 0 };
1912     sym.patptr = pat;
1913     sym.patend = patend;
1914     sym.flags  = FLAG_PACK;
1915
1916     (void)pack_rec( cat, &sym, beglist, endlist );
1917 }
1918
1919
1920 /*
1921 =for apidoc packlist
1922
1923 The engine implementing pack() Perl function.
1924
1925 =cut */
1926
1927
1928 void
1929 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1930 {
1931     tempsym_t sym = { 0 };
1932     sym.patptr = pat;
1933     sym.patend = patend;
1934     sym.flags  = FLAG_PACK;
1935
1936     (void)pack_rec( cat, &sym, beglist, endlist );
1937 }
1938
1939
1940 STATIC
1941 SV **
1942 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1943 {
1944     register I32 items;
1945     STRLEN fromlen;
1946     register I32 len = 0;
1947     SV *fromstr;
1948     /*SUPPRESS 442*/
1949     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1950     static char *space10 = "          ";
1951     bool found;
1952
1953     /* These must not be in registers: */
1954     char achar;
1955     I16 ai16;
1956     U16 au16;
1957     I32 ai32;
1958     U32 au32;
1959 #ifdef HAS_QUAD
1960     Quad_t aquad;
1961     Uquad_t auquad;
1962 #endif
1963 #if SHORTSIZE != SIZE16
1964     short ashort;
1965     unsigned short aushort;
1966 #endif
1967     int aint;
1968     unsigned int auint;
1969 #if LONGSIZE != SIZE32
1970     long along;
1971     unsigned long aulong;
1972 #endif
1973     char *aptr;
1974     float afloat;
1975     double adouble;
1976 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1977     long double aldouble;
1978 #endif
1979     IV aiv;
1980     UV auv;
1981     NV anv;
1982
1983     int strrelbeg = SvCUR(cat);
1984     tempsym_t lookahead;
1985
1986     items = endlist - beglist;
1987     found = next_symbol( symptr );
1988
1989 #ifndef PACKED_IS_OCTETS
1990     if (symptr->level == 0 && found && symptr->code == 'U' ){
1991         SvUTF8_on(cat);
1992     }
1993 #endif
1994
1995     while (found) {
1996         SV *lengthcode = Nullsv;
1997 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1998
1999         I32 datumtype = symptr->code;
2000         howlen_t howlen;
2001
2002         switch( howlen = symptr->howlen ){
2003         case e_no_len:
2004         case e_number:
2005             len = symptr->length;
2006             break;
2007         case e_star:
2008             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
2009             break;
2010         }
2011
2012         /* Look ahead for next symbol. Do we have code/code? */
2013         lookahead = *symptr;
2014         found = next_symbol(&lookahead);
2015         if ( symptr->flags & FLAG_SLASH ) {
2016             if (found){
2017                 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2018                      e_star != lookahead.howlen )
2019                     Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2020                 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
2021                                                    ? *beglist : &PL_sv_no)
2022                                            + (lookahead.code == 'Z' ? 1 : 0)));
2023             } else {
2024                 Perl_croak(aTHX_ "Code missing after '/' in pack");
2025             }
2026         }
2027
2028         switch(TYPE_NO_ENDIANNESS(datumtype)) {
2029         default:
2030             Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
2031         case '%':
2032             Perl_croak(aTHX_ "'%%' may not be used in pack");
2033         case '@':
2034             len += strrelbeg - SvCUR(cat);
2035             if (len > 0)
2036                 goto grow;
2037             len = -len;
2038             if (len > 0)
2039                 goto shrink;
2040             break;
2041         case '(':
2042         {
2043             tempsym_t savsym = *symptr;
2044             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2045             symptr->flags |= group_modifiers;
2046             symptr->patend = savsym.grpend;
2047             symptr->level++;
2048             while (len--) {
2049                 symptr->patptr = savsym.grpbeg;
2050                 beglist = pack_rec(cat, symptr, beglist, endlist );
2051                 if (savsym.howlen == e_star && beglist == endlist)
2052                     break;              /* No way to continue */
2053             }
2054             symptr->flags &= ~group_modifiers;
2055             lookahead.flags = symptr->flags;
2056             *symptr = savsym;
2057             break;
2058         }
2059         case 'X' | TYPE_IS_SHRIEKING:
2060             if (!len)                   /* Avoid division by 0 */
2061                 len = 1;
2062             len = (SvCUR(cat)) % len;
2063             /* FALL THROUGH */
2064         case 'X':
2065           shrink:
2066             if ((I32)SvCUR(cat) < len)
2067                 Perl_croak(aTHX_ "'X' outside of string in pack");
2068             SvCUR(cat) -= len;
2069             *SvEND(cat) = '\0';
2070             break;
2071         case 'x' | TYPE_IS_SHRIEKING:
2072             if (!len)                   /* Avoid division by 0 */
2073                 len = 1;
2074             aint = (SvCUR(cat)) % len;
2075             if (aint)                   /* Other portable ways? */
2076                 len = len - aint;
2077             else
2078                 len = 0;
2079             /* FALL THROUGH */
2080
2081         case 'x':
2082           grow:
2083             while (len >= 10) {
2084                 sv_catpvn(cat, null10, 10);
2085                 len -= 10;
2086             }
2087             sv_catpvn(cat, null10, len);
2088             break;
2089         case 'A':
2090         case 'Z':
2091         case 'a':
2092             fromstr = NEXTFROM;
2093             aptr = SvPV(fromstr, fromlen);
2094             if (howlen == e_star) {
2095                 len = fromlen;
2096                 if (datumtype == 'Z')
2097                     ++len;
2098             }
2099             if ((I32)fromlen >= len) {
2100                 sv_catpvn(cat, aptr, len);
2101                 if (datumtype == 'Z')
2102                     *(SvEND(cat)-1) = '\0';
2103             }
2104             else {
2105                 sv_catpvn(cat, aptr, fromlen);
2106                 len -= fromlen;
2107                 if (datumtype == 'A') {
2108                     while (len >= 10) {
2109                         sv_catpvn(cat, space10, 10);
2110                         len -= 10;
2111                     }
2112                     sv_catpvn(cat, space10, len);
2113                 }
2114                 else {
2115                     while (len >= 10) {
2116                         sv_catpvn(cat, null10, 10);
2117                         len -= 10;
2118                     }
2119                     sv_catpvn(cat, null10, len);
2120                 }
2121             }
2122             break;
2123         case 'B':
2124         case 'b':
2125             {
2126                 register char *str;
2127                 I32 saveitems;
2128
2129                 fromstr = NEXTFROM;
2130                 saveitems = items;
2131                 str = SvPV(fromstr, fromlen);
2132                 if (howlen == e_star)
2133                     len = fromlen;
2134                 aint = SvCUR(cat);
2135                 SvCUR(cat) += (len+7)/8;
2136                 SvGROW(cat, SvCUR(cat) + 1);
2137                 aptr = SvPVX(cat) + aint;
2138                 if (len > (I32)fromlen)
2139                     len = fromlen;
2140                 aint = len;
2141                 items = 0;
2142                 if (datumtype == 'B') {
2143                     for (len = 0; len++ < aint;) {
2144                         items |= *str++ & 1;
2145                         if (len & 7)
2146                             items <<= 1;
2147                         else {
2148                             *aptr++ = items & 0xff;
2149                             items = 0;
2150                         }
2151                     }
2152                 }
2153                 else {
2154                     for (len = 0; len++ < aint;) {
2155                         if (*str++ & 1)
2156                             items |= 128;
2157                         if (len & 7)
2158                             items >>= 1;
2159                         else {
2160                             *aptr++ = items & 0xff;
2161                             items = 0;
2162                         }
2163                     }
2164                 }
2165                 if (aint & 7) {
2166                     if (datumtype == 'B')
2167                         items <<= 7 - (aint & 7);
2168                     else
2169                         items >>= 7 - (aint & 7);
2170                     *aptr++ = items & 0xff;
2171                 }
2172                 str = SvPVX(cat) + SvCUR(cat);
2173                 while (aptr <= str)
2174                     *aptr++ = '\0';
2175
2176                 items = saveitems;
2177             }
2178             break;
2179         case 'H':
2180         case 'h':
2181             {
2182                 register char *str;
2183                 I32 saveitems;
2184
2185                 fromstr = NEXTFROM;
2186                 saveitems = items;
2187                 str = SvPV(fromstr, fromlen);
2188                 if (howlen == e_star)
2189                     len = fromlen;
2190                 aint = SvCUR(cat);
2191                 SvCUR(cat) += (len+1)/2;
2192                 SvGROW(cat, SvCUR(cat) + 1);
2193                 aptr = SvPVX(cat) + aint;
2194                 if (len > (I32)fromlen)
2195                     len = fromlen;
2196                 aint = len;
2197                 items = 0;
2198                 if (datumtype == 'H') {
2199                     for (len = 0; len++ < aint;) {
2200                         if (isALPHA(*str))
2201                             items |= ((*str++ & 15) + 9) & 15;
2202                         else
2203                             items |= *str++ & 15;
2204                         if (len & 1)
2205                             items <<= 4;
2206                         else {
2207                             *aptr++ = items & 0xff;
2208                             items = 0;
2209                         }
2210                     }
2211                 }
2212                 else {
2213                     for (len = 0; len++ < aint;) {
2214                         if (isALPHA(*str))
2215                             items |= (((*str++ & 15) + 9) & 15) << 4;
2216                         else
2217                             items |= (*str++ & 15) << 4;
2218                         if (len & 1)
2219                             items >>= 4;
2220                         else {
2221                             *aptr++ = items & 0xff;
2222                             items = 0;
2223                         }
2224                     }
2225                 }
2226                 if (aint & 1)
2227                     *aptr++ = items & 0xff;
2228                 str = SvPVX(cat) + SvCUR(cat);
2229                 while (aptr <= str)
2230                     *aptr++ = '\0';
2231
2232                 items = saveitems;
2233             }
2234             break;
2235         case 'C':
2236         case 'c':
2237             while (len-- > 0) {
2238                 fromstr = NEXTFROM;
2239                 switch (TYPE_NO_MODIFIERS(datumtype)) {
2240                 case 'C':
2241                     aint = SvIV(fromstr);
2242                     if ((aint < 0 || aint > 255) &&
2243                         ckWARN(WARN_PACK))
2244                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2245                                     "Character in 'C' format wrapped in pack");
2246                     achar = aint & 255;
2247                     sv_catpvn(cat, &achar, sizeof(char));
2248                     break;
2249                 case 'c':
2250                     aint = SvIV(fromstr);
2251                     if ((aint < -128 || aint > 127) &&
2252                         ckWARN(WARN_PACK))
2253                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2254                                     "Character in 'c' format wrapped in pack" );
2255                     achar = aint & 255;
2256                     sv_catpvn(cat, &achar, sizeof(char));
2257                     break;
2258                 }
2259             }
2260             break;
2261         case 'U':
2262             while (len-- > 0) {
2263                 fromstr = NEXTFROM;
2264                 auint = UNI_TO_NATIVE(SvUV(fromstr));
2265                 SvGROW(cat, SvCUR(cat) + UTF8_MAXBYTES + 1);
2266                 SvCUR_set(cat,
2267                           (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2268                                                      auint,
2269                                                      ckWARN(WARN_UTF8) ?
2270                                                      0 : UNICODE_ALLOW_ANY)
2271                           - SvPVX(cat));
2272             }
2273             *SvEND(cat) = '\0';
2274             break;
2275         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2276         case 'f':
2277             while (len-- > 0) {
2278                 fromstr = NEXTFROM;
2279 #ifdef __VOS__
2280 /* VOS does not automatically map a floating-point overflow
2281    during conversion from double to float into infinity, so we
2282    do it by hand.  This code should either be generalized for
2283    any OS that needs it, or removed if and when VOS implements
2284    posix-976 (suggestion to support mapping to infinity).
2285    Paul.Green@stratus.com 02-04-02.  */
2286                 if (SvNV(fromstr) > FLT_MAX)
2287                      afloat = _float_constants[0];   /* single prec. inf. */
2288                 else if (SvNV(fromstr) < -FLT_MAX)
2289                      afloat = _float_constants[0];   /* single prec. inf. */
2290                 else afloat = (float)SvNV(fromstr);
2291 #else
2292 # if defined(VMS) && !defined(__IEEE_FP)
2293 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2294  * on Alpha; fake it if we don't have them.
2295  */
2296                 if (SvNV(fromstr) > FLT_MAX)
2297                      afloat = FLT_MAX;
2298                 else if (SvNV(fromstr) < -FLT_MAX)
2299                      afloat = -FLT_MAX;
2300                 else afloat = (float)SvNV(fromstr);
2301 # else
2302                 afloat = (float)SvNV(fromstr);
2303 # endif
2304 #endif
2305                 DO_BO_PACK_N(afloat, float);
2306                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2307             }
2308             break;
2309         case 'd':
2310             while (len-- > 0) {
2311                 fromstr = NEXTFROM;
2312 #ifdef __VOS__
2313 /* VOS does not automatically map a floating-point overflow
2314    during conversion from long double to double into infinity,
2315    so we do it by hand.  This code should either be generalized
2316    for any OS that needs it, or removed if and when VOS
2317    implements posix-976 (suggestion to support mapping to
2318    infinity).  Paul.Green@stratus.com 02-04-02.  */
2319                 if (SvNV(fromstr) > DBL_MAX)
2320                      adouble = _double_constants[0];   /* double prec. inf. */
2321                 else if (SvNV(fromstr) < -DBL_MAX)
2322                      adouble = _double_constants[0];   /* double prec. inf. */
2323                 else adouble = (double)SvNV(fromstr);
2324 #else
2325 # if defined(VMS) && !defined(__IEEE_FP)
2326 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2327  * on Alpha; fake it if we don't have them.
2328  */
2329                 if (SvNV(fromstr) > DBL_MAX)
2330                      adouble = DBL_MAX;
2331                 else if (SvNV(fromstr) < -DBL_MAX)
2332                      adouble = -DBL_MAX;
2333                 else adouble = (double)SvNV(fromstr);
2334 # else
2335                 adouble = (double)SvNV(fromstr);
2336 # endif
2337 #endif
2338                 DO_BO_PACK_N(adouble, double);
2339                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2340             }
2341             break;
2342         case 'F':
2343             Zero(&anv, 1, NV); /* can be long double with unused bits */
2344             while (len-- > 0) {
2345                 fromstr = NEXTFROM;
2346                 anv = SvNV(fromstr);
2347                 DO_BO_PACK_N(anv, NV);
2348                 sv_catpvn(cat, (char *)&anv, NVSIZE);
2349             }
2350             break;
2351 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2352         case 'D':
2353             /* long doubles can have unused bits, which may be nonzero */
2354             Zero(&aldouble, 1, long double);
2355             while (len-- > 0) {
2356                 fromstr = NEXTFROM;
2357                 aldouble = (long double)SvNV(fromstr);
2358                 DO_BO_PACK_N(aldouble, long double);
2359                 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2360             }
2361             break;
2362 #endif
2363 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2364         case 'n' | TYPE_IS_SHRIEKING:
2365 #endif
2366         case 'n':
2367             while (len-- > 0) {
2368                 fromstr = NEXTFROM;
2369                 ai16 = (I16)SvIV(fromstr);
2370 #ifdef HAS_HTONS
2371                 ai16 = PerlSock_htons(ai16);
2372 #endif
2373                 CAT16(cat, &ai16);
2374             }
2375             break;
2376 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2377         case 'v' | TYPE_IS_SHRIEKING:
2378 #endif
2379         case 'v':
2380             while (len-- > 0) {
2381                 fromstr = NEXTFROM;
2382                 ai16 = (I16)SvIV(fromstr);
2383 #ifdef HAS_HTOVS
2384                 ai16 = htovs(ai16);
2385 #endif
2386                 CAT16(cat, &ai16);
2387             }
2388             break;
2389         case 'S' | TYPE_IS_SHRIEKING:
2390 #if SHORTSIZE != SIZE16
2391             {
2392                 while (len-- > 0) {
2393                     fromstr = NEXTFROM;
2394                     aushort = SvUV(fromstr);
2395                     DO_BO_PACK(aushort, s);
2396                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2397                 }
2398             }
2399             break;
2400 #else
2401             /* Fall through! */
2402 #endif
2403         case 'S':
2404             {
2405                 while (len-- > 0) {
2406                     fromstr = NEXTFROM;
2407                     au16 = (U16)SvUV(fromstr);
2408                     DO_BO_PACK(au16, 16);
2409                     CAT16(cat, &au16);
2410                 }
2411
2412             }
2413             break;
2414         case 's' | TYPE_IS_SHRIEKING:
2415 #if SHORTSIZE != SIZE16
2416             {
2417                 while (len-- > 0) {
2418                     fromstr = NEXTFROM;
2419                     ashort = SvIV(fromstr);
2420                     DO_BO_PACK(ashort, s);
2421                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
2422                 }
2423             }
2424             break;
2425 #else
2426             /* Fall through! */
2427 #endif
2428         case 's':
2429             while (len-- > 0) {
2430                 fromstr = NEXTFROM;
2431                 ai16 = (I16)SvIV(fromstr);
2432                 DO_BO_PACK(ai16, 16);
2433                 CAT16(cat, &ai16);
2434             }
2435             break;
2436         case 'I':
2437         case 'I' | TYPE_IS_SHRIEKING:
2438             while (len-- > 0) {
2439                 fromstr = NEXTFROM;
2440                 auint = SvUV(fromstr);
2441                 DO_BO_PACK(auint, i);
2442                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2443             }
2444             break;
2445         case 'j':
2446             while (len-- > 0) {
2447                 fromstr = NEXTFROM;
2448                 aiv = SvIV(fromstr);
2449 #if IVSIZE == INTSIZE
2450                 DO_BO_PACK(aiv, i);
2451 #elif IVSIZE == LONGSIZE
2452                 DO_BO_PACK(aiv, l);
2453 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2454                 DO_BO_PACK(aiv, 64);
2455 #endif
2456                 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2457             }
2458             break;
2459         case 'J':
2460             while (len-- > 0) {
2461                 fromstr = NEXTFROM;
2462                 auv = SvUV(fromstr);
2463 #if UVSIZE == INTSIZE
2464                 DO_BO_PACK(auv, i);
2465 #elif UVSIZE == LONGSIZE
2466                 DO_BO_PACK(auv, l);
2467 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2468                 DO_BO_PACK(auv, 64);
2469 #endif
2470                 sv_catpvn(cat, (char*)&auv, UVSIZE);
2471             }
2472             break;
2473         case 'w':
2474             while (len-- > 0) {
2475                 fromstr = NEXTFROM;
2476                 anv = SvNV(fromstr);
2477
2478                 if (anv < 0)
2479                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2480
2481                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2482                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2483                    any negative IVs will have already been got by the croak()
2484                    above. IOK is untrue for fractions, so we test them
2485                    against UV_MAX_P1.  */
2486                 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2487                 {
2488                     char   buf[(sizeof(UV)*8)/7+1];
2489                     char  *in = buf + sizeof(buf);
2490                     UV     auv = SvUV(fromstr);
2491
2492                     do {
2493                         *--in = (char)((auv & 0x7f) | 0x80);
2494                         auv >>= 7;
2495                     } while (auv);
2496                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2497                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2498                 }
2499                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
2500                     char           *from, *result, *in;
2501                     SV             *norm;
2502                     STRLEN          len;
2503                     bool            done;
2504
2505                     /* Copy string and check for compliance */
2506                     from = SvPV(fromstr, len);
2507                     if ((norm = is_an_int(from, len)) == NULL)
2508                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2509
2510                     New('w', result, len, char);
2511                     in = result + len;
2512                     done = FALSE;
2513                     while (!done)
2514                         *--in = div128(norm, &done) | 0x80;
2515                     result[len - 1] &= 0x7F; /* clear continue bit */
2516                     sv_catpvn(cat, in, (result + len) - in);
2517                     Safefree(result);
2518                     SvREFCNT_dec(norm); /* free norm */
2519                 }
2520                 else if (SvNOKp(fromstr)) {
2521                     /* 10**NV_MAX_10_EXP is the largest power of 10
2522                        so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2523                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2524                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2525                        And with that many bytes only Inf can overflow.
2526                        Some C compilers are strict about integral constant
2527                        expressions so we conservatively divide by a slightly
2528                        smaller integer instead of multiplying by the exact
2529                        floating-point value.
2530                     */
2531 #ifdef NV_MAX_10_EXP
2532 /*                  char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2533                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2534 #else
2535 /*                  char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2536                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2537 #endif
2538                     char  *in = buf + sizeof(buf);
2539
2540                     anv = Perl_floor(anv);
2541                     do {
2542                         NV next = Perl_floor(anv / 128);
2543                         if (in <= buf)  /* this cannot happen ;-) */
2544                             Perl_croak(aTHX_ "Cannot compress integer in pack");
2545                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2546                         anv = next;
2547                     } while (anv > 0);
2548                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2549                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2550                 }
2551                 else {
2552                     char           *from, *result, *in;
2553                     SV             *norm;
2554                     STRLEN          len;
2555                     bool            done;
2556
2557                     /* Copy string and check for compliance */
2558                     from = SvPV(fromstr, len);
2559                     if ((norm = is_an_int(from, len)) == NULL)
2560                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2561
2562                     New('w', result, len, char);
2563                     in = result + len;
2564                     done = FALSE;
2565                     while (!done)
2566                         *--in = div128(norm, &done) | 0x80;
2567                     result[len - 1] &= 0x7F; /* clear continue bit */
2568                     sv_catpvn(cat, in, (result + len) - in);
2569                     Safefree(result);
2570                     SvREFCNT_dec(norm); /* free norm */
2571                }
2572             }
2573             break;
2574         case 'i':
2575         case 'i' | TYPE_IS_SHRIEKING:
2576             while (len-- > 0) {
2577                 fromstr = NEXTFROM;
2578                 aint = SvIV(fromstr);
2579                 DO_BO_PACK(aint, i);
2580                 sv_catpvn(cat, (char*)&aint, sizeof(int));
2581             }
2582             break;
2583 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2584         case 'N' | TYPE_IS_SHRIEKING:
2585 #endif
2586         case 'N':
2587             while (len-- > 0) {
2588                 fromstr = NEXTFROM;
2589                 au32 = SvUV(fromstr);
2590 #ifdef HAS_HTONL
2591                 au32 = PerlSock_htonl(au32);
2592 #endif
2593                 CAT32(cat, &au32);
2594             }
2595             break;
2596 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2597         case 'V' | TYPE_IS_SHRIEKING:
2598 #endif
2599         case 'V':
2600             while (len-- > 0) {
2601                 fromstr = NEXTFROM;
2602                 au32 = SvUV(fromstr);
2603 #ifdef HAS_HTOVL
2604                 au32 = htovl(au32);
2605 #endif
2606                 CAT32(cat, &au32);
2607             }
2608             break;
2609         case 'L' | TYPE_IS_SHRIEKING:
2610 #if LONGSIZE != SIZE32
2611             {
2612                 while (len-- > 0) {
2613                     fromstr = NEXTFROM;
2614                     aulong = SvUV(fromstr);
2615                     DO_BO_PACK(aulong, l);
2616                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2617                 }
2618             }
2619             break;
2620 #else
2621             /* Fall though! */
2622 #endif
2623         case 'L':
2624             {
2625                 while (len-- > 0) {
2626                     fromstr = NEXTFROM;
2627                     au32 = SvUV(fromstr);
2628                     DO_BO_PACK(au32, 32);
2629                     CAT32(cat, &au32);
2630                 }
2631             }
2632             break;
2633         case 'l' | TYPE_IS_SHRIEKING:
2634 #if LONGSIZE != SIZE32
2635             {
2636                 while (len-- > 0) {
2637                     fromstr = NEXTFROM;
2638                     along = SvIV(fromstr);
2639                     DO_BO_PACK(along, l);
2640                     sv_catpvn(cat, (char *)&along, sizeof(long));
2641                 }
2642             }
2643             break;
2644 #else
2645             /* Fall though! */
2646 #endif
2647         case 'l':
2648             while (len-- > 0) {
2649                 fromstr = NEXTFROM;
2650                 ai32 = SvIV(fromstr);
2651                 DO_BO_PACK(ai32, 32);
2652                 CAT32(cat, &ai32);
2653             }
2654             break;
2655 #ifdef HAS_QUAD
2656         case 'Q':
2657             while (len-- > 0) {
2658                 fromstr = NEXTFROM;
2659                 auquad = (Uquad_t)SvUV(fromstr);
2660                 DO_BO_PACK(auquad, 64);
2661                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2662             }
2663             break;
2664         case 'q':
2665             while (len-- > 0) {
2666                 fromstr = NEXTFROM;
2667                 aquad = (Quad_t)SvIV(fromstr);
2668                 DO_BO_PACK(aquad, 64);
2669                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2670             }
2671             break;
2672 #endif
2673         case 'P':
2674             len = 1;            /* assume SV is correct length */
2675             /* Fall through! */
2676         case 'p':
2677             while (len-- > 0) {
2678                 fromstr = NEXTFROM;
2679                 if (fromstr == &PL_sv_undef)
2680                     aptr = NULL;
2681                 else {
2682                     STRLEN n_a;
2683                     /* XXX better yet, could spirit away the string to
2684                      * a safe spot and hang on to it until the result
2685                      * of pack() (and all copies of the result) are
2686                      * gone.
2687                      */
2688                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2689                                                 || (SvPADTMP(fromstr)
2690                                                     && !SvREADONLY(fromstr))))
2691                     {
2692                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2693                                 "Attempt to pack pointer to temporary value");
2694                     }
2695                     if (SvPOK(fromstr) || SvNIOK(fromstr))
2696                         aptr = SvPV(fromstr,n_a);
2697                     else
2698                         aptr = SvPV_force(fromstr,n_a);
2699                 }
2700                 DO_BO_PACK_P(aptr);
2701                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2702             }
2703             break;
2704         case 'u':
2705             fromstr = NEXTFROM;
2706             aptr = SvPV(fromstr, fromlen);
2707             SvGROW(cat, fromlen * 4 / 3);
2708             if (len <= 2)
2709                 len = 45;
2710             else
2711                 len = len / 3 * 3;
2712             while (fromlen > 0) {
2713                 I32 todo;
2714
2715                 if ((I32)fromlen > len)
2716                     todo = len;
2717                 else
2718                     todo = fromlen;
2719                 doencodes(cat, aptr, todo);
2720                 fromlen -= todo;
2721                 aptr += todo;
2722             }
2723             break;
2724         }
2725         *symptr = lookahead;
2726     }
2727     return beglist;
2728 }
2729 #undef NEXTFROM
2730
2731
2732 PP(pp_pack)
2733 {
2734     dSP; dMARK; dORIGMARK; dTARGET;
2735     register SV *cat = TARG;
2736     STRLEN fromlen;
2737     register char *pat = SvPVx(*++MARK, fromlen);
2738     register char *patend = pat + fromlen;
2739
2740     MARK++;
2741     sv_setpvn(cat, "", 0);
2742
2743     packlist(cat, pat, patend, MARK, SP + 1);
2744
2745     SvSETMAGIC(cat);
2746     SP = ORIGMARK;
2747     PUSHs(cat);
2748     RETURN;
2749 }
2750
2751 /*
2752  * Local variables:
2753  * c-indentation-style: bsd
2754  * c-basic-offset: 4
2755  * indent-tabs-mode: t
2756  * End:
2757  *
2758  * vim: shiftwidth=4:
2759 */