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