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