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