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