pp_pack.c

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