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