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 # if defined(VMS) && !defined(__IEEE_FP)
2105 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2106  * on Alpha; fake it if we don't have them.
2107  */
2108                 if (SvNV(fromstr) > FLT_MAX)
2109                      afloat = FLT_MAX;
2110                 else if (SvNV(fromstr) < -FLT_MAX)
2111                      afloat = -FLT_MAX;
2112                 else afloat = (float)SvNV(fromstr);
2113 # else
2114                 afloat = (float)SvNV(fromstr);
2115 # endif
2116 #endif
2117                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2118             }
2119             break;
2120         case 'd':
2121             while (len-- > 0) {
2122                 fromstr = NEXTFROM;
2123 #ifdef __VOS__
2124 /* VOS does not automatically map a floating-point overflow
2125    during conversion from long double to double into infinity,
2126    so we do it by hand.  This code should either be generalized
2127    for any OS that needs it, or removed if and when VOS
2128    implements posix-976 (suggestion to support mapping to
2129    infinity).  Paul.Green@stratus.com 02-04-02.  */
2130                 if (SvNV(fromstr) > DBL_MAX)
2131                      adouble = _double_constants[0];   /* double prec. inf. */
2132                 else if (SvNV(fromstr) < -DBL_MAX)
2133                      adouble = _double_constants[0];   /* double prec. inf. */
2134                 else adouble = (double)SvNV(fromstr);
2135 #else
2136 # if defined(VMS) && !defined(__IEEE_FP)
2137 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2138  * on Alpha; fake it if we don't have them.
2139  */
2140                 if (SvNV(fromstr) > DBL_MAX)
2141                      adouble = DBL_MAX;
2142                 else if (SvNV(fromstr) < -DBL_MAX)
2143                      adouble = -DBL_MAX;
2144                 else adouble = (double)SvNV(fromstr);
2145 # else
2146                 adouble = (double)SvNV(fromstr);
2147 # endif
2148 #endif
2149                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2150             }
2151             break;
2152         case 'F':
2153             while (len-- > 0) {
2154                 fromstr = NEXTFROM;
2155                 anv = SvNV(fromstr);
2156                 sv_catpvn(cat, (char *)&anv, NVSIZE);
2157             }
2158             break;
2159 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2160         case 'D':
2161             while (len-- > 0) {
2162                 fromstr = NEXTFROM;
2163                 aldouble = (long double)SvNV(fromstr);
2164                 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2165             }
2166             break;
2167 #endif
2168         case 'n':
2169             while (len-- > 0) {
2170                 fromstr = NEXTFROM;
2171                 ashort = (I16)SvIV(fromstr);
2172 #ifdef HAS_HTONS
2173                 ashort = PerlSock_htons(ashort);
2174 #endif
2175                 CAT16(cat, &ashort);
2176             }
2177             break;
2178         case 'v':
2179             while (len-- > 0) {
2180                 fromstr = NEXTFROM;
2181                 ashort = (I16)SvIV(fromstr);
2182 #ifdef HAS_HTOVS
2183                 ashort = htovs(ashort);
2184 #endif
2185                 CAT16(cat, &ashort);
2186             }
2187             break;
2188         case 'S':
2189 #if SHORTSIZE != SIZE16
2190             if (natint) {
2191                 unsigned short aushort;
2192
2193                 while (len-- > 0) {
2194                     fromstr = NEXTFROM;
2195                     aushort = SvUV(fromstr);
2196                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2197                 }
2198             }
2199             else
2200 #endif
2201             {
2202                 U16 aushort;
2203
2204                 while (len-- > 0) {
2205                     fromstr = NEXTFROM;
2206                     aushort = (U16)SvUV(fromstr);
2207                     CAT16(cat, &aushort);
2208                 }
2209
2210             }
2211             break;
2212         case 's':
2213 #if SHORTSIZE != SIZE16
2214             if (natint) {
2215                 short ashort;
2216
2217                 while (len-- > 0) {
2218                     fromstr = NEXTFROM;
2219                     ashort = SvIV(fromstr);
2220                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
2221                 }
2222             }
2223             else
2224 #endif
2225             {
2226                 while (len-- > 0) {
2227                     fromstr = NEXTFROM;
2228                     ashort = (I16)SvIV(fromstr);
2229                     CAT16(cat, &ashort);
2230                 }
2231             }
2232             break;
2233         case 'I':
2234             while (len-- > 0) {
2235                 fromstr = NEXTFROM;
2236                 auint = SvUV(fromstr);
2237                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2238             }
2239             break;
2240         case 'j':
2241             while (len-- > 0) {
2242                 fromstr = NEXTFROM;
2243                 aiv = SvIV(fromstr);
2244                 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2245             }
2246             break;
2247         case 'J':
2248             while (len-- > 0) {
2249                 fromstr = NEXTFROM;
2250                 auv = SvUV(fromstr);
2251                 sv_catpvn(cat, (char*)&auv, UVSIZE);
2252             }
2253             break;
2254         case 'w':
2255             while (len-- > 0) {
2256                 fromstr = NEXTFROM;
2257                 anv = SvNV(fromstr);
2258
2259                 if (anv < 0)
2260                     Perl_croak(aTHX_ "Cannot compress negative numbers");
2261
2262                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2263                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2264                    any negative IVs will have already been got by the croak()
2265                    above. IOK is untrue for fractions, so we test them
2266                    against UV_MAX_P1.  */
2267                 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2268                 {
2269                     char   buf[(sizeof(UV)*8)/7+1];
2270                     char  *in = buf + sizeof(buf);
2271                     UV     auv = SvUV(fromstr);
2272
2273                     do {
2274                         *--in = (char)((auv & 0x7f) | 0x80);
2275                         auv >>= 7;
2276                     } while (auv);
2277                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2278                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2279                 }
2280                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
2281                     char           *from, *result, *in;
2282                     SV             *norm;
2283                     STRLEN          len;
2284                     bool            done;
2285
2286                     /* Copy string and check for compliance */
2287                     from = SvPV(fromstr, len);
2288                     if ((norm = is_an_int(from, len)) == NULL)
2289                         Perl_croak(aTHX_ "can compress only unsigned integer");
2290
2291                     New('w', result, len, char);
2292                     in = result + len;
2293                     done = FALSE;
2294                     while (!done)
2295                         *--in = div128(norm, &done) | 0x80;
2296                     result[len - 1] &= 0x7F; /* clear continue bit */
2297                     sv_catpvn(cat, in, (result + len) - in);
2298                     Safefree(result);
2299                     SvREFCNT_dec(norm); /* free norm */
2300                 }
2301                 else if (SvNOKp(fromstr)) {
2302                     char   buf[sizeof(NV) * 2]; /* 8/7 <= 2 */
2303                     char  *in = buf + sizeof(buf);
2304
2305                     anv = Perl_floor(anv);
2306                     do {
2307                         NV next = Perl_floor(anv / 128);
2308                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2309                         if (in <= buf)  /* this cannot happen ;-) */
2310                             Perl_croak(aTHX_ "Cannot compress integer");
2311                         anv = next;
2312                     } while (anv > 0);
2313                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2314                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2315                 }
2316                 else {
2317                     char           *from, *result, *in;
2318                     SV             *norm;
2319                     STRLEN          len;
2320                     bool            done;
2321
2322                     /* Copy string and check for compliance */
2323                     from = SvPV(fromstr, len);
2324                     if ((norm = is_an_int(from, len)) == NULL)
2325                         Perl_croak(aTHX_ "can compress only unsigned integer");
2326
2327                     New('w', result, len, char);
2328                     in = result + len;
2329                     done = FALSE;
2330                     while (!done)
2331                         *--in = div128(norm, &done) | 0x80;
2332                     result[len - 1] &= 0x7F; /* clear continue bit */
2333                     sv_catpvn(cat, in, (result + len) - in);
2334                     Safefree(result);
2335                     SvREFCNT_dec(norm); /* free norm */
2336                }
2337             }
2338             break;
2339         case 'i':
2340             while (len-- > 0) {
2341                 fromstr = NEXTFROM;
2342                 aint = SvIV(fromstr);
2343                 sv_catpvn(cat, (char*)&aint, sizeof(int));
2344             }
2345             break;
2346         case 'N':
2347             while (len-- > 0) {
2348                 fromstr = NEXTFROM;
2349                 aulong = SvUV(fromstr);
2350 #ifdef HAS_HTONL
2351                 aulong = PerlSock_htonl(aulong);
2352 #endif
2353                 CAT32(cat, &aulong);
2354             }
2355             break;
2356         case 'V':
2357             while (len-- > 0) {
2358                 fromstr = NEXTFROM;
2359                 aulong = SvUV(fromstr);
2360 #ifdef HAS_HTOVL
2361                 aulong = htovl(aulong);
2362 #endif
2363                 CAT32(cat, &aulong);
2364             }
2365             break;
2366         case 'L':
2367 #if LONGSIZE != SIZE32
2368             if (natint) {
2369                 unsigned long aulong;
2370
2371                 while (len-- > 0) {
2372                     fromstr = NEXTFROM;
2373                     aulong = SvUV(fromstr);
2374                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2375                 }
2376             }
2377             else
2378 #endif
2379             {
2380                 while (len-- > 0) {
2381                     fromstr = NEXTFROM;
2382                     aulong = SvUV(fromstr);
2383                     CAT32(cat, &aulong);
2384                 }
2385             }
2386             break;
2387         case 'l':
2388 #if LONGSIZE != SIZE32
2389             if (natint) {
2390                 long along;
2391
2392                 while (len-- > 0) {
2393                     fromstr = NEXTFROM;
2394                     along = SvIV(fromstr);
2395                     sv_catpvn(cat, (char *)&along, sizeof(long));
2396                 }
2397             }
2398             else
2399 #endif
2400             {
2401                 while (len-- > 0) {
2402                     fromstr = NEXTFROM;
2403                     along = SvIV(fromstr);
2404                     CAT32(cat, &along);
2405                 }
2406             }
2407             break;
2408 #ifdef HAS_QUAD
2409         case 'Q':
2410             while (len-- > 0) {
2411                 fromstr = NEXTFROM;
2412                 auquad = (Uquad_t)SvUV(fromstr);
2413                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2414             }
2415             break;
2416         case 'q':
2417             while (len-- > 0) {
2418                 fromstr = NEXTFROM;
2419                 aquad = (Quad_t)SvIV(fromstr);
2420                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2421             }
2422             break;
2423 #endif
2424         case 'P':
2425             len = 1;            /* assume SV is correct length */
2426             /* FALL THROUGH */
2427         case 'p':
2428             while (len-- > 0) {
2429                 fromstr = NEXTFROM;
2430                 if (fromstr == &PL_sv_undef)
2431                     aptr = NULL;
2432                 else {
2433                     STRLEN n_a;
2434                     /* XXX better yet, could spirit away the string to
2435                      * a safe spot and hang on to it until the result
2436                      * of pack() (and all copies of the result) are
2437                      * gone.
2438                      */
2439                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2440                                                 || (SvPADTMP(fromstr)
2441                                                     && !SvREADONLY(fromstr))))
2442                     {
2443                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2444                                 "Attempt to pack pointer to temporary value");
2445                     }
2446                     if (SvPOK(fromstr) || SvNIOK(fromstr))
2447                         aptr = SvPV(fromstr,n_a);
2448                     else
2449                         aptr = SvPV_force(fromstr,n_a);
2450                 }
2451                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2452             }
2453             break;
2454         case 'u':
2455             fromstr = NEXTFROM;
2456             aptr = SvPV(fromstr, fromlen);
2457             SvGROW(cat, fromlen * 4 / 3);
2458             if (len <= 2)
2459                 len = 45;
2460             else
2461                 len = len / 3 * 3;
2462             while (fromlen > 0) {
2463                 I32 todo;
2464
2465                 if ((I32)fromlen > len)
2466                     todo = len;
2467                 else
2468                     todo = fromlen;
2469                 doencodes(cat, aptr, todo);
2470                 fromlen -= todo;
2471                 aptr += todo;
2472             }
2473             break;
2474         }
2475     }
2476     if (next_in_list)
2477         *next_in_list = beglist;
2478 }
2479 #undef NEXTFROM
2480
2481
2482 PP(pp_pack)
2483 {
2484     dSP; dMARK; dORIGMARK; dTARGET;
2485     register SV *cat = TARG;
2486     STRLEN fromlen;
2487     register char *pat = SvPVx(*++MARK, fromlen);
2488     register char *patend = pat + fromlen;
2489
2490     MARK++;
2491     sv_setpvn(cat, "", 0);
2492
2493     pack_cat(cat, pat, patend, MARK, SP + 1, NULL, 0);
2494
2495     SvSETMAGIC(cat);
2496     SP = ORIGMARK;
2497     PUSHs(cat);
2498     RETURN;
2499 }
2500