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     dPOPPOPssrl;
1711     I32 gimme = GIMME_V;
1712     STRLEN llen;
1713     STRLEN rlen;
1714     register char *pat = SvPV(left, llen);
1715 #ifdef PACKED_IS_OCTETS
1716     /* Packed side is assumed to be octets - so force downgrade if it
1717        has been UTF-8 encoded by accident
1718      */
1719     register char *s = SvPVbyte(right, rlen);
1720 #else
1721     register char *s = SvPV(right, rlen);
1722 #endif
1723     char *strend = s + rlen;
1724     register char *patend = pat + llen;
1725     register I32 cnt;
1726
1727     PUTBACK;
1728     cnt = unpackstring(pat, patend, s, strend,
1729                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1730                      | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1731
1732     SPAGAIN;
1733     if ( !cnt && gimme == G_SCALAR )
1734        PUSHs(&PL_sv_undef);
1735     RETURN;
1736 }
1737
1738 STATIC void
1739 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1740 {
1741     char hunk[5];
1742
1743     *hunk = PL_uuemap[len];
1744     sv_catpvn(sv, hunk, 1);
1745     hunk[4] = '\0';
1746     while (len > 2) {
1747         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1748         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1749         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1750         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1751         sv_catpvn(sv, hunk, 4);
1752         s += 3;
1753         len -= 3;
1754     }
1755     if (len > 0) {
1756         char r = (len > 1 ? s[1] : '\0');
1757         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1758         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1759         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1760         hunk[3] = PL_uuemap[0];
1761         sv_catpvn(sv, hunk, 4);
1762     }
1763     sv_catpvn(sv, "\n", 1);
1764 }
1765
1766 STATIC SV *
1767 S_is_an_int(pTHX_ char *s, STRLEN l)
1768 {
1769   STRLEN         n_a;
1770   SV             *result = newSVpvn(s, l);
1771   char           *result_c = SvPV(result, n_a); /* convenience */
1772   char           *out = result_c;
1773   bool            skip = 1;
1774   bool            ignore = 0;
1775
1776   while (*s) {
1777     switch (*s) {
1778     case ' ':
1779       break;
1780     case '+':
1781       if (!skip) {
1782         SvREFCNT_dec(result);
1783         return (NULL);
1784       }
1785       break;
1786     case '0':
1787     case '1':
1788     case '2':
1789     case '3':
1790     case '4':
1791     case '5':
1792     case '6':
1793     case '7':
1794     case '8':
1795     case '9':
1796       skip = 0;
1797       if (!ignore) {
1798         *(out++) = *s;
1799       }
1800       break;
1801     case '.':
1802       ignore = 1;
1803       break;
1804     default:
1805       SvREFCNT_dec(result);
1806       return (NULL);
1807     }
1808     s++;
1809   }
1810   *(out++) = '\0';
1811   SvCUR_set(result, out - result_c);
1812   return (result);
1813 }
1814
1815 /* pnum must be '\0' terminated */
1816 STATIC int
1817 S_div128(pTHX_ SV *pnum, bool *done)
1818 {
1819   STRLEN          len;
1820   char           *s = SvPV(pnum, len);
1821   int             m = 0;
1822   int             r = 0;
1823   char           *t = s;
1824
1825   *done = 1;
1826   while (*t) {
1827     int             i;
1828
1829     i = m * 10 + (*t - '0');
1830     m = i & 0x7F;
1831     r = (i >> 7);               /* r < 10 */
1832     if (r) {
1833       *done = 0;
1834     }
1835     *(t++) = '0' + r;
1836   }
1837   *(t++) = '\0';
1838   SvCUR_set(pnum, (STRLEN) (t - s));
1839   return (m);
1840 }
1841
1842
1843
1844 /*
1845 =for apidoc pack_cat
1846
1847 The engine implementing pack() Perl function. Note: parameters next_in_list and
1848 flags are not used. This call should not be used; use packlist instead.
1849
1850 =cut */
1851
1852
1853 void
1854 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1855 {
1856     tempsym_t sym = { 0 };
1857     sym.patptr = pat;
1858     sym.patend = patend;
1859     sym.flags  = FLAG_PACK;
1860
1861     (void)pack_rec( cat, &sym, beglist, endlist );
1862 }
1863
1864
1865 /*
1866 =for apidoc packlist
1867
1868 The engine implementing pack() Perl function.
1869
1870 =cut */
1871
1872
1873 void
1874 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1875 {
1876     tempsym_t sym = { 0 };
1877     sym.patptr = pat;
1878     sym.patend = patend;
1879     sym.flags  = FLAG_PACK;
1880
1881     (void)pack_rec( cat, &sym, beglist, endlist );
1882 }
1883
1884
1885 STATIC
1886 SV **
1887 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1888 {
1889     register I32 items;
1890     STRLEN fromlen;
1891     register I32 len = 0;
1892     SV *fromstr;
1893     /*SUPPRESS 442*/
1894     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1895     static char *space10 = "          ";
1896     bool found;
1897
1898     /* These must not be in registers: */
1899     char achar;
1900     I16 ashort;
1901     int aint;
1902     unsigned int auint;
1903     I32 along;
1904     U32 aulong;
1905     IV aiv;
1906     UV auv;
1907     NV anv;
1908 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1909     long double aldouble;
1910 #endif
1911 #ifdef HAS_QUAD
1912     Quad_t aquad;
1913     Uquad_t auquad;
1914 #endif
1915     char *aptr;
1916     float afloat;
1917     double adouble;
1918     int strrelbeg = SvCUR(cat);
1919     tempsym_t lookahead;
1920
1921     items = endlist - beglist;
1922     found = next_symbol( symptr );
1923
1924 #ifndef PACKED_IS_OCTETS
1925     if (symptr->level == 0 && found && symptr->code == 'U' ){
1926         SvUTF8_on(cat);
1927     }
1928 #endif
1929
1930     while (found) {
1931         SV *lengthcode = Nullsv;
1932 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1933
1934         I32 datumtype = symptr->code;
1935         howlen_t howlen;
1936
1937         switch( howlen = symptr->howlen ){
1938         case e_no_len:
1939         case e_number:
1940             len = symptr->length;
1941             break;
1942         case e_star:
1943             len = strchr("@Xxu", datumtype) ? 0 : items;
1944             break;
1945         }
1946
1947         /* Look ahead for next symbol. Do we have code/code? */
1948         lookahead = *symptr;
1949         found = next_symbol(&lookahead);
1950         if ( symptr->flags & FLAG_SLASH ) {
1951             if (found){
1952                 if ( 0 == strchr( "aAZ", lookahead.code ) ||
1953                      e_star != lookahead.howlen )
1954                     Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
1955                 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1956                                                    ? *beglist : &PL_sv_no)
1957                                            + (lookahead.code == 'Z' ? 1 : 0)));
1958             } else {
1959                 Perl_croak(aTHX_ "Code missing after '/' in pack");
1960             }
1961         }
1962
1963         switch(datumtype) {
1964         default:
1965             Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)datumtype);
1966         case '%':
1967             Perl_croak(aTHX_ "'%%' may not be used in pack");
1968         case '@':
1969             len += strrelbeg - SvCUR(cat);
1970             if (len > 0)
1971                 goto grow;
1972             len = -len;
1973             if (len > 0)
1974                 goto shrink;
1975             break;
1976         case '(':
1977         {
1978             tempsym_t savsym = *symptr;
1979             symptr->patend = savsym.grpend;
1980             symptr->level++;
1981             while (len--) {
1982                 symptr->patptr = savsym.grpbeg;
1983                 beglist = pack_rec(cat, symptr, beglist, endlist );
1984                 if (savsym.howlen == e_star && beglist == endlist)
1985                     break;              /* No way to continue */
1986             }
1987             lookahead.flags = symptr->flags;
1988             *symptr = savsym;
1989             break;
1990         }
1991         case 'X' | TYPE_IS_SHRIEKING:
1992             if (!len)                   /* Avoid division by 0 */
1993                 len = 1;
1994             len = (SvCUR(cat)) % len;
1995             /* FALL THROUGH */
1996         case 'X':
1997           shrink:
1998             if ((I32)SvCUR(cat) < len)
1999                 Perl_croak(aTHX_ "'X' outside of string in pack");
2000             SvCUR(cat) -= len;
2001             *SvEND(cat) = '\0';
2002             break;
2003         case 'x' | TYPE_IS_SHRIEKING:
2004             if (!len)                   /* Avoid division by 0 */
2005                 len = 1;
2006             aint = (SvCUR(cat)) % len;
2007             if (aint)                   /* Other portable ways? */
2008                 len = len - aint;
2009             else
2010                 len = 0;
2011             /* FALL THROUGH */
2012
2013         case 'x':
2014           grow:
2015             while (len >= 10) {
2016                 sv_catpvn(cat, null10, 10);
2017                 len -= 10;
2018             }
2019             sv_catpvn(cat, null10, len);
2020             break;
2021         case 'A':
2022         case 'Z':
2023         case 'a':
2024             fromstr = NEXTFROM;
2025             aptr = SvPV(fromstr, fromlen);
2026             if (howlen == e_star) {
2027                 len = fromlen;
2028                 if (datumtype == 'Z')
2029                     ++len;
2030             }
2031             if ((I32)fromlen >= len) {
2032                 sv_catpvn(cat, aptr, len);
2033                 if (datumtype == 'Z')
2034                     *(SvEND(cat)-1) = '\0';
2035             }
2036             else {
2037                 sv_catpvn(cat, aptr, fromlen);
2038                 len -= fromlen;
2039                 if (datumtype == 'A') {
2040                     while (len >= 10) {
2041                         sv_catpvn(cat, space10, 10);
2042                         len -= 10;
2043                     }
2044                     sv_catpvn(cat, space10, len);
2045                 }
2046                 else {
2047                     while (len >= 10) {
2048                         sv_catpvn(cat, null10, 10);
2049                         len -= 10;
2050                     }
2051                     sv_catpvn(cat, null10, len);
2052                 }
2053             }
2054             break;
2055         case 'B':
2056         case 'b':
2057             {
2058                 register char *str;
2059                 I32 saveitems;
2060
2061                 fromstr = NEXTFROM;
2062                 saveitems = items;
2063                 str = SvPV(fromstr, fromlen);
2064                 if (howlen == e_star)
2065                     len = fromlen;
2066                 aint = SvCUR(cat);
2067                 SvCUR(cat) += (len+7)/8;
2068                 SvGROW(cat, SvCUR(cat) + 1);
2069                 aptr = SvPVX(cat) + aint;
2070                 if (len > (I32)fromlen)
2071                     len = fromlen;
2072                 aint = len;
2073                 items = 0;
2074                 if (datumtype == 'B') {
2075                     for (len = 0; len++ < aint;) {
2076                         items |= *str++ & 1;
2077                         if (len & 7)
2078                             items <<= 1;
2079                         else {
2080                             *aptr++ = items & 0xff;
2081                             items = 0;
2082                         }
2083                     }
2084                 }
2085                 else {
2086                     for (len = 0; len++ < aint;) {
2087                         if (*str++ & 1)
2088                             items |= 128;
2089                         if (len & 7)
2090                             items >>= 1;
2091                         else {
2092                             *aptr++ = items & 0xff;
2093                             items = 0;
2094                         }
2095                     }
2096                 }
2097                 if (aint & 7) {
2098                     if (datumtype == 'B')
2099                         items <<= 7 - (aint & 7);
2100                     else
2101                         items >>= 7 - (aint & 7);
2102                     *aptr++ = items & 0xff;
2103                 }
2104                 str = SvPVX(cat) + SvCUR(cat);
2105                 while (aptr <= str)
2106                     *aptr++ = '\0';
2107
2108                 items = saveitems;
2109             }
2110             break;
2111         case 'H':
2112         case 'h':
2113             {
2114                 register char *str;
2115                 I32 saveitems;
2116
2117                 fromstr = NEXTFROM;
2118                 saveitems = items;
2119                 str = SvPV(fromstr, fromlen);
2120                 if (howlen == e_star)
2121                     len = fromlen;
2122                 aint = SvCUR(cat);
2123                 SvCUR(cat) += (len+1)/2;
2124                 SvGROW(cat, SvCUR(cat) + 1);
2125                 aptr = SvPVX(cat) + aint;
2126                 if (len > (I32)fromlen)
2127                     len = fromlen;
2128                 aint = len;
2129                 items = 0;
2130                 if (datumtype == 'H') {
2131                     for (len = 0; len++ < aint;) {
2132                         if (isALPHA(*str))
2133                             items |= ((*str++ & 15) + 9) & 15;
2134                         else
2135                             items |= *str++ & 15;
2136                         if (len & 1)
2137                             items <<= 4;
2138                         else {
2139                             *aptr++ = items & 0xff;
2140                             items = 0;
2141                         }
2142                     }
2143                 }
2144                 else {
2145                     for (len = 0; len++ < aint;) {
2146                         if (isALPHA(*str))
2147                             items |= (((*str++ & 15) + 9) & 15) << 4;
2148                         else
2149                             items |= (*str++ & 15) << 4;
2150                         if (len & 1)
2151                             items >>= 4;
2152                         else {
2153                             *aptr++ = items & 0xff;
2154                             items = 0;
2155                         }
2156                     }
2157                 }
2158                 if (aint & 1)
2159                     *aptr++ = items & 0xff;
2160                 str = SvPVX(cat) + SvCUR(cat);
2161                 while (aptr <= str)
2162                     *aptr++ = '\0';
2163
2164                 items = saveitems;
2165             }
2166             break;
2167         case 'C':
2168         case 'c':
2169             while (len-- > 0) {
2170                 fromstr = NEXTFROM;
2171                 switch (datumtype) {
2172                 case 'C':
2173                     aint = SvIV(fromstr);
2174                     if ((aint < 0 || aint > 255) &&
2175                         ckWARN(WARN_PACK))
2176                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2177                                     "Character in 'C' format wrapped in pack");
2178                     achar = aint & 255;
2179                     sv_catpvn(cat, &achar, sizeof(char));
2180                     break;
2181                 case 'c':
2182                     aint = SvIV(fromstr);
2183                     if ((aint < -128 || aint > 127) &&
2184                         ckWARN(WARN_PACK))
2185                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2186                                     "Character in 'c' format wrapped in pack" );
2187                     achar = aint & 255;
2188                     sv_catpvn(cat, &achar, sizeof(char));
2189                     break;
2190                 }
2191             }
2192             break;
2193         case 'U':
2194             while (len-- > 0) {
2195                 fromstr = NEXTFROM;
2196                 auint = UNI_TO_NATIVE(SvUV(fromstr));
2197                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2198                 SvCUR_set(cat,
2199                           (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2200                                                      auint,
2201                                                      ckWARN(WARN_UTF8) ?
2202                                                      0 : UNICODE_ALLOW_ANY)
2203                           - SvPVX(cat));
2204             }
2205             *SvEND(cat) = '\0';
2206             break;
2207         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2208         case 'f':
2209             while (len-- > 0) {
2210                 fromstr = NEXTFROM;
2211 #ifdef __VOS__
2212 /* VOS does not automatically map a floating-point overflow
2213    during conversion from double to float into infinity, so we
2214    do it by hand.  This code should either be generalized for
2215    any OS that needs it, or removed if and when VOS implements
2216    posix-976 (suggestion to support mapping to infinity).
2217    Paul.Green@stratus.com 02-04-02.  */
2218                 if (SvNV(fromstr) > FLT_MAX)
2219                      afloat = _float_constants[0];   /* single prec. inf. */
2220                 else if (SvNV(fromstr) < -FLT_MAX)
2221                      afloat = _float_constants[0];   /* single prec. inf. */
2222                 else afloat = (float)SvNV(fromstr);
2223 #else
2224 # if defined(VMS) && !defined(__IEEE_FP)
2225 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2226  * on Alpha; fake it if we don't have them.
2227  */
2228                 if (SvNV(fromstr) > FLT_MAX)
2229                      afloat = FLT_MAX;
2230                 else if (SvNV(fromstr) < -FLT_MAX)
2231                      afloat = -FLT_MAX;
2232                 else afloat = (float)SvNV(fromstr);
2233 # else
2234                 afloat = (float)SvNV(fromstr);
2235 # endif
2236 #endif
2237                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2238             }
2239             break;
2240         case 'd':
2241             while (len-- > 0) {
2242                 fromstr = NEXTFROM;
2243 #ifdef __VOS__
2244 /* VOS does not automatically map a floating-point overflow
2245    during conversion from long double to double into infinity,
2246    so we do it by hand.  This code should either be generalized
2247    for any OS that needs it, or removed if and when VOS
2248    implements posix-976 (suggestion to support mapping to
2249    infinity).  Paul.Green@stratus.com 02-04-02.  */
2250                 if (SvNV(fromstr) > DBL_MAX)
2251                      adouble = _double_constants[0];   /* double prec. inf. */
2252                 else if (SvNV(fromstr) < -DBL_MAX)
2253                      adouble = _double_constants[0];   /* double prec. inf. */
2254                 else adouble = (double)SvNV(fromstr);
2255 #else
2256 # if defined(VMS) && !defined(__IEEE_FP)
2257 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2258  * on Alpha; fake it if we don't have them.
2259  */
2260                 if (SvNV(fromstr) > DBL_MAX)
2261                      adouble = DBL_MAX;
2262                 else if (SvNV(fromstr) < -DBL_MAX)
2263                      adouble = -DBL_MAX;
2264                 else adouble = (double)SvNV(fromstr);
2265 # else
2266                 adouble = (double)SvNV(fromstr);
2267 # endif
2268 #endif
2269                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2270             }
2271             break;
2272         case 'F':
2273             while (len-- > 0) {
2274                 fromstr = NEXTFROM;
2275                 anv = SvNV(fromstr);
2276                 sv_catpvn(cat, (char *)&anv, NVSIZE);
2277             }
2278             break;
2279 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2280         case 'D':
2281             while (len-- > 0) {
2282                 fromstr = NEXTFROM;
2283                 aldouble = (long double)SvNV(fromstr);
2284                 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2285             }
2286             break;
2287 #endif
2288         case 'n':
2289             while (len-- > 0) {
2290                 fromstr = NEXTFROM;
2291                 ashort = (I16)SvIV(fromstr);
2292 #ifdef HAS_HTONS
2293                 ashort = PerlSock_htons(ashort);
2294 #endif
2295                 CAT16(cat, &ashort);
2296             }
2297             break;
2298         case 'v':
2299             while (len-- > 0) {
2300                 fromstr = NEXTFROM;
2301                 ashort = (I16)SvIV(fromstr);
2302 #ifdef HAS_HTOVS
2303                 ashort = htovs(ashort);
2304 #endif
2305                 CAT16(cat, &ashort);
2306             }
2307             break;
2308         case 'S' | TYPE_IS_SHRIEKING:
2309 #if SHORTSIZE != SIZE16
2310             {
2311                 unsigned short aushort;
2312
2313                 while (len-- > 0) {
2314                     fromstr = NEXTFROM;
2315                     aushort = SvUV(fromstr);
2316                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2317                 }
2318             }
2319             break;
2320 #else
2321             /* Fall through! */
2322 #endif
2323         case 'S':
2324             {
2325                 U16 aushort;
2326
2327                 while (len-- > 0) {
2328                     fromstr = NEXTFROM;
2329                     aushort = (U16)SvUV(fromstr);
2330                     CAT16(cat, &aushort);
2331                 }
2332
2333             }
2334             break;
2335         case 's' | TYPE_IS_SHRIEKING:
2336 #if SHORTSIZE != SIZE16
2337             {
2338                 short ashort;
2339
2340                 while (len-- > 0) {
2341                     fromstr = NEXTFROM;
2342                     ashort = SvIV(fromstr);
2343                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
2344                 }
2345             }
2346             break;
2347 #else
2348             /* Fall through! */
2349 #endif
2350         case 's':
2351             while (len-- > 0) {
2352                 fromstr = NEXTFROM;
2353                 ashort = (I16)SvIV(fromstr);
2354                 CAT16(cat, &ashort);
2355             }
2356             break;
2357         case 'I':
2358         case 'I' | TYPE_IS_SHRIEKING:
2359             while (len-- > 0) {
2360                 fromstr = NEXTFROM;
2361                 auint = SvUV(fromstr);
2362                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2363             }
2364             break;
2365         case 'j':
2366             while (len-- > 0) {
2367                 fromstr = NEXTFROM;
2368                 aiv = SvIV(fromstr);
2369                 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2370             }
2371             break;
2372         case 'J':
2373             while (len-- > 0) {
2374                 fromstr = NEXTFROM;
2375                 auv = SvUV(fromstr);
2376                 sv_catpvn(cat, (char*)&auv, UVSIZE);
2377             }
2378             break;
2379         case 'w':
2380             while (len-- > 0) {
2381                 fromstr = NEXTFROM;
2382                 anv = SvNV(fromstr);
2383
2384                 if (anv < 0)
2385                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2386
2387                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2388                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2389                    any negative IVs will have already been got by the croak()
2390                    above. IOK is untrue for fractions, so we test them
2391                    against UV_MAX_P1.  */
2392                 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2393                 {
2394                     char   buf[(sizeof(UV)*8)/7+1];
2395                     char  *in = buf + sizeof(buf);
2396                     UV     auv = SvUV(fromstr);
2397
2398                     do {
2399                         *--in = (char)((auv & 0x7f) | 0x80);
2400                         auv >>= 7;
2401                     } while (auv);
2402                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2403                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2404                 }
2405                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
2406                     char           *from, *result, *in;
2407                     SV             *norm;
2408                     STRLEN          len;
2409                     bool            done;
2410
2411                     /* Copy string and check for compliance */
2412                     from = SvPV(fromstr, len);
2413                     if ((norm = is_an_int(from, len)) == NULL)
2414                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2415
2416                     New('w', result, len, char);
2417                     in = result + len;
2418                     done = FALSE;
2419                     while (!done)
2420                         *--in = div128(norm, &done) | 0x80;
2421                     result[len - 1] &= 0x7F; /* clear continue bit */
2422                     sv_catpvn(cat, in, (result + len) - in);
2423                     Safefree(result);
2424                     SvREFCNT_dec(norm); /* free norm */
2425                 }
2426                 else if (SvNOKp(fromstr)) {
2427                     /* 10**NV_MAX_10_EXP is the largest power of 10
2428                        so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2429                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2430                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2431                        And with that many bytes only Inf can overflow.
2432                     */
2433 #ifdef NV_MAX_10_EXP
2434                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)];
2435 #else
2436                     char   buf[1 + (int)((308 + 1) * 0.47456)];
2437 #endif
2438                     char  *in = buf + sizeof(buf);
2439
2440                     anv = Perl_floor(anv);
2441                     do {
2442                         NV next = Perl_floor(anv / 128);
2443                         if (in <= buf)  /* this cannot happen ;-) */
2444                             Perl_croak(aTHX_ "Cannot compress integer in pack");
2445                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2446                         anv = next;
2447                     } while (anv > 0);
2448                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2449                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2450                 }
2451                 else {
2452                     char           *from, *result, *in;
2453                     SV             *norm;
2454                     STRLEN          len;
2455                     bool            done;
2456
2457                     /* Copy string and check for compliance */
2458                     from = SvPV(fromstr, len);
2459                     if ((norm = is_an_int(from, len)) == NULL)
2460                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2461
2462                     New('w', result, len, char);
2463                     in = result + len;
2464                     done = FALSE;
2465                     while (!done)
2466                         *--in = div128(norm, &done) | 0x80;
2467                     result[len - 1] &= 0x7F; /* clear continue bit */
2468                     sv_catpvn(cat, in, (result + len) - in);
2469                     Safefree(result);
2470                     SvREFCNT_dec(norm); /* free norm */
2471                }
2472             }
2473             break;
2474         case 'i':
2475         case 'i' | TYPE_IS_SHRIEKING:
2476             while (len-- > 0) {
2477                 fromstr = NEXTFROM;
2478                 aint = SvIV(fromstr);
2479                 sv_catpvn(cat, (char*)&aint, sizeof(int));
2480             }
2481             break;
2482         case 'N':
2483             while (len-- > 0) {
2484                 fromstr = NEXTFROM;
2485                 aulong = SvUV(fromstr);
2486 #ifdef HAS_HTONL
2487                 aulong = PerlSock_htonl(aulong);
2488 #endif
2489                 CAT32(cat, &aulong);
2490             }
2491             break;
2492         case 'V':
2493             while (len-- > 0) {
2494                 fromstr = NEXTFROM;
2495                 aulong = SvUV(fromstr);
2496 #ifdef HAS_HTOVL
2497                 aulong = htovl(aulong);
2498 #endif
2499                 CAT32(cat, &aulong);
2500             }
2501             break;
2502         case 'L' | TYPE_IS_SHRIEKING:
2503 #if LONGSIZE != SIZE32
2504             {
2505                 unsigned long aulong;
2506
2507                 while (len-- > 0) {
2508                     fromstr = NEXTFROM;
2509                     aulong = SvUV(fromstr);
2510                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2511                 }
2512             }
2513             break;
2514 #else
2515             /* Fall though! */
2516 #endif
2517         case 'L':
2518             {
2519                 while (len-- > 0) {
2520                     fromstr = NEXTFROM;
2521                     aulong = SvUV(fromstr);
2522                     CAT32(cat, &aulong);
2523                 }
2524             }
2525             break;
2526         case 'l' | TYPE_IS_SHRIEKING:
2527 #if LONGSIZE != SIZE32
2528             {
2529                 long along;
2530
2531                 while (len-- > 0) {
2532                     fromstr = NEXTFROM;
2533                     along = SvIV(fromstr);
2534                     sv_catpvn(cat, (char *)&along, sizeof(long));
2535                 }
2536             }
2537             break;
2538 #else
2539             /* Fall though! */
2540 #endif
2541         case 'l':
2542             while (len-- > 0) {
2543                 fromstr = NEXTFROM;
2544                 along = SvIV(fromstr);
2545                 CAT32(cat, &along);
2546             }
2547             break;
2548 #ifdef HAS_QUAD
2549         case 'Q':
2550             while (len-- > 0) {
2551                 fromstr = NEXTFROM;
2552                 auquad = (Uquad_t)SvUV(fromstr);
2553                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2554             }
2555             break;
2556         case 'q':
2557             while (len-- > 0) {
2558                 fromstr = NEXTFROM;
2559                 aquad = (Quad_t)SvIV(fromstr);
2560                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2561             }
2562             break;
2563 #endif
2564         case 'P':
2565             len = 1;            /* assume SV is correct length */
2566             /* Fall through! */
2567         case 'p':
2568             while (len-- > 0) {
2569                 fromstr = NEXTFROM;
2570                 if (fromstr == &PL_sv_undef)
2571                     aptr = NULL;
2572                 else {
2573                     STRLEN n_a;
2574                     /* XXX better yet, could spirit away the string to
2575                      * a safe spot and hang on to it until the result
2576                      * of pack() (and all copies of the result) are
2577                      * gone.
2578                      */
2579                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2580                                                 || (SvPADTMP(fromstr)
2581                                                     && !SvREADONLY(fromstr))))
2582                     {
2583                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2584                                 "Attempt to pack pointer to temporary value");
2585                     }
2586                     if (SvPOK(fromstr) || SvNIOK(fromstr))
2587                         aptr = SvPV(fromstr,n_a);
2588                     else
2589                         aptr = SvPV_force(fromstr,n_a);
2590                 }
2591                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2592             }
2593             break;
2594         case 'u':
2595             fromstr = NEXTFROM;
2596             aptr = SvPV(fromstr, fromlen);
2597             SvGROW(cat, fromlen * 4 / 3);
2598             if (len <= 2)
2599                 len = 45;
2600             else
2601                 len = len / 3 * 3;
2602             while (fromlen > 0) {
2603                 I32 todo;
2604
2605                 if ((I32)fromlen > len)
2606                     todo = len;
2607                 else
2608                     todo = fromlen;
2609                 doencodes(cat, aptr, todo);
2610                 fromlen -= todo;
2611                 aptr += todo;
2612             }
2613             break;
2614         }
2615         *symptr = lookahead;
2616     }
2617     return beglist;
2618 }
2619 #undef NEXTFROM
2620
2621
2622 PP(pp_pack)
2623 {
2624     dSP; dMARK; dORIGMARK; dTARGET;
2625     register SV *cat = TARG;
2626     STRLEN fromlen;
2627     register char *pat = SvPVx(*++MARK, fromlen);
2628     register char *patend = pat + fromlen;
2629
2630     MARK++;
2631     sv_setpvn(cat, "", 0);
2632
2633     packlist(cat, pat, patend, MARK, SP + 1);
2634
2635     SvSETMAGIC(cat);
2636     SP = ORIGMARK;
2637     PUSHs(cat);
2638     RETURN;
2639 }
2640