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