pp_pack.c

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