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