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