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_ packWARN(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_ packWARN(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, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
 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, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
 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    /* possible checksum byte */
1529                     if (s + 1 < strend && s[1] == '\n')
1530                         s += 2;
1531             }
1532             XPUSHs(sv_2mortal(sv));
1533             break;
1534         }
1535         if (checksum) {
1536             sv = NEWSV(42, 0);
1537             if (strchr("fFdD", datumtype) ||
1538               (checksum > bits_in_uv &&
1539                strchr("csSiIlLnNUvVqQjJ", datumtype)) ) {
1540                 NV trouble;
1541
1542                 adouble = (NV) (1 << (checksum & 15));
1543                 while (checksum >= 16) {
1544                     checksum -= 16;
1545                     adouble *= 65536.0;
1546                 }
1547                 while (cdouble < 0.0)
1548                     cdouble += adouble;
1549                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1550                 sv_setnv(sv, cdouble);
1551             }
1552             else {
1553                 if (checksum < bits_in_uv) {
1554                     UV mask = ((UV)1 << checksum) - 1;
1555
1556                     cuv &= mask;
1557                 }
1558                 sv_setuv(sv, cuv);
1559             }
1560             XPUSHs(sv_2mortal(sv));
1561             checksum = 0;
1562         }
1563     }
1564     if (new_s)
1565         *new_s = s;
1566     PUTBACK;
1567     return SP - PL_stack_base - start_sp_offset;
1568 }
1569
1570 PP(pp_unpack)
1571 {
1572     dSP;
1573     dPOPPOPssrl;
1574     I32 gimme = GIMME_V;
1575     STRLEN llen;
1576     STRLEN rlen;
1577     register char *pat = SvPV(left, llen);
1578 #ifdef PACKED_IS_OCTETS
1579     /* Packed side is assumed to be octets - so force downgrade if it
1580        has been UTF-8 encoded by accident
1581      */
1582     register char *s = SvPVbyte(right, rlen);
1583 #else
1584     register char *s = SvPV(right, rlen);
1585 #endif
1586     char *strend = s + rlen;
1587     register char *patend = pat + llen;
1588     register I32 cnt;
1589
1590     PUTBACK;
1591     cnt = unpack_str(pat, patend, s, s, strend, NULL, 0,
1592                      ((gimme == G_SCALAR) ? UNPACK_ONLY_ONE : 0)
1593                      | (DO_UTF8(right) ? UNPACK_DO_UTF8 : 0));
1594     SPAGAIN;
1595     if ( !cnt && gimme == G_SCALAR )
1596        PUSHs(&PL_sv_undef);
1597     RETURN;
1598 }
1599
1600 STATIC void
1601 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1602 {
1603     char hunk[5];
1604
1605     *hunk = PL_uuemap[len];
1606     sv_catpvn(sv, hunk, 1);
1607     hunk[4] = '\0';
1608     while (len > 2) {
1609         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1610         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1611         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1612         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1613         sv_catpvn(sv, hunk, 4);
1614         s += 3;
1615         len -= 3;
1616     }
1617     if (len > 0) {
1618         char r = (len > 1 ? s[1] : '\0');
1619         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1620         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1621         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1622         hunk[3] = PL_uuemap[0];
1623         sv_catpvn(sv, hunk, 4);
1624     }
1625     sv_catpvn(sv, "\n", 1);
1626 }
1627
1628 STATIC SV *
1629 S_is_an_int(pTHX_ char *s, STRLEN l)
1630 {
1631   STRLEN         n_a;
1632   SV             *result = newSVpvn(s, l);
1633   char           *result_c = SvPV(result, n_a); /* convenience */
1634   char           *out = result_c;
1635   bool            skip = 1;
1636   bool            ignore = 0;
1637
1638   while (*s) {
1639     switch (*s) {
1640     case ' ':
1641       break;
1642     case '+':
1643       if (!skip) {
1644         SvREFCNT_dec(result);
1645         return (NULL);
1646       }
1647       break;
1648     case '0':
1649     case '1':
1650     case '2':
1651     case '3':
1652     case '4':
1653     case '5':
1654     case '6':
1655     case '7':
1656     case '8':
1657     case '9':
1658       skip = 0;
1659       if (!ignore) {
1660         *(out++) = *s;
1661       }
1662       break;
1663     case '.':
1664       ignore = 1;
1665       break;
1666     default:
1667       SvREFCNT_dec(result);
1668       return (NULL);
1669     }
1670     s++;
1671   }
1672   *(out++) = '\0';
1673   SvCUR_set(result, out - result_c);
1674   return (result);
1675 }
1676
1677 /* pnum must be '\0' terminated */
1678 STATIC int
1679 S_div128(pTHX_ SV *pnum, bool *done)
1680 {
1681   STRLEN          len;
1682   char           *s = SvPV(pnum, len);
1683   int             m = 0;
1684   int             r = 0;
1685   char           *t = s;
1686
1687   *done = 1;
1688   while (*t) {
1689     int             i;
1690
1691     i = m * 10 + (*t - '0');
1692     m = i & 0x7F;
1693     r = (i >> 7);               /* r < 10 */
1694     if (r) {
1695       *done = 0;
1696     }
1697     *(t++) = '0' + r;
1698   }
1699   *(t++) = '\0';
1700   SvCUR_set(pnum, (STRLEN) (t - s));
1701   return (m);
1702 }
1703
1704 #define PACK_CHILD      0x1
1705
1706 /*
1707 =for apidoc pack_cat
1708
1709 The engine implementing pack() Perl function.
1710
1711 =cut */
1712
1713 void
1714 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1715 {
1716     register I32 items;
1717     STRLEN fromlen;
1718     register I32 len;
1719     I32 datumtype;
1720     SV *fromstr;
1721     /*SUPPRESS 442*/
1722     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1723     static char *space10 = "          ";
1724     int star;
1725
1726     /* These must not be in registers: */
1727     char achar;
1728     I16 ashort;
1729     int aint;
1730     unsigned int auint;
1731     I32 along;
1732     U32 aulong;
1733     IV aiv;
1734     UV auv;
1735     NV anv;
1736 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1737     long double aldouble;
1738 #endif
1739 #ifdef HAS_QUAD
1740     Quad_t aquad;
1741     Uquad_t auquad;
1742 #endif
1743     char *aptr;
1744     float afloat;
1745     double adouble;
1746     int commas = 0;
1747 #ifdef PERL_NATINT_PACK
1748     int natint;         /* native integer */
1749 #endif
1750
1751     items = endlist - beglist;
1752 #ifndef PACKED_IS_OCTETS
1753     pat = next_symbol(pat, patend);
1754     if (pat < patend && *pat == 'U' && !flags)
1755         SvUTF8_on(cat);
1756 #endif
1757     while ((pat = next_symbol(pat, patend)) < patend) {
1758         SV *lengthcode = Nullsv;
1759 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1760         datumtype = *pat++ & 0xFF;
1761 #ifdef PERL_NATINT_PACK
1762         natint = 0;
1763 #endif
1764         if (*pat == '!') {
1765             static const char natstr[] = "sSiIlLxX";
1766
1767             if (strchr(natstr, datumtype)) {
1768                 if (datumtype == 'x' || datumtype == 'X') {
1769                     datumtype |= TYPE_IS_SHRIEKING;
1770                 } else {                /* XXXX Should be redone similarly! */
1771 #ifdef PERL_NATINT_PACK
1772                     natint = 1;
1773 #endif
1774                 }
1775                 pat++;
1776             }
1777             else
1778                 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
1779         }
1780         len = find_count(&pat, patend, &star);
1781         if (star > 0)                   /* Count is '*' */
1782             len = strchr("@Xxu", datumtype) ? 0 : items;
1783         else if (star < 0)              /* Default len */
1784             len = 1;
1785         if (*pat == '/') {              /* doing lookahead how... */
1786             ++pat;
1787             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
1788                 Perl_croak(aTHX_ "/ must be followed by a*, A* or Z*");
1789             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1790                                                    ? *beglist : &PL_sv_no)
1791                                             + (*pat == 'Z' ? 1 : 0)));
1792         }
1793         switch(datumtype) {
1794         default:
1795             Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
1796         case ',': /* grandfather in commas but with a warning */
1797             if (commas++ == 0 && ckWARN(WARN_PACK))
1798                 Perl_warner(aTHX_ packWARN(WARN_PACK),
1799                             "Invalid type in pack: '%c'", (int)datumtype);
1800             break;
1801         case '%':
1802             Perl_croak(aTHX_ "%% may only be used in unpack");
1803         case '@':
1804             len -= SvCUR(cat);
1805             if (len > 0)
1806                 goto grow;
1807             len = -len;
1808             if (len > 0)
1809                 goto shrink;
1810             break;
1811         case '(':
1812         {
1813             char *beg = pat;
1814             SV **savebeglist = beglist; /* beglist de-register-ed */
1815
1816             if (star >= 0)
1817                 Perl_croak(aTHX_ "()-group starts with a count");
1818             aptr = group_end(beg, patend, ')');
1819             pat = aptr + 1;
1820             if (star != -2) {
1821                 len = find_count(&pat, patend, &star);
1822                 if (star < 0)           /* No count */
1823                     len = 1;
1824                 else if (star > 0)      /* Star */
1825                     len = items;        /* long enough? */
1826             }
1827             while (len--) {
1828                 pack_cat(cat, beg, aptr, savebeglist, endlist,
1829                          &savebeglist, PACK_CHILD);
1830                 if (star > 0 && savebeglist == endlist)
1831                     break;              /* No way to continue */
1832             }
1833             beglist = savebeglist;
1834             break;
1835         }
1836         case 'X' | TYPE_IS_SHRIEKING:
1837             if (!len)                   /* Avoid division by 0 */
1838                 len = 1;
1839             len = (SvCUR(cat)) % len;
1840             /* FALL THROUGH */
1841         case 'X':
1842           shrink:
1843             if (SvCUR(cat) < len)
1844                 Perl_croak(aTHX_ "X outside of string");
1845             SvCUR(cat) -= len;
1846             *SvEND(cat) = '\0';
1847             break;
1848         case 'x' | TYPE_IS_SHRIEKING:
1849             if (!len)                   /* Avoid division by 0 */
1850                 len = 1;
1851             aint = (SvCUR(cat)) % len;
1852             if (aint)                   /* Other portable ways? */
1853                 len = len - aint;
1854             else
1855                 len = 0;
1856             /* FALL THROUGH */
1857         case 'x':
1858           grow:
1859             while (len >= 10) {
1860                 sv_catpvn(cat, null10, 10);
1861                 len -= 10;
1862             }
1863             sv_catpvn(cat, null10, len);
1864             break;
1865         case 'A':
1866         case 'Z':
1867         case 'a':
1868             fromstr = NEXTFROM;
1869             aptr = SvPV(fromstr, fromlen);
1870             if (star > 0) { /* -2 after '/' */
1871                 len = fromlen;
1872                 if (datumtype == 'Z')
1873                     ++len;
1874             }
1875             if (fromlen >= len) {
1876                 sv_catpvn(cat, aptr, len);
1877                 if (datumtype == 'Z')
1878                     *(SvEND(cat)-1) = '\0';
1879             }
1880             else {
1881                 sv_catpvn(cat, aptr, fromlen);
1882                 len -= fromlen;
1883                 if (datumtype == 'A') {
1884                     while (len >= 10) {
1885                         sv_catpvn(cat, space10, 10);
1886                         len -= 10;
1887                     }
1888                     sv_catpvn(cat, space10, len);
1889                 }
1890                 else {
1891                     while (len >= 10) {
1892                         sv_catpvn(cat, null10, 10);
1893                         len -= 10;
1894                     }
1895                     sv_catpvn(cat, null10, len);
1896                 }
1897             }
1898             break;
1899         case 'B':
1900         case 'b':
1901             {
1902                 register char *str;
1903                 I32 saveitems;
1904
1905                 fromstr = NEXTFROM;
1906                 saveitems = items;
1907                 str = SvPV(fromstr, fromlen);
1908                 if (star > 0)
1909                     len = fromlen;
1910                 aint = SvCUR(cat);
1911                 SvCUR(cat) += (len+7)/8;
1912                 SvGROW(cat, SvCUR(cat) + 1);
1913                 aptr = SvPVX(cat) + aint;
1914                 if (len > fromlen)
1915                     len = fromlen;
1916                 aint = len;
1917                 items = 0;
1918                 if (datumtype == 'B') {
1919                     for (len = 0; len++ < aint;) {
1920                         items |= *str++ & 1;
1921                         if (len & 7)
1922                             items <<= 1;
1923                         else {
1924                             *aptr++ = items & 0xff;
1925                             items = 0;
1926                         }
1927                     }
1928                 }
1929                 else {
1930                     for (len = 0; len++ < aint;) {
1931                         if (*str++ & 1)
1932                             items |= 128;
1933                         if (len & 7)
1934                             items >>= 1;
1935                         else {
1936                             *aptr++ = items & 0xff;
1937                             items = 0;
1938                         }
1939                     }
1940                 }
1941                 if (aint & 7) {
1942                     if (datumtype == 'B')
1943                         items <<= 7 - (aint & 7);
1944                     else
1945                         items >>= 7 - (aint & 7);
1946                     *aptr++ = items & 0xff;
1947                 }
1948                 str = SvPVX(cat) + SvCUR(cat);
1949                 while (aptr <= str)
1950                     *aptr++ = '\0';
1951
1952                 items = saveitems;
1953             }
1954             break;
1955         case 'H':
1956         case 'h':
1957             {
1958                 register char *str;
1959                 I32 saveitems;
1960
1961                 fromstr = NEXTFROM;
1962                 saveitems = items;
1963                 str = SvPV(fromstr, fromlen);
1964                 if (star > 0)
1965                     len = fromlen;
1966                 aint = SvCUR(cat);
1967                 SvCUR(cat) += (len+1)/2;
1968                 SvGROW(cat, SvCUR(cat) + 1);
1969                 aptr = SvPVX(cat) + aint;
1970                 if (len > fromlen)
1971                     len = fromlen;
1972                 aint = len;
1973                 items = 0;
1974                 if (datumtype == 'H') {
1975                     for (len = 0; len++ < aint;) {
1976                         if (isALPHA(*str))
1977                             items |= ((*str++ & 15) + 9) & 15;
1978                         else
1979                             items |= *str++ & 15;
1980                         if (len & 1)
1981                             items <<= 4;
1982                         else {
1983                             *aptr++ = items & 0xff;
1984                             items = 0;
1985                         }
1986                     }
1987                 }
1988                 else {
1989                     for (len = 0; len++ < aint;) {
1990                         if (isALPHA(*str))
1991                             items |= (((*str++ & 15) + 9) & 15) << 4;
1992                         else
1993                             items |= (*str++ & 15) << 4;
1994                         if (len & 1)
1995                             items >>= 4;
1996                         else {
1997                             *aptr++ = items & 0xff;
1998                             items = 0;
1999                         }
2000                     }
2001                 }
2002                 if (aint & 1)
2003                     *aptr++ = items & 0xff;
2004                 str = SvPVX(cat) + SvCUR(cat);
2005                 while (aptr <= str)
2006                     *aptr++ = '\0';
2007
2008                 items = saveitems;
2009             }
2010             break;
2011         case 'C':
2012         case 'c':
2013             while (len-- > 0) {
2014                 fromstr = NEXTFROM;
2015                 switch (datumtype) {
2016                 case 'C':
2017                     aint = SvIV(fromstr);
2018                     if ((aint < 0 || aint > 255) &&
2019                         ckWARN(WARN_PACK))
2020                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2021                                     "Character in \"C\" format wrapped");
2022                     achar = aint & 255;
2023                     sv_catpvn(cat, &achar, sizeof(char));
2024                     break;
2025                 case 'c':
2026                     aint = SvIV(fromstr);
2027                     if ((aint < -128 || aint > 127) &&
2028                         ckWARN(WARN_PACK))
2029                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2030                                     "Character in \"c\" format wrapped");
2031                     achar = aint & 255;
2032                     sv_catpvn(cat, &achar, sizeof(char));
2033                     break;
2034                 }
2035             }
2036             break;
2037         case 'U':
2038             while (len-- > 0) {
2039                 fromstr = NEXTFROM;
2040                 auint = UNI_TO_NATIVE(SvUV(fromstr));
2041                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2042                 SvCUR_set(cat,
2043                           (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2044                                                      auint,
2045                                                      ckWARN(WARN_UTF8) ?
2046                                                      0 : UNICODE_ALLOW_ANY)
2047                           - SvPVX(cat));
2048             }
2049             *SvEND(cat) = '\0';
2050             break;
2051         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2052         case 'f':
2053             while (len-- > 0) {
2054                 fromstr = NEXTFROM;
2055 #ifdef __VOS__
2056 /* VOS does not automatically map a floating-point overflow
2057    during conversion from double to float into infinity, so we
2058    do it by hand.  This code should either be generalized for
2059    any OS that needs it, or removed if and when VOS implements
2060    posix-976 (suggestion to support mapping to infinity).
2061    Paul.Green@stratus.com 02-04-02.  */
2062                 if (SvNV(fromstr) > FLT_MAX)
2063                      afloat = _float_constants[0];   /* single prec. inf. */
2064                 else if (SvNV(fromstr) < -FLT_MAX)
2065                      afloat = _float_constants[0];   /* single prec. inf. */
2066                 else afloat = (float)SvNV(fromstr);
2067 #else
2068                 afloat = (float)SvNV(fromstr);
2069 #endif
2070                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2071             }
2072             break;
2073         case 'd':
2074             while (len-- > 0) {
2075                 fromstr = NEXTFROM;
2076 #ifdef __VOS__
2077 /* VOS does not automatically map a floating-point overflow
2078    during conversion from long double to double into infinity,
2079    so we do it by hand.  This code should either be generalized
2080    for any OS that needs it, or removed if and when VOS
2081    implements posix-976 (suggestion to support mapping to
2082    infinity).  Paul.Green@stratus.com 02-04-02.  */
2083                 if (SvNV(fromstr) > DBL_MAX)
2084                      adouble = _double_constants[0];   /* double prec. inf. */
2085                 else if (SvNV(fromstr) < -DBL_MAX)
2086                      adouble = _double_constants[0];   /* double prec. inf. */
2087                 else adouble = (double)SvNV(fromstr);
2088 #else
2089                 adouble = (double)SvNV(fromstr);
2090 #endif
2091                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2092             }
2093             break;
2094         case 'F':
2095             while (len-- > 0) {
2096                 fromstr = NEXTFROM;
2097                 anv = SvNV(fromstr);
2098                 sv_catpvn(cat, (char *)&anv, NVSIZE);
2099             }
2100             break;
2101 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2102         case 'D':
2103             while (len-- > 0) {
2104                 fromstr = NEXTFROM;
2105                 aldouble = (long double)SvNV(fromstr);
2106                 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2107             }
2108             break;
2109 #endif
2110         case 'n':
2111             while (len-- > 0) {
2112                 fromstr = NEXTFROM;
2113                 ashort = (I16)SvIV(fromstr);
2114 #ifdef HAS_HTONS
2115                 ashort = PerlSock_htons(ashort);
2116 #endif
2117                 CAT16(cat, &ashort);
2118             }
2119             break;
2120         case 'v':
2121             while (len-- > 0) {
2122                 fromstr = NEXTFROM;
2123                 ashort = (I16)SvIV(fromstr);
2124 #ifdef HAS_HTOVS
2125                 ashort = htovs(ashort);
2126 #endif
2127                 CAT16(cat, &ashort);
2128             }
2129             break;
2130         case 'S':
2131 #if SHORTSIZE != SIZE16
2132             if (natint) {
2133                 unsigned short aushort;
2134
2135                 while (len-- > 0) {
2136                     fromstr = NEXTFROM;
2137                     aushort = SvUV(fromstr);
2138                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2139                 }
2140             }
2141             else
2142 #endif
2143             {
2144                 U16 aushort;
2145
2146                 while (len-- > 0) {
2147                     fromstr = NEXTFROM;
2148                     aushort = (U16)SvUV(fromstr);
2149                     CAT16(cat, &aushort);
2150                 }
2151
2152             }
2153             break;
2154         case 's':
2155 #if SHORTSIZE != SIZE16
2156             if (natint) {
2157                 short ashort;
2158
2159                 while (len-- > 0) {
2160                     fromstr = NEXTFROM;
2161                     ashort = SvIV(fromstr);
2162                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
2163                 }
2164             }
2165             else
2166 #endif
2167             {
2168                 while (len-- > 0) {
2169                     fromstr = NEXTFROM;
2170                     ashort = (I16)SvIV(fromstr);
2171                     CAT16(cat, &ashort);
2172                 }
2173             }
2174             break;
2175         case 'I':
2176             while (len-- > 0) {
2177                 fromstr = NEXTFROM;
2178                 auint = SvUV(fromstr);
2179                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2180             }
2181             break;
2182         case 'j':
2183             while (len-- > 0) {
2184                 fromstr = NEXTFROM;
2185                 aiv = SvIV(fromstr);
2186                 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2187             }
2188             break;
2189         case 'J':
2190             while (len-- > 0) {
2191                 fromstr = NEXTFROM;
2192                 auv = SvUV(fromstr);
2193                 sv_catpvn(cat, (char*)&auv, UVSIZE);
2194             }
2195             break;
2196         case 'w':
2197             while (len-- > 0) {
2198                 fromstr = NEXTFROM;
2199                 adouble = SvNV(fromstr);
2200
2201                 if (adouble < 0)
2202                     Perl_croak(aTHX_ "Cannot compress negative numbers");
2203
2204                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2205                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2206                    any negative IVs will have already been got by the croak()
2207                    above. IOK is untrue for fractions, so we test them
2208                    against UV_MAX_P1.  */
2209                 if (SvIOK(fromstr) || adouble < UV_MAX_P1)
2210                 {
2211                     char   buf[(sizeof(UV)*8)/7+1];
2212                     char  *in = buf + sizeof(buf);
2213                     UV     auv = SvUV(fromstr);
2214
2215                     do {
2216                         *--in = (auv & 0x7f) | 0x80;
2217                         auv >>= 7;
2218                     } while (auv);
2219                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2220                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2221                 }
2222                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
2223                     char           *from, *result, *in;
2224                     SV             *norm;
2225                     STRLEN          len;
2226                     bool            done;
2227
2228                     /* Copy string and check for compliance */
2229                     from = SvPV(fromstr, len);
2230                     if ((norm = is_an_int(from, len)) == NULL)
2231                         Perl_croak(aTHX_ "can compress only unsigned integer");
2232
2233                     New('w', result, len, char);
2234                     in = result + len;
2235                     done = FALSE;
2236                     while (!done)
2237                         *--in = div128(norm, &done) | 0x80;
2238                     result[len - 1] &= 0x7F; /* clear continue bit */
2239                     sv_catpvn(cat, in, (result + len) - in);
2240                     Safefree(result);
2241                     SvREFCNT_dec(norm); /* free norm */
2242                 }
2243                 else if (SvNOKp(fromstr)) {
2244                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
2245                     char  *in = buf + sizeof(buf);
2246
2247                     adouble = Perl_floor(adouble);
2248                     do {
2249                         double next = floor(adouble / 128);
2250                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
2251                         if (in <= buf)  /* this cannot happen ;-) */
2252                             Perl_croak(aTHX_ "Cannot compress integer");
2253                         adouble = next;
2254                     } while (adouble > 0);
2255                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2256                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2257                 }
2258                 else {
2259                     char           *from, *result, *in;
2260                     SV             *norm;
2261                     STRLEN          len;
2262                     bool            done;
2263
2264                     /* Copy string and check for compliance */
2265                     from = SvPV(fromstr, len);
2266                     if ((norm = is_an_int(from, len)) == NULL)
2267                         Perl_croak(aTHX_ "can compress only unsigned integer");
2268
2269                     New('w', result, len, char);
2270                     in = result + len;
2271                     done = FALSE;
2272                     while (!done)
2273                         *--in = div128(norm, &done) | 0x80;
2274                     result[len - 1] &= 0x7F; /* clear continue bit */
2275                     sv_catpvn(cat, in, (result + len) - in);
2276                     Safefree(result);
2277                     SvREFCNT_dec(norm); /* free norm */
2278                }
2279             }
2280             break;
2281         case 'i':
2282             while (len-- > 0) {
2283                 fromstr = NEXTFROM;
2284                 aint = SvIV(fromstr);
2285                 sv_catpvn(cat, (char*)&aint, sizeof(int));
2286             }
2287             break;
2288         case 'N':
2289             while (len-- > 0) {
2290                 fromstr = NEXTFROM;
2291                 aulong = SvUV(fromstr);
2292 #ifdef HAS_HTONL
2293                 aulong = PerlSock_htonl(aulong);
2294 #endif
2295                 CAT32(cat, &aulong);
2296             }
2297             break;
2298         case 'V':
2299             while (len-- > 0) {
2300                 fromstr = NEXTFROM;
2301                 aulong = SvUV(fromstr);
2302 #ifdef HAS_HTOVL
2303                 aulong = htovl(aulong);
2304 #endif
2305                 CAT32(cat, &aulong);
2306             }
2307             break;
2308         case 'L':
2309 #if LONGSIZE != SIZE32
2310             if (natint) {
2311                 unsigned long aulong;
2312
2313                 while (len-- > 0) {
2314                     fromstr = NEXTFROM;
2315                     aulong = SvUV(fromstr);
2316                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2317                 }
2318             }
2319             else
2320 #endif
2321             {
2322                 while (len-- > 0) {
2323                     fromstr = NEXTFROM;
2324                     aulong = SvUV(fromstr);
2325                     CAT32(cat, &aulong);
2326                 }
2327             }
2328             break;
2329         case 'l':
2330 #if LONGSIZE != SIZE32
2331             if (natint) {
2332                 long along;
2333
2334                 while (len-- > 0) {
2335                     fromstr = NEXTFROM;
2336                     along = SvIV(fromstr);
2337                     sv_catpvn(cat, (char *)&along, sizeof(long));
2338                 }
2339             }
2340             else
2341 #endif
2342             {
2343                 while (len-- > 0) {
2344                     fromstr = NEXTFROM;
2345                     along = SvIV(fromstr);
2346                     CAT32(cat, &along);
2347                 }
2348             }
2349             break;
2350 #ifdef HAS_QUAD
2351         case 'Q':
2352             while (len-- > 0) {
2353                 fromstr = NEXTFROM;
2354                 auquad = (Uquad_t)SvUV(fromstr);
2355                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2356             }
2357             break;
2358         case 'q':
2359             while (len-- > 0) {
2360                 fromstr = NEXTFROM;
2361                 aquad = (Quad_t)SvIV(fromstr);
2362                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2363             }
2364             break;
2365 #endif
2366         case 'P':
2367             len = 1;            /* assume SV is correct length */
2368             /* FALL THROUGH */
2369         case 'p':
2370             while (len-- > 0) {
2371                 fromstr = NEXTFROM;
2372                 if (fromstr == &PL_sv_undef)
2373                     aptr = NULL;
2374                 else {
2375                     STRLEN n_a;
2376                     /* XXX better yet, could spirit away the string to
2377                      * a safe spot and hang on to it until the result
2378                      * of pack() (and all copies of the result) are
2379                      * gone.
2380                      */
2381                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2382                                                 || (SvPADTMP(fromstr)
2383                                                     && !SvREADONLY(fromstr))))
2384                     {
2385                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2386                                 "Attempt to pack pointer to temporary value");
2387                     }
2388                     if (SvPOK(fromstr) || SvNIOK(fromstr))
2389                         aptr = SvPV(fromstr,n_a);
2390                     else
2391                         aptr = SvPV_force(fromstr,n_a);
2392                 }
2393                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2394             }
2395             break;
2396         case 'u':
2397             fromstr = NEXTFROM;
2398             aptr = SvPV(fromstr, fromlen);
2399             SvGROW(cat, fromlen * 4 / 3);
2400             if (len <= 2)
2401                 len = 45;
2402             else
2403                 len = len / 3 * 3;
2404             while (fromlen > 0) {
2405                 I32 todo;
2406
2407                 if (fromlen > len)
2408                     todo = len;
2409                 else
2410                     todo = fromlen;
2411                 doencodes(cat, aptr, todo);
2412                 fromlen -= todo;
2413                 aptr += todo;
2414             }
2415             break;
2416         }
2417     }
2418     if (next_in_list)
2419         *next_in_list = beglist;
2420 }
2421 #undef NEXTFROM
2422
2423
2424 PP(pp_pack)
2425 {
2426     dSP; dMARK; dORIGMARK; dTARGET;
2427     register SV *cat = TARG;
2428     STRLEN fromlen;
2429     register char *pat = SvPVx(*++MARK, fromlen);
2430     register char *patend = pat + fromlen;
2431
2432     MARK++;
2433     sv_setpvn(cat, "", 0);
2434
2435     pack_cat(cat, pat, patend, MARK, SP + 1, NULL, 0);
2436
2437     SvSETMAGIC(cat);
2438     SP = ORIGMARK;
2439     PUSHs(cat);
2440     RETURN;
2441 }
2442