pp_pack.c

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