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