pp_pack.c

   1 /*    pp_pack.c
   2  *
   3  *    Copyright (c) 1991-2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * He still hopefully carried some of his gear in his pack: a small tinder-box,
  12  * two small shallow pans, the smaller fitting into the larger; inside them a
  13  * wooden spoon, a short two-pronged fork and some skewers were stowed; and
  14  * hidden at the bottom of the pack in a flat wooden box a dwindling treasure,
  15  * some salt.
  16  */
  17
  18 #include "EXTERN.h"
  19 #define PERL_IN_PP_PACK_C
  20 #include "perl.h"
  21
  22 /*
  23  * The compiler on Concurrent CX/UX systems has a subtle bug which only
  24  * seems to show up when compiling pp.c - it generates the wrong double
  25  * precision constant value for (double)UV_MAX when used inline in the body
  26  * of the code below, so this makes a static variable up front (which the
  27  * compiler seems to get correct) and uses it in place of UV_MAX below.
  28  */
  29 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
  30 static double UV_MAX_cxux = ((double)UV_MAX);
  31 #endif
  32
  33 /*
  34  * Offset for integer pack/unpack.
  35  *
  36  * On architectures where I16 and I32 aren't really 16 and 32 bits,
  37  * which for now are all Crays, pack and unpack have to play games.
  38  */
  39
  40 /*
  41  * These values are required for portability of pack() output.
  42  * If they're not right on your machine, then pack() and unpack()
  43  * wouldn't work right anyway; you'll need to apply the Cray hack.
  44  * (I'd like to check them with #if, but you can't use sizeof() in
  45  * the preprocessor.)  --???
  46  */
  47 /*
  48     The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
  49     defines are now in config.h.  --Andy Dougherty  April 1998
  50  */
  51 #define SIZE16 2
  52 #define SIZE32 4
  53
  54 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
  55    --jhi Feb 1999 */
  56
  57 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
  58 #   define PERL_NATINT_PACK
  59 #endif
  60
  61 #if LONGSIZE > 4 && defined(_CRAY)
  62 #  if BYTEORDER == 0x12345678
  63 #    define OFF16(p)    (char*)(p)
  64 #    define OFF32(p)    (char*)(p)
  65 #  else
  66 #    if BYTEORDER == 0x87654321
  67 #      define OFF16(p)  ((char*)(p) + (sizeof(U16) - SIZE16))
  68 #      define OFF32(p)  ((char*)(p) + (sizeof(U32) - SIZE32))
  69 #    else
  70        }}}} bad cray byte order
  71 #    endif
  72 #  endif
  73 #  define COPY16(s,p)  (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
  74 #  define COPY32(s,p)  (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
  75 #  define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
  76 #  define CAT16(sv,p)  sv_catpvn(sv, OFF16(p), SIZE16)
  77 #  define CAT32(sv,p)  sv_catpvn(sv, OFF32(p), SIZE32)
  78 #else
  79 #  define COPY16(s,p)  Copy(s, p, SIZE16, char)
  80 #  define COPY32(s,p)  Copy(s, p, SIZE32, char)
  81 #  define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
  82 #  define CAT16(sv,p)  sv_catpvn(sv, (char*)(p), SIZE16)
  83 #  define CAT32(sv,p)  sv_catpvn(sv, (char*)(p), SIZE32)
  84 #endif
  85
  86 STATIC SV *
  87 S_mul128(pTHX_ SV *sv, U8 m)
  88 {
  89   STRLEN          len;
  90   char           *s = SvPV(sv, len);
  91   char           *t;
  92   U32             i = 0;
  93
  94   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
  95     SV             *tmpNew = newSVpvn("0000000000", 10);
  96
  97     sv_catsv(tmpNew, sv);
  98     SvREFCNT_dec(sv);           /* free old sv */
  99     sv = tmpNew;
 100     s = SvPV(sv, len);
 101   }
 102   t = s + len - 1;
 103   while (!*t)                   /* trailing '\0'? */
 104     t--;
 105   while (t > s) {
 106     i = ((*t - '0') << 7) + m;
 107     *(t--) = '0' + (i % 10);
 108     m = i / 10;
 109   }
 110   return (sv);
 111 }
 112
 113 /* Explosives and implosives. */
 114
 115 #if 'I' == 73 && 'J' == 74
 116 /* On an ASCII/ISO kind of system */
 117 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
 118 #else
 119 /*
 120   Some other sort of character set - use memchr() so we don't match
 121   the null byte.
 122  */
 123 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
 124 #endif
 125
 126
 127 PP(pp_unpack)
 128 {
 129     dSP;
 130     dPOPPOPssrl;
 131     I32 start_sp_offset = SP - PL_stack_base;
 132     I32 gimme = GIMME_V;
 133     SV *sv;
 134     STRLEN llen;
 135     STRLEN rlen;
 136     register char *pat = SvPV(left, llen);
 137 #ifdef PACKED_IS_OCTETS
 138     /* Packed side is assumed to be octets - so force downgrade if it
 139        has been UTF-8 encoded by accident
 140      */
 141     register char *s = SvPVbyte(right, rlen);
 142 #else
 143     register char *s = SvPV(right, rlen);
 144 #endif
 145     char *strend = s + rlen;
 146     char *strbeg = s;
 147     register char *patend = pat + llen;
 148     I32 datumtype;
 149     register I32 len;
 150     register I32 bits = 0;
 151     register char *str;
 152
 153     /* These must not be in registers: */
 154     short ashort;
 155     int aint;
 156     long along;
 157 #ifdef HAS_QUAD
 158     Quad_t aquad;
 159 #endif
 160     U16 aushort;
 161     unsigned int auint;
 162     U32 aulong;
 163 #ifdef HAS_QUAD
 164     Uquad_t auquad;
 165 #endif
 166     char *aptr;
 167     float afloat;
 168     double adouble;
 169     I32 checksum = 0;
 170     UV culong = 0;
 171     NV cdouble = 0.0;
 172     const int bits_in_uv = 8 * sizeof(culong);
 173     int commas = 0;
 174     int star;
 175 #ifdef PERL_NATINT_PACK
 176     int natint;         /* native integer */
 177     int unatint;        /* unsigned native integer */
 178 #endif
 179     bool do_utf8 = DO_UTF8(right);
 180
 181     while (pat < patend) {
 182       reparse:
 183         datumtype = *pat++ & 0xFF;
 184 #ifdef PERL_NATINT_PACK
 185         natint = 0;
 186 #endif
 187         if (isSPACE(datumtype))
 188             continue;
 189         if (datumtype == '#') {
 190             while (pat < patend && *pat != '\n')
 191                 pat++;
 192             continue;
 193         }
 194         if (*pat == '!') {
 195             char *natstr = "sSiIlL";
 196
 197             if (strchr(natstr, datumtype)) {
 198 #ifdef PERL_NATINT_PACK
 199                 natint = 1;
 200 #endif
 201                 pat++;
 202             }
 203             else
 204                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
 205         }
 206         star = 0;
 207         if (pat >= patend)
 208             len = 1;
 209         else if (*pat == '*') {
 210             len = strend - strbeg;      /* long enough */
 211             pat++;
 212             star = 1;
 213         }
 214         else if (isDIGIT(*pat)) {
 215             len = *pat++ - '0';
 216             while (isDIGIT(*pat)) {
 217                 len = (len * 10) + (*pat++ - '0');
 218                 if (len < 0)
 219                     DIE(aTHX_ "Repeat count in unpack overflows");
 220             }
 221         }
 222         else
 223             len = (datumtype != '@');
 224       redo_switch:
 225         switch(datumtype) {
 226         default:
 227             DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
 228         case ',': /* grandfather in commas but with a warning */
 229             if (commas++ == 0 && ckWARN(WARN_UNPACK))
 230                 Perl_warner(aTHX_ WARN_UNPACK,
 231                             "Invalid type in unpack: '%c'", (int)datumtype);
 232             break;
 233         case '%':
 234             if (len == 1 && pat[-1] != '1')
 235                 len = 16;
 236             checksum = len;
 237             culong = 0;
 238             cdouble = 0;
 239             if (pat < patend)
 240                 goto reparse;
 241             break;
 242         case '@':
 243             if (len > strend - strbeg)
 244                 DIE(aTHX_ "@ outside of string");
 245             s = strbeg + len;
 246             break;
 247         case 'X':
 248             if (len > s - strbeg)
 249                 DIE(aTHX_ "X outside of string");
 250             s -= len;
 251             break;
 252         case 'x':
 253             if (len > strend - s)
 254                 DIE(aTHX_ "x outside of string");
 255             s += len;
 256             break;
 257         case '/':
 258             if (start_sp_offset >= SP - PL_stack_base)
 259                 DIE(aTHX_ "/ must follow a numeric type");
 260             datumtype = *pat++;
 261             if (*pat == '*')
 262                 pat++;          /* ignore '*' for compatibility with pack */
 263             if (isDIGIT(*pat))
 264                 DIE(aTHX_ "/ cannot take a count" );
 265             len = POPi;
 266             star = 0;
 267             goto redo_switch;
 268         case 'A':
 269         case 'Z':
 270         case 'a':
 271             if (len > strend - s)
 272                 len = strend - s;
 273             if (checksum)
 274                 goto uchar_checksum;
 275             sv = NEWSV(35, len);
 276             sv_setpvn(sv, s, len);
 277             if (datumtype == 'A' || datumtype == 'Z') {
 278                 aptr = s;       /* borrow register */
 279                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
 280                     s = SvPVX(sv);
 281                     while (*s)
 282                         s++;
 283                     if (star) /* exact for 'Z*' */
 284                         len = s - SvPVX(sv) + 1;
 285                 }
 286                 else {          /* 'A' strips both nulls and spaces */
 287                     s = SvPVX(sv) + len - 1;
 288                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
 289                         s--;
 290                     *++s = '\0';
 291                 }
 292                 SvCUR_set(sv, s - SvPVX(sv));
 293                 s = aptr;       /* unborrow register */
 294             }
 295             s += len;
 296             XPUSHs(sv_2mortal(sv));
 297             break;
 298         case 'B':
 299         case 'b':
 300             if (star || len > (strend - s) * 8)
 301                 len = (strend - s) * 8;
 302             if (checksum) {
 303                 if (!PL_bitcount) {
 304                     Newz(601, PL_bitcount, 256, char);
 305                     for (bits = 1; bits < 256; bits++) {
 306                         if (bits & 1)   PL_bitcount[bits]++;
 307                         if (bits & 2)   PL_bitcount[bits]++;
 308                         if (bits & 4)   PL_bitcount[bits]++;
 309                         if (bits & 8)   PL_bitcount[bits]++;
 310                         if (bits & 16)  PL_bitcount[bits]++;
 311                         if (bits & 32)  PL_bitcount[bits]++;
 312                         if (bits & 64)  PL_bitcount[bits]++;
 313                         if (bits & 128) PL_bitcount[bits]++;
 314                     }
 315                 }
 316                 while (len >= 8) {
 317                     culong += PL_bitcount[*(unsigned char*)s++];
 318                     len -= 8;
 319                 }
 320                 if (len) {
 321                     bits = *s;
 322                     if (datumtype == 'b') {
 323                         while (len-- > 0) {
 324                             if (bits & 1) culong++;
 325                             bits >>= 1;
 326                         }
 327                     }
 328                     else {
 329                         while (len-- > 0) {
 330                             if (bits & 128) culong++;
 331                             bits <<= 1;
 332                         }
 333                     }
 334                 }
 335                 break;
 336             }
 337             sv = NEWSV(35, len + 1);
 338             SvCUR_set(sv, len);
 339             SvPOK_on(sv);
 340             str = SvPVX(sv);
 341             if (datumtype == 'b') {
 342                 aint = len;
 343                 for (len = 0; len < aint; len++) {
 344                     if (len & 7)                /*SUPPRESS 595*/
 345                         bits >>= 1;
 346                     else
 347                         bits = *s++;
 348                     *str++ = '0' + (bits & 1);
 349                 }
 350             }
 351             else {
 352                 aint = len;
 353                 for (len = 0; len < aint; len++) {
 354                     if (len & 7)
 355                         bits <<= 1;
 356                     else
 357                         bits = *s++;
 358                     *str++ = '0' + ((bits & 128) != 0);
 359                 }
 360             }
 361             *str = '\0';
 362             XPUSHs(sv_2mortal(sv));
 363             break;
 364         case 'H':
 365         case 'h':
 366             if (star || len > (strend - s) * 2)
 367                 len = (strend - s) * 2;
 368             sv = NEWSV(35, len + 1);
 369             SvCUR_set(sv, len);
 370             SvPOK_on(sv);
 371             str = SvPVX(sv);
 372             if (datumtype == 'h') {
 373                 aint = len;
 374                 for (len = 0; len < aint; len++) {
 375                     if (len & 1)
 376                         bits >>= 4;
 377                     else
 378                         bits = *s++;
 379                     *str++ = PL_hexdigit[bits & 15];
 380                 }
 381             }
 382             else {
 383                 aint = len;
 384                 for (len = 0; len < aint; len++) {
 385                     if (len & 1)
 386                         bits <<= 4;
 387                     else
 388                         bits = *s++;
 389                     *str++ = PL_hexdigit[(bits >> 4) & 15];
 390                 }
 391             }
 392             *str = '\0';
 393             XPUSHs(sv_2mortal(sv));
 394             break;
 395         case 'c':
 396             if (len > strend - s)
 397                 len = strend - s;
 398             if (checksum) {
 399                 while (len-- > 0) {
 400                     aint = *s++;
 401                     if (aint >= 128)    /* fake up signed chars */
 402                         aint -= 256;
 403                     if (checksum > bits_in_uv)
 404                         cdouble += (NV)aint;
 405                     else
 406                         culong += aint;
 407                 }
 408             }
 409             else {
 410                 EXTEND(SP, len);
 411                 EXTEND_MORTAL(len);
 412                 while (len-- > 0) {
 413                     aint = *s++;
 414                     if (aint >= 128)    /* fake up signed chars */
 415                         aint -= 256;
 416                     sv = NEWSV(36, 0);
 417                     sv_setiv(sv, (IV)aint);
 418                     PUSHs(sv_2mortal(sv));
 419                 }
 420             }
 421             break;
 422         case 'C':
 423         unpack_C: /* unpack U will jump here if not UTF-8 */
 424             if (len == 0) {
 425                 do_utf8 = FALSE;
 426                 break;
 427             }
 428             if (len > strend - s)
 429                 len = strend - s;
 430             if (checksum) {
 431               uchar_checksum:
 432                 while (len-- > 0) {
 433                     auint = *s++ & 255;
 434                     culong += auint;
 435                 }
 436             }
 437             else {
 438                 EXTEND(SP, len);
 439                 EXTEND_MORTAL(len);
 440                 while (len-- > 0) {
 441                     auint = *s++ & 255;
 442                     sv = NEWSV(37, 0);
 443                     sv_setiv(sv, (IV)auint);
 444                     PUSHs(sv_2mortal(sv));
 445                 }
 446             }
 447             break;
 448         case 'U':
 449             if (len == 0) {
 450                 do_utf8 = TRUE;
 451                 break;
 452             }
 453             if (!do_utf8)
 454                  goto unpack_C;
 455             if (len > strend - s)
 456                 len = strend - s;
 457             if (checksum) {
 458                 while (len-- > 0 && s < strend) {
 459                     STRLEN alen;
 460                     auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, 0));
 461                     along = alen;
 462                     s += along;
 463                     if (checksum > bits_in_uv)
 464                         cdouble += (NV)auint;
 465                     else
 466                         culong += auint;
 467                 }
 468             }
 469             else {
 470                 EXTEND(SP, len);
 471                 EXTEND_MORTAL(len);
 472                 while (len-- > 0 && s < strend) {
 473                     STRLEN alen;
 474                     auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, 0));
 475                     along = alen;
 476                     s += along;
 477                     sv = NEWSV(37, 0);
 478                     sv_setuv(sv, (UV)auint);
 479                     PUSHs(sv_2mortal(sv));
 480                 }
 481             }
 482             break;
 483         case 's':
 484 #if SHORTSIZE == SIZE16
 485             along = (strend - s) / SIZE16;
 486 #else
 487             along = (strend - s) / (natint ? sizeof(short) : SIZE16);
 488 #endif
 489             if (len > along)
 490                 len = along;
 491             if (checksum) {
 492 #if SHORTSIZE != SIZE16
 493                 if (natint) {
 494                     short ashort;
 495                     while (len-- > 0) {
 496                         COPYNN(s, &ashort, sizeof(short));
 497                         s += sizeof(short);
 498                         if (checksum > bits_in_uv)
 499                             cdouble += (NV)ashort;
 500                         else
 501                             culong += ashort;
 502
 503                     }
 504                 }
 505                 else
 506 #endif
 507                 {
 508                     while (len-- > 0) {
 509                         COPY16(s, &ashort);
 510 #if SHORTSIZE > SIZE16
 511                         if (ashort > 32767)
 512                           ashort -= 65536;
 513 #endif
 514                         s += SIZE16;
 515                         if (checksum > bits_in_uv)
 516                             cdouble += (NV)ashort;
 517                         else
 518                             culong += ashort;
 519                     }
 520                 }
 521             }
 522             else {
 523                 EXTEND(SP, len);
 524                 EXTEND_MORTAL(len);
 525 #if SHORTSIZE != SIZE16
 526                 if (natint) {
 527                     short ashort;
 528                     while (len-- > 0) {
 529                         COPYNN(s, &ashort, sizeof(short));
 530                         s += sizeof(short);
 531                         sv = NEWSV(38, 0);
 532                         sv_setiv(sv, (IV)ashort);
 533                         PUSHs(sv_2mortal(sv));
 534                     }
 535                 }
 536                 else
 537 #endif
 538                 {
 539                     while (len-- > 0) {
 540                         COPY16(s, &ashort);
 541 #if SHORTSIZE > SIZE16
 542                         if (ashort > 32767)
 543                           ashort -= 65536;
 544 #endif
 545                         s += SIZE16;
 546                         sv = NEWSV(38, 0);
 547                         sv_setiv(sv, (IV)ashort);
 548                         PUSHs(sv_2mortal(sv));
 549                     }
 550                 }
 551             }
 552             break;
 553         case 'v':
 554         case 'n':
 555         case 'S':
 556 #if SHORTSIZE == SIZE16
 557             along = (strend - s) / SIZE16;
 558 #else
 559             unatint = natint && datumtype == 'S';
 560             along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
 561 #endif
 562             if (len > along)
 563                 len = along;
 564             if (checksum) {
 565 #if SHORTSIZE != SIZE16
 566                 if (unatint) {
 567                     unsigned short aushort;
 568                     while (len-- > 0) {
 569                         COPYNN(s, &aushort, sizeof(unsigned short));
 570                         s += sizeof(unsigned short);
 571                         if (checksum > bits_in_uv)
 572                             cdouble += (NV)aushort;
 573                         else
 574                             culong += aushort;
 575                     }
 576                 }
 577                 else
 578 #endif
 579                 {
 580                     while (len-- > 0) {
 581                         COPY16(s, &aushort);
 582                         s += SIZE16;
 583 #ifdef HAS_NTOHS
 584                         if (datumtype == 'n')
 585                             aushort = PerlSock_ntohs(aushort);
 586 #endif
 587 #ifdef HAS_VTOHS
 588                         if (datumtype == 'v')
 589                             aushort = vtohs(aushort);
 590 #endif
 591                         if (checksum > bits_in_uv)
 592                             cdouble += (NV)aushort;
 593                         else
 594                             culong += aushort;
 595                     }
 596                 }
 597             }
 598             else {
 599                 EXTEND(SP, len);
 600                 EXTEND_MORTAL(len);
 601 #if SHORTSIZE != SIZE16
 602                 if (unatint) {
 603                     unsigned short aushort;
 604                     while (len-- > 0) {
 605                         COPYNN(s, &aushort, sizeof(unsigned short));
 606                         s += sizeof(unsigned short);
 607                         sv = NEWSV(39, 0);
 608                         sv_setiv(sv, (UV)aushort);
 609                         PUSHs(sv_2mortal(sv));
 610                     }
 611                 }
 612                 else
 613 #endif
 614                 {
 615                     while (len-- > 0) {
 616                         COPY16(s, &aushort);
 617                         s += SIZE16;
 618                         sv = NEWSV(39, 0);
 619 #ifdef HAS_NTOHS
 620                         if (datumtype == 'n')
 621                             aushort = PerlSock_ntohs(aushort);
 622 #endif
 623 #ifdef HAS_VTOHS
 624                         if (datumtype == 'v')
 625                             aushort = vtohs(aushort);
 626 #endif
 627                         sv_setiv(sv, (UV)aushort);
 628                         PUSHs(sv_2mortal(sv));
 629                     }
 630                 }
 631             }
 632             break;
 633         case 'i':
 634             along = (strend - s) / sizeof(int);
 635             if (len > along)
 636                 len = along;
 637             if (checksum) {
 638                 while (len-- > 0) {
 639                     Copy(s, &aint, 1, int);
 640                     s += sizeof(int);
 641                     if (checksum > bits_in_uv)
 642                         cdouble += (NV)aint;
 643                     else
 644                         culong += aint;
 645                 }
 646             }
 647             else {
 648                 EXTEND(SP, len);
 649                 EXTEND_MORTAL(len);
 650                 while (len-- > 0) {
 651                     Copy(s, &aint, 1, int);
 652                     s += sizeof(int);
 653                     sv = NEWSV(40, 0);
 654 #ifdef __osf__
 655                     /* Without the dummy below unpack("i", pack("i",-1))
 656                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
 657                      * cc with optimization turned on.
 658                      *
 659                      * The bug was detected in
 660                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
 661                      * with optimization (-O4) turned on.
 662                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
 663                      * does not have this problem even with -O4.
 664                      *
 665                      * This bug was reported as DECC_BUGS 1431
 666                      * and tracked internally as GEM_BUGS 7775.
 667                      *
 668                      * The bug is fixed in
 669                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
 670                      * UNIX V4.0F support:   DEC C V5.9-006 or later
 671                      * UNIX V4.0E support:   DEC C V5.8-011 or later
 672                      * and also in DTK.
 673                      *
 674                      * See also few lines later for the same bug.
 675                      */
 676                     (aint) ?
 677                         sv_setiv(sv, (IV)aint) :
 678 #endif
 679                     sv_setiv(sv, (IV)aint);
 680                     PUSHs(sv_2mortal(sv));
 681                 }
 682             }
 683             break;
 684         case 'I':
 685             along = (strend - s) / sizeof(unsigned int);
 686             if (len > along)
 687                 len = along;
 688             if (checksum) {
 689                 while (len-- > 0) {
 690                     Copy(s, &auint, 1, unsigned int);
 691                     s += sizeof(unsigned int);
 692                     if (checksum > bits_in_uv)
 693                         cdouble += (NV)auint;
 694                     else
 695                         culong += auint;
 696                 }
 697             }
 698             else {
 699                 EXTEND(SP, len);
 700                 EXTEND_MORTAL(len);
 701                 while (len-- > 0) {
 702                     Copy(s, &auint, 1, unsigned int);
 703                     s += sizeof(unsigned int);
 704                     sv = NEWSV(41, 0);
 705 #ifdef __osf__
 706                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
 707                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
 708                      * See details few lines earlier. */
 709                     (auint) ?
 710                         sv_setuv(sv, (UV)auint) :
 711 #endif
 712                     sv_setuv(sv, (UV)auint);
 713                     PUSHs(sv_2mortal(sv));
 714                 }
 715             }
 716             break;
 717         case 'l':
 718 #if LONGSIZE == SIZE32
 719             along = (strend - s) / SIZE32;
 720 #else
 721             along = (strend - s) / (natint ? sizeof(long) : SIZE32);
 722 #endif
 723             if (len > along)
 724                 len = along;
 725             if (checksum) {
 726 #if LONGSIZE != SIZE32
 727                 if (natint) {
 728                     while (len-- > 0) {
 729                         COPYNN(s, &along, sizeof(long));
 730                         s += sizeof(long);
 731                         if (checksum > bits_in_uv)
 732                             cdouble += (NV)along;
 733                         else
 734                             culong += along;
 735                     }
 736                 }
 737                 else
 738 #endif
 739                 {
 740                     while (len-- > 0) {
 741 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
 742                         I32 along;
 743 #endif
 744                         COPY32(s, &along);
 745 #if LONGSIZE > SIZE32
 746                         if (along > 2147483647)
 747                           along -= 4294967296;
 748 #endif
 749                         s += SIZE32;
 750                         if (checksum > bits_in_uv)
 751                             cdouble += (NV)along;
 752                         else
 753                             culong += along;
 754                     }
 755                 }
 756             }
 757             else {
 758                 EXTEND(SP, len);
 759                 EXTEND_MORTAL(len);
 760 #if LONGSIZE != SIZE32
 761                 if (natint) {
 762                     while (len-- > 0) {
 763                         COPYNN(s, &along, sizeof(long));
 764                         s += sizeof(long);
 765                         sv = NEWSV(42, 0);
 766                         sv_setiv(sv, (IV)along);
 767                         PUSHs(sv_2mortal(sv));
 768                     }
 769                 }
 770                 else
 771 #endif
 772                 {
 773                     while (len-- > 0) {
 774 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
 775                         I32 along;
 776 #endif
 777                         COPY32(s, &along);
 778 #if LONGSIZE > SIZE32
 779                         if (along > 2147483647)
 780                           along -= 4294967296;
 781 #endif
 782                         s += SIZE32;
 783                         sv = NEWSV(42, 0);
 784                         sv_setiv(sv, (IV)along);
 785                         PUSHs(sv_2mortal(sv));
 786                     }
 787                 }
 788             }
 789             break;
 790         case 'V':
 791         case 'N':
 792         case 'L':
 793 #if LONGSIZE == SIZE32
 794             along = (strend - s) / SIZE32;
 795 #else
 796             unatint = natint && datumtype == 'L';
 797             along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
 798 #endif
 799             if (len > along)
 800                 len = along;
 801             if (checksum) {
 802 #if LONGSIZE != SIZE32
 803                 if (unatint) {
 804                     unsigned long aulong;
 805                     while (len-- > 0) {
 806                         COPYNN(s, &aulong, sizeof(unsigned long));
 807                         s += sizeof(unsigned long);
 808                         if (checksum > bits_in_uv)
 809                             cdouble += (NV)aulong;
 810                         else
 811                             culong += aulong;
 812                     }
 813                 }
 814                 else
 815 #endif
 816                 {
 817                     while (len-- > 0) {
 818                         COPY32(s, &aulong);
 819                         s += SIZE32;
 820 #ifdef HAS_NTOHL
 821                         if (datumtype == 'N')
 822                             aulong = PerlSock_ntohl(aulong);
 823 #endif
 824 #ifdef HAS_VTOHL
 825                         if (datumtype == 'V')
 826                             aulong = vtohl(aulong);
 827 #endif
 828                         if (checksum > bits_in_uv)
 829                             cdouble += (NV)aulong;
 830                         else
 831                             culong += aulong;
 832                     }
 833                 }
 834             }
 835             else {
 836                 EXTEND(SP, len);
 837                 EXTEND_MORTAL(len);
 838 #if LONGSIZE != SIZE32
 839                 if (unatint) {
 840                     unsigned long aulong;
 841                     while (len-- > 0) {
 842                         COPYNN(s, &aulong, sizeof(unsigned long));
 843                         s += sizeof(unsigned long);
 844                         sv = NEWSV(43, 0);
 845                         sv_setuv(sv, (UV)aulong);
 846                         PUSHs(sv_2mortal(sv));
 847                     }
 848                 }
 849                 else
 850 #endif
 851                 {
 852                     while (len-- > 0) {
 853                         COPY32(s, &aulong);
 854                         s += SIZE32;
 855 #ifdef HAS_NTOHL
 856                         if (datumtype == 'N')
 857                             aulong = PerlSock_ntohl(aulong);
 858 #endif
 859 #ifdef HAS_VTOHL
 860                         if (datumtype == 'V')
 861                             aulong = vtohl(aulong);
 862 #endif
 863                         sv = NEWSV(43, 0);
 864                         sv_setuv(sv, (UV)aulong);
 865                         PUSHs(sv_2mortal(sv));
 866                     }
 867                 }
 868             }
 869             break;
 870         case 'p':
 871             along = (strend - s) / sizeof(char*);
 872             if (len > along)
 873                 len = along;
 874             EXTEND(SP, len);
 875             EXTEND_MORTAL(len);
 876             while (len-- > 0) {
 877                 if (sizeof(char*) > strend - s)
 878                     break;
 879                 else {
 880                     Copy(s, &aptr, 1, char*);
 881                     s += sizeof(char*);
 882                 }
 883                 sv = NEWSV(44, 0);
 884                 if (aptr)
 885                     sv_setpv(sv, aptr);
 886                 PUSHs(sv_2mortal(sv));
 887             }
 888             break;
 889         case 'w':
 890             EXTEND(SP, len);
 891             EXTEND_MORTAL(len);
 892             {
 893                 UV auv = 0;
 894                 U32 bytes = 0;
 895
 896                 while ((len > 0) && (s < strend)) {
 897                     auv = (auv << 7) | (*s & 0x7f);
 898                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
 899                     if ((U8)(*s++) < 0x80) {
 900                         bytes = 0;
 901                         sv = NEWSV(40, 0);
 902                         sv_setuv(sv, auv);
 903                         PUSHs(sv_2mortal(sv));
 904                         len--;
 905                         auv = 0;
 906                     }
 907                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
 908                         char *t;
 909                         STRLEN n_a;
 910
 911                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
 912                         while (s < strend) {
 913                             sv = mul128(sv, *s & 0x7f);
 914                             if (!(*s++ & 0x80)) {
 915                                 bytes = 0;
 916                                 break;
 917                             }
 918                         }
 919                         t = SvPV(sv, n_a);
 920                         while (*t == '0')
 921                             t++;
 922                         sv_chop(sv, t);
 923                         PUSHs(sv_2mortal(sv));
 924                         len--;
 925                         auv = 0;
 926                     }
 927                 }
 928                 if ((s >= strend) && bytes)
 929                     DIE(aTHX_ "Unterminated compressed integer");
 930             }
 931             break;
 932         case 'P':
 933             if (star)
 934                 DIE(aTHX_ "P must have an explicit size");
 935             EXTEND(SP, 1);
 936             if (sizeof(char*) > strend - s)
 937                 break;
 938             else {
 939                 Copy(s, &aptr, 1, char*);
 940                 s += sizeof(char*);
 941             }
 942             sv = NEWSV(44, 0);
 943             if (aptr)
 944                 sv_setpvn(sv, aptr, len);
 945             PUSHs(sv_2mortal(sv));
 946             break;
 947 #ifdef HAS_QUAD
 948         case 'q':
 949             along = (strend - s) / sizeof(Quad_t);
 950             if (len > along)
 951                 len = along;
 952             if (checksum) {
 953                 while (len-- > 0) {
 954                     Copy(s, &aquad, 1, Quad_t);
 955                     s += sizeof(Quad_t);
 956                     if (checksum > bits_in_uv)
 957                         cdouble += (NV)aquad;
 958                     else
 959                         culong += aquad;
 960                 }
 961             }
 962             else {
 963                 EXTEND(SP, len);
 964                 EXTEND_MORTAL(len);
 965                 while (len-- > 0) {
 966                     if (s + sizeof(Quad_t) > strend)
 967                         aquad = 0;
 968                     else {
 969                     Copy(s, &aquad, 1, Quad_t);
 970                     s += sizeof(Quad_t);
 971                     }
 972                     sv = NEWSV(42, 0);
 973                     if (aquad >= IV_MIN && aquad <= IV_MAX)
 974                     sv_setiv(sv, (IV)aquad);
 975                     else
 976                         sv_setnv(sv, (NV)aquad);
 977                     PUSHs(sv_2mortal(sv));
 978                 }
 979             }
 980             break;
 981         case 'Q':
 982             along = (strend - s) / sizeof(Quad_t);
 983             if (len > along)
 984                 len = along;
 985             if (checksum) {
 986                 while (len-- > 0) {
 987                     Copy(s, &auquad, 1, Uquad_t);
 988                     s += sizeof(Uquad_t);
 989                     if (checksum > bits_in_uv)
 990                         cdouble += (NV)auquad;
 991                     else
 992                         culong += auquad;
 993                 }
 994             }
 995             else {
 996                 EXTEND(SP, len);
 997                 EXTEND_MORTAL(len);
 998                 while (len-- > 0) {
 999                     if (s + sizeof(Uquad_t) > strend)
1000                         auquad = 0;
1001                     else {
1002                         Copy(s, &auquad, 1, Uquad_t);
1003                         s += sizeof(Uquad_t);
1004                     }
1005                     sv = NEWSV(43, 0);
1006                     if (auquad <= UV_MAX)
1007                         sv_setuv(sv, (UV)auquad);
1008                     else
1009                     sv_setnv(sv, (NV)auquad);
1010                     PUSHs(sv_2mortal(sv));
1011                 }
1012             }
1013             break;
1014 #endif
1015         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1016         case 'f':
1017         case 'F':
1018             along = (strend - s) / sizeof(float);
1019             if (len > along)
1020                 len = along;
1021             if (checksum) {
1022                 while (len-- > 0) {
1023                     Copy(s, &afloat, 1, float);
1024                     s += sizeof(float);
1025                     cdouble += afloat;
1026                 }
1027             }
1028             else {
1029                 EXTEND(SP, len);
1030                 EXTEND_MORTAL(len);
1031                 while (len-- > 0) {
1032                     Copy(s, &afloat, 1, float);
1033                     s += sizeof(float);
1034                     sv = NEWSV(47, 0);
1035                     sv_setnv(sv, (NV)afloat);
1036                     PUSHs(sv_2mortal(sv));
1037                 }
1038             }
1039             break;
1040         case 'd':
1041         case 'D':
1042             along = (strend - s) / sizeof(double);
1043             if (len > along)
1044                 len = along;
1045             if (checksum) {
1046                 while (len-- > 0) {
1047                     Copy(s, &adouble, 1, double);
1048                     s += sizeof(double);
1049                     cdouble += adouble;
1050                 }
1051             }
1052             else {
1053                 EXTEND(SP, len);
1054                 EXTEND_MORTAL(len);
1055                 while (len-- > 0) {
1056                     Copy(s, &adouble, 1, double);
1057                     s += sizeof(double);
1058                     sv = NEWSV(48, 0);
1059                     sv_setnv(sv, (NV)adouble);
1060                     PUSHs(sv_2mortal(sv));
1061                 }
1062             }
1063             break;
1064         case 'u':
1065             /* MKS:
1066              * Initialise the decode mapping.  By using a table driven
1067              * algorithm, the code will be character-set independent
1068              * (and just as fast as doing character arithmetic)
1069              */
1070             if (PL_uudmap['M'] == 0) {
1071                 int i;
1072
1073                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1074                     PL_uudmap[(U8)PL_uuemap[i]] = i;
1075                 /*
1076                  * Because ' ' and '`' map to the same value,
1077                  * we need to decode them both the same.
1078                  */
1079                 PL_uudmap[' '] = 0;
1080             }
1081
1082             along = (strend - s) * 3 / 4;
1083             sv = NEWSV(42, along);
1084             if (along)
1085                 SvPOK_on(sv);
1086             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1087                 I32 a, b, c, d;
1088                 char hunk[4];
1089
1090                 hunk[3] = '\0';
1091                 len = PL_uudmap[*(U8*)s++] & 077;
1092                 while (len > 0) {
1093                     if (s < strend && ISUUCHAR(*s))
1094                         a = PL_uudmap[*(U8*)s++] & 077;
1095                     else
1096                         a = 0;
1097                     if (s < strend && ISUUCHAR(*s))
1098                         b = PL_uudmap[*(U8*)s++] & 077;
1099                     else
1100                         b = 0;
1101                     if (s < strend && ISUUCHAR(*s))
1102                         c = PL_uudmap[*(U8*)s++] & 077;
1103                     else
1104                         c = 0;
1105                     if (s < strend && ISUUCHAR(*s))
1106                         d = PL_uudmap[*(U8*)s++] & 077;
1107                     else
1108                         d = 0;
1109                     hunk[0] = (a << 2) | (b >> 4);
1110                     hunk[1] = (b << 4) | (c >> 2);
1111                     hunk[2] = (c << 6) | d;
1112                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1113                     len -= 3;
1114                 }
1115                 if (*s == '\n')
1116                     s++;
1117                 else if (s[1] == '\n')          /* possible checksum byte */
1118                     s += 2;
1119             }
1120             XPUSHs(sv_2mortal(sv));
1121             break;
1122         }
1123         if (checksum) {
1124             sv = NEWSV(42, 0);
1125             if (strchr("fFdD", datumtype) ||
1126               (checksum > bits_in_uv && strchr("csSiIlLnNUvVqQ", datumtype)) ) {
1127                 NV trouble;
1128
1129                 adouble = (NV) (1 << (checksum & 15));
1130                 while (checksum >= 16) {
1131                     checksum -= 16;
1132                     adouble *= 65536.0;
1133                 }
1134                 while (cdouble < 0.0)
1135                     cdouble += adouble;
1136                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1137                 sv_setnv(sv, cdouble);
1138             }
1139             else {
1140                 if (checksum < bits_in_uv) {
1141                     UV mask = ((UV)1 << checksum) - 1;
1142                     culong &= mask;
1143                 }
1144                 sv_setuv(sv, (UV)culong);
1145             }
1146             XPUSHs(sv_2mortal(sv));
1147             checksum = 0;
1148         }
1149         if (gimme != G_ARRAY &&
1150             SP - PL_stack_base == start_sp_offset + 1) {
1151           /* do first one only unless in list context
1152              / is implmented by unpacking the count, then poping it from the
1153              stack, so must check that we're not in the middle of a /  */
1154           if ((pat >= patend) || *pat != '/')
1155             RETURN;
1156         }
1157     }
1158     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
1159         PUSHs(&PL_sv_undef);
1160     RETURN;
1161 }
1162
1163 STATIC void
1164 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1165 {
1166     char hunk[5];
1167
1168     *hunk = PL_uuemap[len];
1169     sv_catpvn(sv, hunk, 1);
1170     hunk[4] = '\0';
1171     while (len > 2) {
1172         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1173         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1174         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1175         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1176         sv_catpvn(sv, hunk, 4);
1177         s += 3;
1178         len -= 3;
1179     }
1180     if (len > 0) {
1181         char r = (len > 1 ? s[1] : '\0');
1182         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1183         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1184         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1185         hunk[3] = PL_uuemap[0];
1186         sv_catpvn(sv, hunk, 4);
1187     }
1188     sv_catpvn(sv, "\n", 1);
1189 }
1190
1191 STATIC SV *
1192 S_is_an_int(pTHX_ char *s, STRLEN l)
1193 {
1194   STRLEN         n_a;
1195   SV             *result = newSVpvn(s, l);
1196   char           *result_c = SvPV(result, n_a); /* convenience */
1197   char           *out = result_c;
1198   bool            skip = 1;
1199   bool            ignore = 0;
1200
1201   while (*s) {
1202     switch (*s) {
1203     case ' ':
1204       break;
1205     case '+':
1206       if (!skip) {
1207         SvREFCNT_dec(result);
1208         return (NULL);
1209       }
1210       break;
1211     case '0':
1212     case '1':
1213     case '2':
1214     case '3':
1215     case '4':
1216     case '5':
1217     case '6':
1218     case '7':
1219     case '8':
1220     case '9':
1221       skip = 0;
1222       if (!ignore) {
1223         *(out++) = *s;
1224       }
1225       break;
1226     case '.':
1227       ignore = 1;
1228       break;
1229     default:
1230       SvREFCNT_dec(result);
1231       return (NULL);
1232     }
1233     s++;
1234   }
1235   *(out++) = '\0';
1236   SvCUR_set(result, out - result_c);
1237   return (result);
1238 }
1239
1240 /* pnum must be '\0' terminated */
1241 STATIC int
1242 S_div128(pTHX_ SV *pnum, bool *done)
1243 {
1244   STRLEN          len;
1245   char           *s = SvPV(pnum, len);
1246   int             m = 0;
1247   int             r = 0;
1248   char           *t = s;
1249
1250   *done = 1;
1251   while (*t) {
1252     int             i;
1253
1254     i = m * 10 + (*t - '0');
1255     m = i & 0x7F;
1256     r = (i >> 7);               /* r < 10 */
1257     if (r) {
1258       *done = 0;
1259     }
1260     *(t++) = '0' + r;
1261   }
1262   *(t++) = '\0';
1263   SvCUR_set(pnum, (STRLEN) (t - s));
1264   return (m);
1265 }
1266
1267
1268 PP(pp_pack)
1269 {
1270     dSP; dMARK; dORIGMARK; dTARGET;
1271     register SV *cat = TARG;
1272     register I32 items;
1273     STRLEN fromlen;
1274     register char *pat = SvPVx(*++MARK, fromlen);
1275     char *patcopy;
1276     register char *patend = pat + fromlen;
1277     register I32 len;
1278     I32 datumtype;
1279     SV *fromstr;
1280     /*SUPPRESS 442*/
1281     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1282     static char *space10 = "          ";
1283
1284     /* These must not be in registers: */
1285     char achar;
1286     I16 ashort;
1287     int aint;
1288     unsigned int auint;
1289     I32 along;
1290     U32 aulong;
1291 #ifdef HAS_QUAD
1292     Quad_t aquad;
1293     Uquad_t auquad;
1294 #endif
1295     char *aptr;
1296     float afloat;
1297     double adouble;
1298     int commas = 0;
1299 #ifdef PERL_NATINT_PACK
1300     int natint;         /* native integer */
1301 #endif
1302
1303     items = SP - MARK;
1304     MARK++;
1305     sv_setpvn(cat, "", 0);
1306     patcopy = pat;
1307     while (pat < patend) {
1308         SV *lengthcode = Nullsv;
1309 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
1310         datumtype = *pat++ & 0xFF;
1311 #ifdef PERL_NATINT_PACK
1312         natint = 0;
1313 #endif
1314         if (isSPACE(datumtype)) {
1315             patcopy++;
1316             continue;
1317         }
1318 #ifndef PACKED_IS_OCTETS
1319         if (datumtype == 'U' && pat == patcopy+1)
1320             SvUTF8_on(cat);
1321 #endif
1322         if (datumtype == '#') {
1323             while (pat < patend && *pat != '\n')
1324                 pat++;
1325             continue;
1326         }
1327         if (*pat == '!') {
1328             char *natstr = "sSiIlL";
1329
1330             if (strchr(natstr, datumtype)) {
1331 #ifdef PERL_NATINT_PACK
1332                 natint = 1;
1333 #endif
1334                 pat++;
1335             }
1336             else
1337                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
1338         }
1339         if (*pat == '*') {
1340             len = strchr("@Xxu", datumtype) ? 0 : items;
1341             pat++;
1342         }
1343         else if (isDIGIT(*pat)) {
1344             len = *pat++ - '0';
1345             while (isDIGIT(*pat)) {
1346                 len = (len * 10) + (*pat++ - '0');
1347                 if (len < 0)
1348                     DIE(aTHX_ "Repeat count in pack overflows");
1349             }
1350         }
1351         else
1352             len = 1;
1353         if (*pat == '/') {
1354             ++pat;
1355             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
1356                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
1357             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1358                                                    ? *MARK : &PL_sv_no)
1359                                             + (*pat == 'Z' ? 1 : 0)));
1360         }
1361         switch(datumtype) {
1362         default:
1363             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
1364         case ',': /* grandfather in commas but with a warning */
1365             if (commas++ == 0 && ckWARN(WARN_PACK))
1366                 Perl_warner(aTHX_ WARN_PACK,
1367                             "Invalid type in pack: '%c'", (int)datumtype);
1368             break;
1369         case '%':
1370             DIE(aTHX_ "%% may only be used in unpack");
1371         case '@':
1372             len -= SvCUR(cat);
1373             if (len > 0)
1374                 goto grow;
1375             len = -len;
1376             if (len > 0)
1377                 goto shrink;
1378             break;
1379         case 'X':
1380           shrink:
1381             if (SvCUR(cat) < len)
1382                 DIE(aTHX_ "X outside of string");
1383             SvCUR(cat) -= len;
1384             *SvEND(cat) = '\0';
1385             break;
1386         case 'x':
1387           grow:
1388             while (len >= 10) {
1389                 sv_catpvn(cat, null10, 10);
1390                 len -= 10;
1391             }
1392             sv_catpvn(cat, null10, len);
1393             break;
1394         case 'A':
1395         case 'Z':
1396         case 'a':
1397             fromstr = NEXTFROM;
1398             aptr = SvPV(fromstr, fromlen);
1399             if (pat[lengthcode ? -2 : -1] == '*') { /* -2 after '/' */
1400                 len = fromlen;
1401                 if (datumtype == 'Z')
1402                     ++len;
1403             }
1404             if (fromlen >= len) {
1405                 sv_catpvn(cat, aptr, len);
1406                 if (datumtype == 'Z')
1407                     *(SvEND(cat)-1) = '\0';
1408             }
1409             else {
1410                 sv_catpvn(cat, aptr, fromlen);
1411                 len -= fromlen;
1412                 if (datumtype == 'A') {
1413                     while (len >= 10) {
1414                         sv_catpvn(cat, space10, 10);
1415                         len -= 10;
1416                     }
1417                     sv_catpvn(cat, space10, len);
1418                 }
1419                 else {
1420                     while (len >= 10) {
1421                         sv_catpvn(cat, null10, 10);
1422                         len -= 10;
1423                     }
1424                     sv_catpvn(cat, null10, len);
1425                 }
1426             }
1427             break;
1428         case 'B':
1429         case 'b':
1430             {
1431                 register char *str;
1432                 I32 saveitems;
1433
1434                 fromstr = NEXTFROM;
1435                 saveitems = items;
1436                 str = SvPV(fromstr, fromlen);
1437                 if (pat[-1] == '*')
1438                     len = fromlen;
1439                 aint = SvCUR(cat);
1440                 SvCUR(cat) += (len+7)/8;
1441                 SvGROW(cat, SvCUR(cat) + 1);
1442                 aptr = SvPVX(cat) + aint;
1443                 if (len > fromlen)
1444                     len = fromlen;
1445                 aint = len;
1446                 items = 0;
1447                 if (datumtype == 'B') {
1448                     for (len = 0; len++ < aint;) {
1449                         items |= *str++ & 1;
1450                         if (len & 7)
1451                             items <<= 1;
1452                         else {
1453                             *aptr++ = items & 0xff;
1454                             items = 0;
1455                         }
1456                     }
1457                 }
1458                 else {
1459                     for (len = 0; len++ < aint;) {
1460                         if (*str++ & 1)
1461                             items |= 128;
1462                         if (len & 7)
1463                             items >>= 1;
1464                         else {
1465                             *aptr++ = items & 0xff;
1466                             items = 0;
1467                         }
1468                     }
1469                 }
1470                 if (aint & 7) {
1471                     if (datumtype == 'B')
1472                         items <<= 7 - (aint & 7);
1473                     else
1474                         items >>= 7 - (aint & 7);
1475                     *aptr++ = items & 0xff;
1476                 }
1477                 str = SvPVX(cat) + SvCUR(cat);
1478                 while (aptr <= str)
1479                     *aptr++ = '\0';
1480
1481                 items = saveitems;
1482             }
1483             break;
1484         case 'H':
1485         case 'h':
1486             {
1487                 register char *str;
1488                 I32 saveitems;
1489
1490                 fromstr = NEXTFROM;
1491                 saveitems = items;
1492                 str = SvPV(fromstr, fromlen);
1493                 if (pat[-1] == '*')
1494                     len = fromlen;
1495                 aint = SvCUR(cat);
1496                 SvCUR(cat) += (len+1)/2;
1497                 SvGROW(cat, SvCUR(cat) + 1);
1498                 aptr = SvPVX(cat) + aint;
1499                 if (len > fromlen)
1500                     len = fromlen;
1501                 aint = len;
1502                 items = 0;
1503                 if (datumtype == 'H') {
1504                     for (len = 0; len++ < aint;) {
1505                         if (isALPHA(*str))
1506                             items |= ((*str++ & 15) + 9) & 15;
1507                         else
1508                             items |= *str++ & 15;
1509                         if (len & 1)
1510                             items <<= 4;
1511                         else {
1512                             *aptr++ = items & 0xff;
1513                             items = 0;
1514                         }
1515                     }
1516                 }
1517                 else {
1518                     for (len = 0; len++ < aint;) {
1519                         if (isALPHA(*str))
1520                             items |= (((*str++ & 15) + 9) & 15) << 4;
1521                         else
1522                             items |= (*str++ & 15) << 4;
1523                         if (len & 1)
1524                             items >>= 4;
1525                         else {
1526                             *aptr++ = items & 0xff;
1527                             items = 0;
1528                         }
1529                     }
1530                 }
1531                 if (aint & 1)
1532                     *aptr++ = items & 0xff;
1533                 str = SvPVX(cat) + SvCUR(cat);
1534                 while (aptr <= str)
1535                     *aptr++ = '\0';
1536
1537                 items = saveitems;
1538             }
1539             break;
1540         case 'C':
1541         case 'c':
1542             while (len-- > 0) {
1543                 fromstr = NEXTFROM;
1544                 switch (datumtype) {
1545                 case 'C':
1546                     aint = SvIV(fromstr);
1547                     if ((aint < 0 || aint > 255) &&
1548                         ckWARN(WARN_PACK))
1549                         Perl_warner(aTHX_ WARN_PACK,
1550                                     "Character in \"C\" format wrapped");
1551                     achar = aint & 255;
1552                     sv_catpvn(cat, &achar, sizeof(char));
1553                     break;
1554                 case 'c':
1555                     aint = SvIV(fromstr);
1556                     if ((aint < -128 || aint > 127) &&
1557                         ckWARN(WARN_PACK))
1558                         Perl_warner(aTHX_ WARN_PACK,
1559                                     "Character in \"c\" format wrapped");
1560                     achar = aint & 255;
1561                     sv_catpvn(cat, &achar, sizeof(char));
1562                     break;
1563                 }
1564             }
1565             break;
1566         case 'U':
1567             while (len-- > 0) {
1568                 fromstr = NEXTFROM;
1569                 auint = UNI_TO_NATIVE(SvUV(fromstr));
1570                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
1571                 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
1572                                - SvPVX(cat));
1573             }
1574             *SvEND(cat) = '\0';
1575             break;
1576         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
1577         case 'f':
1578         case 'F':
1579             while (len-- > 0) {
1580                 fromstr = NEXTFROM;
1581                 afloat = (float)SvNV(fromstr);
1582                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
1583             }
1584             break;
1585         case 'd':
1586         case 'D':
1587             while (len-- > 0) {
1588                 fromstr = NEXTFROM;
1589                 adouble = (double)SvNV(fromstr);
1590                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
1591             }
1592             break;
1593         case 'n':
1594             while (len-- > 0) {
1595                 fromstr = NEXTFROM;
1596                 ashort = (I16)SvIV(fromstr);
1597 #ifdef HAS_HTONS
1598                 ashort = PerlSock_htons(ashort);
1599 #endif
1600                 CAT16(cat, &ashort);
1601             }
1602             break;
1603         case 'v':
1604             while (len-- > 0) {
1605                 fromstr = NEXTFROM;
1606                 ashort = (I16)SvIV(fromstr);
1607 #ifdef HAS_HTOVS
1608                 ashort = htovs(ashort);
1609 #endif
1610                 CAT16(cat, &ashort);
1611             }
1612             break;
1613         case 'S':
1614 #if SHORTSIZE != SIZE16
1615             if (natint) {
1616                 unsigned short aushort;
1617
1618                 while (len-- > 0) {
1619                     fromstr = NEXTFROM;
1620                     aushort = SvUV(fromstr);
1621                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
1622                 }
1623             }
1624             else
1625 #endif
1626             {
1627                 U16 aushort;
1628
1629                 while (len-- > 0) {
1630                     fromstr = NEXTFROM;
1631                     aushort = (U16)SvUV(fromstr);
1632                     CAT16(cat, &aushort);
1633                 }
1634
1635             }
1636             break;
1637         case 's':
1638 #if SHORTSIZE != SIZE16
1639             if (natint) {
1640                 short ashort;
1641
1642                 while (len-- > 0) {
1643                     fromstr = NEXTFROM;
1644                     ashort = SvIV(fromstr);
1645                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
1646                 }
1647             }
1648             else
1649 #endif
1650             {
1651                 while (len-- > 0) {
1652                     fromstr = NEXTFROM;
1653                     ashort = (I16)SvIV(fromstr);
1654                     CAT16(cat, &ashort);
1655                 }
1656             }
1657             break;
1658         case 'I':
1659             while (len-- > 0) {
1660                 fromstr = NEXTFROM;
1661                 auint = SvUV(fromstr);
1662                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
1663             }
1664             break;
1665         case 'w':
1666             while (len-- > 0) {
1667                 fromstr = NEXTFROM;
1668                 adouble = Perl_floor(SvNV(fromstr));
1669
1670                 if (adouble < 0)
1671                     DIE(aTHX_ "Cannot compress negative numbers");
1672
1673                 if (
1674 #if UVSIZE > 4 && UVSIZE >= NVSIZE
1675                     adouble <= 0xffffffff
1676 #else
1677 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
1678                     adouble <= UV_MAX_cxux
1679 #   else
1680                     adouble <= UV_MAX
1681 #   endif
1682 #endif
1683                     )
1684                 {
1685                     char   buf[1 + sizeof(UV)];
1686                     char  *in = buf + sizeof(buf);
1687                     UV     auv = U_V(adouble);
1688
1689                     do {
1690                         *--in = (auv & 0x7f) | 0x80;
1691                         auv >>= 7;
1692                     } while (auv);
1693                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
1694                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
1695                 }
1696                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
1697                     char           *from, *result, *in;
1698                     SV             *norm;
1699                     STRLEN          len;
1700                     bool            done;
1701
1702                     /* Copy string and check for compliance */
1703                     from = SvPV(fromstr, len);
1704                     if ((norm = is_an_int(from, len)) == NULL)
1705                         DIE(aTHX_ "can compress only unsigned integer");
1706
1707                     New('w', result, len, char);
1708                     in = result + len;
1709                     done = FALSE;
1710                     while (!done)
1711                         *--in = div128(norm, &done) | 0x80;
1712                     result[len - 1] &= 0x7F; /* clear continue bit */
1713                     sv_catpvn(cat, in, (result + len) - in);
1714                     Safefree(result);
1715                     SvREFCNT_dec(norm); /* free norm */
1716                 }
1717                 else if (SvNOKp(fromstr)) {
1718                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
1719                     char  *in = buf + sizeof(buf);
1720
1721                     do {
1722                         double next = floor(adouble / 128);
1723                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
1724                         if (in <= buf)  /* this cannot happen ;-) */
1725                             DIE(aTHX_ "Cannot compress integer");
1726                         adouble = next;
1727                     } while (adouble > 0);
1728                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
1729                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
1730                 }
1731                 else {
1732                     char           *from, *result, *in;
1733                     SV             *norm;
1734                     STRLEN          len;
1735                     bool            done;
1736
1737                     /* Copy string and check for compliance */
1738                     from = SvPV(fromstr, len);
1739                     if ((norm = is_an_int(from, len)) == NULL)
1740                         DIE(aTHX_ "can compress only unsigned integer");
1741
1742                     New('w', result, len, char);
1743                     in = result + len;
1744                     done = FALSE;
1745                     while (!done)
1746                         *--in = div128(norm, &done) | 0x80;
1747                     result[len - 1] &= 0x7F; /* clear continue bit */
1748                     sv_catpvn(cat, in, (result + len) - in);
1749                     Safefree(result);
1750                     SvREFCNT_dec(norm); /* free norm */
1751                }
1752             }
1753             break;
1754         case 'i':
1755             while (len-- > 0) {
1756                 fromstr = NEXTFROM;
1757                 aint = SvIV(fromstr);
1758                 sv_catpvn(cat, (char*)&aint, sizeof(int));
1759             }
1760             break;
1761         case 'N':
1762             while (len-- > 0) {
1763                 fromstr = NEXTFROM;
1764                 aulong = SvUV(fromstr);
1765 #ifdef HAS_HTONL
1766                 aulong = PerlSock_htonl(aulong);
1767 #endif
1768                 CAT32(cat, &aulong);
1769             }
1770             break;
1771         case 'V':
1772             while (len-- > 0) {
1773                 fromstr = NEXTFROM;
1774                 aulong = SvUV(fromstr);
1775 #ifdef HAS_HTOVL
1776                 aulong = htovl(aulong);
1777 #endif
1778                 CAT32(cat, &aulong);
1779             }
1780             break;
1781         case 'L':
1782 #if LONGSIZE != SIZE32
1783             if (natint) {
1784                 unsigned long aulong;
1785
1786                 while (len-- > 0) {
1787                     fromstr = NEXTFROM;
1788                     aulong = SvUV(fromstr);
1789                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
1790                 }
1791             }
1792             else
1793 #endif
1794             {
1795                 while (len-- > 0) {
1796                     fromstr = NEXTFROM;
1797                     aulong = SvUV(fromstr);
1798                     CAT32(cat, &aulong);
1799                 }
1800             }
1801             break;
1802         case 'l':
1803 #if LONGSIZE != SIZE32
1804             if (natint) {
1805                 long along;
1806
1807                 while (len-- > 0) {
1808                     fromstr = NEXTFROM;
1809                     along = SvIV(fromstr);
1810                     sv_catpvn(cat, (char *)&along, sizeof(long));
1811                 }
1812             }
1813             else
1814 #endif
1815             {
1816                 while (len-- > 0) {
1817                     fromstr = NEXTFROM;
1818                     along = SvIV(fromstr);
1819                     CAT32(cat, &along);
1820                 }
1821             }
1822             break;
1823 #ifdef HAS_QUAD
1824         case 'Q':
1825             while (len-- > 0) {
1826                 fromstr = NEXTFROM;
1827                 auquad = (Uquad_t)SvUV(fromstr);
1828                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
1829             }
1830             break;
1831         case 'q':
1832             while (len-- > 0) {
1833                 fromstr = NEXTFROM;
1834                 aquad = (Quad_t)SvIV(fromstr);
1835                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
1836             }
1837             break;
1838 #endif
1839         case 'P':
1840             len = 1;            /* assume SV is correct length */
1841             /* FALL THROUGH */
1842         case 'p':
1843             while (len-- > 0) {
1844                 fromstr = NEXTFROM;
1845                 if (fromstr == &PL_sv_undef)
1846                     aptr = NULL;
1847                 else {
1848                     STRLEN n_a;
1849                     /* XXX better yet, could spirit away the string to
1850                      * a safe spot and hang on to it until the result
1851                      * of pack() (and all copies of the result) are
1852                      * gone.
1853                      */
1854                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
1855                                                 || (SvPADTMP(fromstr)
1856                                                     && !SvREADONLY(fromstr))))
1857                     {
1858                         Perl_warner(aTHX_ WARN_PACK,
1859                                 "Attempt to pack pointer to temporary value");
1860                     }
1861                     if (SvPOK(fromstr) || SvNIOK(fromstr))
1862                         aptr = SvPV(fromstr,n_a);
1863                     else
1864                         aptr = SvPV_force(fromstr,n_a);
1865                 }
1866                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
1867             }
1868             break;
1869         case 'u':
1870             fromstr = NEXTFROM;
1871             aptr = SvPV(fromstr, fromlen);
1872             SvGROW(cat, fromlen * 4 / 3);
1873             if (len <= 2)
1874                 len = 45;
1875             else
1876                 len = len / 3 * 3;
1877             while (fromlen > 0) {
1878                 I32 todo;
1879
1880                 if (fromlen > len)
1881                     todo = len;
1882                 else
1883                     todo = fromlen;
1884                 doencodes(cat, aptr, todo);
1885                 fromlen -= todo;
1886                 aptr += todo;
1887             }
1888             break;
1889         }
1890     }
1891     SvSETMAGIC(cat);
1892     SP = ORIGMARK;
1893     PUSHs(cat);
1894     RETURN;
1895 }
1896 #undef NEXTFROM
1897