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