pp_pack.c

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