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