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