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' + (char)(i % 10);
 108     m = (char)(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] = (char)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) != 0;
 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                 if (len && (flags & UNPACK_ONLY_ONE))
 724                     len = 1;
 725                 EXTEND(SP, len);
 726                 EXTEND_MORTAL(len);
 727                 while (len-- > 0) {
 728                     aint = *s++;
 729                     if (aint >= 128)    /* fake up signed chars */
 730                         aint -= 256;
 731                     sv = NEWSV(36, 0);
 732                     sv_setiv(sv, (IV)aint);
 733                     PUSHs(sv_2mortal(sv));
 734                 }
 735             }
 736             break;
 737         case 'C':
 738         unpack_C: /* unpack U will jump here if not UTF-8 */
 739             if (len == 0) {
 740                 do_utf8 = FALSE;
 741                 break;
 742             }
 743             if (len > strend - s)
 744                 len = strend - s;
 745             if (checksum) {
 746               uchar_checksum:
 747                 while (len-- > 0) {
 748                     auint = *s++ & 255;
 749                     cuv += auint;
 750                 }
 751             }
 752             else {
 753                 if (len && (flags & UNPACK_ONLY_ONE))
 754                     len = 1;
 755                 EXTEND(SP, len);
 756                 EXTEND_MORTAL(len);
 757                 while (len-- > 0) {
 758                     auint = *s++ & 255;
 759                     sv = NEWSV(37, 0);
 760                     sv_setiv(sv, (IV)auint);
 761                     PUSHs(sv_2mortal(sv));
 762                 }
 763             }
 764             break;
 765         case 'U':
 766             if (len == 0) {
 767                 do_utf8 = TRUE;
 768                 break;
 769             }
 770             if (!do_utf8)
 771                  goto unpack_C;
 772             if (len > strend - s)
 773                 len = strend - s;
 774             if (checksum) {
 775                 while (len-- > 0 && s < strend) {
 776                     STRLEN alen;
 777                     auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
 778                     along = alen;
 779                     s += along;
 780                     if (checksum > bits_in_uv)
 781                         cdouble += (NV)auint;
 782                     else
 783                         cuv += auint;
 784                 }
 785             }
 786             else {
 787                 if (len && (flags & UNPACK_ONLY_ONE))
 788                     len = 1;
 789                 EXTEND(SP, len);
 790                 EXTEND_MORTAL(len);
 791                 while (len-- > 0 && s < strend) {
 792                     STRLEN alen;
 793                     auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
 794                     along = alen;
 795                     s += along;
 796                     sv = NEWSV(37, 0);
 797                     sv_setuv(sv, (UV)auint);
 798                     PUSHs(sv_2mortal(sv));
 799                 }
 800             }
 801             break;
 802         case 's':
 803 #if SHORTSIZE == SIZE16
 804             along = (strend - s) / SIZE16;
 805 #else
 806             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
 807 #endif
 808             if (len > along)
 809                 len = along;
 810             if (checksum) {
 811 #if SHORTSIZE != SIZE16
 812                 if (natint) {
 813                     short ashort;
 814                     while (len-- > 0) {
 815                         COPYNN(s, &ashort, sizeof(short));
 816                         s += sizeof(short);
 817                         if (checksum > bits_in_uv)
 818                             cdouble += (NV)ashort;
 819                         else
 820                             cuv += ashort;
 821
 822                     }
 823                 }
 824                 else
 825 #endif
 826                 {
 827                     while (len-- > 0) {
 828                         COPY16(s, &ashort);
 829 #if SHORTSIZE > SIZE16
 830                         if (ashort > 32767)
 831                           ashort -= 65536;
 832 #endif
 833                         s += SIZE16;
 834                         if (checksum > bits_in_uv)
 835                             cdouble += (NV)ashort;
 836                         else
 837                             cuv += ashort;
 838                     }
 839                 }
 840             }
 841             else {
 842                 if (len && (flags & UNPACK_ONLY_ONE))
 843                     len = 1;
 844                 EXTEND(SP, len);
 845                 EXTEND_MORTAL(len);
 846 #if SHORTSIZE != SIZE16
 847                 if (natint) {
 848                     short ashort;
 849                     while (len-- > 0) {
 850                         COPYNN(s, &ashort, sizeof(short));
 851                         s += sizeof(short);
 852                         sv = NEWSV(38, 0);
 853                         sv_setiv(sv, (IV)ashort);
 854                         PUSHs(sv_2mortal(sv));
 855                     }
 856                 }
 857                 else
 858 #endif
 859                 {
 860                     while (len-- > 0) {
 861                         COPY16(s, &ashort);
 862 #if SHORTSIZE > SIZE16
 863                         if (ashort > 32767)
 864                           ashort -= 65536;
 865 #endif
 866                         s += SIZE16;
 867                         sv = NEWSV(38, 0);
 868                         sv_setiv(sv, (IV)ashort);
 869                         PUSHs(sv_2mortal(sv));
 870                     }
 871                 }
 872             }
 873             break;
 874         case 'v':
 875         case 'n':
 876         case 'S':
 877 #if SHORTSIZE == SIZE16
 878             along = (strend - s) / SIZE16;
 879 #else
 880             unatint = natint && datumtype == 'S';
 881             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
 882 #endif
 883             if (len > along)
 884                 len = along;
 885             if (checksum) {
 886 #if SHORTSIZE != SIZE16
 887                 if (unatint) {
 888                     unsigned short aushort;
 889                     while (len-- > 0) {
 890                         COPYNN(s, &aushort, sizeof(unsigned short));
 891                         s += sizeof(unsigned short);
 892                         if (checksum > bits_in_uv)
 893                             cdouble += (NV)aushort;
 894                         else
 895                             cuv += aushort;
 896                     }
 897                 }
 898                 else
 899 #endif
 900                 {
 901                     while (len-- > 0) {
 902                         COPY16(s, &aushort);
 903                         s += SIZE16;
 904 #ifdef HAS_NTOHS
 905                         if (datumtype == 'n')
 906                             aushort = PerlSock_ntohs(aushort);
 907 #endif
 908 #ifdef HAS_VTOHS
 909                         if (datumtype == 'v')
 910                             aushort = vtohs(aushort);
 911 #endif
 912                         if (checksum > bits_in_uv)
 913                             cdouble += (NV)aushort;
 914                         else
 915                             cuv += aushort;
 916                     }
 917                 }
 918             }
 919             else {
 920                 if (len && (flags & UNPACK_ONLY_ONE))
 921                     len = 1;
 922                 EXTEND(SP, len);
 923                 EXTEND_MORTAL(len);
 924 #if SHORTSIZE != SIZE16
 925                 if (unatint) {
 926                     unsigned short aushort;
 927                     while (len-- > 0) {
 928                         COPYNN(s, &aushort, sizeof(unsigned short));
 929                         s += sizeof(unsigned short);
 930                         sv = NEWSV(39, 0);
 931                         sv_setiv(sv, (UV)aushort);
 932                         PUSHs(sv_2mortal(sv));
 933                     }
 934                 }
 935                 else
 936 #endif
 937                 {
 938                     while (len-- > 0) {
 939                         COPY16(s, &aushort);
 940                         s += SIZE16;
 941                         sv = NEWSV(39, 0);
 942 #ifdef HAS_NTOHS
 943                         if (datumtype == 'n')
 944                             aushort = PerlSock_ntohs(aushort);
 945 #endif
 946 #ifdef HAS_VTOHS
 947                         if (datumtype == 'v')
 948                             aushort = vtohs(aushort);
 949 #endif
 950                         sv_setiv(sv, (UV)aushort);
 951                         PUSHs(sv_2mortal(sv));
 952                     }
 953                 }
 954             }
 955             break;
 956         case 'i':
 957             along = (strend - s) / sizeof(int);
 958             if (len > along)
 959                 len = along;
 960             if (checksum) {
 961                 while (len-- > 0) {
 962                     Copy(s, &aint, 1, int);
 963                     s += sizeof(int);
 964                     if (checksum > bits_in_uv)
 965                         cdouble += (NV)aint;
 966                     else
 967                         cuv += aint;
 968                 }
 969             }
 970             else {
 971                 if (len && (flags & UNPACK_ONLY_ONE))
 972                     len = 1;
 973                 EXTEND(SP, len);
 974                 EXTEND_MORTAL(len);
 975                 while (len-- > 0) {
 976                     Copy(s, &aint, 1, int);
 977                     s += sizeof(int);
 978                     sv = NEWSV(40, 0);
 979 #ifdef __osf__
 980                     /* Without the dummy below unpack("i", pack("i",-1))
 981                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
 982                      * cc with optimization turned on.
 983                      *
 984                      * The bug was detected in
 985                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
 986                      * with optimization (-O4) turned on.
 987                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
 988                      * does not have this problem even with -O4.
 989                      *
 990                      * This bug was reported as DECC_BUGS 1431
 991                      * and tracked internally as GEM_BUGS 7775.
 992                      *
 993                      * The bug is fixed in
 994                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
 995                      * UNIX V4.0F support:   DEC C V5.9-006 or later
 996                      * UNIX V4.0E support:   DEC C V5.8-011 or later
 997                      * and also in DTK.
 998                      *
 999                      * See also few lines later for the same bug.
1000                      */
1001                     (aint) ?
1002                         sv_setiv(sv, (IV)aint) :
1003 #endif
1004                     sv_setiv(sv, (IV)aint);
1005                     PUSHs(sv_2mortal(sv));
1006                 }
1007             }
1008             break;
1009         case 'I':
1010             along = (strend - s) / sizeof(unsigned int);
1011             if (len > along)
1012                 len = along;
1013             if (checksum) {
1014                 while (len-- > 0) {
1015                     Copy(s, &auint, 1, unsigned int);
1016                     s += sizeof(unsigned int);
1017                     if (checksum > bits_in_uv)
1018                         cdouble += (NV)auint;
1019                     else
1020                         cuv += auint;
1021                 }
1022             }
1023             else {
1024                 if (len && (flags & UNPACK_ONLY_ONE))
1025                     len = 1;
1026                 EXTEND(SP, len);
1027                 EXTEND_MORTAL(len);
1028                 while (len-- > 0) {
1029                     Copy(s, &auint, 1, unsigned int);
1030                     s += sizeof(unsigned int);
1031                     sv = NEWSV(41, 0);
1032 #ifdef __osf__
1033                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1034                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1035                      * See details few lines earlier. */
1036                     (auint) ?
1037                         sv_setuv(sv, (UV)auint) :
1038 #endif
1039                     sv_setuv(sv, (UV)auint);
1040                     PUSHs(sv_2mortal(sv));
1041                 }
1042             }
1043             break;
1044         case 'j':
1045             along = (strend - s) / IVSIZE;
1046             if (len > along)
1047                 len = along;
1048             if (checksum) {
1049                 while (len-- > 0) {
1050                     Copy(s, &aiv, 1, IV);
1051                     s += IVSIZE;
1052                     if (checksum > bits_in_uv)
1053                         cdouble += (NV)aiv;
1054                     else
1055                         cuv += aiv;
1056                 }
1057             }
1058             else {
1059                 if (len && (flags & UNPACK_ONLY_ONE))
1060                     len = 1;
1061                 EXTEND(SP, len);
1062                 EXTEND_MORTAL(len);
1063                 while (len-- > 0) {
1064                     Copy(s, &aiv, 1, IV);
1065                     s += IVSIZE;
1066                     sv = NEWSV(40, 0);
1067                     sv_setiv(sv, aiv);
1068                     PUSHs(sv_2mortal(sv));
1069                 }
1070             }
1071             break;
1072         case 'J':
1073             along = (strend - s) / UVSIZE;
1074             if (len > along)
1075                 len = along;
1076             if (checksum) {
1077                 while (len-- > 0) {
1078                     Copy(s, &auv, 1, UV);
1079                     s += UVSIZE;
1080                     if (checksum > bits_in_uv)
1081                         cdouble += (NV)auv;
1082                     else
1083                         cuv += auv;
1084                 }
1085             }
1086             else {
1087                 if (len && (flags & UNPACK_ONLY_ONE))
1088                     len = 1;
1089                 EXTEND(SP, len);
1090                 EXTEND_MORTAL(len);
1091                 while (len-- > 0) {
1092                     Copy(s, &auv, 1, UV);
1093                     s += UVSIZE;
1094                     sv = NEWSV(41, 0);
1095                     sv_setuv(sv, auv);
1096                     PUSHs(sv_2mortal(sv));
1097                 }
1098             }
1099             break;
1100         case 'l':
1101 #if LONGSIZE == SIZE32
1102             along = (strend - s) / SIZE32;
1103 #else
1104             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
1105 #endif
1106             if (len > along)
1107                 len = along;
1108             if (checksum) {
1109 #if LONGSIZE != SIZE32
1110                 if (natint) {
1111                     while (len-- > 0) {
1112                         COPYNN(s, &along, sizeof(long));
1113                         s += sizeof(long);
1114                         if (checksum > bits_in_uv)
1115                             cdouble += (NV)along;
1116                         else
1117                             cuv += along;
1118                     }
1119                 }
1120                 else
1121 #endif
1122                 {
1123                     while (len-- > 0) {
1124 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1125                         I32 along;
1126 #endif
1127                         COPY32(s, &along);
1128 #if LONGSIZE > SIZE32
1129                         if (along > 2147483647)
1130                           along -= 4294967296;
1131 #endif
1132                         s += SIZE32;
1133                         if (checksum > bits_in_uv)
1134                             cdouble += (NV)along;
1135                         else
1136                             cuv += along;
1137                     }
1138                 }
1139             }
1140             else {
1141                 if (len && (flags & UNPACK_ONLY_ONE))
1142                     len = 1;
1143                 EXTEND(SP, len);
1144                 EXTEND_MORTAL(len);
1145 #if LONGSIZE != SIZE32
1146                 if (natint) {
1147                     while (len-- > 0) {
1148                         COPYNN(s, &along, sizeof(long));
1149                         s += sizeof(long);
1150                         sv = NEWSV(42, 0);
1151                         sv_setiv(sv, (IV)along);
1152                         PUSHs(sv_2mortal(sv));
1153                     }
1154                 }
1155                 else
1156 #endif
1157                 {
1158                     while (len-- > 0) {
1159 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1160                         I32 along;
1161 #endif
1162                         COPY32(s, &along);
1163 #if LONGSIZE > SIZE32
1164                         if (along > 2147483647)
1165                           along -= 4294967296;
1166 #endif
1167                         s += SIZE32;
1168                         sv = NEWSV(42, 0);
1169                         sv_setiv(sv, (IV)along);
1170                         PUSHs(sv_2mortal(sv));
1171                     }
1172                 }
1173             }
1174             break;
1175         case 'V':
1176         case 'N':
1177         case 'L':
1178 #if LONGSIZE == SIZE32
1179             along = (strend - s) / SIZE32;
1180 #else
1181             unatint = natint && datumtype == 'L';
1182             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
1183 #endif
1184             if (len > along)
1185                 len = along;
1186             if (checksum) {
1187 #if LONGSIZE != SIZE32
1188                 if (unatint) {
1189                     unsigned long aulong;
1190                     while (len-- > 0) {
1191                         COPYNN(s, &aulong, sizeof(unsigned long));
1192                         s += sizeof(unsigned long);
1193                         if (checksum > bits_in_uv)
1194                             cdouble += (NV)aulong;
1195                         else
1196                             cuv += aulong;
1197                     }
1198                 }
1199                 else
1200 #endif
1201                 {
1202                     while (len-- > 0) {
1203                         COPY32(s, &aulong);
1204                         s += SIZE32;
1205 #ifdef HAS_NTOHL
1206                         if (datumtype == 'N')
1207                             aulong = PerlSock_ntohl(aulong);
1208 #endif
1209 #ifdef HAS_VTOHL
1210                         if (datumtype == 'V')
1211                             aulong = vtohl(aulong);
1212 #endif
1213                         if (checksum > bits_in_uv)
1214                             cdouble += (NV)aulong;
1215                         else
1216                             cuv += aulong;
1217                     }
1218                 }
1219             }
1220             else {
1221                 if (len && (flags & UNPACK_ONLY_ONE))
1222                     len = 1;
1223                 EXTEND(SP, len);
1224                 EXTEND_MORTAL(len);
1225 #if LONGSIZE != SIZE32
1226                 if (unatint) {
1227                     unsigned long aulong;
1228                     while (len-- > 0) {
1229                         COPYNN(s, &aulong, sizeof(unsigned long));
1230                         s += sizeof(unsigned long);
1231                         sv = NEWSV(43, 0);
1232                         sv_setuv(sv, (UV)aulong);
1233                         PUSHs(sv_2mortal(sv));
1234                     }
1235                 }
1236                 else
1237 #endif
1238                 {
1239                     while (len-- > 0) {
1240                         COPY32(s, &aulong);
1241                         s += SIZE32;
1242 #ifdef HAS_NTOHL
1243                         if (datumtype == 'N')
1244                             aulong = PerlSock_ntohl(aulong);
1245 #endif
1246 #ifdef HAS_VTOHL
1247                         if (datumtype == 'V')
1248                             aulong = vtohl(aulong);
1249 #endif
1250                         sv = NEWSV(43, 0);
1251                         sv_setuv(sv, (UV)aulong);
1252                         PUSHs(sv_2mortal(sv));
1253                     }
1254                 }
1255             }
1256             break;
1257         case 'p':
1258             along = (strend - s) / sizeof(char*);
1259             if (len > along)
1260                 len = along;
1261             EXTEND(SP, len);
1262             EXTEND_MORTAL(len);
1263             while (len-- > 0) {
1264                 if (sizeof(char*) > strend - s)
1265                     break;
1266                 else {
1267                     Copy(s, &aptr, 1, char*);
1268                     s += sizeof(char*);
1269                 }
1270                 sv = NEWSV(44, 0);
1271                 if (aptr)
1272                     sv_setpv(sv, aptr);
1273                 PUSHs(sv_2mortal(sv));
1274             }
1275             break;
1276         case 'w':
1277             if (len && (flags & UNPACK_ONLY_ONE))
1278                 len = 1;
1279             EXTEND(SP, len);
1280             EXTEND_MORTAL(len);
1281             {
1282                 UV auv = 0;
1283                 U32 bytes = 0;
1284
1285                 while ((len > 0) && (s < strend)) {
1286                     auv = (auv << 7) | (*s & 0x7f);
1287                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1288                     if ((U8)(*s++) < 0x80) {
1289                         bytes = 0;
1290                         sv = NEWSV(40, 0);
1291                         sv_setuv(sv, auv);
1292                         PUSHs(sv_2mortal(sv));
1293                         len--;
1294                         auv = 0;
1295                     }
1296                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
1297                         char *t;
1298                         STRLEN n_a;
1299
1300                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1301                         while (s < strend) {
1302                             sv = mul128(sv, (U8)(*s & 0x7f));
1303                             if (!(*s++ & 0x80)) {
1304                                 bytes = 0;
1305                                 break;
1306                             }
1307                         }
1308                         t = SvPV(sv, n_a);
1309                         while (*t == '0')
1310                             t++;
1311                         sv_chop(sv, t);
1312                         PUSHs(sv_2mortal(sv));
1313                         len--;
1314                         auv = 0;
1315                     }
1316                 }
1317                 if ((s >= strend) && bytes)
1318                     Perl_croak(aTHX_ "Unterminated compressed integer");
1319             }
1320             break;
1321         case 'P':
1322             if (star > 0)
1323                 Perl_croak(aTHX_ "P must have an explicit size");
1324             EXTEND(SP, 1);
1325             if (sizeof(char*) > strend - s)
1326                 break;
1327             else {
1328                 Copy(s, &aptr, 1, char*);
1329                 s += sizeof(char*);
1330             }
1331             sv = NEWSV(44, 0);
1332             if (aptr)
1333                 sv_setpvn(sv, aptr, len);
1334             PUSHs(sv_2mortal(sv));
1335             break;
1336 #ifdef HAS_QUAD
1337         case 'q':
1338             along = (strend - s) / sizeof(Quad_t);
1339             if (len > along)
1340                 len = along;
1341             if (checksum) {
1342                 while (len-- > 0) {
1343                     Copy(s, &aquad, 1, Quad_t);
1344                     s += sizeof(Quad_t);
1345                     if (checksum > bits_in_uv)
1346                         cdouble += (NV)aquad;
1347                     else
1348                         cuv += aquad;
1349                 }
1350             }
1351             else {
1352                 if (len && (flags & UNPACK_ONLY_ONE))
1353                     len = 1;
1354                 EXTEND(SP, len);
1355                 EXTEND_MORTAL(len);
1356                 while (len-- > 0) {
1357                     if (s + sizeof(Quad_t) > strend)
1358                         aquad = 0;
1359                     else {
1360                         Copy(s, &aquad, 1, Quad_t);
1361                         s += sizeof(Quad_t);
1362                     }
1363                     sv = NEWSV(42, 0);
1364                     if (aquad >= IV_MIN && aquad <= IV_MAX)
1365                         sv_setiv(sv, (IV)aquad);
1366                     else
1367                         sv_setnv(sv, (NV)aquad);
1368                     PUSHs(sv_2mortal(sv));
1369                 }
1370             }
1371             break;
1372         case 'Q':
1373             along = (strend - s) / sizeof(Uquad_t);
1374             if (len > along)
1375                 len = along;
1376             if (checksum) {
1377                 while (len-- > 0) {
1378                     Copy(s, &auquad, 1, Uquad_t);
1379                     s += sizeof(Uquad_t);
1380                     if (checksum > bits_in_uv)
1381                         cdouble += (NV)auquad;
1382                     else
1383                         cuv += auquad;
1384                 }
1385             }
1386             else {
1387                 if (len && (flags & UNPACK_ONLY_ONE))
1388                     len = 1;
1389                 EXTEND(SP, len);
1390                 EXTEND_MORTAL(len);
1391                 while (len-- > 0) {
1392                     if (s + sizeof(Uquad_t) > strend)
1393                         auquad = 0;
1394                     else {
1395                         Copy(s, &auquad, 1, Uquad_t);
1396                         s += sizeof(Uquad_t);
1397                     }
1398                     sv = NEWSV(43, 0);
1399                     if (auquad <= UV_MAX)
1400                         sv_setuv(sv, (UV)auquad);
1401                     else
1402                     sv_setnv(sv, (NV)auquad);
1403                     PUSHs(sv_2mortal(sv));
1404                 }
1405             }
1406             break;
1407 #endif
1408         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1409         case 'f':
1410             along = (strend - s) / sizeof(float);
1411             if (len > along)
1412                 len = along;
1413             if (checksum) {
1414                 while (len-- > 0) {
1415                     Copy(s, &afloat, 1, float);
1416                     s += sizeof(float);
1417                     cdouble += afloat;
1418                 }
1419             }
1420             else {
1421                 if (len && (flags & UNPACK_ONLY_ONE))
1422                     len = 1;
1423                 EXTEND(SP, len);
1424                 EXTEND_MORTAL(len);
1425                 while (len-- > 0) {
1426                     Copy(s, &afloat, 1, float);
1427                     s += sizeof(float);
1428                     sv = NEWSV(47, 0);
1429                     sv_setnv(sv, (NV)afloat);
1430                     PUSHs(sv_2mortal(sv));
1431                 }
1432             }
1433             break;
1434         case 'd':
1435             along = (strend - s) / sizeof(double);
1436             if (len > along)
1437                 len = along;
1438             if (checksum) {
1439                 while (len-- > 0) {
1440                     Copy(s, &adouble, 1, double);
1441                     s += sizeof(double);
1442                     cdouble += adouble;
1443                 }
1444             }
1445             else {
1446                 if (len && (flags & UNPACK_ONLY_ONE))
1447                     len = 1;
1448                 EXTEND(SP, len);
1449                 EXTEND_MORTAL(len);
1450                 while (len-- > 0) {
1451                     Copy(s, &adouble, 1, double);
1452                     s += sizeof(double);
1453                     sv = NEWSV(48, 0);
1454                     sv_setnv(sv, (NV)adouble);
1455                     PUSHs(sv_2mortal(sv));
1456                 }
1457             }
1458             break;
1459         case 'F':
1460             along = (strend - s) / NVSIZE;
1461             if (len > along)
1462                 len = along;
1463             if (checksum) {
1464                 while (len-- > 0) {
1465                     Copy(s, &anv, 1, NV);
1466                     s += NVSIZE;
1467                     cdouble += anv;
1468                 }
1469             }
1470             else {
1471                 if (len && (flags & UNPACK_ONLY_ONE))
1472                     len = 1;
1473                 EXTEND(SP, len);
1474                 EXTEND_MORTAL(len);
1475                 while (len-- > 0) {
1476                     Copy(s, &anv, 1, NV);
1477                     s += NVSIZE;
1478                     sv = NEWSV(48, 0);
1479                     sv_setnv(sv, anv);
1480                     PUSHs(sv_2mortal(sv));
1481                 }
1482             }
1483             break;
1484 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1485         case 'D':
1486             along = (strend - s) / LONG_DOUBLESIZE;
1487             if (len > along)
1488                 len = along;
1489             if (checksum) {
1490                 while (len-- > 0) {
1491                     Copy(s, &aldouble, 1, long double);
1492                     s += LONG_DOUBLESIZE;
1493                     cdouble += aldouble;
1494                 }
1495             }
1496             else {
1497                 if (len && (flags & UNPACK_ONLY_ONE))
1498                     len = 1;
1499                 EXTEND(SP, len);
1500                 EXTEND_MORTAL(len);
1501                 while (len-- > 0) {
1502                     Copy(s, &aldouble, 1, long double);
1503                     s += LONG_DOUBLESIZE;
1504                     sv = NEWSV(48, 0);
1505                     sv_setnv(sv, (NV)aldouble);
1506                     PUSHs(sv_2mortal(sv));
1507                 }
1508             }
1509             break;
1510 #endif
1511         case 'u':
1512             /* MKS:
1513              * Initialise the decode mapping.  By using a table driven
1514              * algorithm, the code will be character-set independent
1515              * (and just as fast as doing character arithmetic)
1516              */
1517             if (PL_uudmap['M'] == 0) {
1518                 int i;
1519
1520                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1521                     PL_uudmap[(U8)PL_uuemap[i]] = i;
1522                 /*
1523                  * Because ' ' and '`' map to the same value,
1524                  * we need to decode them both the same.
1525                  */
1526                 PL_uudmap[' '] = 0;
1527             }
1528
1529             along = (strend - s) * 3 / 4;
1530             sv = NEWSV(42, along);
1531             if (along)
1532                 SvPOK_on(sv);
1533             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1534                 I32 a, b, c, d;
1535                 char hunk[4];
1536
1537                 hunk[3] = '\0';
1538                 len = PL_uudmap[*(U8*)s++] & 077;
1539                 while (len > 0) {
1540                     if (s < strend && ISUUCHAR(*s))
1541                         a = PL_uudmap[*(U8*)s++] & 077;
1542                     else
1543                         a = 0;
1544                     if (s < strend && ISUUCHAR(*s))
1545                         b = PL_uudmap[*(U8*)s++] & 077;
1546                     else
1547                         b = 0;
1548                     if (s < strend && ISUUCHAR(*s))
1549                         c = PL_uudmap[*(U8*)s++] & 077;
1550                     else
1551                         c = 0;
1552                     if (s < strend && ISUUCHAR(*s))
1553                         d = PL_uudmap[*(U8*)s++] & 077;
1554                     else
1555                         d = 0;
1556                     hunk[0] = (char)((a << 2) | (b >> 4));
1557                     hunk[1] = (char)((b << 4) | (c >> 2));
1558                     hunk[2] = (char)((c << 6) | d);
1559                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1560                     len -= 3;
1561                 }
1562                 if (*s == '\n')
1563                     s++;
1564                 else    /* possible checksum byte */
1565                     if (s + 1 < strend && s[1] == '\n')
1566                         s += 2;
1567             }
1568             XPUSHs(sv_2mortal(sv));
1569             break;
1570         }
1571         if (checksum) {
1572             sv = NEWSV(42, 0);
1573             if (strchr("fFdD", datumtype) ||
1574               (checksum > bits_in_uv &&
1575                strchr("csSiIlLnNUvVqQjJ", datumtype)) ) {
1576                 NV trouble;
1577
1578                 adouble = (NV) (1 << (checksum & 15));
1579                 while (checksum >= 16) {
1580                     checksum -= 16;
1581                     adouble *= 65536.0;
1582                 }
1583                 while (cdouble < 0.0)
1584                     cdouble += adouble;
1585                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1586                 sv_setnv(sv, cdouble);
1587             }
1588             else {
1589                 if (checksum < bits_in_uv) {
1590                     UV mask = ((UV)1 << checksum) - 1;
1591
1592                     cuv &= mask;
1593                 }
1594                 sv_setuv(sv, cuv);
1595             }
1596             XPUSHs(sv_2mortal(sv));
1597             checksum = 0;
1598         }
1599     }
1600     if (new_s)
1601         *new_s = s;
1602     PUTBACK;
1603     return SP - PL_stack_base - start_sp_offset;
1604 }
1605
1606 PP(pp_unpack)
1607 {
1608     dSP;
1609     dPOPPOPssrl;
1610     I32 gimme = GIMME_V;
1611     STRLEN llen;
1612     STRLEN rlen;
1613     register char *pat = SvPV(left, llen);
1614 #ifdef PACKED_IS_OCTETS
1615     /* Packed side is assumed to be octets - so force downgrade if it
1616        has been UTF-8 encoded by accident
1617      */
1618     register char *s = SvPVbyte(right, rlen);
1619 #else
1620     register char *s = SvPV(right, rlen);
1621 #endif
1622     char *strend = s + rlen;
1623     register char *patend = pat + llen;
1624     register I32 cnt;
1625
1626     PUTBACK;
1627     cnt = unpack_str(pat, patend, s, s, strend, NULL, 0,
1628                      ((gimme == G_SCALAR) ? UNPACK_ONLY_ONE : 0)
1629                      | (DO_UTF8(right) ? UNPACK_DO_UTF8 : 0));
1630     SPAGAIN;
1631     if ( !cnt && gimme == G_SCALAR )
1632        PUSHs(&PL_sv_undef);
1633     RETURN;
1634 }
1635
1636 STATIC void
1637 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1638 {
1639     char hunk[5];
1640
1641     *hunk = PL_uuemap[len];
1642     sv_catpvn(sv, hunk, 1);
1643     hunk[4] = '\0';
1644     while (len > 2) {
1645         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1646         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1647         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1648         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1649         sv_catpvn(sv, hunk, 4);
1650         s += 3;
1651         len -= 3;
1652     }
1653     if (len > 0) {
1654         char r = (len > 1 ? s[1] : '\0');
1655         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1656         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1657         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1658         hunk[3] = PL_uuemap[0];
1659         sv_catpvn(sv, hunk, 4);
1660     }
1661     sv_catpvn(sv, "\n", 1);
1662 }
1663
1664 STATIC SV *
1665 S_is_an_int(pTHX_ char *s, STRLEN l)
1666 {
1667   STRLEN         n_a;
1668   SV             *result = newSVpvn(s, l);
1669   char           *result_c = SvPV(result, n_a); /* convenience */
1670   char           *out = result_c;
1671   bool            skip = 1;
1672   bool            ignore = 0;
1673
1674   while (*s) {
1675     switch (*s) {
1676     case ' ':
1677       break;
1678     case '+':
1679       if (!skip) {
1680         SvREFCNT_dec(result);
1681         return (NULL);
1682       }
1683       break;
1684     case '0':
1685     case '1':
1686     case '2':
1687     case '3':
1688     case '4':
1689     case '5':
1690     case '6':
1691     case '7':
1692     case '8':
1693     case '9':
1694       skip = 0;
1695       if (!ignore) {
1696         *(out++) = *s;
1697       }
1698       break;
1699     case '.':
1700       ignore = 1;
1701       break;
1702     default:
1703       SvREFCNT_dec(result);
1704       return (NULL);
1705     }
1706     s++;
1707   }
1708   *(out++) = '\0';
1709   SvCUR_set(result, out - result_c);
1710   return (result);
1711 }
1712
1713 /* pnum must be '\0' terminated */
1714 STATIC int
1715 S_div128(pTHX_ SV *pnum, bool *done)
1716 {
1717   STRLEN          len;
1718   char           *s = SvPV(pnum, len);
1719   int             m = 0;
1720   int             r = 0;
1721   char           *t = s;
1722
1723   *done = 1;
1724   while (*t) {
1725     int             i;
1726
1727     i = m * 10 + (*t - '0');
1728     m = i & 0x7F;
1729     r = (i >> 7);               /* r < 10 */
1730     if (r) {
1731       *done = 0;
1732     }
1733     *(t++) = '0' + r;
1734   }
1735   *(t++) = '\0';
1736   SvCUR_set(pnum, (STRLEN) (t - s));
1737   return (m);
1738 }
1739
1740 #define PACK_CHILD      0x1
1741
1742 /*
1743 =for apidoc pack_cat
1744
1745 The engine implementing pack() Perl function.
1746
1747 =cut */
1748
1749 void
1750 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1751 {
1752     register I32 items;
1753     STRLEN fromlen;
1754     register I32 len;
1755     I32 datumtype;
1756     SV *fromstr;
1757     /*SUPPRESS 442*/
1758     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1759     static char *space10 = "          ";
1760     int star;
1761
1762     /* These must not be in registers: */
1763     char achar;
1764     I16 ashort;
1765     int aint;
1766     unsigned int auint;
1767     I32 along;
1768     U32 aulong;
1769     IV aiv;
1770     UV auv;
1771     NV anv;
1772 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1773     long double aldouble;
1774 #endif
1775 #ifdef HAS_QUAD
1776     Quad_t aquad;
1777     Uquad_t auquad;
1778 #endif
1779     char *aptr;
1780     float afloat;
1781     double adouble;
1782     int commas = 0;
1783 #ifdef PERL_NATINT_PACK
1784     int natint;         /* native integer */
1785 #endif
1786
1787     items = endlist - beglist;
1788 #ifndef PACKED_IS_OCTETS
1789     pat = next_symbol(pat, patend);
1790     if (pat < patend && *pat == 'U' && !flags)
1791         SvUTF8_on(cat);
1792 #endif
1793     while ((pat = next_symbol(pat, patend)) < patend) {
1794         SV *lengthcode = Nullsv;
1795 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1796         datumtype = *pat++ & 0xFF;
1797 #ifdef PERL_NATINT_PACK
1798         natint = 0;
1799 #endif
1800         if (*pat == '!') {
1801             static const char natstr[] = "sSiIlLxX";
1802
1803             if (strchr(natstr, datumtype)) {
1804                 if (datumtype == 'x' || datumtype == 'X') {
1805                     datumtype |= TYPE_IS_SHRIEKING;
1806                 } else {                /* XXXX Should be redone similarly! */
1807 #ifdef PERL_NATINT_PACK
1808                     natint = 1;
1809 #endif
1810                 }
1811                 pat++;
1812             }
1813             else
1814                 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
1815         }
1816         len = find_count(&pat, patend, &star);
1817         if (star > 0)                   /* Count is '*' */
1818             len = strchr("@Xxu", datumtype) ? 0 : items;
1819         else if (star < 0)              /* Default len */
1820             len = 1;
1821         if (*pat == '/') {              /* doing lookahead how... */
1822             ++pat;
1823             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
1824                 Perl_croak(aTHX_ "/ must be followed by a*, A* or Z*");
1825             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1826                                                    ? *beglist : &PL_sv_no)
1827                                             + (*pat == 'Z' ? 1 : 0)));
1828         }
1829         switch(datumtype) {
1830         default:
1831             Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
1832         case ',': /* grandfather in commas but with a warning */
1833             if (commas++ == 0 && ckWARN(WARN_PACK))
1834                 Perl_warner(aTHX_ packWARN(WARN_PACK),
1835                             "Invalid type in pack: '%c'", (int)datumtype);
1836             break;
1837         case '%':
1838             Perl_croak(aTHX_ "%% may only be used in unpack");
1839         case '@':
1840             len -= SvCUR(cat);
1841             if (len > 0)
1842                 goto grow;
1843             len = -len;
1844             if (len > 0)
1845                 goto shrink;
1846             break;
1847         case '(':
1848         {
1849             char *beg = pat;
1850             SV **savebeglist = beglist; /* beglist de-register-ed */
1851
1852             if (star >= 0)
1853                 Perl_croak(aTHX_ "()-group starts with a count");
1854             aptr = group_end(beg, patend, ')');
1855             pat = aptr + 1;
1856             if (star != -2) {
1857                 len = find_count(&pat, patend, &star);
1858                 if (star < 0)           /* No count */
1859                     len = 1;
1860                 else if (star > 0)      /* Star */
1861                     len = items;        /* long enough? */
1862             }
1863             while (len--) {
1864                 pack_cat(cat, beg, aptr, savebeglist, endlist,
1865                          &savebeglist, PACK_CHILD);
1866                 if (star > 0 && savebeglist == endlist)
1867                     break;              /* No way to continue */
1868             }
1869             beglist = savebeglist;
1870             break;
1871         }
1872         case 'X' | TYPE_IS_SHRIEKING:
1873             if (!len)                   /* Avoid division by 0 */
1874                 len = 1;
1875             len = (SvCUR(cat)) % len;
1876             /* FALL THROUGH */
1877         case 'X':
1878           shrink:
1879             if ((I32)SvCUR(cat) < len)
1880                 Perl_croak(aTHX_ "X outside of string");
1881             SvCUR(cat) -= len;
1882             *SvEND(cat) = '\0';
1883             break;
1884         case 'x' | TYPE_IS_SHRIEKING:
1885             if (!len)                   /* Avoid division by 0 */
1886                 len = 1;
1887             aint = (SvCUR(cat)) % len;
1888             if (aint)                   /* Other portable ways? */
1889                 len = len - aint;
1890             else
1891                 len = 0;
1892             /* FALL THROUGH */
1893         case 'x':
1894           grow:
1895             while (len >= 10) {
1896                 sv_catpvn(cat, null10, 10);
1897                 len -= 10;
1898             }
1899             sv_catpvn(cat, null10, len);
1900             break;
1901         case 'A':
1902         case 'Z':
1903         case 'a':
1904             fromstr = NEXTFROM;
1905             aptr = SvPV(fromstr, fromlen);
1906             if (star > 0) { /* -2 after '/' */
1907                 len = fromlen;
1908                 if (datumtype == 'Z')
1909                     ++len;
1910             }
1911             if ((I32)fromlen >= len) {
1912                 sv_catpvn(cat, aptr, len);
1913                 if (datumtype == 'Z')
1914                     *(SvEND(cat)-1) = '\0';
1915             }
1916             else {
1917                 sv_catpvn(cat, aptr, fromlen);
1918                 len -= fromlen;
1919                 if (datumtype == 'A') {
1920                     while (len >= 10) {
1921                         sv_catpvn(cat, space10, 10);
1922                         len -= 10;
1923                     }
1924                     sv_catpvn(cat, space10, len);
1925                 }
1926                 else {
1927                     while (len >= 10) {
1928                         sv_catpvn(cat, null10, 10);
1929                         len -= 10;
1930                     }
1931                     sv_catpvn(cat, null10, len);
1932                 }
1933             }
1934             break;
1935         case 'B':
1936         case 'b':
1937             {
1938                 register char *str;
1939                 I32 saveitems;
1940
1941                 fromstr = NEXTFROM;
1942                 saveitems = items;
1943                 str = SvPV(fromstr, fromlen);
1944                 if (star > 0)
1945                     len = fromlen;
1946                 aint = SvCUR(cat);
1947                 SvCUR(cat) += (len+7)/8;
1948                 SvGROW(cat, SvCUR(cat) + 1);
1949                 aptr = SvPVX(cat) + aint;
1950                 if (len > (I32)fromlen)
1951                     len = fromlen;
1952                 aint = len;
1953                 items = 0;
1954                 if (datumtype == 'B') {
1955                     for (len = 0; len++ < aint;) {
1956                         items |= *str++ & 1;
1957                         if (len & 7)
1958                             items <<= 1;
1959                         else {
1960                             *aptr++ = items & 0xff;
1961                             items = 0;
1962                         }
1963                     }
1964                 }
1965                 else {
1966                     for (len = 0; len++ < aint;) {
1967                         if (*str++ & 1)
1968                             items |= 128;
1969                         if (len & 7)
1970                             items >>= 1;
1971                         else {
1972                             *aptr++ = items & 0xff;
1973                             items = 0;
1974                         }
1975                     }
1976                 }
1977                 if (aint & 7) {
1978                     if (datumtype == 'B')
1979                         items <<= 7 - (aint & 7);
1980                     else
1981                         items >>= 7 - (aint & 7);
1982                     *aptr++ = items & 0xff;
1983                 }
1984                 str = SvPVX(cat) + SvCUR(cat);
1985                 while (aptr <= str)
1986                     *aptr++ = '\0';
1987
1988                 items = saveitems;
1989             }
1990             break;
1991         case 'H':
1992         case 'h':
1993             {
1994                 register char *str;
1995                 I32 saveitems;
1996
1997                 fromstr = NEXTFROM;
1998                 saveitems = items;
1999                 str = SvPV(fromstr, fromlen);
2000                 if (star > 0)
2001                     len = fromlen;
2002                 aint = SvCUR(cat);
2003                 SvCUR(cat) += (len+1)/2;
2004                 SvGROW(cat, SvCUR(cat) + 1);
2005                 aptr = SvPVX(cat) + aint;
2006                 if (len > (I32)fromlen)
2007                     len = fromlen;
2008                 aint = len;
2009                 items = 0;
2010                 if (datumtype == 'H') {
2011                     for (len = 0; len++ < aint;) {
2012                         if (isALPHA(*str))
2013                             items |= ((*str++ & 15) + 9) & 15;
2014                         else
2015                             items |= *str++ & 15;
2016                         if (len & 1)
2017                             items <<= 4;
2018                         else {
2019                             *aptr++ = items & 0xff;
2020                             items = 0;
2021                         }
2022                     }
2023                 }
2024                 else {
2025                     for (len = 0; len++ < aint;) {
2026                         if (isALPHA(*str))
2027                             items |= (((*str++ & 15) + 9) & 15) << 4;
2028                         else
2029                             items |= (*str++ & 15) << 4;
2030                         if (len & 1)
2031                             items >>= 4;
2032                         else {
2033                             *aptr++ = items & 0xff;
2034                             items = 0;
2035                         }
2036                     }
2037                 }
2038                 if (aint & 1)
2039                     *aptr++ = items & 0xff;
2040                 str = SvPVX(cat) + SvCUR(cat);
2041                 while (aptr <= str)
2042                     *aptr++ = '\0';
2043
2044                 items = saveitems;
2045             }
2046             break;
2047         case 'C':
2048         case 'c':
2049             while (len-- > 0) {
2050                 fromstr = NEXTFROM;
2051                 switch (datumtype) {
2052                 case 'C':
2053                     aint = SvIV(fromstr);
2054                     if ((aint < 0 || aint > 255) &&
2055                         ckWARN(WARN_PACK))
2056                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2057                                     "Character in \"C\" format wrapped");
2058                     achar = aint & 255;
2059                     sv_catpvn(cat, &achar, sizeof(char));
2060                     break;
2061                 case 'c':
2062                     aint = SvIV(fromstr);
2063                     if ((aint < -128 || aint > 127) &&
2064                         ckWARN(WARN_PACK))
2065                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2066                                     "Character in \"c\" format wrapped");
2067                     achar = aint & 255;
2068                     sv_catpvn(cat, &achar, sizeof(char));
2069                     break;
2070                 }
2071             }
2072             break;
2073         case 'U':
2074             while (len-- > 0) {
2075                 fromstr = NEXTFROM;
2076                 auint = UNI_TO_NATIVE(SvUV(fromstr));
2077                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2078                 SvCUR_set(cat,
2079                           (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2080                                                      auint,
2081                                                      ckWARN(WARN_UTF8) ?
2082                                                      0 : UNICODE_ALLOW_ANY)
2083                           - SvPVX(cat));
2084             }
2085             *SvEND(cat) = '\0';
2086             break;
2087         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2088         case 'f':
2089             while (len-- > 0) {
2090                 fromstr = NEXTFROM;
2091 #ifdef __VOS__
2092 /* VOS does not automatically map a floating-point overflow
2093    during conversion from double to float into infinity, so we
2094    do it by hand.  This code should either be generalized for
2095    any OS that needs it, or removed if and when VOS implements
2096    posix-976 (suggestion to support mapping to infinity).
2097    Paul.Green@stratus.com 02-04-02.  */
2098                 if (SvNV(fromstr) > FLT_MAX)
2099                      afloat = _float_constants[0];   /* single prec. inf. */
2100                 else if (SvNV(fromstr) < -FLT_MAX)
2101                      afloat = _float_constants[0];   /* single prec. inf. */
2102                 else afloat = (float)SvNV(fromstr);
2103 #else
2104                 afloat = (float)SvNV(fromstr);
2105 #endif
2106                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2107             }
2108             break;
2109         case 'd':
2110             while (len-- > 0) {
2111                 fromstr = NEXTFROM;
2112 #ifdef __VOS__
2113 /* VOS does not automatically map a floating-point overflow
2114    during conversion from long double to double into infinity,
2115    so we do it by hand.  This code should either be generalized
2116    for any OS that needs it, or removed if and when VOS
2117    implements posix-976 (suggestion to support mapping to
2118    infinity).  Paul.Green@stratus.com 02-04-02.  */
2119                 if (SvNV(fromstr) > DBL_MAX)
2120                      adouble = _double_constants[0];   /* double prec. inf. */
2121                 else if (SvNV(fromstr) < -DBL_MAX)
2122                      adouble = _double_constants[0];   /* double prec. inf. */
2123                 else adouble = (double)SvNV(fromstr);
2124 #else
2125                 adouble = (double)SvNV(fromstr);
2126 #endif
2127                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2128             }
2129             break;
2130         case 'F':
2131             while (len-- > 0) {
2132                 fromstr = NEXTFROM;
2133                 anv = SvNV(fromstr);
2134                 sv_catpvn(cat, (char *)&anv, NVSIZE);
2135             }
2136             break;
2137 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2138         case 'D':
2139             while (len-- > 0) {
2140                 fromstr = NEXTFROM;
2141                 aldouble = (long double)SvNV(fromstr);
2142                 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2143             }
2144             break;
2145 #endif
2146         case 'n':
2147             while (len-- > 0) {
2148                 fromstr = NEXTFROM;
2149                 ashort = (I16)SvIV(fromstr);
2150 #ifdef HAS_HTONS
2151                 ashort = PerlSock_htons(ashort);
2152 #endif
2153                 CAT16(cat, &ashort);
2154             }
2155             break;
2156         case 'v':
2157             while (len-- > 0) {
2158                 fromstr = NEXTFROM;
2159                 ashort = (I16)SvIV(fromstr);
2160 #ifdef HAS_HTOVS
2161                 ashort = htovs(ashort);
2162 #endif
2163                 CAT16(cat, &ashort);
2164             }
2165             break;
2166         case 'S':
2167 #if SHORTSIZE != SIZE16
2168             if (natint) {
2169                 unsigned short aushort;
2170
2171                 while (len-- > 0) {
2172                     fromstr = NEXTFROM;
2173                     aushort = SvUV(fromstr);
2174                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2175                 }
2176             }
2177             else
2178 #endif
2179             {
2180                 U16 aushort;
2181
2182                 while (len-- > 0) {
2183                     fromstr = NEXTFROM;
2184                     aushort = (U16)SvUV(fromstr);
2185                     CAT16(cat, &aushort);
2186                 }
2187
2188             }
2189             break;
2190         case 's':
2191 #if SHORTSIZE != SIZE16
2192             if (natint) {
2193                 short ashort;
2194
2195                 while (len-- > 0) {
2196                     fromstr = NEXTFROM;
2197                     ashort = SvIV(fromstr);
2198                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
2199                 }
2200             }
2201             else
2202 #endif
2203             {
2204                 while (len-- > 0) {
2205                     fromstr = NEXTFROM;
2206                     ashort = (I16)SvIV(fromstr);
2207                     CAT16(cat, &ashort);
2208                 }
2209             }
2210             break;
2211         case 'I':
2212             while (len-- > 0) {
2213                 fromstr = NEXTFROM;
2214                 auint = SvUV(fromstr);
2215                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2216             }
2217             break;
2218         case 'j':
2219             while (len-- > 0) {
2220                 fromstr = NEXTFROM;
2221                 aiv = SvIV(fromstr);
2222                 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2223             }
2224             break;
2225         case 'J':
2226             while (len-- > 0) {
2227                 fromstr = NEXTFROM;
2228                 auv = SvUV(fromstr);
2229                 sv_catpvn(cat, (char*)&auv, UVSIZE);
2230             }
2231             break;
2232         case 'w':
2233             while (len-- > 0) {
2234                 fromstr = NEXTFROM;
2235                 adouble = SvNV(fromstr);
2236
2237                 if (adouble < 0)
2238                     Perl_croak(aTHX_ "Cannot compress negative numbers");
2239
2240                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2241                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2242                    any negative IVs will have already been got by the croak()
2243                    above. IOK is untrue for fractions, so we test them
2244                    against UV_MAX_P1.  */
2245                 if (SvIOK(fromstr) || adouble < UV_MAX_P1)
2246                 {
2247                     char   buf[(sizeof(UV)*8)/7+1];
2248                     char  *in = buf + sizeof(buf);
2249                     UV     auv = SvUV(fromstr);
2250
2251                     do {
2252                         *--in = (char)((auv & 0x7f) | 0x80);
2253                         auv >>= 7;
2254                     } while (auv);
2255                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2256                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2257                 }
2258                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
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                 else if (SvNOKp(fromstr)) {
2280                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
2281                     char  *in = buf + sizeof(buf);
2282
2283                     adouble = Perl_floor(adouble);
2284                     do {
2285                         double next = floor(adouble / 128);
2286                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
2287                         if (in <= buf)  /* this cannot happen ;-) */
2288                             Perl_croak(aTHX_ "Cannot compress integer");
2289                         adouble = next;
2290                     } while (adouble > 0);
2291                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2292                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2293                 }
2294                 else {
2295                     char           *from, *result, *in;
2296                     SV             *norm;
2297                     STRLEN          len;
2298                     bool            done;
2299
2300                     /* Copy string and check for compliance */
2301                     from = SvPV(fromstr, len);
2302                     if ((norm = is_an_int(from, len)) == NULL)
2303                         Perl_croak(aTHX_ "can compress only unsigned integer");
2304
2305                     New('w', result, len, char);
2306                     in = result + len;
2307                     done = FALSE;
2308                     while (!done)
2309                         *--in = div128(norm, &done) | 0x80;
2310                     result[len - 1] &= 0x7F; /* clear continue bit */
2311                     sv_catpvn(cat, in, (result + len) - in);
2312                     Safefree(result);
2313                     SvREFCNT_dec(norm); /* free norm */
2314                }
2315             }
2316             break;
2317         case 'i':
2318             while (len-- > 0) {
2319                 fromstr = NEXTFROM;
2320                 aint = SvIV(fromstr);
2321                 sv_catpvn(cat, (char*)&aint, sizeof(int));
2322             }
2323             break;
2324         case 'N':
2325             while (len-- > 0) {
2326                 fromstr = NEXTFROM;
2327                 aulong = SvUV(fromstr);
2328 #ifdef HAS_HTONL
2329                 aulong = PerlSock_htonl(aulong);
2330 #endif
2331                 CAT32(cat, &aulong);
2332             }
2333             break;
2334         case 'V':
2335             while (len-- > 0) {
2336                 fromstr = NEXTFROM;
2337                 aulong = SvUV(fromstr);
2338 #ifdef HAS_HTOVL
2339                 aulong = htovl(aulong);
2340 #endif
2341                 CAT32(cat, &aulong);
2342             }
2343             break;
2344         case 'L':
2345 #if LONGSIZE != SIZE32
2346             if (natint) {
2347                 unsigned long aulong;
2348
2349                 while (len-- > 0) {
2350                     fromstr = NEXTFROM;
2351                     aulong = SvUV(fromstr);
2352                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2353                 }
2354             }
2355             else
2356 #endif
2357             {
2358                 while (len-- > 0) {
2359                     fromstr = NEXTFROM;
2360                     aulong = SvUV(fromstr);
2361                     CAT32(cat, &aulong);
2362                 }
2363             }
2364             break;
2365         case 'l':
2366 #if LONGSIZE != SIZE32
2367             if (natint) {
2368                 long along;
2369
2370                 while (len-- > 0) {
2371                     fromstr = NEXTFROM;
2372                     along = SvIV(fromstr);
2373                     sv_catpvn(cat, (char *)&along, sizeof(long));
2374                 }
2375             }
2376             else
2377 #endif
2378             {
2379                 while (len-- > 0) {
2380                     fromstr = NEXTFROM;
2381                     along = SvIV(fromstr);
2382                     CAT32(cat, &along);
2383                 }
2384             }
2385             break;
2386 #ifdef HAS_QUAD
2387         case 'Q':
2388             while (len-- > 0) {
2389                 fromstr = NEXTFROM;
2390                 auquad = (Uquad_t)SvUV(fromstr);
2391                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2392             }
2393             break;
2394         case 'q':
2395             while (len-- > 0) {
2396                 fromstr = NEXTFROM;
2397                 aquad = (Quad_t)SvIV(fromstr);
2398                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2399             }
2400             break;
2401 #endif
2402         case 'P':
2403             len = 1;            /* assume SV is correct length */
2404             /* FALL THROUGH */
2405         case 'p':
2406             while (len-- > 0) {
2407                 fromstr = NEXTFROM;
2408                 if (fromstr == &PL_sv_undef)
2409                     aptr = NULL;
2410                 else {
2411                     STRLEN n_a;
2412                     /* XXX better yet, could spirit away the string to
2413                      * a safe spot and hang on to it until the result
2414                      * of pack() (and all copies of the result) are
2415                      * gone.
2416                      */
2417                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2418                                                 || (SvPADTMP(fromstr)
2419                                                     && !SvREADONLY(fromstr))))
2420                     {
2421                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2422                                 "Attempt to pack pointer to temporary value");
2423                     }
2424                     if (SvPOK(fromstr) || SvNIOK(fromstr))
2425                         aptr = SvPV(fromstr,n_a);
2426                     else
2427                         aptr = SvPV_force(fromstr,n_a);
2428                 }
2429                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2430             }
2431             break;
2432         case 'u':
2433             fromstr = NEXTFROM;
2434             aptr = SvPV(fromstr, fromlen);
2435             SvGROW(cat, fromlen * 4 / 3);
2436             if (len <= 2)
2437                 len = 45;
2438             else
2439                 len = len / 3 * 3;
2440             while (fromlen > 0) {
2441                 I32 todo;
2442
2443                 if ((I32)fromlen > len)
2444                     todo = len;
2445                 else
2446                     todo = fromlen;
2447                 doencodes(cat, aptr, todo);
2448                 fromlen -= todo;
2449                 aptr += todo;
2450             }
2451             break;
2452         }
2453     }
2454     if (next_in_list)
2455         *next_in_list = beglist;
2456 }
2457 #undef NEXTFROM
2458
2459
2460 PP(pp_pack)
2461 {
2462     dSP; dMARK; dORIGMARK; dTARGET;
2463     register SV *cat = TARG;
2464     STRLEN fromlen;
2465     register char *pat = SvPVx(*++MARK, fromlen);
2466     register char *patend = pat + fromlen;
2467
2468     MARK++;
2469     sv_setpvn(cat, "", 0);
2470
2471     pack_cat(cat, pat, patend, MARK, SP + 1, NULL, 0);
2472
2473     SvSETMAGIC(cat);
2474     SP = ORIGMARK;
2475     PUSHs(cat);
2476     RETURN;
2477 }
2478