pp_pack.c

   1 /*    pp_pack.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * He still hopefully carried some of his gear in his pack: a small tinder-box,
  13  * two small shallow pans, the smaller fitting into the larger; inside them a
  14  * wooden spoon, a short two-pronged fork and some skewers were stowed; and
  15  * hidden at the bottom of the pack in a flat wooden box a dwindling treasure,
  16  * some salt.
  17  */
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_PP_PACK_C
  21 #include "perl.h"
  22
  23 /*
  24  * The compiler on Concurrent CX/UX systems has a subtle bug which only
  25  * seems to show up when compiling pp.c - it generates the wrong double
  26  * precision constant value for (double)UV_MAX when used inline in the body
  27  * of the code below, so this makes a static variable up front (which the
  28  * compiler seems to get correct) and uses it in place of UV_MAX below.
  29  */
  30 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
  31 static double UV_MAX_cxux = ((double)UV_MAX);
  32 #endif
  33
  34 /*
  35  * Offset for integer pack/unpack.
  36  *
  37  * On architectures where I16 and I32 aren't really 16 and 32 bits,
  38  * which for now are all Crays, pack and unpack have to play games.
  39  */
  40
  41 /*
  42  * These values are required for portability of pack() output.
  43  * If they're not right on your machine, then pack() and unpack()
  44  * wouldn't work right anyway; you'll need to apply the Cray hack.
  45  * (I'd like to check them with #if, but you can't use sizeof() in
  46  * the preprocessor.)  --???
  47  */
  48 /*
  49     The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
  50     defines are now in config.h.  --Andy Dougherty  April 1998
  51  */
  52 #define SIZE16 2
  53 #define SIZE32 4
  54
  55 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
  56    --jhi Feb 1999 */
  57
  58 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
  59 #   define PERL_NATINT_PACK
  60 #endif
  61
  62 #if LONGSIZE > 4 && defined(_CRAY)
  63 #  if BYTEORDER == 0x12345678
  64 #    define OFF16(p)    (char*)(p)
  65 #    define OFF32(p)    (char*)(p)
  66 #  else
  67 #    if BYTEORDER == 0x87654321
  68 #      define OFF16(p)  ((char*)(p) + (sizeof(U16) - SIZE16))
  69 #      define OFF32(p)  ((char*)(p) + (sizeof(U32) - SIZE32))
  70 #    else
  71        }}}} bad cray byte order
  72 #    endif
  73 #  endif
  74 #  define COPY16(s,p)  (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
  75 #  define COPY32(s,p)  (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
  76 #  define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
  77 #  define CAT16(sv,p)  sv_catpvn(sv, OFF16(p), SIZE16)
  78 #  define CAT32(sv,p)  sv_catpvn(sv, OFF32(p), SIZE32)
  79 #else
  80 #  define COPY16(s,p)  Copy(s, p, SIZE16, char)
  81 #  define COPY32(s,p)  Copy(s, p, SIZE32, char)
  82 #  define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
  83 #  define CAT16(sv,p)  sv_catpvn(sv, (char*)(p), SIZE16)
  84 #  define CAT32(sv,p)  sv_catpvn(sv, (char*)(p), SIZE32)
  85 #endif
  86
  87 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
  88 #define MAX_SUB_TEMPLATE_LEVEL 100
  89
  90 /* flags */
  91 #define FLAG_UNPACK_ONLY_ONE  0x10
  92 #define FLAG_UNPACK_DO_UTF8   0x08
  93 #define FLAG_SLASH            0x04
  94 #define FLAG_COMMA            0x02
  95 #define FLAG_PACK             0x01
  96
  97 STATIC SV *
  98 S_mul128(pTHX_ SV *sv, U8 m)
  99 {
 100   STRLEN          len;
 101   char           *s = SvPV(sv, len);
 102   char           *t;
 103   U32             i = 0;
 104
 105   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
 106     SV             *tmpNew = newSVpvn("0000000000", 10);
 107
 108     sv_catsv(tmpNew, sv);
 109     SvREFCNT_dec(sv);           /* free old sv */
 110     sv = tmpNew;
 111     s = SvPV(sv, len);
 112   }
 113   t = s + len - 1;
 114   while (!*t)                   /* trailing '\0'? */
 115     t--;
 116   while (t > s) {
 117     i = ((*t - '0') << 7) + m;
 118     *(t--) = '0' + (char)(i % 10);
 119     m = (char)(i / 10);
 120   }
 121   return (sv);
 122 }
 123
 124 /* Explosives and implosives. */
 125
 126 #if 'I' == 73 && 'J' == 74
 127 /* On an ASCII/ISO kind of system */
 128 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
 129 #else
 130 /*
 131   Some other sort of character set - use memchr() so we don't match
 132   the null byte.
 133  */
 134 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
 135 #endif
 136
 137 #define TYPE_IS_SHRIEKING       0x100
 138
 139 /* Returns the sizeof() struct described by pat */
 140 STATIC I32
 141 S_measure_struct(pTHX_ register tempsym_t* symptr)
 142 {
 143     register I32 len = 0;
 144     register I32 total = 0;
 145     int star;
 146
 147     register int size;
 148
 149     while (next_symbol(symptr)) {
 150
 151         switch( symptr->howlen ){
 152         case e_no_len:
 153         case e_number:
 154             len = symptr->length;
 155             break;
 156         case e_star:
 157             Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
 158                        symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 159             break;
 160         }
 161
 162         switch(symptr->code) {
 163         default:
 164     Perl_croak(aTHX_ "Invalid type '%c' in %s",
 165                        (int)symptr->code,
 166                        symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 167         case '@':
 168         case '/':
 169         case 'U':                       /* XXXX Is it correct? */
 170         case 'w':
 171         case 'u':
 172             Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
 173                        (int)symptr->code,
 174                        symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 175         case '%':
 176             size = 0;
 177             break;
 178         case '(':
 179         {
 180             tempsym_t savsym = *symptr;
 181             symptr->patptr = savsym.grpbeg;
 182             symptr->patend = savsym.grpend;
 183             /* XXXX Theoretically, we need to measure many times at different
 184                positions, since the subexpression may contain
 185                alignment commands, but be not of aligned length.
 186                Need to detect this and croak().  */
 187             size = measure_struct(symptr);
 188             *symptr = savsym;
 189             break;
 190         }
 191         case 'X' | TYPE_IS_SHRIEKING:
 192             /* XXXX Is this useful?  Then need to treat MEASURE_BACKWARDS. */
 193             if (!len)                   /* Avoid division by 0 */
 194                 len = 1;
 195             len = total % len;          /* Assumed: the start is aligned. */
 196             /* FALL THROUGH */
 197         case 'X':
 198             size = -1;
 199             if (total < len)
 200                 Perl_croak(aTHX_ "'X' outside of string in %s",
 201                           symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 202             break;
 203         case 'x' | TYPE_IS_SHRIEKING:
 204             if (!len)                   /* Avoid division by 0 */
 205                 len = 1;
 206             star = total % len;         /* Assumed: the start is aligned. */
 207             if (star)                   /* Other portable ways? */
 208                 len = len - star;
 209             else
 210                 len = 0;
 211             /* FALL THROUGH */
 212         case 'x':
 213         case 'A':
 214         case 'Z':
 215         case 'a':
 216         case 'c':
 217         case 'C':
 218             size = 1;
 219             break;
 220         case 'B':
 221         case 'b':
 222             len = (len + 7)/8;
 223             size = 1;
 224             break;
 225         case 'H':
 226         case 'h':
 227             len = (len + 1)/2;
 228             size = 1;
 229             break;
 230         case 's' | TYPE_IS_SHRIEKING:
 231 #if SHORTSIZE != SIZE16
 232             size = sizeof(short);
 233             break;
 234 #else
 235             /* FALL THROUGH */
 236 #endif
 237         case 's':
 238             size = SIZE16;
 239             break;
 240         case 'S' | TYPE_IS_SHRIEKING:
 241 #if SHORTSIZE != SIZE16
 242             size = sizeof(unsigned short);
 243             break;
 244 #else
 245             /* FALL THROUGH */
 246 #endif
 247         case 'v':
 248         case 'n':
 249         case 'S':
 250             size = SIZE16;
 251             break;
 252         case 'i' | TYPE_IS_SHRIEKING:
 253         case 'i':
 254             size = sizeof(int);
 255             break;
 256         case 'I' | TYPE_IS_SHRIEKING:
 257         case 'I':
 258             size = sizeof(unsigned int);
 259             break;
 260         case 'j':
 261             size = IVSIZE;
 262             break;
 263         case 'J':
 264             size = UVSIZE;
 265             break;
 266         case 'l' | TYPE_IS_SHRIEKING:
 267 #if LONGSIZE != SIZE32
 268             size = sizeof(long);
 269             break;
 270 #else
 271             /* FALL THROUGH */
 272 #endif
 273         case 'l':
 274             size = SIZE32;
 275             break;
 276         case 'L' | TYPE_IS_SHRIEKING:
 277 #if LONGSIZE != SIZE32
 278             size = sizeof(unsigned long);
 279             break;
 280 #else
 281             /* FALL THROUGH */
 282 #endif
 283         case 'V':
 284         case 'N':
 285         case 'L':
 286             size = SIZE32;
 287             break;
 288         case 'P':
 289             len = 1;
 290             /* FALL THROUGH */
 291         case 'p':
 292             size = sizeof(char*);
 293             break;
 294 #ifdef HAS_QUAD
 295         case 'q':
 296             size = sizeof(Quad_t);
 297             break;
 298         case 'Q':
 299             size = sizeof(Uquad_t);
 300             break;
 301 #endif
 302         case 'f':
 303             size = sizeof(float);
 304             break;
 305         case 'd':
 306             size = sizeof(double);
 307             break;
 308         case 'F':
 309             size = NVSIZE;
 310             break;
 311 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
 312         case 'D':
 313             size = LONG_DOUBLESIZE;
 314             break;
 315 #endif
 316         }
 317         total += len * size;
 318     }
 319     return total;
 320 }
 321
 322
 323 /* locate matching closing parenthesis or bracket
 324  * returns char pointer to char after match, or NULL
 325  */
 326 STATIC char *
 327 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
 328 {
 329     while (patptr < patend) {
 330         char c = *patptr++;
 331
 332         if (isSPACE(c))
 333             continue;
 334         else if (c == ender)
 335             return patptr-1;
 336         else if (c == '#') {
 337             while (patptr < patend && *patptr != '\n')
 338                 patptr++;
 339             continue;
 340         } else if (c == '(')
 341             patptr = group_end(patptr, patend, ')') + 1;
 342         else if (c == '[')
 343             patptr = group_end(patptr, patend, ']') + 1;
 344     }
 345     Perl_croak(aTHX_ "No group ending character '%c' found in template",
 346                ender);
 347     return 0;
 348 }
 349
 350
 351 /* Convert unsigned decimal number to binary.
 352  * Expects a pointer to the first digit and address of length variable
 353  * Advances char pointer to 1st non-digit char and returns number
 354  */
 355 STATIC char *
 356 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
 357 {
 358   I32 len = *patptr++ - '0';
 359   while (isDIGIT(*patptr)) {
 360     if (len >= 0x7FFFFFFF/10)
 361       Perl_croak(aTHX_ "pack/unpack repeat count overflow");
 362     len = (len * 10) + (*patptr++ - '0');
 363   }
 364   *lenptr = len;
 365   return patptr;
 366 }
 367
 368 /* The marvellous template parsing routine: Using state stored in *symptr,
 369  * locates next template code and count
 370  */
 371 STATIC bool
 372 S_next_symbol(pTHX_ register tempsym_t* symptr )
 373 {
 374   register char* patptr = symptr->patptr;
 375   register char* patend = symptr->patend;
 376
 377   symptr->flags &= ~FLAG_SLASH;
 378
 379   while (patptr < patend) {
 380     if (isSPACE(*patptr))
 381       patptr++;
 382     else if (*patptr == '#') {
 383       patptr++;
 384       while (patptr < patend && *patptr != '\n')
 385         patptr++;
 386       if (patptr < patend)
 387         patptr++;
 388     } else {
 389       /* We should have found a template code */
 390       I32 code = *patptr++ & 0xFF;
 391
 392       if (code == ','){ /* grandfather in commas but with a warning */
 393         if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
 394           symptr->flags |= FLAG_COMMA;
 395           Perl_warner(aTHX_ packWARN(WARN_UNPACK),
 396                       "Invalid type ',' in %s",
 397                       symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 398         }
 399         continue;
 400       }
 401
 402       /* for '(', skip to ')' */
 403       if (code == '(') {
 404         if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
 405           Perl_croak(aTHX_ "()-group starts with a count in %s",
 406                      symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 407         symptr->grpbeg = patptr;
 408         patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
 409         if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
 410           Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
 411                      symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 412       }
 413
 414       /* test for '!' modifier */
 415       if (patptr < patend && *patptr == '!') {
 416         static const char natstr[] = "sSiIlLxX";
 417         patptr++;
 418         if (strchr(natstr, code))
 419           code |= TYPE_IS_SHRIEKING;
 420         else
 421           Perl_croak(aTHX_ "'!' allowed only after types %s in %s",
 422                      natstr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 423       }
 424
 425       /* look for count and/or / */
 426       if (patptr < patend) {
 427         if (isDIGIT(*patptr)) {
 428           patptr = get_num( patptr, &symptr->length );
 429           symptr->howlen = e_number;
 430
 431         } else if (*patptr == '*') {
 432           patptr++;
 433           symptr->howlen = e_star;
 434
 435         } else if (*patptr == '[') {
 436           char* lenptr = ++patptr;
 437           symptr->howlen = e_number;
 438           patptr = group_end( patptr, patend, ']' ) + 1;
 439           /* what kind of [] is it? */
 440           if (isDIGIT(*lenptr)) {
 441             lenptr = get_num( lenptr, &symptr->length );
 442             if( *lenptr != ']' )
 443               Perl_croak(aTHX_ "Malformed integer in [] in %s",
 444                          symptr->flags & FLAG_PACK ? "pack" : "unpack");
 445           } else {
 446             tempsym_t savsym = *symptr;
 447             symptr->patend = patptr-1;
 448             symptr->patptr = lenptr;
 449             savsym.length = measure_struct(symptr);
 450             *symptr = savsym;
 451           }
 452         } else {
 453           symptr->howlen = e_no_len;
 454           symptr->length = 1;
 455         }
 456
 457         /* try to find / */
 458         while (patptr < patend) {
 459           if (isSPACE(*patptr))
 460             patptr++;
 461           else if (*patptr == '#') {
 462             patptr++;
 463             while (patptr < patend && *patptr != '\n')
 464               patptr++;
 465             if (patptr < patend)
 466               patptr++;
 467           } else {
 468             if( *patptr == '/' ){
 469               symptr->flags |= FLAG_SLASH;
 470               patptr++;
 471               if( patptr < patend &&
 472                   (isDIGIT(*patptr) || *patptr == '*' || *patptr == '[') )
 473                 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
 474                            symptr->flags & FLAG_PACK ? "pack" : "unpack" );
 475             }
 476             break;
 477           }
 478         }
 479       } else {
 480         /* at end - no count, no / */
 481         symptr->howlen = e_no_len;
 482         symptr->length = 1;
 483       }
 484
 485       symptr->code = code;
 486       symptr->patptr = patptr;
 487       return TRUE;
 488     }
 489   }
 490   symptr->patptr = patptr;
 491   return FALSE;
 492 }
 493
 494 /*
 495 =for apidoc unpack_str
 496
 497 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
 498 and ocnt are not used. This call should not be used, use unpackstring instead.
 499
 500 =cut */
 501
 502 I32
 503 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
 504 {
 505     tempsym_t sym = { 0 };
 506     sym.patptr = pat;
 507     sym.patend = patend;
 508     sym.flags  = flags;
 509
 510     return unpack_rec(&sym, s, s, strend, NULL );
 511 }
 512
 513 /*
 514 =for apidoc unpackstring
 515
 516 The engine implementing unpack() Perl function. C<unpackstring> puts the
 517 extracted list items on the stack and returns the number of elements.
 518 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
 519
 520 =cut */
 521
 522 I32
 523 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
 524 {
 525     tempsym_t sym = { 0 };
 526     sym.patptr = pat;
 527     sym.patend = patend;
 528     sym.flags  = flags;
 529
 530     return unpack_rec(&sym, s, s, strend, NULL );
 531 }
 532
 533 STATIC
 534 I32
 535 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
 536 {
 537     dSP;
 538     I32 datumtype;
 539     register I32 len = 0;
 540     register I32 bits = 0;
 541     register char *str;
 542     SV *sv;
 543     I32 start_sp_offset = SP - PL_stack_base;
 544     howlen_t howlen;
 545
 546     /* These must not be in registers: */
 547     short ashort;
 548     int aint;
 549     long along;
 550 #ifdef HAS_QUAD
 551     Quad_t aquad;
 552 #endif
 553     U16 aushort;
 554     unsigned int auint;
 555     U32 aulong;
 556 #ifdef HAS_QUAD
 557     Uquad_t auquad;
 558 #endif
 559     char *aptr;
 560     float afloat;
 561     double adouble;
 562     I32 checksum = 0;
 563     UV cuv = 0;
 564     NV cdouble = 0.0;
 565     const int bits_in_uv = 8 * sizeof(cuv);
 566     char* strrelbeg = s;
 567     bool beyond = FALSE;
 568     bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
 569
 570     IV aiv;
 571     UV auv;
 572     NV anv;
 573 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
 574     long double aldouble;
 575 #endif
 576
 577     while (next_symbol(symptr)) {
 578         datumtype = symptr->code;
 579         /* do first one only unless in list context
 580            / is implemented by unpacking the count, then poping it from the
 581            stack, so must check that we're not in the middle of a /  */
 582         if ( unpack_only_one
 583              && (SP - PL_stack_base == start_sp_offset + 1)
 584              && (datumtype != '/') )   /* XXX can this be omitted */
 585             break;
 586
 587         switch( howlen = symptr->howlen ){
 588         case e_no_len:
 589         case e_number:
 590             len = symptr->length;
 591             break;
 592         case e_star:
 593             len = strend - strbeg;      /* long enough */
 594             break;
 595         }
 596
 597       redo_switch:
 598         beyond = s >= strend;
 599         switch(datumtype) {
 600         default:
 601             Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)datumtype );
 602
 603         case '%':
 604             if (howlen == e_no_len)
 605                 len = 16;               /* len is not specified */
 606             checksum = len;
 607             cuv = 0;
 608             cdouble = 0;
 609             continue;
 610             break;
 611         case '(':
 612         {
 613             char *ss = s;               /* Move from register */
 614             tempsym_t savsym = *symptr;
 615             symptr->patend = savsym.grpend;
 616             symptr->level++;
 617             PUTBACK;
 618             while (len--) {
 619                 symptr->patptr = savsym.grpbeg;
 620                 unpack_rec(symptr, ss, strbeg, strend, &ss );
 621                 if (ss == strend && savsym.howlen == e_star)
 622                     break; /* No way to continue */
 623             }
 624             SPAGAIN;
 625             s = ss;
 626             savsym.flags = symptr->flags;
 627             *symptr = savsym;
 628             break;
 629         }
 630         case '@':
 631             if (len > strend - strrelbeg)
 632                 Perl_croak(aTHX_ "'@' outside of string in unpack");
 633             s = strrelbeg + len;
 634             break;
 635         case 'X' | TYPE_IS_SHRIEKING:
 636             if (!len)                   /* Avoid division by 0 */
 637                 len = 1;
 638             len = (s - strbeg) % len;
 639             /* FALL THROUGH */
 640         case 'X':
 641             if (len > s - strbeg)
 642                 Perl_croak(aTHX_ "'X' outside of string in unpack" );
 643             s -= len;
 644             break;
 645         case 'x' | TYPE_IS_SHRIEKING:
 646             if (!len)                   /* Avoid division by 0 */
 647                 len = 1;
 648             aint = (s - strbeg) % len;
 649             if (aint)                   /* Other portable ways? */
 650                 len = len - aint;
 651             else
 652                 len = 0;
 653             /* FALL THROUGH */
 654         case 'x':
 655             if (len > strend - s)
 656                 Perl_croak(aTHX_ "'x' outside of string in unpack");
 657             s += len;
 658             break;
 659         case '/':
 660             Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
 661             break;
 662         case 'A':
 663         case 'Z':
 664         case 'a':
 665             if (len > strend - s)
 666                 len = strend - s;
 667             if (checksum)
 668                 goto uchar_checksum;
 669             sv = NEWSV(35, len);
 670             sv_setpvn(sv, s, len);
 671             if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
 672                 aptr = s;       /* borrow register */
 673                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
 674                     s = SvPVX(sv);
 675                     while (*s)
 676                         s++;
 677                     if (howlen == e_star) /* exact for 'Z*' */
 678                         len = s - SvPVX(sv) + 1;
 679                 }
 680                 else {          /* 'A' strips both nulls and spaces */
 681                     s = SvPVX(sv) + len - 1;
 682                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
 683                         s--;
 684                     *++s = '\0';
 685                 }
 686                 SvCUR_set(sv, s - SvPVX(sv));
 687                 s = aptr;       /* unborrow register */
 688             }
 689             s += len;
 690             XPUSHs(sv_2mortal(sv));
 691             break;
 692         case 'B':
 693         case 'b':
 694             if (howlen == e_star || len > (strend - s) * 8)
 695                 len = (strend - s) * 8;
 696             if (checksum) {
 697                 if (!PL_bitcount) {
 698                     Newz(601, PL_bitcount, 256, char);
 699                     for (bits = 1; bits < 256; bits++) {
 700                         if (bits & 1)   PL_bitcount[bits]++;
 701                         if (bits & 2)   PL_bitcount[bits]++;
 702                         if (bits & 4)   PL_bitcount[bits]++;
 703                         if (bits & 8)   PL_bitcount[bits]++;
 704                         if (bits & 16)  PL_bitcount[bits]++;
 705                         if (bits & 32)  PL_bitcount[bits]++;
 706                         if (bits & 64)  PL_bitcount[bits]++;
 707                         if (bits & 128) PL_bitcount[bits]++;
 708                     }
 709                 }
 710                 while (len >= 8) {
 711                     cuv += PL_bitcount[*(unsigned char*)s++];
 712                     len -= 8;
 713                 }
 714                 if (len) {
 715                     bits = *s;
 716                     if (datumtype == 'b') {
 717                         while (len-- > 0) {
 718                             if (bits & 1) cuv++;
 719                             bits >>= 1;
 720                         }
 721                     }
 722                     else {
 723                         while (len-- > 0) {
 724                             if (bits & 128) cuv++;
 725                             bits <<= 1;
 726                         }
 727                     }
 728                 }
 729                 break;
 730             }
 731             sv = NEWSV(35, len + 1);
 732             SvCUR_set(sv, len);
 733             SvPOK_on(sv);
 734             str = SvPVX(sv);
 735             if (datumtype == 'b') {
 736                 aint = len;
 737                 for (len = 0; len < aint; len++) {
 738                     if (len & 7)                /*SUPPRESS 595*/
 739                         bits >>= 1;
 740                     else
 741                         bits = *s++;
 742                     *str++ = '0' + (bits & 1);
 743                 }
 744             }
 745             else {
 746                 aint = len;
 747                 for (len = 0; len < aint; len++) {
 748                     if (len & 7)
 749                         bits <<= 1;
 750                     else
 751                         bits = *s++;
 752                     *str++ = '0' + ((bits & 128) != 0);
 753                 }
 754             }
 755             *str = '\0';
 756             XPUSHs(sv_2mortal(sv));
 757             break;
 758         case 'H':
 759         case 'h':
 760             if (howlen == e_star || len > (strend - s) * 2)
 761                 len = (strend - s) * 2;
 762             sv = NEWSV(35, len + 1);
 763             SvCUR_set(sv, len);
 764             SvPOK_on(sv);
 765             str = SvPVX(sv);
 766             if (datumtype == 'h') {
 767                 aint = len;
 768                 for (len = 0; len < aint; len++) {
 769                     if (len & 1)
 770                         bits >>= 4;
 771                     else
 772                         bits = *s++;
 773                     *str++ = PL_hexdigit[bits & 15];
 774                 }
 775             }
 776             else {
 777                 aint = len;
 778                 for (len = 0; len < aint; len++) {
 779                     if (len & 1)
 780                         bits <<= 4;
 781                     else
 782                         bits = *s++;
 783                     *str++ = PL_hexdigit[(bits >> 4) & 15];
 784                 }
 785             }
 786             *str = '\0';
 787             XPUSHs(sv_2mortal(sv));
 788             break;
 789         case 'c':
 790             if (len > strend - s)
 791                 len = strend - s;
 792             if (checksum) {
 793                 while (len-- > 0) {
 794                     aint = *s++;
 795                     if (aint >= 128)    /* fake up signed chars */
 796                         aint -= 256;
 797                     if (checksum > bits_in_uv)
 798                         cdouble += (NV)aint;
 799                     else
 800                         cuv += aint;
 801                 }
 802             }
 803             else {
 804                 if (len && unpack_only_one)
 805                     len = 1;
 806                 EXTEND(SP, len);
 807                 EXTEND_MORTAL(len);
 808                 while (len-- > 0) {
 809                     aint = *s++;
 810                     if (aint >= 128)    /* fake up signed chars */
 811                         aint -= 256;
 812                     sv = NEWSV(36, 0);
 813                     sv_setiv(sv, (IV)aint);
 814                     PUSHs(sv_2mortal(sv));
 815                 }
 816             }
 817             break;
 818         case 'C':
 819         unpack_C: /* unpack U will jump here if not UTF-8 */
 820             if (len == 0) {
 821                 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
 822                 break;
 823             }
 824             if (len > strend - s)
 825                 len = strend - s;
 826             if (checksum) {
 827               uchar_checksum:
 828                 while (len-- > 0) {
 829                     auint = *s++ & 255;
 830                     cuv += auint;
 831                 }
 832             }
 833             else {
 834                 if (len && unpack_only_one)
 835                     len = 1;
 836                 EXTEND(SP, len);
 837                 EXTEND_MORTAL(len);
 838                 while (len-- > 0) {
 839                     auint = *s++ & 255;
 840                     sv = NEWSV(37, 0);
 841                     sv_setiv(sv, (IV)auint);
 842                     PUSHs(sv_2mortal(sv));
 843                 }
 844             }
 845             break;
 846         case 'U':
 847             if (len == 0) {
 848                 symptr->flags |= FLAG_UNPACK_DO_UTF8;
 849                 break;
 850             }
 851             if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
 852                  goto unpack_C;
 853             if (len > strend - s)
 854                 len = strend - s;
 855             if (checksum) {
 856                 while (len-- > 0 && s < strend) {
 857                     STRLEN alen;
 858                     auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
 859                     along = alen;
 860                     s += along;
 861                     if (checksum > bits_in_uv)
 862                         cdouble += (NV)auint;
 863                     else
 864                         cuv += auint;
 865                 }
 866             }
 867             else {
 868                 if (len && unpack_only_one)
 869                     len = 1;
 870                 EXTEND(SP, len);
 871                 EXTEND_MORTAL(len);
 872                 while (len-- > 0 && s < strend) {
 873                     STRLEN alen;
 874                     auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
 875                     along = alen;
 876                     s += along;
 877                     sv = NEWSV(37, 0);
 878                     sv_setuv(sv, (UV)auint);
 879                     PUSHs(sv_2mortal(sv));
 880                 }
 881             }
 882             break;
 883         case 's' | TYPE_IS_SHRIEKING:
 884 #if SHORTSIZE != SIZE16
 885             along = (strend - s) / sizeof(short);
 886             if (len > along)
 887                 len = along;
 888             if (checksum) {
 889                 short ashort;
 890                 while (len-- > 0) {
 891                      COPYNN(s, &ashort, sizeof(short));
 892                       s += sizeof(short);
 893                       if (checksum > bits_in_uv)
 894                           cdouble += (NV)ashort;
 895                       else
 896                           cuv += ashort;
 897
 898                 }
 899             }
 900             else {
 901                 short ashort;
 902                 if (len && unpack_only_one)
 903                     len = 1;
 904                 EXTEND(SP, len);
 905                 EXTEND_MORTAL(len);
 906                 while (len-- > 0) {
 907                     COPYNN(s, &ashort, sizeof(short));
 908                     s += sizeof(short);
 909                     sv = NEWSV(38, 0);
 910                     sv_setiv(sv, (IV)ashort);
 911                     PUSHs(sv_2mortal(sv));
 912                 }
 913             }
 914             break;
 915 #else
 916             /* Fallthrough! */
 917 #endif
 918         case 's':
 919             along = (strend - s) / SIZE16;
 920             if (len > along)
 921                 len = along;
 922             if (checksum) {
 923                 while (len-- > 0) {
 924                     COPY16(s, &ashort);
 925 #if SHORTSIZE > SIZE16
 926                     if (ashort > 32767)
 927                         ashort -= 65536;
 928 #endif
 929                     s += SIZE16;
 930                     if (checksum > bits_in_uv)
 931                         cdouble += (NV)ashort;
 932                     else
 933                         cuv += ashort;
 934                 }
 935             }
 936             else {
 937                 if (len && unpack_only_one)
 938                     len = 1;
 939                 EXTEND(SP, len);
 940                 EXTEND_MORTAL(len);
 941
 942                 while (len-- > 0) {
 943                     COPY16(s, &ashort);
 944 #if SHORTSIZE > SIZE16
 945                     if (ashort > 32767)
 946                         ashort -= 65536;
 947 #endif
 948                     s += SIZE16;
 949                     sv = NEWSV(38, 0);
 950                     sv_setiv(sv, (IV)ashort);
 951                     PUSHs(sv_2mortal(sv));
 952                 }
 953             }
 954             break;
 955         case 'S' | TYPE_IS_SHRIEKING:
 956 #if SHORTSIZE != SIZE16
 957             along = (strend - s) / sizeof(unsigned short);
 958             if (len > along)
 959                 len = along;
 960             if (checksum) {
 961                 unsigned short aushort;
 962                 while (len-- > 0) {
 963                     COPYNN(s, &aushort, sizeof(unsigned short));
 964                     s += sizeof(unsigned short);
 965                     if (checksum > bits_in_uv)
 966                         cdouble += (NV)aushort;
 967                     else
 968                         cuv += aushort;
 969                 }
 970             }
 971             else {
 972                 if (len && unpack_only_one)
 973                     len = 1;
 974                 EXTEND(SP, len);
 975                 EXTEND_MORTAL(len);
 976                 while (len-- > 0) {
 977                     unsigned short aushort;
 978                     COPYNN(s, &aushort, sizeof(unsigned short));
 979                     s += sizeof(unsigned short);
 980                     sv = NEWSV(39, 0);
 981                     sv_setiv(sv, (UV)aushort);
 982                     PUSHs(sv_2mortal(sv));
 983                 }
 984             }
 985             break;
 986 #else
 987             /* Fallhrough! */
 988 #endif
 989         case 'v':
 990         case 'n':
 991         case 'S':
 992             along = (strend - s) / SIZE16;
 993             if (len > along)
 994                 len = along;
 995             if (checksum) {
 996                 while (len-- > 0) {
 997                     COPY16(s, &aushort);
 998                     s += SIZE16;
 999 #ifdef HAS_NTOHS
1000                     if (datumtype == 'n')
1001                         aushort = PerlSock_ntohs(aushort);
1002 #endif
1003 #ifdef HAS_VTOHS
1004                     if (datumtype == 'v')
1005                         aushort = vtohs(aushort);
1006 #endif
1007                     if (checksum > bits_in_uv)
1008                         cdouble += (NV)aushort;
1009                     else
1010                         cuv += aushort;
1011                 }
1012             }
1013             else {
1014                 if (len && unpack_only_one)
1015                     len = 1;
1016                 EXTEND(SP, len);
1017                 EXTEND_MORTAL(len);
1018                 while (len-- > 0) {
1019                     COPY16(s, &aushort);
1020                     s += SIZE16;
1021                     sv = NEWSV(39, 0);
1022 #ifdef HAS_NTOHS
1023                     if (datumtype == 'n')
1024                         aushort = PerlSock_ntohs(aushort);
1025 #endif
1026 #ifdef HAS_VTOHS
1027                     if (datumtype == 'v')
1028                         aushort = vtohs(aushort);
1029 #endif
1030                     sv_setiv(sv, (UV)aushort);
1031                     PUSHs(sv_2mortal(sv));
1032                 }
1033             }
1034             break;
1035         case 'i':
1036         case 'i' | TYPE_IS_SHRIEKING:
1037             along = (strend - s) / sizeof(int);
1038             if (len > along)
1039                 len = along;
1040             if (checksum) {
1041                 while (len-- > 0) {
1042                     Copy(s, &aint, 1, int);
1043                     s += sizeof(int);
1044                     if (checksum > bits_in_uv)
1045                         cdouble += (NV)aint;
1046                     else
1047                         cuv += aint;
1048                 }
1049             }
1050             else {
1051                 if (len && unpack_only_one)
1052                     len = 1;
1053                 EXTEND(SP, len);
1054                 EXTEND_MORTAL(len);
1055                 while (len-- > 0) {
1056                     Copy(s, &aint, 1, int);
1057                     s += sizeof(int);
1058                     sv = NEWSV(40, 0);
1059 #ifdef __osf__
1060                     /* Without the dummy below unpack("i", pack("i",-1))
1061                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
1062                      * cc with optimization turned on.
1063                      *
1064                      * The bug was detected in
1065                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
1066                      * with optimization (-O4) turned on.
1067                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
1068                      * does not have this problem even with -O4.
1069                      *
1070                      * This bug was reported as DECC_BUGS 1431
1071                      * and tracked internally as GEM_BUGS 7775.
1072                      *
1073                      * The bug is fixed in
1074                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
1075                      * UNIX V4.0F support:   DEC C V5.9-006 or later
1076                      * UNIX V4.0E support:   DEC C V5.8-011 or later
1077                      * and also in DTK.
1078                      *
1079                      * See also few lines later for the same bug.
1080                      */
1081                     (aint) ?
1082                         sv_setiv(sv, (IV)aint) :
1083 #endif
1084                     sv_setiv(sv, (IV)aint);
1085                     PUSHs(sv_2mortal(sv));
1086                 }
1087             }
1088             break;
1089         case 'I':
1090         case 'I' | TYPE_IS_SHRIEKING:
1091             along = (strend - s) / sizeof(unsigned int);
1092             if (len > along)
1093                 len = along;
1094             if (checksum) {
1095                 while (len-- > 0) {
1096                     Copy(s, &auint, 1, unsigned int);
1097                     s += sizeof(unsigned int);
1098                     if (checksum > bits_in_uv)
1099                         cdouble += (NV)auint;
1100                     else
1101                         cuv += auint;
1102                 }
1103             }
1104             else {
1105                 if (len && unpack_only_one)
1106                     len = 1;
1107                 EXTEND(SP, len);
1108                 EXTEND_MORTAL(len);
1109                 while (len-- > 0) {
1110                     Copy(s, &auint, 1, unsigned int);
1111                     s += sizeof(unsigned int);
1112                     sv = NEWSV(41, 0);
1113 #ifdef __osf__
1114                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1115                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1116                      * See details few lines earlier. */
1117                     (auint) ?
1118                         sv_setuv(sv, (UV)auint) :
1119 #endif
1120                     sv_setuv(sv, (UV)auint);
1121                     PUSHs(sv_2mortal(sv));
1122                 }
1123             }
1124             break;
1125         case 'j':
1126             along = (strend - s) / IVSIZE;
1127             if (len > along)
1128                 len = along;
1129             if (checksum) {
1130                 while (len-- > 0) {
1131                     Copy(s, &aiv, 1, IV);
1132                     s += IVSIZE;
1133                     if (checksum > bits_in_uv)
1134                         cdouble += (NV)aiv;
1135                     else
1136                         cuv += aiv;
1137                 }
1138             }
1139             else {
1140                 if (len && unpack_only_one)
1141                     len = 1;
1142                 EXTEND(SP, len);
1143                 EXTEND_MORTAL(len);
1144                 while (len-- > 0) {
1145                     Copy(s, &aiv, 1, IV);
1146                     s += IVSIZE;
1147                     sv = NEWSV(40, 0);
1148                     sv_setiv(sv, aiv);
1149                     PUSHs(sv_2mortal(sv));
1150                 }
1151             }
1152             break;
1153         case 'J':
1154             along = (strend - s) / UVSIZE;
1155             if (len > along)
1156                 len = along;
1157             if (checksum) {
1158                 while (len-- > 0) {
1159                     Copy(s, &auv, 1, UV);
1160                     s += UVSIZE;
1161                     if (checksum > bits_in_uv)
1162                         cdouble += (NV)auv;
1163                     else
1164                         cuv += auv;
1165                 }
1166             }
1167             else {
1168                 if (len && unpack_only_one)
1169                     len = 1;
1170                 EXTEND(SP, len);
1171                 EXTEND_MORTAL(len);
1172                 while (len-- > 0) {
1173                     Copy(s, &auv, 1, UV);
1174                     s += UVSIZE;
1175                     sv = NEWSV(41, 0);
1176                     sv_setuv(sv, auv);
1177                     PUSHs(sv_2mortal(sv));
1178                 }
1179             }
1180             break;
1181         case 'l' | TYPE_IS_SHRIEKING:
1182 #if LONGSIZE != SIZE32
1183             along = (strend - s) / sizeof(long);
1184             if (len > along)
1185                 len = along;
1186             if (checksum) {
1187                 while (len-- > 0) {
1188                     COPYNN(s, &along, sizeof(long));
1189                     s += sizeof(long);
1190                     if (checksum > bits_in_uv)
1191                         cdouble += (NV)along;
1192                     else
1193                         cuv += along;
1194                 }
1195             }
1196             else {
1197                 if (len && unpack_only_one)
1198                     len = 1;
1199                 EXTEND(SP, len);
1200                 EXTEND_MORTAL(len);
1201                 while (len-- > 0) {
1202                     COPYNN(s, &along, sizeof(long));
1203                     s += sizeof(long);
1204                     sv = NEWSV(42, 0);
1205                     sv_setiv(sv, (IV)along);
1206                     PUSHs(sv_2mortal(sv));
1207                 }
1208             }
1209             break;
1210 #else
1211             /* Fallthrough! */
1212 #endif
1213         case 'l':
1214             along = (strend - s) / SIZE32;
1215             if (len > along)
1216                 len = along;
1217             if (checksum) {
1218                 while (len-- > 0) {
1219 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1220                     I32 along;
1221 #endif
1222                     COPY32(s, &along);
1223 #if LONGSIZE > SIZE32
1224                     if (along > 2147483647)
1225                         along -= 4294967296;
1226 #endif
1227                     s += SIZE32;
1228                     if (checksum > bits_in_uv)
1229                         cdouble += (NV)along;
1230                     else
1231                         cuv += along;
1232                 }
1233             }
1234             else {
1235                 if (len && unpack_only_one)
1236                     len = 1;
1237                 EXTEND(SP, len);
1238                 EXTEND_MORTAL(len);
1239                 while (len-- > 0) {
1240 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1241                     I32 along;
1242 #endif
1243                     COPY32(s, &along);
1244 #if LONGSIZE > SIZE32
1245                     if (along > 2147483647)
1246                         along -= 4294967296;
1247 #endif
1248                     s += SIZE32;
1249                     sv = NEWSV(42, 0);
1250                     sv_setiv(sv, (IV)along);
1251                     PUSHs(sv_2mortal(sv));
1252                 }
1253             }
1254             break;
1255         case 'L' | TYPE_IS_SHRIEKING:
1256 #if LONGSIZE != SIZE32
1257             along = (strend - s) / sizeof(unsigned long);
1258             if (len > along)
1259                 len = along;
1260             if (checksum) {
1261                 while (len-- > 0) {
1262                     unsigned long aulong;
1263                     COPYNN(s, &aulong, sizeof(unsigned long));
1264                     s += sizeof(unsigned long);
1265                     if (checksum > bits_in_uv)
1266                         cdouble += (NV)aulong;
1267                     else
1268                         cuv += aulong;
1269                 }
1270             }
1271             else {
1272                 if (len && unpack_only_one)
1273                     len = 1;
1274                 EXTEND(SP, len);
1275                 EXTEND_MORTAL(len);
1276                 while (len-- > 0) {
1277                     unsigned long aulong;
1278                     COPYNN(s, &aulong, sizeof(unsigned long));
1279                     s += sizeof(unsigned long);
1280                     sv = NEWSV(43, 0);
1281                     sv_setuv(sv, (UV)aulong);
1282                     PUSHs(sv_2mortal(sv));
1283                 }
1284             }
1285             break;
1286 #else
1287             /* Fall through! */
1288 #endif
1289         case 'V':
1290         case 'N':
1291         case 'L':
1292             along = (strend - s) / SIZE32;
1293             if (len > along)
1294                 len = along;
1295             if (checksum) {
1296                 while (len-- > 0) {
1297                     COPY32(s, &aulong);
1298                     s += SIZE32;
1299 #ifdef HAS_NTOHL
1300                     if (datumtype == 'N')
1301                         aulong = PerlSock_ntohl(aulong);
1302 #endif
1303 #ifdef HAS_VTOHL
1304                     if (datumtype == 'V')
1305                         aulong = vtohl(aulong);
1306 #endif
1307                     if (checksum > bits_in_uv)
1308                         cdouble += (NV)aulong;
1309                     else
1310                         cuv += aulong;
1311                 }
1312             }
1313             else {
1314                 if (len && unpack_only_one)
1315                     len = 1;
1316                 EXTEND(SP, len);
1317                 EXTEND_MORTAL(len);
1318                 while (len-- > 0) {
1319                     COPY32(s, &aulong);
1320                     s += SIZE32;
1321 #ifdef HAS_NTOHL
1322                     if (datumtype == 'N')
1323                         aulong = PerlSock_ntohl(aulong);
1324 #endif
1325 #ifdef HAS_VTOHL
1326                     if (datumtype == 'V')
1327                         aulong = vtohl(aulong);
1328 #endif
1329                     sv = NEWSV(43, 0);
1330                     sv_setuv(sv, (UV)aulong);
1331                     PUSHs(sv_2mortal(sv));
1332                 }
1333             }
1334             break;
1335         case 'p':
1336             along = (strend - s) / sizeof(char*);
1337             if (len > along)
1338                 len = along;
1339             EXTEND(SP, len);
1340             EXTEND_MORTAL(len);
1341             while (len-- > 0) {
1342                 if (sizeof(char*) > strend - s)
1343                     break;
1344                 else {
1345                     Copy(s, &aptr, 1, char*);
1346                     s += sizeof(char*);
1347                 }
1348                 sv = NEWSV(44, 0);
1349                 if (aptr)
1350                     sv_setpv(sv, aptr);
1351                 PUSHs(sv_2mortal(sv));
1352             }
1353             break;
1354         case 'w':
1355             if (len && unpack_only_one)
1356                 len = 1;
1357             EXTEND(SP, len);
1358             EXTEND_MORTAL(len);
1359             {
1360                 UV auv = 0;
1361                 U32 bytes = 0;
1362
1363                 while ((len > 0) && (s < strend)) {
1364                     auv = (auv << 7) | (*s & 0x7f);
1365                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1366                     if ((U8)(*s++) < 0x80) {
1367                         bytes = 0;
1368                         sv = NEWSV(40, 0);
1369                         sv_setuv(sv, auv);
1370                         PUSHs(sv_2mortal(sv));
1371                         len--;
1372                         auv = 0;
1373                     }
1374                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
1375                         char *t;
1376                         STRLEN n_a;
1377
1378                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1379                         while (s < strend) {
1380                             sv = mul128(sv, (U8)(*s & 0x7f));
1381                             if (!(*s++ & 0x80)) {
1382                                 bytes = 0;
1383                                 break;
1384                             }
1385                         }
1386                         t = SvPV(sv, n_a);
1387                         while (*t == '0')
1388                             t++;
1389                         sv_chop(sv, t);
1390                         PUSHs(sv_2mortal(sv));
1391                         len--;
1392                         auv = 0;
1393                     }
1394                 }
1395                 if ((s >= strend) && bytes)
1396                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1397             }
1398             break;
1399         case 'P':
1400             if (symptr->howlen == e_star)
1401                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1402             EXTEND(SP, 1);
1403             if (sizeof(char*) > strend - s)
1404                 break;
1405             else {
1406                 Copy(s, &aptr, 1, char*);
1407                 s += sizeof(char*);
1408             }
1409             sv = NEWSV(44, 0);
1410             if (aptr)
1411                 sv_setpvn(sv, aptr, len);
1412             PUSHs(sv_2mortal(sv));
1413             break;
1414 #ifdef HAS_QUAD
1415         case 'q':
1416             along = (strend - s) / sizeof(Quad_t);
1417             if (len > along)
1418                 len = along;
1419             if (checksum) {
1420                 while (len-- > 0) {
1421                     Copy(s, &aquad, 1, Quad_t);
1422                     s += sizeof(Quad_t);
1423                     if (checksum > bits_in_uv)
1424                         cdouble += (NV)aquad;
1425                     else
1426                         cuv += aquad;
1427                 }
1428             }
1429             else {
1430                 if (len && unpack_only_one)
1431                     len = 1;
1432                 EXTEND(SP, len);
1433                 EXTEND_MORTAL(len);
1434                 while (len-- > 0) {
1435                     if (s + sizeof(Quad_t) > strend)
1436                         aquad = 0;
1437                     else {
1438                         Copy(s, &aquad, 1, Quad_t);
1439                         s += sizeof(Quad_t);
1440                     }
1441                     sv = NEWSV(42, 0);
1442                     if (aquad >= IV_MIN && aquad <= IV_MAX)
1443                         sv_setiv(sv, (IV)aquad);
1444                     else
1445                         sv_setnv(sv, (NV)aquad);
1446                     PUSHs(sv_2mortal(sv));
1447                 }
1448             }
1449             break;
1450         case 'Q':
1451             along = (strend - s) / sizeof(Uquad_t);
1452             if (len > along)
1453                 len = along;
1454             if (checksum) {
1455                 while (len-- > 0) {
1456                     Copy(s, &auquad, 1, Uquad_t);
1457                     s += sizeof(Uquad_t);
1458                     if (checksum > bits_in_uv)
1459                         cdouble += (NV)auquad;
1460                     else
1461                         cuv += auquad;
1462                 }
1463             }
1464             else {
1465                 if (len && unpack_only_one)
1466                     len = 1;
1467                 EXTEND(SP, len);
1468                 EXTEND_MORTAL(len);
1469                 while (len-- > 0) {
1470                     if (s + sizeof(Uquad_t) > strend)
1471                         auquad = 0;
1472                     else {
1473                         Copy(s, &auquad, 1, Uquad_t);
1474                         s += sizeof(Uquad_t);
1475                     }
1476                     sv = NEWSV(43, 0);
1477                     if (auquad <= UV_MAX)
1478                         sv_setuv(sv, (UV)auquad);
1479                     else
1480                     sv_setnv(sv, (NV)auquad);
1481                     PUSHs(sv_2mortal(sv));
1482                 }
1483             }
1484             break;
1485 #endif
1486         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1487         case 'f':
1488             along = (strend - s) / sizeof(float);
1489             if (len > along)
1490                 len = along;
1491             if (checksum) {
1492                 while (len-- > 0) {
1493                     Copy(s, &afloat, 1, float);
1494                     s += sizeof(float);
1495                     cdouble += afloat;
1496                 }
1497             }
1498             else {
1499                 if (len && unpack_only_one)
1500                     len = 1;
1501                 EXTEND(SP, len);
1502                 EXTEND_MORTAL(len);
1503                 while (len-- > 0) {
1504                     Copy(s, &afloat, 1, float);
1505                     s += sizeof(float);
1506                     sv = NEWSV(47, 0);
1507                     sv_setnv(sv, (NV)afloat);
1508                     PUSHs(sv_2mortal(sv));
1509                 }
1510             }
1511             break;
1512         case 'd':
1513             along = (strend - s) / sizeof(double);
1514             if (len > along)
1515                 len = along;
1516             if (checksum) {
1517                 while (len-- > 0) {
1518                     Copy(s, &adouble, 1, double);
1519                     s += sizeof(double);
1520                     cdouble += adouble;
1521                 }
1522             }
1523             else {
1524                 if (len && unpack_only_one)
1525                     len = 1;
1526                 EXTEND(SP, len);
1527                 EXTEND_MORTAL(len);
1528                 while (len-- > 0) {
1529                     Copy(s, &adouble, 1, double);
1530                     s += sizeof(double);
1531                     sv = NEWSV(48, 0);
1532                     sv_setnv(sv, (NV)adouble);
1533                     PUSHs(sv_2mortal(sv));
1534                 }
1535             }
1536             break;
1537         case 'F':
1538             along = (strend - s) / NVSIZE;
1539             if (len > along)
1540                 len = along;
1541             if (checksum) {
1542                 while (len-- > 0) {
1543                     Copy(s, &anv, 1, NV);
1544                     s += NVSIZE;
1545                     cdouble += anv;
1546                 }
1547             }
1548             else {
1549                 if (len && unpack_only_one)
1550                     len = 1;
1551                 EXTEND(SP, len);
1552                 EXTEND_MORTAL(len);
1553                 while (len-- > 0) {
1554                     Copy(s, &anv, 1, NV);
1555                     s += NVSIZE;
1556                     sv = NEWSV(48, 0);
1557                     sv_setnv(sv, anv);
1558                     PUSHs(sv_2mortal(sv));
1559                 }
1560             }
1561             break;
1562 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1563         case 'D':
1564             along = (strend - s) / LONG_DOUBLESIZE;
1565             if (len > along)
1566                 len = along;
1567             if (checksum) {
1568                 while (len-- > 0) {
1569                     Copy(s, &aldouble, 1, long double);
1570                     s += LONG_DOUBLESIZE;
1571                     cdouble += aldouble;
1572                 }
1573             }
1574             else {
1575                 if (len && unpack_only_one)
1576                     len = 1;
1577                 EXTEND(SP, len);
1578                 EXTEND_MORTAL(len);
1579                 while (len-- > 0) {
1580                     Copy(s, &aldouble, 1, long double);
1581                     s += LONG_DOUBLESIZE;
1582                     sv = NEWSV(48, 0);
1583                     sv_setnv(sv, (NV)aldouble);
1584                     PUSHs(sv_2mortal(sv));
1585                 }
1586             }
1587             break;
1588 #endif
1589         case 'u':
1590             /* MKS:
1591              * Initialise the decode mapping.  By using a table driven
1592              * algorithm, the code will be character-set independent
1593              * (and just as fast as doing character arithmetic)
1594              */
1595             if (PL_uudmap['M'] == 0) {
1596                 int i;
1597
1598                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1599                     PL_uudmap[(U8)PL_uuemap[i]] = i;
1600                 /*
1601                  * Because ' ' and '`' map to the same value,
1602                  * we need to decode them both the same.
1603                  */
1604                 PL_uudmap[' '] = 0;
1605             }
1606
1607             along = (strend - s) * 3 / 4;
1608             sv = NEWSV(42, along);
1609             if (along)
1610                 SvPOK_on(sv);
1611             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1612                 I32 a, b, c, d;
1613                 char hunk[4];
1614
1615                 hunk[3] = '\0';
1616                 len = PL_uudmap[*(U8*)s++] & 077;
1617                 while (len > 0) {
1618                     if (s < strend && ISUUCHAR(*s))
1619                         a = PL_uudmap[*(U8*)s++] & 077;
1620                     else
1621                         a = 0;
1622                     if (s < strend && ISUUCHAR(*s))
1623                         b = PL_uudmap[*(U8*)s++] & 077;
1624                     else
1625                         b = 0;
1626                     if (s < strend && ISUUCHAR(*s))
1627                         c = PL_uudmap[*(U8*)s++] & 077;
1628                     else
1629                         c = 0;
1630                     if (s < strend && ISUUCHAR(*s))
1631                         d = PL_uudmap[*(U8*)s++] & 077;
1632                     else
1633                         d = 0;
1634                     hunk[0] = (char)((a << 2) | (b >> 4));
1635                     hunk[1] = (char)((b << 4) | (c >> 2));
1636                     hunk[2] = (char)((c << 6) | d);
1637                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1638                     len -= 3;
1639                 }
1640                 if (*s == '\n')
1641                     s++;
1642                 else    /* possible checksum byte */
1643                     if (s + 1 < strend && s[1] == '\n')
1644                         s += 2;
1645             }
1646             XPUSHs(sv_2mortal(sv));
1647             break;
1648         }
1649
1650         if (checksum) {
1651             sv = NEWSV(42, 0);
1652             if (strchr("fFdD", datumtype) ||
1653               (checksum > bits_in_uv &&
1654                strchr("csSiIlLnNUvVqQjJ", datumtype&0xFF)) ) {
1655                 NV trouble;
1656
1657                 adouble = (NV) (1 << (checksum & 15));
1658                 while (checksum >= 16) {
1659                     checksum -= 16;
1660                     adouble *= 65536.0;
1661                 }
1662                 while (cdouble < 0.0)
1663                     cdouble += adouble;
1664                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1665                 sv_setnv(sv, cdouble);
1666             }
1667             else {
1668                 if (checksum < bits_in_uv) {
1669                     UV mask = ((UV)1 << checksum) - 1;
1670                     cuv &= mask;
1671                 }
1672                 sv_setuv(sv, cuv);
1673             }
1674             XPUSHs(sv_2mortal(sv));
1675             checksum = 0;
1676         }
1677
1678         if (symptr->flags & FLAG_SLASH){
1679             if (SP - PL_stack_base - start_sp_offset <= 0)
1680                 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1681             if( next_symbol(symptr) ){
1682               if( symptr->howlen == e_number )
1683                 Perl_croak(aTHX_ "Count after length/code in unpack" );
1684               if( beyond ){
1685                 /* ...end of char buffer then no decent length available */
1686                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1687               } else {
1688                 /* take top of stack (hope it's numeric) */
1689                 len = POPi;
1690                 if( len < 0 )
1691                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
1692               }
1693             } else {
1694                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1695             }
1696             datumtype = symptr->code;
1697             goto redo_switch;
1698         }
1699     }
1700
1701     if (new_s)
1702         *new_s = s;
1703     PUTBACK;
1704     return SP - PL_stack_base - start_sp_offset;
1705 }
1706
1707 PP(pp_unpack)
1708 {
1709     dSP;
1710     SV *right = (MAXARG > 1) ? POPs : GvSV(PL_defgv);
1711     SV *left = POPs;
1712     I32 gimme = GIMME_V;
1713     STRLEN llen;
1714     STRLEN rlen;
1715     register char *pat = SvPV(left, llen);
1716 #ifdef PACKED_IS_OCTETS
1717     /* Packed side is assumed to be octets - so force downgrade if it
1718        has been UTF-8 encoded by accident
1719      */
1720     register char *s = SvPVbyte(right, rlen);
1721 #else
1722     register char *s = SvPV(right, rlen);
1723 #endif
1724     char *strend = s + rlen;
1725     register char *patend = pat + llen;
1726     register I32 cnt;
1727
1728     PUTBACK;
1729     cnt = unpackstring(pat, patend, s, strend,
1730                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1731                      | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1732
1733     SPAGAIN;
1734     if ( !cnt && gimme == G_SCALAR )
1735        PUSHs(&PL_sv_undef);
1736     RETURN;
1737 }
1738
1739 STATIC void
1740 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1741 {
1742     char hunk[5];
1743
1744     *hunk = PL_uuemap[len];
1745     sv_catpvn(sv, hunk, 1);
1746     hunk[4] = '\0';
1747     while (len > 2) {
1748         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1749         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1750         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1751         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1752         sv_catpvn(sv, hunk, 4);
1753         s += 3;
1754         len -= 3;
1755     }
1756     if (len > 0) {
1757         char r = (len > 1 ? s[1] : '\0');
1758         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1759         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1760         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1761         hunk[3] = PL_uuemap[0];
1762         sv_catpvn(sv, hunk, 4);
1763     }
1764     sv_catpvn(sv, "\n", 1);
1765 }
1766
1767 STATIC SV *
1768 S_is_an_int(pTHX_ char *s, STRLEN l)
1769 {
1770   STRLEN         n_a;
1771   SV             *result = newSVpvn(s, l);
1772   char           *result_c = SvPV(result, n_a); /* convenience */
1773   char           *out = result_c;
1774   bool            skip = 1;
1775   bool            ignore = 0;
1776
1777   while (*s) {
1778     switch (*s) {
1779     case ' ':
1780       break;
1781     case '+':
1782       if (!skip) {
1783         SvREFCNT_dec(result);
1784         return (NULL);
1785       }
1786       break;
1787     case '0':
1788     case '1':
1789     case '2':
1790     case '3':
1791     case '4':
1792     case '5':
1793     case '6':
1794     case '7':
1795     case '8':
1796     case '9':
1797       skip = 0;
1798       if (!ignore) {
1799         *(out++) = *s;
1800       }
1801       break;
1802     case '.':
1803       ignore = 1;
1804       break;
1805     default:
1806       SvREFCNT_dec(result);
1807       return (NULL);
1808     }
1809     s++;
1810   }
1811   *(out++) = '\0';
1812   SvCUR_set(result, out - result_c);
1813   return (result);
1814 }
1815
1816 /* pnum must be '\0' terminated */
1817 STATIC int
1818 S_div128(pTHX_ SV *pnum, bool *done)
1819 {
1820   STRLEN          len;
1821   char           *s = SvPV(pnum, len);
1822   int             m = 0;
1823   int             r = 0;
1824   char           *t = s;
1825
1826   *done = 1;
1827   while (*t) {
1828     int             i;
1829
1830     i = m * 10 + (*t - '0');
1831     m = i & 0x7F;
1832     r = (i >> 7);               /* r < 10 */
1833     if (r) {
1834       *done = 0;
1835     }
1836     *(t++) = '0' + r;
1837   }
1838   *(t++) = '\0';
1839   SvCUR_set(pnum, (STRLEN) (t - s));
1840   return (m);
1841 }
1842
1843
1844
1845 /*
1846 =for apidoc pack_cat
1847
1848 The engine implementing pack() Perl function. Note: parameters next_in_list and
1849 flags are not used. This call should not be used; use packlist instead.
1850
1851 =cut */
1852
1853
1854 void
1855 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1856 {
1857     tempsym_t sym = { 0 };
1858     sym.patptr = pat;
1859     sym.patend = patend;
1860     sym.flags  = FLAG_PACK;
1861
1862     (void)pack_rec( cat, &sym, beglist, endlist );
1863 }
1864
1865
1866 /*
1867 =for apidoc packlist
1868
1869 The engine implementing pack() Perl function.
1870
1871 =cut */
1872
1873
1874 void
1875 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1876 {
1877     tempsym_t sym = { 0 };
1878     sym.patptr = pat;
1879     sym.patend = patend;
1880     sym.flags  = FLAG_PACK;
1881
1882     (void)pack_rec( cat, &sym, beglist, endlist );
1883 }
1884
1885
1886 STATIC
1887 SV **
1888 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1889 {
1890     register I32 items;
1891     STRLEN fromlen;
1892     register I32 len = 0;
1893     SV *fromstr;
1894     /*SUPPRESS 442*/
1895     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1896     static char *space10 = "          ";
1897     bool found;
1898
1899     /* These must not be in registers: */
1900     char achar;
1901     I16 ashort;
1902     int aint;
1903     unsigned int auint;
1904     I32 along;
1905     U32 aulong;
1906     IV aiv;
1907     UV auv;
1908     NV anv;
1909 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1910     long double aldouble;
1911 #endif
1912 #ifdef HAS_QUAD
1913     Quad_t aquad;
1914     Uquad_t auquad;
1915 #endif
1916     char *aptr;
1917     float afloat;
1918     double adouble;
1919     int strrelbeg = SvCUR(cat);
1920     tempsym_t lookahead;
1921
1922     items = endlist - beglist;
1923     found = next_symbol( symptr );
1924
1925 #ifndef PACKED_IS_OCTETS
1926     if (symptr->level == 0 && found && symptr->code == 'U' ){
1927         SvUTF8_on(cat);
1928     }
1929 #endif
1930
1931     while (found) {
1932         SV *lengthcode = Nullsv;
1933 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1934
1935         I32 datumtype = symptr->code;
1936         howlen_t howlen;
1937
1938         switch( howlen = symptr->howlen ){
1939         case e_no_len:
1940         case e_number:
1941             len = symptr->length;
1942             break;
1943         case e_star:
1944             len = strchr("@Xxu", datumtype) ? 0 : items;
1945             break;
1946         }
1947
1948         /* Look ahead for next symbol. Do we have code/code? */
1949         lookahead = *symptr;
1950         found = next_symbol(&lookahead);
1951         if ( symptr->flags & FLAG_SLASH ) {
1952             if (found){
1953                 if ( 0 == strchr( "aAZ", lookahead.code ) ||
1954                      e_star != lookahead.howlen )
1955                     Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
1956                 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1957                                                    ? *beglist : &PL_sv_no)
1958                                            + (lookahead.code == 'Z' ? 1 : 0)));
1959             } else {
1960                 Perl_croak(aTHX_ "Code missing after '/' in pack");
1961             }
1962         }
1963
1964         switch(datumtype) {
1965         default:
1966             Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)datumtype);
1967         case '%':
1968             Perl_croak(aTHX_ "'%%' may not be used in pack");
1969         case '@':
1970             len += strrelbeg - SvCUR(cat);
1971             if (len > 0)
1972                 goto grow;
1973             len = -len;
1974             if (len > 0)
1975                 goto shrink;
1976             break;
1977         case '(':
1978         {
1979             tempsym_t savsym = *symptr;
1980             symptr->patend = savsym.grpend;
1981             symptr->level++;
1982             while (len--) {
1983                 symptr->patptr = savsym.grpbeg;
1984                 beglist = pack_rec(cat, symptr, beglist, endlist );
1985                 if (savsym.howlen == e_star && beglist == endlist)
1986                     break;              /* No way to continue */
1987             }
1988             lookahead.flags = symptr->flags;
1989             *symptr = savsym;
1990             break;
1991         }
1992         case 'X' | TYPE_IS_SHRIEKING:
1993             if (!len)                   /* Avoid division by 0 */
1994                 len = 1;
1995             len = (SvCUR(cat)) % len;
1996             /* FALL THROUGH */
1997         case 'X':
1998           shrink:
1999             if ((I32)SvCUR(cat) < len)
2000                 Perl_croak(aTHX_ "'X' outside of string in pack");
2001             SvCUR(cat) -= len;
2002             *SvEND(cat) = '\0';
2003             break;
2004         case 'x' | TYPE_IS_SHRIEKING:
2005             if (!len)                   /* Avoid division by 0 */
2006                 len = 1;
2007             aint = (SvCUR(cat)) % len;
2008             if (aint)                   /* Other portable ways? */
2009                 len = len - aint;
2010             else
2011                 len = 0;
2012             /* FALL THROUGH */
2013
2014         case 'x':
2015           grow:
2016             while (len >= 10) {
2017                 sv_catpvn(cat, null10, 10);
2018                 len -= 10;
2019             }
2020             sv_catpvn(cat, null10, len);
2021             break;
2022         case 'A':
2023         case 'Z':
2024         case 'a':
2025             fromstr = NEXTFROM;
2026             aptr = SvPV(fromstr, fromlen);
2027             if (howlen == e_star) {
2028                 len = fromlen;
2029                 if (datumtype == 'Z')
2030                     ++len;
2031             }
2032             if ((I32)fromlen >= len) {
2033                 sv_catpvn(cat, aptr, len);
2034                 if (datumtype == 'Z')
2035                     *(SvEND(cat)-1) = '\0';
2036             }
2037             else {
2038                 sv_catpvn(cat, aptr, fromlen);
2039                 len -= fromlen;
2040                 if (datumtype == 'A') {
2041                     while (len >= 10) {
2042                         sv_catpvn(cat, space10, 10);
2043                         len -= 10;
2044                     }
2045                     sv_catpvn(cat, space10, len);
2046                 }
2047                 else {
2048                     while (len >= 10) {
2049                         sv_catpvn(cat, null10, 10);
2050                         len -= 10;
2051                     }
2052                     sv_catpvn(cat, null10, len);
2053                 }
2054             }
2055             break;
2056         case 'B':
2057         case 'b':
2058             {
2059                 register char *str;
2060                 I32 saveitems;
2061
2062                 fromstr = NEXTFROM;
2063                 saveitems = items;
2064                 str = SvPV(fromstr, fromlen);
2065                 if (howlen == e_star)
2066                     len = fromlen;
2067                 aint = SvCUR(cat);
2068                 SvCUR(cat) += (len+7)/8;
2069                 SvGROW(cat, SvCUR(cat) + 1);
2070                 aptr = SvPVX(cat) + aint;
2071                 if (len > (I32)fromlen)
2072                     len = fromlen;
2073                 aint = len;
2074                 items = 0;
2075                 if (datumtype == 'B') {
2076                     for (len = 0; len++ < aint;) {
2077                         items |= *str++ & 1;
2078                         if (len & 7)
2079                             items <<= 1;
2080                         else {
2081                             *aptr++ = items & 0xff;
2082                             items = 0;
2083                         }
2084                     }
2085                 }
2086                 else {
2087                     for (len = 0; len++ < aint;) {
2088                         if (*str++ & 1)
2089                             items |= 128;
2090                         if (len & 7)
2091                             items >>= 1;
2092                         else {
2093                             *aptr++ = items & 0xff;
2094                             items = 0;
2095                         }
2096                     }
2097                 }
2098                 if (aint & 7) {
2099                     if (datumtype == 'B')
2100                         items <<= 7 - (aint & 7);
2101                     else
2102                         items >>= 7 - (aint & 7);
2103                     *aptr++ = items & 0xff;
2104                 }
2105                 str = SvPVX(cat) + SvCUR(cat);
2106                 while (aptr <= str)
2107                     *aptr++ = '\0';
2108
2109                 items = saveitems;
2110             }
2111             break;
2112         case 'H':
2113         case 'h':
2114             {
2115                 register char *str;
2116                 I32 saveitems;
2117
2118                 fromstr = NEXTFROM;
2119                 saveitems = items;
2120                 str = SvPV(fromstr, fromlen);
2121                 if (howlen == e_star)
2122                     len = fromlen;
2123                 aint = SvCUR(cat);
2124                 SvCUR(cat) += (len+1)/2;
2125                 SvGROW(cat, SvCUR(cat) + 1);
2126                 aptr = SvPVX(cat) + aint;
2127                 if (len > (I32)fromlen)
2128                     len = fromlen;
2129                 aint = len;
2130                 items = 0;
2131                 if (datumtype == 'H') {
2132                     for (len = 0; len++ < aint;) {
2133                         if (isALPHA(*str))
2134                             items |= ((*str++ & 15) + 9) & 15;
2135                         else
2136                             items |= *str++ & 15;
2137                         if (len & 1)
2138                             items <<= 4;
2139                         else {
2140                             *aptr++ = items & 0xff;
2141                             items = 0;
2142                         }
2143                     }
2144                 }
2145                 else {
2146                     for (len = 0; len++ < aint;) {
2147                         if (isALPHA(*str))
2148                             items |= (((*str++ & 15) + 9) & 15) << 4;
2149                         else
2150                             items |= (*str++ & 15) << 4;
2151                         if (len & 1)
2152                             items >>= 4;
2153                         else {
2154                             *aptr++ = items & 0xff;
2155                             items = 0;
2156                         }
2157                     }
2158                 }
2159                 if (aint & 1)
2160                     *aptr++ = items & 0xff;
2161                 str = SvPVX(cat) + SvCUR(cat);
2162                 while (aptr <= str)
2163                     *aptr++ = '\0';
2164
2165                 items = saveitems;
2166             }
2167             break;
2168         case 'C':
2169         case 'c':
2170             while (len-- > 0) {
2171                 fromstr = NEXTFROM;
2172                 switch (datumtype) {
2173                 case 'C':
2174                     aint = SvIV(fromstr);
2175                     if ((aint < 0 || aint > 255) &&
2176                         ckWARN(WARN_PACK))
2177                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2178                                     "Character in 'C' format wrapped in pack");
2179                     achar = aint & 255;
2180                     sv_catpvn(cat, &achar, sizeof(char));
2181                     break;
2182                 case 'c':
2183                     aint = SvIV(fromstr);
2184                     if ((aint < -128 || aint > 127) &&
2185                         ckWARN(WARN_PACK))
2186                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2187                                     "Character in 'c' format wrapped in pack" );
2188                     achar = aint & 255;
2189                     sv_catpvn(cat, &achar, sizeof(char));
2190                     break;
2191                 }
2192             }
2193             break;
2194         case 'U':
2195             while (len-- > 0) {
2196                 fromstr = NEXTFROM;
2197                 auint = UNI_TO_NATIVE(SvUV(fromstr));
2198                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2199                 SvCUR_set(cat,
2200                           (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2201                                                      auint,
2202                                                      ckWARN(WARN_UTF8) ?
2203                                                      0 : UNICODE_ALLOW_ANY)
2204                           - SvPVX(cat));
2205             }
2206             *SvEND(cat) = '\0';
2207             break;
2208         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2209         case 'f':
2210             while (len-- > 0) {
2211                 fromstr = NEXTFROM;
2212 #ifdef __VOS__
2213 /* VOS does not automatically map a floating-point overflow
2214    during conversion from double to float into infinity, so we
2215    do it by hand.  This code should either be generalized for
2216    any OS that needs it, or removed if and when VOS implements
2217    posix-976 (suggestion to support mapping to infinity).
2218    Paul.Green@stratus.com 02-04-02.  */
2219                 if (SvNV(fromstr) > FLT_MAX)
2220                      afloat = _float_constants[0];   /* single prec. inf. */
2221                 else if (SvNV(fromstr) < -FLT_MAX)
2222                      afloat = _float_constants[0];   /* single prec. inf. */
2223                 else afloat = (float)SvNV(fromstr);
2224 #else
2225 # if defined(VMS) && !defined(__IEEE_FP)
2226 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2227  * on Alpha; fake it if we don't have them.
2228  */
2229                 if (SvNV(fromstr) > FLT_MAX)
2230                      afloat = FLT_MAX;
2231                 else if (SvNV(fromstr) < -FLT_MAX)
2232                      afloat = -FLT_MAX;
2233                 else afloat = (float)SvNV(fromstr);
2234 # else
2235                 afloat = (float)SvNV(fromstr);
2236 # endif
2237 #endif
2238                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2239             }
2240             break;
2241         case 'd':
2242             while (len-- > 0) {
2243                 fromstr = NEXTFROM;
2244 #ifdef __VOS__
2245 /* VOS does not automatically map a floating-point overflow
2246    during conversion from long double to double into infinity,
2247    so we do it by hand.  This code should either be generalized
2248    for any OS that needs it, or removed if and when VOS
2249    implements posix-976 (suggestion to support mapping to
2250    infinity).  Paul.Green@stratus.com 02-04-02.  */
2251                 if (SvNV(fromstr) > DBL_MAX)
2252                      adouble = _double_constants[0];   /* double prec. inf. */
2253                 else if (SvNV(fromstr) < -DBL_MAX)
2254                      adouble = _double_constants[0];   /* double prec. inf. */
2255                 else adouble = (double)SvNV(fromstr);
2256 #else
2257 # if defined(VMS) && !defined(__IEEE_FP)
2258 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2259  * on Alpha; fake it if we don't have them.
2260  */
2261                 if (SvNV(fromstr) > DBL_MAX)
2262                      adouble = DBL_MAX;
2263                 else if (SvNV(fromstr) < -DBL_MAX)
2264                      adouble = -DBL_MAX;
2265                 else adouble = (double)SvNV(fromstr);
2266 # else
2267                 adouble = (double)SvNV(fromstr);
2268 # endif
2269 #endif
2270                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2271             }
2272             break;
2273         case 'F':
2274             while (len-- > 0) {
2275                 fromstr = NEXTFROM;
2276                 anv = SvNV(fromstr);
2277                 sv_catpvn(cat, (char *)&anv, NVSIZE);
2278             }
2279             break;
2280 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2281         case 'D':
2282             while (len-- > 0) {
2283                 fromstr = NEXTFROM;
2284                 aldouble = (long double)SvNV(fromstr);
2285                 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2286             }
2287             break;
2288 #endif
2289         case 'n':
2290             while (len-- > 0) {
2291                 fromstr = NEXTFROM;
2292                 ashort = (I16)SvIV(fromstr);
2293 #ifdef HAS_HTONS
2294                 ashort = PerlSock_htons(ashort);
2295 #endif
2296                 CAT16(cat, &ashort);
2297             }
2298             break;
2299         case 'v':
2300             while (len-- > 0) {
2301                 fromstr = NEXTFROM;
2302                 ashort = (I16)SvIV(fromstr);
2303 #ifdef HAS_HTOVS
2304                 ashort = htovs(ashort);
2305 #endif
2306                 CAT16(cat, &ashort);
2307             }
2308             break;
2309         case 'S' | TYPE_IS_SHRIEKING:
2310 #if SHORTSIZE != SIZE16
2311             {
2312                 unsigned short aushort;
2313
2314                 while (len-- > 0) {
2315                     fromstr = NEXTFROM;
2316                     aushort = SvUV(fromstr);
2317                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2318                 }
2319             }
2320             break;
2321 #else
2322             /* Fall through! */
2323 #endif
2324         case 'S':
2325             {
2326                 U16 aushort;
2327
2328                 while (len-- > 0) {
2329                     fromstr = NEXTFROM;
2330                     aushort = (U16)SvUV(fromstr);
2331                     CAT16(cat, &aushort);
2332                 }
2333
2334             }
2335             break;
2336         case 's' | TYPE_IS_SHRIEKING:
2337 #if SHORTSIZE != SIZE16
2338             {
2339                 short ashort;
2340
2341                 while (len-- > 0) {
2342                     fromstr = NEXTFROM;
2343                     ashort = SvIV(fromstr);
2344                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
2345                 }
2346             }
2347             break;
2348 #else
2349             /* Fall through! */
2350 #endif
2351         case 's':
2352             while (len-- > 0) {
2353                 fromstr = NEXTFROM;
2354                 ashort = (I16)SvIV(fromstr);
2355                 CAT16(cat, &ashort);
2356             }
2357             break;
2358         case 'I':
2359         case 'I' | TYPE_IS_SHRIEKING:
2360             while (len-- > 0) {
2361                 fromstr = NEXTFROM;
2362                 auint = SvUV(fromstr);
2363                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2364             }
2365             break;
2366         case 'j':
2367             while (len-- > 0) {
2368                 fromstr = NEXTFROM;
2369                 aiv = SvIV(fromstr);
2370                 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2371             }
2372             break;
2373         case 'J':
2374             while (len-- > 0) {
2375                 fromstr = NEXTFROM;
2376                 auv = SvUV(fromstr);
2377                 sv_catpvn(cat, (char*)&auv, UVSIZE);
2378             }
2379             break;
2380         case 'w':
2381             while (len-- > 0) {
2382                 fromstr = NEXTFROM;
2383                 anv = SvNV(fromstr);
2384
2385                 if (anv < 0)
2386                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2387
2388                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2389                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2390                    any negative IVs will have already been got by the croak()
2391                    above. IOK is untrue for fractions, so we test them
2392                    against UV_MAX_P1.  */
2393                 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2394                 {
2395                     char   buf[(sizeof(UV)*8)/7+1];
2396                     char  *in = buf + sizeof(buf);
2397                     UV     auv = SvUV(fromstr);
2398
2399                     do {
2400                         *--in = (char)((auv & 0x7f) | 0x80);
2401                         auv >>= 7;
2402                     } while (auv);
2403                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2404                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2405                 }
2406                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
2407                     char           *from, *result, *in;
2408                     SV             *norm;
2409                     STRLEN          len;
2410                     bool            done;
2411
2412                     /* Copy string and check for compliance */
2413                     from = SvPV(fromstr, len);
2414                     if ((norm = is_an_int(from, len)) == NULL)
2415                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2416
2417                     New('w', result, len, char);
2418                     in = result + len;
2419                     done = FALSE;
2420                     while (!done)
2421                         *--in = div128(norm, &done) | 0x80;
2422                     result[len - 1] &= 0x7F; /* clear continue bit */
2423                     sv_catpvn(cat, in, (result + len) - in);
2424                     Safefree(result);
2425                     SvREFCNT_dec(norm); /* free norm */
2426                 }
2427                 else if (SvNOKp(fromstr)) {
2428                     /* 10**NV_MAX_10_EXP is the largest power of 10
2429                        so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2430                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2431                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2432                        And with that many bytes only Inf can overflow.
2433                     */
2434 #ifdef NV_MAX_10_EXP
2435                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)];
2436 #else
2437                     char   buf[1 + (int)((308 + 1) * 0.47456)];
2438 #endif
2439                     char  *in = buf + sizeof(buf);
2440
2441                     anv = Perl_floor(anv);
2442                     do {
2443                         NV next = Perl_floor(anv / 128);
2444                         if (in <= buf)  /* this cannot happen ;-) */
2445                             Perl_croak(aTHX_ "Cannot compress integer in pack");
2446                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2447                         anv = next;
2448                     } while (anv > 0);
2449                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2450                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2451                 }
2452                 else {
2453                     char           *from, *result, *in;
2454                     SV             *norm;
2455                     STRLEN          len;
2456                     bool            done;
2457
2458                     /* Copy string and check for compliance */
2459                     from = SvPV(fromstr, len);
2460                     if ((norm = is_an_int(from, len)) == NULL)
2461                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2462
2463                     New('w', result, len, char);
2464                     in = result + len;
2465                     done = FALSE;
2466                     while (!done)
2467                         *--in = div128(norm, &done) | 0x80;
2468                     result[len - 1] &= 0x7F; /* clear continue bit */
2469                     sv_catpvn(cat, in, (result + len) - in);
2470                     Safefree(result);
2471                     SvREFCNT_dec(norm); /* free norm */
2472                }
2473             }
2474             break;
2475         case 'i':
2476         case 'i' | TYPE_IS_SHRIEKING:
2477             while (len-- > 0) {
2478                 fromstr = NEXTFROM;
2479                 aint = SvIV(fromstr);
2480                 sv_catpvn(cat, (char*)&aint, sizeof(int));
2481             }
2482             break;
2483         case 'N':
2484             while (len-- > 0) {
2485                 fromstr = NEXTFROM;
2486                 aulong = SvUV(fromstr);
2487 #ifdef HAS_HTONL
2488                 aulong = PerlSock_htonl(aulong);
2489 #endif
2490                 CAT32(cat, &aulong);
2491             }
2492             break;
2493         case 'V':
2494             while (len-- > 0) {
2495                 fromstr = NEXTFROM;
2496                 aulong = SvUV(fromstr);
2497 #ifdef HAS_HTOVL
2498                 aulong = htovl(aulong);
2499 #endif
2500                 CAT32(cat, &aulong);
2501             }
2502             break;
2503         case 'L' | TYPE_IS_SHRIEKING:
2504 #if LONGSIZE != SIZE32
2505             {
2506                 unsigned long aulong;
2507
2508                 while (len-- > 0) {
2509                     fromstr = NEXTFROM;
2510                     aulong = SvUV(fromstr);
2511                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2512                 }
2513             }
2514             break;
2515 #else
2516             /* Fall though! */
2517 #endif
2518         case 'L':
2519             {
2520                 while (len-- > 0) {
2521                     fromstr = NEXTFROM;
2522                     aulong = SvUV(fromstr);
2523                     CAT32(cat, &aulong);
2524                 }
2525             }
2526             break;
2527         case 'l' | TYPE_IS_SHRIEKING:
2528 #if LONGSIZE != SIZE32
2529             {
2530                 long along;
2531
2532                 while (len-- > 0) {
2533                     fromstr = NEXTFROM;
2534                     along = SvIV(fromstr);
2535                     sv_catpvn(cat, (char *)&along, sizeof(long));
2536                 }
2537             }
2538             break;
2539 #else
2540             /* Fall though! */
2541 #endif
2542         case 'l':
2543             while (len-- > 0) {
2544                 fromstr = NEXTFROM;
2545                 along = SvIV(fromstr);
2546                 CAT32(cat, &along);
2547             }
2548             break;
2549 #ifdef HAS_QUAD
2550         case 'Q':
2551             while (len-- > 0) {
2552                 fromstr = NEXTFROM;
2553                 auquad = (Uquad_t)SvUV(fromstr);
2554                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2555             }
2556             break;
2557         case 'q':
2558             while (len-- > 0) {
2559                 fromstr = NEXTFROM;
2560                 aquad = (Quad_t)SvIV(fromstr);
2561                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2562             }
2563             break;
2564 #endif
2565         case 'P':
2566             len = 1;            /* assume SV is correct length */
2567             /* Fall through! */
2568         case 'p':
2569             while (len-- > 0) {
2570                 fromstr = NEXTFROM;
2571                 if (fromstr == &PL_sv_undef)
2572                     aptr = NULL;
2573                 else {
2574                     STRLEN n_a;
2575                     /* XXX better yet, could spirit away the string to
2576                      * a safe spot and hang on to it until the result
2577                      * of pack() (and all copies of the result) are
2578                      * gone.
2579                      */
2580                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2581                                                 || (SvPADTMP(fromstr)
2582                                                     && !SvREADONLY(fromstr))))
2583                     {
2584                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2585                                 "Attempt to pack pointer to temporary value");
2586                     }
2587                     if (SvPOK(fromstr) || SvNIOK(fromstr))
2588                         aptr = SvPV(fromstr,n_a);
2589                     else
2590                         aptr = SvPV_force(fromstr,n_a);
2591                 }
2592                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2593             }
2594             break;
2595         case 'u':
2596             fromstr = NEXTFROM;
2597             aptr = SvPV(fromstr, fromlen);
2598             SvGROW(cat, fromlen * 4 / 3);
2599             if (len <= 2)
2600                 len = 45;
2601             else
2602                 len = len / 3 * 3;
2603             while (fromlen > 0) {
2604                 I32 todo;
2605
2606                 if ((I32)fromlen > len)
2607                     todo = len;
2608                 else
2609                     todo = fromlen;
2610                 doencodes(cat, aptr, todo);
2611                 fromlen -= todo;
2612                 aptr += todo;
2613             }
2614             break;
2615         }
2616         *symptr = lookahead;
2617     }
2618     return beglist;
2619 }
2620 #undef NEXTFROM
2621
2622
2623 PP(pp_pack)
2624 {
2625     dSP; dMARK; dORIGMARK; dTARGET;
2626     register SV *cat = TARG;
2627     STRLEN fromlen;
2628     register char *pat = SvPVx(*++MARK, fromlen);
2629     register char *patend = pat + fromlen;
2630
2631     MARK++;
2632     sv_setpvn(cat, "", 0);
2633
2634     packlist(cat, pat, patend, MARK, SP + 1);
2635
2636     SvSETMAGIC(cat);
2637     SP = ORIGMARK;
2638     PUSHs(cat);
2639     RETURN;
2640 }
2641