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.
 517
 518 =cut */
 519
 520 I32
 521 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
 522 {
 523     tempsym_t sym = { 0 };
 524     sym.patptr = pat;
 525     sym.patend = patend;
 526     sym.flags  = flags;
 527
 528     return unpack_rec(&sym, s, s, strend, NULL );
 529 }
 530
 531 STATIC
 532 I32
 533 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
 534 {
 535     dSP;
 536     I32 datumtype;
 537     register I32 len = 0;
 538     register I32 bits = 0;
 539     register char *str;
 540     SV *sv;
 541     I32 start_sp_offset = SP - PL_stack_base;
 542     howlen_t howlen;
 543
 544     /* These must not be in registers: */
 545     short ashort;
 546     int aint;
 547     long along;
 548 #ifdef HAS_QUAD
 549     Quad_t aquad;
 550 #endif
 551     U16 aushort;
 552     unsigned int auint;
 553     U32 aulong;
 554 #ifdef HAS_QUAD
 555     Uquad_t auquad;
 556 #endif
 557     char *aptr;
 558     float afloat;
 559     double adouble;
 560     I32 checksum = 0;
 561     UV cuv = 0;
 562     NV cdouble = 0.0;
 563     const int bits_in_uv = 8 * sizeof(cuv);
 564     char* strrelbeg = s;
 565     bool beyond = FALSE;
 566     bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
 567
 568     IV aiv;
 569     UV auv;
 570     NV anv;
 571 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
 572     long double aldouble;
 573 #endif
 574
 575     while (next_symbol(symptr)) {
 576         datumtype = symptr->code;
 577         /* do first one only unless in list context
 578            / is implemented by unpacking the count, then poping it from the
 579            stack, so must check that we're not in the middle of a /  */
 580         if ( unpack_only_one
 581              && (SP - PL_stack_base == start_sp_offset + 1)
 582              && (datumtype != '/') )   /* XXX can this be omitted */
 583             break;
 584
 585         switch( howlen = symptr->howlen ){
 586         case e_no_len:
 587         case e_number:
 588             len = symptr->length;
 589             break;
 590         case e_star:
 591             len = strend - strbeg;      /* long enough */
 592             break;
 593         }
 594
 595       redo_switch:
 596         beyond = s >= strend;
 597         switch(datumtype) {
 598         default:
 599             Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)datumtype );
 600
 601         case '%':
 602             if (howlen == e_no_len)
 603                 len = 16;               /* len is not specified */
 604             checksum = len;
 605             cuv = 0;
 606             cdouble = 0;
 607             continue;
 608             break;
 609         case '(':
 610         {
 611             char *ss = s;               /* Move from register */
 612             tempsym_t savsym = *symptr;
 613             symptr->patend = savsym.grpend;
 614             symptr->level++;
 615             PUTBACK;
 616             while (len--) {
 617                 symptr->patptr = savsym.grpbeg;
 618                 unpack_rec(symptr, ss, strbeg, strend, &ss );
 619                 if (ss == strend && savsym.howlen == e_star)
 620                     break; /* No way to continue */
 621             }
 622             SPAGAIN;
 623             s = ss;
 624             savsym.flags = symptr->flags;
 625             *symptr = savsym;
 626             break;
 627         }
 628         case '@':
 629             if (len > strend - strrelbeg)
 630                 Perl_croak(aTHX_ "'@' outside of string in unpack");
 631             s = strrelbeg + len;
 632             break;
 633         case 'X' | TYPE_IS_SHRIEKING:
 634             if (!len)                   /* Avoid division by 0 */
 635                 len = 1;
 636             len = (s - strbeg) % len;
 637             /* FALL THROUGH */
 638         case 'X':
 639             if (len > s - strbeg)
 640                 Perl_croak(aTHX_ "'X' outside of string in unpack" );
 641             s -= len;
 642             break;
 643         case 'x' | TYPE_IS_SHRIEKING:
 644             if (!len)                   /* Avoid division by 0 */
 645                 len = 1;
 646             aint = (s - strbeg) % len;
 647             if (aint)                   /* Other portable ways? */
 648                 len = len - aint;
 649             else
 650                 len = 0;
 651             /* FALL THROUGH */
 652         case 'x':
 653             if (len > strend - s)
 654                 Perl_croak(aTHX_ "'x' outside of string in unpack");
 655             s += len;
 656             break;
 657         case '/':
 658             Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
 659             break;
 660         case 'A':
 661         case 'Z':
 662         case 'a':
 663             if (len > strend - s)
 664                 len = strend - s;
 665             if (checksum)
 666                 goto uchar_checksum;
 667             sv = NEWSV(35, len);
 668             sv_setpvn(sv, s, len);
 669             if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
 670                 aptr = s;       /* borrow register */
 671                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
 672                     s = SvPVX(sv);
 673                     while (*s)
 674                         s++;
 675                     if (howlen == e_star) /* exact for 'Z*' */
 676                         len = s - SvPVX(sv) + 1;
 677                 }
 678                 else {          /* 'A' strips both nulls and spaces */
 679                     s = SvPVX(sv) + len - 1;
 680                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
 681                         s--;
 682                     *++s = '\0';
 683                 }
 684                 SvCUR_set(sv, s - SvPVX(sv));
 685                 s = aptr;       /* unborrow register */
 686             }
 687             s += len;
 688             XPUSHs(sv_2mortal(sv));
 689             break;
 690         case 'B':
 691         case 'b':
 692             if (howlen == e_star || len > (strend - s) * 8)
 693                 len = (strend - s) * 8;
 694             if (checksum) {
 695                 if (!PL_bitcount) {
 696                     Newz(601, PL_bitcount, 256, char);
 697                     for (bits = 1; bits < 256; bits++) {
 698                         if (bits & 1)   PL_bitcount[bits]++;
 699                         if (bits & 2)   PL_bitcount[bits]++;
 700                         if (bits & 4)   PL_bitcount[bits]++;
 701                         if (bits & 8)   PL_bitcount[bits]++;
 702                         if (bits & 16)  PL_bitcount[bits]++;
 703                         if (bits & 32)  PL_bitcount[bits]++;
 704                         if (bits & 64)  PL_bitcount[bits]++;
 705                         if (bits & 128) PL_bitcount[bits]++;
 706                     }
 707                 }
 708                 while (len >= 8) {
 709                     cuv += PL_bitcount[*(unsigned char*)s++];
 710                     len -= 8;
 711                 }
 712                 if (len) {
 713                     bits = *s;
 714                     if (datumtype == 'b') {
 715                         while (len-- > 0) {
 716                             if (bits & 1) cuv++;
 717                             bits >>= 1;
 718                         }
 719                     }
 720                     else {
 721                         while (len-- > 0) {
 722                             if (bits & 128) cuv++;
 723                             bits <<= 1;
 724                         }
 725                     }
 726                 }
 727                 break;
 728             }
 729             sv = NEWSV(35, len + 1);
 730             SvCUR_set(sv, len);
 731             SvPOK_on(sv);
 732             str = SvPVX(sv);
 733             if (datumtype == 'b') {
 734                 aint = len;
 735                 for (len = 0; len < aint; len++) {
 736                     if (len & 7)                /*SUPPRESS 595*/
 737                         bits >>= 1;
 738                     else
 739                         bits = *s++;
 740                     *str++ = '0' + (bits & 1);
 741                 }
 742             }
 743             else {
 744                 aint = len;
 745                 for (len = 0; len < aint; len++) {
 746                     if (len & 7)
 747                         bits <<= 1;
 748                     else
 749                         bits = *s++;
 750                     *str++ = '0' + ((bits & 128) != 0);
 751                 }
 752             }
 753             *str = '\0';
 754             XPUSHs(sv_2mortal(sv));
 755             break;
 756         case 'H':
 757         case 'h':
 758             if (howlen == e_star || len > (strend - s) * 2)
 759                 len = (strend - s) * 2;
 760             sv = NEWSV(35, len + 1);
 761             SvCUR_set(sv, len);
 762             SvPOK_on(sv);
 763             str = SvPVX(sv);
 764             if (datumtype == 'h') {
 765                 aint = len;
 766                 for (len = 0; len < aint; len++) {
 767                     if (len & 1)
 768                         bits >>= 4;
 769                     else
 770                         bits = *s++;
 771                     *str++ = PL_hexdigit[bits & 15];
 772                 }
 773             }
 774             else {
 775                 aint = len;
 776                 for (len = 0; len < aint; len++) {
 777                     if (len & 1)
 778                         bits <<= 4;
 779                     else
 780                         bits = *s++;
 781                     *str++ = PL_hexdigit[(bits >> 4) & 15];
 782                 }
 783             }
 784             *str = '\0';
 785             XPUSHs(sv_2mortal(sv));
 786             break;
 787         case 'c':
 788             if (len > strend - s)
 789                 len = strend - s;
 790             if (checksum) {
 791                 while (len-- > 0) {
 792                     aint = *s++;
 793                     if (aint >= 128)    /* fake up signed chars */
 794                         aint -= 256;
 795                     if (checksum > bits_in_uv)
 796                         cdouble += (NV)aint;
 797                     else
 798                         cuv += aint;
 799                 }
 800             }
 801             else {
 802                 if (len && unpack_only_one)
 803                     len = 1;
 804                 EXTEND(SP, len);
 805                 EXTEND_MORTAL(len);
 806                 while (len-- > 0) {
 807                     aint = *s++;
 808                     if (aint >= 128)    /* fake up signed chars */
 809                         aint -= 256;
 810                     sv = NEWSV(36, 0);
 811                     sv_setiv(sv, (IV)aint);
 812                     PUSHs(sv_2mortal(sv));
 813                 }
 814             }
 815             break;
 816         case 'C':
 817         unpack_C: /* unpack U will jump here if not UTF-8 */
 818             if (len == 0) {
 819                 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
 820                 break;
 821             }
 822             if (len > strend - s)
 823                 len = strend - s;
 824             if (checksum) {
 825               uchar_checksum:
 826                 while (len-- > 0) {
 827                     auint = *s++ & 255;
 828                     cuv += auint;
 829                 }
 830             }
 831             else {
 832                 if (len && unpack_only_one)
 833                     len = 1;
 834                 EXTEND(SP, len);
 835                 EXTEND_MORTAL(len);
 836                 while (len-- > 0) {
 837                     auint = *s++ & 255;
 838                     sv = NEWSV(37, 0);
 839                     sv_setiv(sv, (IV)auint);
 840                     PUSHs(sv_2mortal(sv));
 841                 }
 842             }
 843             break;
 844         case 'U':
 845             if (len == 0) {
 846                 symptr->flags |= FLAG_UNPACK_DO_UTF8;
 847                 break;
 848             }
 849             if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
 850                  goto unpack_C;
 851             if (len > strend - s)
 852                 len = strend - s;
 853             if (checksum) {
 854                 while (len-- > 0 && s < strend) {
 855                     STRLEN alen;
 856                     auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
 857                     along = alen;
 858                     s += along;
 859                     if (checksum > bits_in_uv)
 860                         cdouble += (NV)auint;
 861                     else
 862                         cuv += auint;
 863                 }
 864             }
 865             else {
 866                 if (len && unpack_only_one)
 867                     len = 1;
 868                 EXTEND(SP, len);
 869                 EXTEND_MORTAL(len);
 870                 while (len-- > 0 && s < strend) {
 871                     STRLEN alen;
 872                     auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
 873                     along = alen;
 874                     s += along;
 875                     sv = NEWSV(37, 0);
 876                     sv_setuv(sv, (UV)auint);
 877                     PUSHs(sv_2mortal(sv));
 878                 }
 879             }
 880             break;
 881         case 's' | TYPE_IS_SHRIEKING:
 882 #if SHORTSIZE != SIZE16
 883             along = (strend - s) / sizeof(short);
 884             if (len > along)
 885                 len = along;
 886             if (checksum) {
 887                 short ashort;
 888                 while (len-- > 0) {
 889                      COPYNN(s, &ashort, sizeof(short));
 890                       s += sizeof(short);
 891                       if (checksum > bits_in_uv)
 892                           cdouble += (NV)ashort;
 893                       else
 894                           cuv += ashort;
 895
 896                 }
 897             }
 898             else {
 899                 short ashort;
 900                 if (len && unpack_only_one)
 901                     len = 1;
 902                 EXTEND(SP, len);
 903                 EXTEND_MORTAL(len);
 904                 while (len-- > 0) {
 905                     COPYNN(s, &ashort, sizeof(short));
 906                     s += sizeof(short);
 907                     sv = NEWSV(38, 0);
 908                     sv_setiv(sv, (IV)ashort);
 909                     PUSHs(sv_2mortal(sv));
 910                 }
 911             }
 912             break;
 913 #else
 914             /* Fallthrough! */
 915 #endif
 916         case 's':
 917             along = (strend - s) / SIZE16;
 918             if (len > along)
 919                 len = along;
 920             if (checksum) {
 921                 while (len-- > 0) {
 922                     COPY16(s, &ashort);
 923 #if SHORTSIZE > SIZE16
 924                     if (ashort > 32767)
 925                         ashort -= 65536;
 926 #endif
 927                     s += SIZE16;
 928                     if (checksum > bits_in_uv)
 929                         cdouble += (NV)ashort;
 930                     else
 931                         cuv += ashort;
 932                 }
 933             }
 934             else {
 935                 if (len && unpack_only_one)
 936                     len = 1;
 937                 EXTEND(SP, len);
 938                 EXTEND_MORTAL(len);
 939
 940                 while (len-- > 0) {
 941                     COPY16(s, &ashort);
 942 #if SHORTSIZE > SIZE16
 943                     if (ashort > 32767)
 944                         ashort -= 65536;
 945 #endif
 946                     s += SIZE16;
 947                     sv = NEWSV(38, 0);
 948                     sv_setiv(sv, (IV)ashort);
 949                     PUSHs(sv_2mortal(sv));
 950                 }
 951             }
 952             break;
 953         case 'S' | TYPE_IS_SHRIEKING:
 954 #if SHORTSIZE != SIZE16
 955             along = (strend - s) / sizeof(unsigned short);
 956             if (len > along)
 957                 len = along;
 958             if (checksum) {
 959                 unsigned short aushort;
 960                 while (len-- > 0) {
 961                     COPYNN(s, &aushort, sizeof(unsigned short));
 962                     s += sizeof(unsigned short);
 963                     if (checksum > bits_in_uv)
 964                         cdouble += (NV)aushort;
 965                     else
 966                         cuv += aushort;
 967                 }
 968             }
 969             else {
 970                 if (len && unpack_only_one)
 971                     len = 1;
 972                 EXTEND(SP, len);
 973                 EXTEND_MORTAL(len);
 974                 while (len-- > 0) {
 975                     unsigned short aushort;
 976                     COPYNN(s, &aushort, sizeof(unsigned short));
 977                     s += sizeof(unsigned short);
 978                     sv = NEWSV(39, 0);
 979                     sv_setiv(sv, (UV)aushort);
 980                     PUSHs(sv_2mortal(sv));
 981                 }
 982             }
 983             break;
 984 #else
 985             /* Fallhrough! */
 986 #endif
 987         case 'v':
 988         case 'n':
 989         case 'S':
 990             along = (strend - s) / SIZE16;
 991             if (len > along)
 992                 len = along;
 993             if (checksum) {
 994                 while (len-- > 0) {
 995                     COPY16(s, &aushort);
 996                     s += SIZE16;
 997 #ifdef HAS_NTOHS
 998                     if (datumtype == 'n')
 999                         aushort = PerlSock_ntohs(aushort);
1000 #endif
1001 #ifdef HAS_VTOHS
1002                     if (datumtype == 'v')
1003                         aushort = vtohs(aushort);
1004 #endif
1005                     if (checksum > bits_in_uv)
1006                         cdouble += (NV)aushort;
1007                     else
1008                         cuv += aushort;
1009                 }
1010             }
1011             else {
1012                 if (len && unpack_only_one)
1013                     len = 1;
1014                 EXTEND(SP, len);
1015                 EXTEND_MORTAL(len);
1016                 while (len-- > 0) {
1017                     COPY16(s, &aushort);
1018                     s += SIZE16;
1019                     sv = NEWSV(39, 0);
1020 #ifdef HAS_NTOHS
1021                     if (datumtype == 'n')
1022                         aushort = PerlSock_ntohs(aushort);
1023 #endif
1024 #ifdef HAS_VTOHS
1025                     if (datumtype == 'v')
1026                         aushort = vtohs(aushort);
1027 #endif
1028                     sv_setiv(sv, (UV)aushort);
1029                     PUSHs(sv_2mortal(sv));
1030                 }
1031             }
1032             break;
1033         case 'i':
1034         case 'i' | TYPE_IS_SHRIEKING:
1035             along = (strend - s) / sizeof(int);
1036             if (len > along)
1037                 len = along;
1038             if (checksum) {
1039                 while (len-- > 0) {
1040                     Copy(s, &aint, 1, int);
1041                     s += sizeof(int);
1042                     if (checksum > bits_in_uv)
1043                         cdouble += (NV)aint;
1044                     else
1045                         cuv += aint;
1046                 }
1047             }
1048             else {
1049                 if (len && unpack_only_one)
1050                     len = 1;
1051                 EXTEND(SP, len);
1052                 EXTEND_MORTAL(len);
1053                 while (len-- > 0) {
1054                     Copy(s, &aint, 1, int);
1055                     s += sizeof(int);
1056                     sv = NEWSV(40, 0);
1057 #ifdef __osf__
1058                     /* Without the dummy below unpack("i", pack("i",-1))
1059                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
1060                      * cc with optimization turned on.
1061                      *
1062                      * The bug was detected in
1063                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
1064                      * with optimization (-O4) turned on.
1065                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
1066                      * does not have this problem even with -O4.
1067                      *
1068                      * This bug was reported as DECC_BUGS 1431
1069                      * and tracked internally as GEM_BUGS 7775.
1070                      *
1071                      * The bug is fixed in
1072                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
1073                      * UNIX V4.0F support:   DEC C V5.9-006 or later
1074                      * UNIX V4.0E support:   DEC C V5.8-011 or later
1075                      * and also in DTK.
1076                      *
1077                      * See also few lines later for the same bug.
1078                      */
1079                     (aint) ?
1080                         sv_setiv(sv, (IV)aint) :
1081 #endif
1082                     sv_setiv(sv, (IV)aint);
1083                     PUSHs(sv_2mortal(sv));
1084                 }
1085             }
1086             break;
1087         case 'I':
1088         case 'I' | TYPE_IS_SHRIEKING:
1089             along = (strend - s) / sizeof(unsigned int);
1090             if (len > along)
1091                 len = along;
1092             if (checksum) {
1093                 while (len-- > 0) {
1094                     Copy(s, &auint, 1, unsigned int);
1095                     s += sizeof(unsigned int);
1096                     if (checksum > bits_in_uv)
1097                         cdouble += (NV)auint;
1098                     else
1099                         cuv += auint;
1100                 }
1101             }
1102             else {
1103                 if (len && unpack_only_one)
1104                     len = 1;
1105                 EXTEND(SP, len);
1106                 EXTEND_MORTAL(len);
1107                 while (len-- > 0) {
1108                     Copy(s, &auint, 1, unsigned int);
1109                     s += sizeof(unsigned int);
1110                     sv = NEWSV(41, 0);
1111 #ifdef __osf__
1112                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1113                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1114                      * See details few lines earlier. */
1115                     (auint) ?
1116                         sv_setuv(sv, (UV)auint) :
1117 #endif
1118                     sv_setuv(sv, (UV)auint);
1119                     PUSHs(sv_2mortal(sv));
1120                 }
1121             }
1122             break;
1123         case 'j':
1124             along = (strend - s) / IVSIZE;
1125             if (len > along)
1126                 len = along;
1127             if (checksum) {
1128                 while (len-- > 0) {
1129                     Copy(s, &aiv, 1, IV);
1130                     s += IVSIZE;
1131                     if (checksum > bits_in_uv)
1132                         cdouble += (NV)aiv;
1133                     else
1134                         cuv += aiv;
1135                 }
1136             }
1137             else {
1138                 if (len && unpack_only_one)
1139                     len = 1;
1140                 EXTEND(SP, len);
1141                 EXTEND_MORTAL(len);
1142                 while (len-- > 0) {
1143                     Copy(s, &aiv, 1, IV);
1144                     s += IVSIZE;
1145                     sv = NEWSV(40, 0);
1146                     sv_setiv(sv, aiv);
1147                     PUSHs(sv_2mortal(sv));
1148                 }
1149             }
1150             break;
1151         case 'J':
1152             along = (strend - s) / UVSIZE;
1153             if (len > along)
1154                 len = along;
1155             if (checksum) {
1156                 while (len-- > 0) {
1157                     Copy(s, &auv, 1, UV);
1158                     s += UVSIZE;
1159                     if (checksum > bits_in_uv)
1160                         cdouble += (NV)auv;
1161                     else
1162                         cuv += auv;
1163                 }
1164             }
1165             else {
1166                 if (len && unpack_only_one)
1167                     len = 1;
1168                 EXTEND(SP, len);
1169                 EXTEND_MORTAL(len);
1170                 while (len-- > 0) {
1171                     Copy(s, &auv, 1, UV);
1172                     s += UVSIZE;
1173                     sv = NEWSV(41, 0);
1174                     sv_setuv(sv, auv);
1175                     PUSHs(sv_2mortal(sv));
1176                 }
1177             }
1178             break;
1179         case 'l' | TYPE_IS_SHRIEKING:
1180 #if LONGSIZE != SIZE32
1181             along = (strend - s) / sizeof(long);
1182             if (len > along)
1183                 len = along;
1184             if (checksum) {
1185                 while (len-- > 0) {
1186                     COPYNN(s, &along, sizeof(long));
1187                     s += sizeof(long);
1188                     if (checksum > bits_in_uv)
1189                         cdouble += (NV)along;
1190                     else
1191                         cuv += along;
1192                 }
1193             }
1194             else {
1195                 if (len && unpack_only_one)
1196                     len = 1;
1197                 EXTEND(SP, len);
1198                 EXTEND_MORTAL(len);
1199                 while (len-- > 0) {
1200                     COPYNN(s, &along, sizeof(long));
1201                     s += sizeof(long);
1202                     sv = NEWSV(42, 0);
1203                     sv_setiv(sv, (IV)along);
1204                     PUSHs(sv_2mortal(sv));
1205                 }
1206             }
1207             break;
1208 #else
1209             /* Fallthrough! */
1210 #endif
1211         case 'l':
1212             along = (strend - s) / SIZE32;
1213             if (len > along)
1214                 len = along;
1215             if (checksum) {
1216                 while (len-- > 0) {
1217 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1218                     I32 along;
1219 #endif
1220                     COPY32(s, &along);
1221 #if LONGSIZE > SIZE32
1222                     if (along > 2147483647)
1223                         along -= 4294967296;
1224 #endif
1225                     s += SIZE32;
1226                     if (checksum > bits_in_uv)
1227                         cdouble += (NV)along;
1228                     else
1229                         cuv += along;
1230                 }
1231             }
1232             else {
1233                 if (len && unpack_only_one)
1234                     len = 1;
1235                 EXTEND(SP, len);
1236                 EXTEND_MORTAL(len);
1237                 while (len-- > 0) {
1238 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1239                     I32 along;
1240 #endif
1241                     COPY32(s, &along);
1242 #if LONGSIZE > SIZE32
1243                     if (along > 2147483647)
1244                         along -= 4294967296;
1245 #endif
1246                     s += SIZE32;
1247                     sv = NEWSV(42, 0);
1248                     sv_setiv(sv, (IV)along);
1249                     PUSHs(sv_2mortal(sv));
1250                 }
1251             }
1252             break;
1253         case 'L' | TYPE_IS_SHRIEKING:
1254 #if LONGSIZE != SIZE32
1255             along = (strend - s) / sizeof(unsigned long);
1256             if (len > along)
1257                 len = along;
1258             if (checksum) {
1259                 while (len-- > 0) {
1260                     unsigned long aulong;
1261                     COPYNN(s, &aulong, sizeof(unsigned long));
1262                     s += sizeof(unsigned long);
1263                     if (checksum > bits_in_uv)
1264                         cdouble += (NV)aulong;
1265                     else
1266                         cuv += aulong;
1267                 }
1268             }
1269             else {
1270                 if (len && unpack_only_one)
1271                     len = 1;
1272                 EXTEND(SP, len);
1273                 EXTEND_MORTAL(len);
1274                 while (len-- > 0) {
1275                     unsigned long aulong;
1276                     COPYNN(s, &aulong, sizeof(unsigned long));
1277                     s += sizeof(unsigned long);
1278                     sv = NEWSV(43, 0);
1279                     sv_setuv(sv, (UV)aulong);
1280                     PUSHs(sv_2mortal(sv));
1281                 }
1282             }
1283             break;
1284 #else
1285             /* Fall through! */
1286 #endif
1287         case 'V':
1288         case 'N':
1289         case 'L':
1290             along = (strend - s) / SIZE32;
1291             if (len > along)
1292                 len = along;
1293             if (checksum) {
1294                 while (len-- > 0) {
1295                     COPY32(s, &aulong);
1296                     s += SIZE32;
1297 #ifdef HAS_NTOHL
1298                     if (datumtype == 'N')
1299                         aulong = PerlSock_ntohl(aulong);
1300 #endif
1301 #ifdef HAS_VTOHL
1302                     if (datumtype == 'V')
1303                         aulong = vtohl(aulong);
1304 #endif
1305                     if (checksum > bits_in_uv)
1306                         cdouble += (NV)aulong;
1307                     else
1308                         cuv += aulong;
1309                 }
1310             }
1311             else {
1312                 if (len && unpack_only_one)
1313                     len = 1;
1314                 EXTEND(SP, len);
1315                 EXTEND_MORTAL(len);
1316                 while (len-- > 0) {
1317                     COPY32(s, &aulong);
1318                     s += SIZE32;
1319 #ifdef HAS_NTOHL
1320                     if (datumtype == 'N')
1321                         aulong = PerlSock_ntohl(aulong);
1322 #endif
1323 #ifdef HAS_VTOHL
1324                     if (datumtype == 'V')
1325                         aulong = vtohl(aulong);
1326 #endif
1327                     sv = NEWSV(43, 0);
1328                     sv_setuv(sv, (UV)aulong);
1329                     PUSHs(sv_2mortal(sv));
1330                 }
1331             }
1332             break;
1333         case 'p':
1334             along = (strend - s) / sizeof(char*);
1335             if (len > along)
1336                 len = along;
1337             EXTEND(SP, len);
1338             EXTEND_MORTAL(len);
1339             while (len-- > 0) {
1340                 if (sizeof(char*) > strend - s)
1341                     break;
1342                 else {
1343                     Copy(s, &aptr, 1, char*);
1344                     s += sizeof(char*);
1345                 }
1346                 sv = NEWSV(44, 0);
1347                 if (aptr)
1348                     sv_setpv(sv, aptr);
1349                 PUSHs(sv_2mortal(sv));
1350             }
1351             break;
1352         case 'w':
1353             if (len && unpack_only_one)
1354                 len = 1;
1355             EXTEND(SP, len);
1356             EXTEND_MORTAL(len);
1357             {
1358                 UV auv = 0;
1359                 U32 bytes = 0;
1360
1361                 while ((len > 0) && (s < strend)) {
1362                     auv = (auv << 7) | (*s & 0x7f);
1363                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1364                     if ((U8)(*s++) < 0x80) {
1365                         bytes = 0;
1366                         sv = NEWSV(40, 0);
1367                         sv_setuv(sv, auv);
1368                         PUSHs(sv_2mortal(sv));
1369                         len--;
1370                         auv = 0;
1371                     }
1372                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
1373                         char *t;
1374                         STRLEN n_a;
1375
1376                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1377                         while (s < strend) {
1378                             sv = mul128(sv, (U8)(*s & 0x7f));
1379                             if (!(*s++ & 0x80)) {
1380                                 bytes = 0;
1381                                 break;
1382                             }
1383                         }
1384                         t = SvPV(sv, n_a);
1385                         while (*t == '0')
1386                             t++;
1387                         sv_chop(sv, t);
1388                         PUSHs(sv_2mortal(sv));
1389                         len--;
1390                         auv = 0;
1391                     }
1392                 }
1393                 if ((s >= strend) && bytes)
1394                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1395             }
1396             break;
1397         case 'P':
1398             if (symptr->howlen == e_star)
1399                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1400             EXTEND(SP, 1);
1401             if (sizeof(char*) > strend - s)
1402                 break;
1403             else {
1404                 Copy(s, &aptr, 1, char*);
1405                 s += sizeof(char*);
1406             }
1407             sv = NEWSV(44, 0);
1408             if (aptr)
1409                 sv_setpvn(sv, aptr, len);
1410             PUSHs(sv_2mortal(sv));
1411             break;
1412 #ifdef HAS_QUAD
1413         case 'q':
1414             along = (strend - s) / sizeof(Quad_t);
1415             if (len > along)
1416                 len = along;
1417             if (checksum) {
1418                 while (len-- > 0) {
1419                     Copy(s, &aquad, 1, Quad_t);
1420                     s += sizeof(Quad_t);
1421                     if (checksum > bits_in_uv)
1422                         cdouble += (NV)aquad;
1423                     else
1424                         cuv += aquad;
1425                 }
1426             }
1427             else {
1428                 if (len && unpack_only_one)
1429                     len = 1;
1430                 EXTEND(SP, len);
1431                 EXTEND_MORTAL(len);
1432                 while (len-- > 0) {
1433                     if (s + sizeof(Quad_t) > strend)
1434                         aquad = 0;
1435                     else {
1436                         Copy(s, &aquad, 1, Quad_t);
1437                         s += sizeof(Quad_t);
1438                     }
1439                     sv = NEWSV(42, 0);
1440                     if (aquad >= IV_MIN && aquad <= IV_MAX)
1441                         sv_setiv(sv, (IV)aquad);
1442                     else
1443                         sv_setnv(sv, (NV)aquad);
1444                     PUSHs(sv_2mortal(sv));
1445                 }
1446             }
1447             break;
1448         case 'Q':
1449             along = (strend - s) / sizeof(Uquad_t);
1450             if (len > along)
1451                 len = along;
1452             if (checksum) {
1453                 while (len-- > 0) {
1454                     Copy(s, &auquad, 1, Uquad_t);
1455                     s += sizeof(Uquad_t);
1456                     if (checksum > bits_in_uv)
1457                         cdouble += (NV)auquad;
1458                     else
1459                         cuv += auquad;
1460                 }
1461             }
1462             else {
1463                 if (len && unpack_only_one)
1464                     len = 1;
1465                 EXTEND(SP, len);
1466                 EXTEND_MORTAL(len);
1467                 while (len-- > 0) {
1468                     if (s + sizeof(Uquad_t) > strend)
1469                         auquad = 0;
1470                     else {
1471                         Copy(s, &auquad, 1, Uquad_t);
1472                         s += sizeof(Uquad_t);
1473                     }
1474                     sv = NEWSV(43, 0);
1475                     if (auquad <= UV_MAX)
1476                         sv_setuv(sv, (UV)auquad);
1477                     else
1478                     sv_setnv(sv, (NV)auquad);
1479                     PUSHs(sv_2mortal(sv));
1480                 }
1481             }
1482             break;
1483 #endif
1484         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1485         case 'f':
1486             along = (strend - s) / sizeof(float);
1487             if (len > along)
1488                 len = along;
1489             if (checksum) {
1490                 while (len-- > 0) {
1491                     Copy(s, &afloat, 1, float);
1492                     s += sizeof(float);
1493                     cdouble += afloat;
1494                 }
1495             }
1496             else {
1497                 if (len && unpack_only_one)
1498                     len = 1;
1499                 EXTEND(SP, len);
1500                 EXTEND_MORTAL(len);
1501                 while (len-- > 0) {
1502                     Copy(s, &afloat, 1, float);
1503                     s += sizeof(float);
1504                     sv = NEWSV(47, 0);
1505                     sv_setnv(sv, (NV)afloat);
1506                     PUSHs(sv_2mortal(sv));
1507                 }
1508             }
1509             break;
1510         case 'd':
1511             along = (strend - s) / sizeof(double);
1512             if (len > along)
1513                 len = along;
1514             if (checksum) {
1515                 while (len-- > 0) {
1516                     Copy(s, &adouble, 1, double);
1517                     s += sizeof(double);
1518                     cdouble += adouble;
1519                 }
1520             }
1521             else {
1522                 if (len && unpack_only_one)
1523                     len = 1;
1524                 EXTEND(SP, len);
1525                 EXTEND_MORTAL(len);
1526                 while (len-- > 0) {
1527                     Copy(s, &adouble, 1, double);
1528                     s += sizeof(double);
1529                     sv = NEWSV(48, 0);
1530                     sv_setnv(sv, (NV)adouble);
1531                     PUSHs(sv_2mortal(sv));
1532                 }
1533             }
1534             break;
1535         case 'F':
1536             along = (strend - s) / NVSIZE;
1537             if (len > along)
1538                 len = along;
1539             if (checksum) {
1540                 while (len-- > 0) {
1541                     Copy(s, &anv, 1, NV);
1542                     s += NVSIZE;
1543                     cdouble += anv;
1544                 }
1545             }
1546             else {
1547                 if (len && unpack_only_one)
1548                     len = 1;
1549                 EXTEND(SP, len);
1550                 EXTEND_MORTAL(len);
1551                 while (len-- > 0) {
1552                     Copy(s, &anv, 1, NV);
1553                     s += NVSIZE;
1554                     sv = NEWSV(48, 0);
1555                     sv_setnv(sv, anv);
1556                     PUSHs(sv_2mortal(sv));
1557                 }
1558             }
1559             break;
1560 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1561         case 'D':
1562             along = (strend - s) / LONG_DOUBLESIZE;
1563             if (len > along)
1564                 len = along;
1565             if (checksum) {
1566                 while (len-- > 0) {
1567                     Copy(s, &aldouble, 1, long double);
1568                     s += LONG_DOUBLESIZE;
1569                     cdouble += aldouble;
1570                 }
1571             }
1572             else {
1573                 if (len && unpack_only_one)
1574                     len = 1;
1575                 EXTEND(SP, len);
1576                 EXTEND_MORTAL(len);
1577                 while (len-- > 0) {
1578                     Copy(s, &aldouble, 1, long double);
1579                     s += LONG_DOUBLESIZE;
1580                     sv = NEWSV(48, 0);
1581                     sv_setnv(sv, (NV)aldouble);
1582                     PUSHs(sv_2mortal(sv));
1583                 }
1584             }
1585             break;
1586 #endif
1587         case 'u':
1588             /* MKS:
1589              * Initialise the decode mapping.  By using a table driven
1590              * algorithm, the code will be character-set independent
1591              * (and just as fast as doing character arithmetic)
1592              */
1593             if (PL_uudmap['M'] == 0) {
1594                 int i;
1595
1596                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1597                     PL_uudmap[(U8)PL_uuemap[i]] = i;
1598                 /*
1599                  * Because ' ' and '`' map to the same value,
1600                  * we need to decode them both the same.
1601                  */
1602                 PL_uudmap[' '] = 0;
1603             }
1604
1605             along = (strend - s) * 3 / 4;
1606             sv = NEWSV(42, along);
1607             if (along)
1608                 SvPOK_on(sv);
1609             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1610                 I32 a, b, c, d;
1611                 char hunk[4];
1612
1613                 hunk[3] = '\0';
1614                 len = PL_uudmap[*(U8*)s++] & 077;
1615                 while (len > 0) {
1616                     if (s < strend && ISUUCHAR(*s))
1617                         a = PL_uudmap[*(U8*)s++] & 077;
1618                     else
1619                         a = 0;
1620                     if (s < strend && ISUUCHAR(*s))
1621                         b = PL_uudmap[*(U8*)s++] & 077;
1622                     else
1623                         b = 0;
1624                     if (s < strend && ISUUCHAR(*s))
1625                         c = PL_uudmap[*(U8*)s++] & 077;
1626                     else
1627                         c = 0;
1628                     if (s < strend && ISUUCHAR(*s))
1629                         d = PL_uudmap[*(U8*)s++] & 077;
1630                     else
1631                         d = 0;
1632                     hunk[0] = (char)((a << 2) | (b >> 4));
1633                     hunk[1] = (char)((b << 4) | (c >> 2));
1634                     hunk[2] = (char)((c << 6) | d);
1635                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1636                     len -= 3;
1637                 }
1638                 if (*s == '\n')
1639                     s++;
1640                 else    /* possible checksum byte */
1641                     if (s + 1 < strend && s[1] == '\n')
1642                         s += 2;
1643             }
1644             XPUSHs(sv_2mortal(sv));
1645             break;
1646         }
1647
1648         if (checksum) {
1649             sv = NEWSV(42, 0);
1650             if (strchr("fFdD", datumtype) ||
1651               (checksum > bits_in_uv &&
1652                strchr("csSiIlLnNUvVqQjJ", datumtype&0xFF)) ) {
1653                 NV trouble;
1654
1655                 adouble = (NV) (1 << (checksum & 15));
1656                 while (checksum >= 16) {
1657                     checksum -= 16;
1658                     adouble *= 65536.0;
1659                 }
1660                 while (cdouble < 0.0)
1661                     cdouble += adouble;
1662                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1663                 sv_setnv(sv, cdouble);
1664             }
1665             else {
1666                 if (checksum < bits_in_uv) {
1667                     UV mask = ((UV)1 << checksum) - 1;
1668                     cuv &= mask;
1669                 }
1670                 sv_setuv(sv, cuv);
1671             }
1672             XPUSHs(sv_2mortal(sv));
1673             checksum = 0;
1674         }
1675
1676         if (symptr->flags & FLAG_SLASH){
1677             if (SP - PL_stack_base - start_sp_offset <= 0)
1678                 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1679             if( next_symbol(symptr) ){
1680               if( symptr->howlen == e_number )
1681                 Perl_croak(aTHX_ "Count after length/code in unpack" );
1682               if( beyond ){
1683                 /* ...end of char buffer then no decent length available */
1684                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1685               } else {
1686                 /* take top of stack (hope it's numeric) */
1687                 len = POPi;
1688                 if( len < 0 )
1689                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
1690               }
1691             } else {
1692                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1693             }
1694             datumtype = symptr->code;
1695             goto redo_switch;
1696         }
1697     }
1698
1699     if (new_s)
1700         *new_s = s;
1701     PUTBACK;
1702     return SP - PL_stack_base - start_sp_offset;
1703 }
1704
1705 PP(pp_unpack)
1706 {
1707     dSP;
1708     SV *right = (MAXARG > 1) ? POPs : GvSV(PL_defgv);
1709     SV *left = POPs;
1710     I32 gimme = GIMME_V;
1711     STRLEN llen;
1712     STRLEN rlen;
1713     register char *pat = SvPV(left, llen);
1714 #ifdef PACKED_IS_OCTETS
1715     /* Packed side is assumed to be octets - so force downgrade if it
1716        has been UTF-8 encoded by accident
1717      */
1718     register char *s = SvPVbyte(right, rlen);
1719 #else
1720     register char *s = SvPV(right, rlen);
1721 #endif
1722     char *strend = s + rlen;
1723     register char *patend = pat + llen;
1724     register I32 cnt;
1725
1726     PUTBACK;
1727     cnt = unpackstring(pat, patend, s, strend,
1728                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1729                      | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1730
1731     SPAGAIN;
1732     if ( !cnt && gimme == G_SCALAR )
1733        PUSHs(&PL_sv_undef);
1734     RETURN;
1735 }
1736
1737 STATIC void
1738 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1739 {
1740     char hunk[5];
1741
1742     *hunk = PL_uuemap[len];
1743     sv_catpvn(sv, hunk, 1);
1744     hunk[4] = '\0';
1745     while (len > 2) {
1746         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1747         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1748         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1749         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1750         sv_catpvn(sv, hunk, 4);
1751         s += 3;
1752         len -= 3;
1753     }
1754     if (len > 0) {
1755         char r = (len > 1 ? s[1] : '\0');
1756         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1757         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1758         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1759         hunk[3] = PL_uuemap[0];
1760         sv_catpvn(sv, hunk, 4);
1761     }
1762     sv_catpvn(sv, "\n", 1);
1763 }
1764
1765 STATIC SV *
1766 S_is_an_int(pTHX_ char *s, STRLEN l)
1767 {
1768   STRLEN         n_a;
1769   SV             *result = newSVpvn(s, l);
1770   char           *result_c = SvPV(result, n_a); /* convenience */
1771   char           *out = result_c;
1772   bool            skip = 1;
1773   bool            ignore = 0;
1774
1775   while (*s) {
1776     switch (*s) {
1777     case ' ':
1778       break;
1779     case '+':
1780       if (!skip) {
1781         SvREFCNT_dec(result);
1782         return (NULL);
1783       }
1784       break;
1785     case '0':
1786     case '1':
1787     case '2':
1788     case '3':
1789     case '4':
1790     case '5':
1791     case '6':
1792     case '7':
1793     case '8':
1794     case '9':
1795       skip = 0;
1796       if (!ignore) {
1797         *(out++) = *s;
1798       }
1799       break;
1800     case '.':
1801       ignore = 1;
1802       break;
1803     default:
1804       SvREFCNT_dec(result);
1805       return (NULL);
1806     }
1807     s++;
1808   }
1809   *(out++) = '\0';
1810   SvCUR_set(result, out - result_c);
1811   return (result);
1812 }
1813
1814 /* pnum must be '\0' terminated */
1815 STATIC int
1816 S_div128(pTHX_ SV *pnum, bool *done)
1817 {
1818   STRLEN          len;
1819   char           *s = SvPV(pnum, len);
1820   int             m = 0;
1821   int             r = 0;
1822   char           *t = s;
1823
1824   *done = 1;
1825   while (*t) {
1826     int             i;
1827
1828     i = m * 10 + (*t - '0');
1829     m = i & 0x7F;
1830     r = (i >> 7);               /* r < 10 */
1831     if (r) {
1832       *done = 0;
1833     }
1834     *(t++) = '0' + r;
1835   }
1836   *(t++) = '\0';
1837   SvCUR_set(pnum, (STRLEN) (t - s));
1838   return (m);
1839 }
1840
1841
1842
1843 /*
1844 =for apidoc pack_cat
1845
1846 The engine implementing pack() Perl function. Note: parameters next_in_list and
1847 flags are not used. This call should not be used; use packlist instead.
1848
1849 =cut */
1850
1851
1852 void
1853 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1854 {
1855     tempsym_t sym = { 0 };
1856     sym.patptr = pat;
1857     sym.patend = patend;
1858     sym.flags  = FLAG_PACK;
1859
1860     (void)pack_rec( cat, &sym, beglist, endlist );
1861 }
1862
1863
1864 /*
1865 =for apidoc packlist
1866
1867 The engine implementing pack() Perl function.
1868
1869 =cut */
1870
1871
1872 void
1873 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1874 {
1875     tempsym_t sym = { 0 };
1876     sym.patptr = pat;
1877     sym.patend = patend;
1878     sym.flags  = FLAG_PACK;
1879
1880     (void)pack_rec( cat, &sym, beglist, endlist );
1881 }
1882
1883
1884 STATIC
1885 SV **
1886 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1887 {
1888     register I32 items;
1889     STRLEN fromlen;
1890     register I32 len = 0;
1891     SV *fromstr;
1892     /*SUPPRESS 442*/
1893     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1894     static char *space10 = "          ";
1895     bool found;
1896
1897     /* These must not be in registers: */
1898     char achar;
1899     I16 ashort;
1900     int aint;
1901     unsigned int auint;
1902     I32 along;
1903     U32 aulong;
1904     IV aiv;
1905     UV auv;
1906     NV anv;
1907 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1908     long double aldouble;
1909 #endif
1910 #ifdef HAS_QUAD
1911     Quad_t aquad;
1912     Uquad_t auquad;
1913 #endif
1914     char *aptr;
1915     float afloat;
1916     double adouble;
1917     int strrelbeg = SvCUR(cat);
1918     tempsym_t lookahead;
1919
1920     items = endlist - beglist;
1921     found = next_symbol( symptr );
1922
1923 #ifndef PACKED_IS_OCTETS
1924     if (symptr->level == 0 && found && symptr->code == 'U' ){
1925         SvUTF8_on(cat);
1926     }
1927 #endif
1928
1929     while (found) {
1930         SV *lengthcode = Nullsv;
1931 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1932
1933         I32 datumtype = symptr->code;
1934         howlen_t howlen;
1935
1936         switch( howlen = symptr->howlen ){
1937         case e_no_len:
1938         case e_number:
1939             len = symptr->length;
1940             break;
1941         case e_star:
1942             len = strchr("@Xxu", datumtype) ? 0 : items;
1943             break;
1944         }
1945
1946         /* Look ahead for next symbol. Do we have code/code? */
1947         lookahead = *symptr;
1948         found = next_symbol(&lookahead);
1949         if ( symptr->flags & FLAG_SLASH ) {
1950             if (found){
1951                 if ( 0 == strchr( "aAZ", lookahead.code ) ||
1952                      e_star != lookahead.howlen )
1953                     Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
1954                 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1955                                                    ? *beglist : &PL_sv_no)
1956                                            + (lookahead.code == 'Z' ? 1 : 0)));
1957             } else {
1958                 Perl_croak(aTHX_ "Code missing after '/' in pack");
1959             }
1960         }
1961
1962         switch(datumtype) {
1963         default:
1964             Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)datumtype);
1965         case '%':
1966             Perl_croak(aTHX_ "'%%' may not be used in pack");
1967         case '@':
1968             len += strrelbeg - SvCUR(cat);
1969             if (len > 0)
1970                 goto grow;
1971             len = -len;
1972             if (len > 0)
1973                 goto shrink;
1974             break;
1975         case '(':
1976         {
1977             tempsym_t savsym = *symptr;
1978             symptr->patend = savsym.grpend;
1979             symptr->level++;
1980             while (len--) {
1981                 symptr->patptr = savsym.grpbeg;
1982                 beglist = pack_rec(cat, symptr, beglist, endlist );
1983                 if (savsym.howlen == e_star && beglist == endlist)
1984                     break;              /* No way to continue */
1985             }
1986             lookahead.flags = symptr->flags;
1987             *symptr = savsym;
1988             break;
1989         }
1990         case 'X' | TYPE_IS_SHRIEKING:
1991             if (!len)                   /* Avoid division by 0 */
1992                 len = 1;
1993             len = (SvCUR(cat)) % len;
1994             /* FALL THROUGH */
1995         case 'X':
1996           shrink:
1997             if ((I32)SvCUR(cat) < len)
1998                 Perl_croak(aTHX_ "'X' outside of string in pack");
1999             SvCUR(cat) -= len;
2000             *SvEND(cat) = '\0';
2001             break;
2002         case 'x' | TYPE_IS_SHRIEKING:
2003             if (!len)                   /* Avoid division by 0 */
2004                 len = 1;
2005             aint = (SvCUR(cat)) % len;
2006             if (aint)                   /* Other portable ways? */
2007                 len = len - aint;
2008             else
2009                 len = 0;
2010             /* FALL THROUGH */
2011
2012         case 'x':
2013           grow:
2014             while (len >= 10) {
2015                 sv_catpvn(cat, null10, 10);
2016                 len -= 10;
2017             }
2018             sv_catpvn(cat, null10, len);
2019             break;
2020         case 'A':
2021         case 'Z':
2022         case 'a':
2023             fromstr = NEXTFROM;
2024             aptr = SvPV(fromstr, fromlen);
2025             if (howlen == e_star) {
2026                 len = fromlen;
2027                 if (datumtype == 'Z')
2028                     ++len;
2029             }
2030             if ((I32)fromlen >= len) {
2031                 sv_catpvn(cat, aptr, len);
2032                 if (datumtype == 'Z')
2033                     *(SvEND(cat)-1) = '\0';
2034             }
2035             else {
2036                 sv_catpvn(cat, aptr, fromlen);
2037                 len -= fromlen;
2038                 if (datumtype == 'A') {
2039                     while (len >= 10) {
2040                         sv_catpvn(cat, space10, 10);
2041                         len -= 10;
2042                     }
2043                     sv_catpvn(cat, space10, len);
2044                 }
2045                 else {
2046                     while (len >= 10) {
2047                         sv_catpvn(cat, null10, 10);
2048                         len -= 10;
2049                     }
2050                     sv_catpvn(cat, null10, len);
2051                 }
2052             }
2053             break;
2054         case 'B':
2055         case 'b':
2056             {
2057                 register char *str;
2058                 I32 saveitems;
2059
2060                 fromstr = NEXTFROM;
2061                 saveitems = items;
2062                 str = SvPV(fromstr, fromlen);
2063                 if (howlen == e_star)
2064                     len = fromlen;
2065                 aint = SvCUR(cat);
2066                 SvCUR(cat) += (len+7)/8;
2067                 SvGROW(cat, SvCUR(cat) + 1);
2068                 aptr = SvPVX(cat) + aint;
2069                 if (len > (I32)fromlen)
2070                     len = fromlen;
2071                 aint = len;
2072                 items = 0;
2073                 if (datumtype == 'B') {
2074                     for (len = 0; len++ < aint;) {
2075                         items |= *str++ & 1;
2076                         if (len & 7)
2077                             items <<= 1;
2078                         else {
2079                             *aptr++ = items & 0xff;
2080                             items = 0;
2081                         }
2082                     }
2083                 }
2084                 else {
2085                     for (len = 0; len++ < aint;) {
2086                         if (*str++ & 1)
2087                             items |= 128;
2088                         if (len & 7)
2089                             items >>= 1;
2090                         else {
2091                             *aptr++ = items & 0xff;
2092                             items = 0;
2093                         }
2094                     }
2095                 }
2096                 if (aint & 7) {
2097                     if (datumtype == 'B')
2098                         items <<= 7 - (aint & 7);
2099                     else
2100                         items >>= 7 - (aint & 7);
2101                     *aptr++ = items & 0xff;
2102                 }
2103                 str = SvPVX(cat) + SvCUR(cat);
2104                 while (aptr <= str)
2105                     *aptr++ = '\0';
2106
2107                 items = saveitems;
2108             }
2109             break;
2110         case 'H':
2111         case 'h':
2112             {
2113                 register char *str;
2114                 I32 saveitems;
2115
2116                 fromstr = NEXTFROM;
2117                 saveitems = items;
2118                 str = SvPV(fromstr, fromlen);
2119                 if (howlen == e_star)
2120                     len = fromlen;
2121                 aint = SvCUR(cat);
2122                 SvCUR(cat) += (len+1)/2;
2123                 SvGROW(cat, SvCUR(cat) + 1);
2124                 aptr = SvPVX(cat) + aint;
2125                 if (len > (I32)fromlen)
2126                     len = fromlen;
2127                 aint = len;
2128                 items = 0;
2129                 if (datumtype == 'H') {
2130                     for (len = 0; len++ < aint;) {
2131                         if (isALPHA(*str))
2132                             items |= ((*str++ & 15) + 9) & 15;
2133                         else
2134                             items |= *str++ & 15;
2135                         if (len & 1)
2136                             items <<= 4;
2137                         else {
2138                             *aptr++ = items & 0xff;
2139                             items = 0;
2140                         }
2141                     }
2142                 }
2143                 else {
2144                     for (len = 0; len++ < aint;) {
2145                         if (isALPHA(*str))
2146                             items |= (((*str++ & 15) + 9) & 15) << 4;
2147                         else
2148                             items |= (*str++ & 15) << 4;
2149                         if (len & 1)
2150                             items >>= 4;
2151                         else {
2152                             *aptr++ = items & 0xff;
2153                             items = 0;
2154                         }
2155                     }
2156                 }
2157                 if (aint & 1)
2158                     *aptr++ = items & 0xff;
2159                 str = SvPVX(cat) + SvCUR(cat);
2160                 while (aptr <= str)
2161                     *aptr++ = '\0';
2162
2163                 items = saveitems;
2164             }
2165             break;
2166         case 'C':
2167         case 'c':
2168             while (len-- > 0) {
2169                 fromstr = NEXTFROM;
2170                 switch (datumtype) {
2171                 case 'C':
2172                     aint = SvIV(fromstr);
2173                     if ((aint < 0 || aint > 255) &&
2174                         ckWARN(WARN_PACK))
2175                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2176                                     "Character in 'C' format wrapped in pack");
2177                     achar = aint & 255;
2178                     sv_catpvn(cat, &achar, sizeof(char));
2179                     break;
2180                 case 'c':
2181                     aint = SvIV(fromstr);
2182                     if ((aint < -128 || aint > 127) &&
2183                         ckWARN(WARN_PACK))
2184                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2185                                     "Character in 'c' format wrapped in pack" );
2186                     achar = aint & 255;
2187                     sv_catpvn(cat, &achar, sizeof(char));
2188                     break;
2189                 }
2190             }
2191             break;
2192         case 'U':
2193             while (len-- > 0) {
2194                 fromstr = NEXTFROM;
2195                 auint = UNI_TO_NATIVE(SvUV(fromstr));
2196                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2197                 SvCUR_set(cat,
2198                           (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2199                                                      auint,
2200                                                      ckWARN(WARN_UTF8) ?
2201                                                      0 : UNICODE_ALLOW_ANY)
2202                           - SvPVX(cat));
2203             }
2204             *SvEND(cat) = '\0';
2205             break;
2206         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2207         case 'f':
2208             while (len-- > 0) {
2209                 fromstr = NEXTFROM;
2210 #ifdef __VOS__
2211 /* VOS does not automatically map a floating-point overflow
2212    during conversion from double to float into infinity, so we
2213    do it by hand.  This code should either be generalized for
2214    any OS that needs it, or removed if and when VOS implements
2215    posix-976 (suggestion to support mapping to infinity).
2216    Paul.Green@stratus.com 02-04-02.  */
2217                 if (SvNV(fromstr) > FLT_MAX)
2218                      afloat = _float_constants[0];   /* single prec. inf. */
2219                 else if (SvNV(fromstr) < -FLT_MAX)
2220                      afloat = _float_constants[0];   /* single prec. inf. */
2221                 else afloat = (float)SvNV(fromstr);
2222 #else
2223 # if defined(VMS) && !defined(__IEEE_FP)
2224 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2225  * on Alpha; fake it if we don't have them.
2226  */
2227                 if (SvNV(fromstr) > FLT_MAX)
2228                      afloat = FLT_MAX;
2229                 else if (SvNV(fromstr) < -FLT_MAX)
2230                      afloat = -FLT_MAX;
2231                 else afloat = (float)SvNV(fromstr);
2232 # else
2233                 afloat = (float)SvNV(fromstr);
2234 # endif
2235 #endif
2236                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2237             }
2238             break;
2239         case 'd':
2240             while (len-- > 0) {
2241                 fromstr = NEXTFROM;
2242 #ifdef __VOS__
2243 /* VOS does not automatically map a floating-point overflow
2244    during conversion from long double to double into infinity,
2245    so we do it by hand.  This code should either be generalized
2246    for any OS that needs it, or removed if and when VOS
2247    implements posix-976 (suggestion to support mapping to
2248    infinity).  Paul.Green@stratus.com 02-04-02.  */
2249                 if (SvNV(fromstr) > DBL_MAX)
2250                      adouble = _double_constants[0];   /* double prec. inf. */
2251                 else if (SvNV(fromstr) < -DBL_MAX)
2252                      adouble = _double_constants[0];   /* double prec. inf. */
2253                 else adouble = (double)SvNV(fromstr);
2254 #else
2255 # if defined(VMS) && !defined(__IEEE_FP)
2256 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2257  * on Alpha; fake it if we don't have them.
2258  */
2259                 if (SvNV(fromstr) > DBL_MAX)
2260                      adouble = DBL_MAX;
2261                 else if (SvNV(fromstr) < -DBL_MAX)
2262                      adouble = -DBL_MAX;
2263                 else adouble = (double)SvNV(fromstr);
2264 # else
2265                 adouble = (double)SvNV(fromstr);
2266 # endif
2267 #endif
2268                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2269             }
2270             break;
2271         case 'F':
2272             while (len-- > 0) {
2273                 fromstr = NEXTFROM;
2274                 anv = SvNV(fromstr);
2275                 sv_catpvn(cat, (char *)&anv, NVSIZE);
2276             }
2277             break;
2278 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2279         case 'D':
2280             while (len-- > 0) {
2281                 fromstr = NEXTFROM;
2282                 aldouble = (long double)SvNV(fromstr);
2283                 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2284             }
2285             break;
2286 #endif
2287         case 'n':
2288             while (len-- > 0) {
2289                 fromstr = NEXTFROM;
2290                 ashort = (I16)SvIV(fromstr);
2291 #ifdef HAS_HTONS
2292                 ashort = PerlSock_htons(ashort);
2293 #endif
2294                 CAT16(cat, &ashort);
2295             }
2296             break;
2297         case 'v':
2298             while (len-- > 0) {
2299                 fromstr = NEXTFROM;
2300                 ashort = (I16)SvIV(fromstr);
2301 #ifdef HAS_HTOVS
2302                 ashort = htovs(ashort);
2303 #endif
2304                 CAT16(cat, &ashort);
2305             }
2306             break;
2307         case 'S' | TYPE_IS_SHRIEKING:
2308 #if SHORTSIZE != SIZE16
2309             {
2310                 unsigned short aushort;
2311
2312                 while (len-- > 0) {
2313                     fromstr = NEXTFROM;
2314                     aushort = SvUV(fromstr);
2315                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2316                 }
2317             }
2318             break;
2319 #else
2320             /* Fall through! */
2321 #endif
2322         case 'S':
2323             {
2324                 U16 aushort;
2325
2326                 while (len-- > 0) {
2327                     fromstr = NEXTFROM;
2328                     aushort = (U16)SvUV(fromstr);
2329                     CAT16(cat, &aushort);
2330                 }
2331
2332             }
2333             break;
2334         case 's' | TYPE_IS_SHRIEKING:
2335 #if SHORTSIZE != SIZE16
2336             {
2337                 short ashort;
2338
2339                 while (len-- > 0) {
2340                     fromstr = NEXTFROM;
2341                     ashort = SvIV(fromstr);
2342                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
2343                 }
2344             }
2345             break;
2346 #else
2347             /* Fall through! */
2348 #endif
2349         case 's':
2350             while (len-- > 0) {
2351                 fromstr = NEXTFROM;
2352                 ashort = (I16)SvIV(fromstr);
2353                 CAT16(cat, &ashort);
2354             }
2355             break;
2356         case 'I':
2357         case 'I' | TYPE_IS_SHRIEKING:
2358             while (len-- > 0) {
2359                 fromstr = NEXTFROM;
2360                 auint = SvUV(fromstr);
2361                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2362             }
2363             break;
2364         case 'j':
2365             while (len-- > 0) {
2366                 fromstr = NEXTFROM;
2367                 aiv = SvIV(fromstr);
2368                 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2369             }
2370             break;
2371         case 'J':
2372             while (len-- > 0) {
2373                 fromstr = NEXTFROM;
2374                 auv = SvUV(fromstr);
2375                 sv_catpvn(cat, (char*)&auv, UVSIZE);
2376             }
2377             break;
2378         case 'w':
2379             while (len-- > 0) {
2380                 fromstr = NEXTFROM;
2381                 anv = SvNV(fromstr);
2382
2383                 if (anv < 0)
2384                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2385
2386                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2387                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2388                    any negative IVs will have already been got by the croak()
2389                    above. IOK is untrue for fractions, so we test them
2390                    against UV_MAX_P1.  */
2391                 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2392                 {
2393                     char   buf[(sizeof(UV)*8)/7+1];
2394                     char  *in = buf + sizeof(buf);
2395                     UV     auv = SvUV(fromstr);
2396
2397                     do {
2398                         *--in = (char)((auv & 0x7f) | 0x80);
2399                         auv >>= 7;
2400                     } while (auv);
2401                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2402                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2403                 }
2404                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
2405                     char           *from, *result, *in;
2406                     SV             *norm;
2407                     STRLEN          len;
2408                     bool            done;
2409
2410                     /* Copy string and check for compliance */
2411                     from = SvPV(fromstr, len);
2412                     if ((norm = is_an_int(from, len)) == NULL)
2413                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2414
2415                     New('w', result, len, char);
2416                     in = result + len;
2417                     done = FALSE;
2418                     while (!done)
2419                         *--in = div128(norm, &done) | 0x80;
2420                     result[len - 1] &= 0x7F; /* clear continue bit */
2421                     sv_catpvn(cat, in, (result + len) - in);
2422                     Safefree(result);
2423                     SvREFCNT_dec(norm); /* free norm */
2424                 }
2425                 else if (SvNOKp(fromstr)) {
2426                     /* 10**NV_MAX_10_EXP is the largest power of 10
2427                        so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2428                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2429                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2430                        And with that many bytes only Inf can overflow.
2431                     */
2432 #ifdef NV_MAX_10_EXP
2433                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)];
2434 #else
2435                     char   buf[1 + (int)((308 + 1) * 0.47456)];
2436 #endif
2437                     char  *in = buf + sizeof(buf);
2438
2439                     anv = Perl_floor(anv);
2440                     do {
2441                         NV next = Perl_floor(anv / 128);
2442                         if (in <= buf)  /* this cannot happen ;-) */
2443                             Perl_croak(aTHX_ "Cannot compress integer in pack");
2444                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2445                         anv = next;
2446                     } while (anv > 0);
2447                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2448                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2449                 }
2450                 else {
2451                     char           *from, *result, *in;
2452                     SV             *norm;
2453                     STRLEN          len;
2454                     bool            done;
2455
2456                     /* Copy string and check for compliance */
2457                     from = SvPV(fromstr, len);
2458                     if ((norm = is_an_int(from, len)) == NULL)
2459                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2460
2461                     New('w', result, len, char);
2462                     in = result + len;
2463                     done = FALSE;
2464                     while (!done)
2465                         *--in = div128(norm, &done) | 0x80;
2466                     result[len - 1] &= 0x7F; /* clear continue bit */
2467                     sv_catpvn(cat, in, (result + len) - in);
2468                     Safefree(result);
2469                     SvREFCNT_dec(norm); /* free norm */
2470                }
2471             }
2472             break;
2473         case 'i':
2474         case 'i' | TYPE_IS_SHRIEKING:
2475             while (len-- > 0) {
2476                 fromstr = NEXTFROM;
2477                 aint = SvIV(fromstr);
2478                 sv_catpvn(cat, (char*)&aint, sizeof(int));
2479             }
2480             break;
2481         case 'N':
2482             while (len-- > 0) {
2483                 fromstr = NEXTFROM;
2484                 aulong = SvUV(fromstr);
2485 #ifdef HAS_HTONL
2486                 aulong = PerlSock_htonl(aulong);
2487 #endif
2488                 CAT32(cat, &aulong);
2489             }
2490             break;
2491         case 'V':
2492             while (len-- > 0) {
2493                 fromstr = NEXTFROM;
2494                 aulong = SvUV(fromstr);
2495 #ifdef HAS_HTOVL
2496                 aulong = htovl(aulong);
2497 #endif
2498                 CAT32(cat, &aulong);
2499             }
2500             break;
2501         case 'L' | TYPE_IS_SHRIEKING:
2502 #if LONGSIZE != SIZE32
2503             {
2504                 unsigned long aulong;
2505
2506                 while (len-- > 0) {
2507                     fromstr = NEXTFROM;
2508                     aulong = SvUV(fromstr);
2509                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2510                 }
2511             }
2512             break;
2513 #else
2514             /* Fall though! */
2515 #endif
2516         case 'L':
2517             {
2518                 while (len-- > 0) {
2519                     fromstr = NEXTFROM;
2520                     aulong = SvUV(fromstr);
2521                     CAT32(cat, &aulong);
2522                 }
2523             }
2524             break;
2525         case 'l' | TYPE_IS_SHRIEKING:
2526 #if LONGSIZE != SIZE32
2527             {
2528                 long along;
2529
2530                 while (len-- > 0) {
2531                     fromstr = NEXTFROM;
2532                     along = SvIV(fromstr);
2533                     sv_catpvn(cat, (char *)&along, sizeof(long));
2534                 }
2535             }
2536             break;
2537 #else
2538             /* Fall though! */
2539 #endif
2540         case 'l':
2541             while (len-- > 0) {
2542                 fromstr = NEXTFROM;
2543                 along = SvIV(fromstr);
2544                 CAT32(cat, &along);
2545             }
2546             break;
2547 #ifdef HAS_QUAD
2548         case 'Q':
2549             while (len-- > 0) {
2550                 fromstr = NEXTFROM;
2551                 auquad = (Uquad_t)SvUV(fromstr);
2552                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2553             }
2554             break;
2555         case 'q':
2556             while (len-- > 0) {
2557                 fromstr = NEXTFROM;
2558                 aquad = (Quad_t)SvIV(fromstr);
2559                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2560             }
2561             break;
2562 #endif
2563         case 'P':
2564             len = 1;            /* assume SV is correct length */
2565             /* Fall through! */
2566         case 'p':
2567             while (len-- > 0) {
2568                 fromstr = NEXTFROM;
2569                 if (fromstr == &PL_sv_undef)
2570                     aptr = NULL;
2571                 else {
2572                     STRLEN n_a;
2573                     /* XXX better yet, could spirit away the string to
2574                      * a safe spot and hang on to it until the result
2575                      * of pack() (and all copies of the result) are
2576                      * gone.
2577                      */
2578                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2579                                                 || (SvPADTMP(fromstr)
2580                                                     && !SvREADONLY(fromstr))))
2581                     {
2582                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2583                                 "Attempt to pack pointer to temporary value");
2584                     }
2585                     if (SvPOK(fromstr) || SvNIOK(fromstr))
2586                         aptr = SvPV(fromstr,n_a);
2587                     else
2588                         aptr = SvPV_force(fromstr,n_a);
2589                 }
2590                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2591             }
2592             break;
2593         case 'u':
2594             fromstr = NEXTFROM;
2595             aptr = SvPV(fromstr, fromlen);
2596             SvGROW(cat, fromlen * 4 / 3);
2597             if (len <= 2)
2598                 len = 45;
2599             else
2600                 len = len / 3 * 3;
2601             while (fromlen > 0) {
2602                 I32 todo;
2603
2604                 if ((I32)fromlen > len)
2605                     todo = len;
2606                 else
2607                     todo = fromlen;
2608                 doencodes(cat, aptr, todo);
2609                 fromlen -= todo;
2610                 aptr += todo;
2611             }
2612             break;
2613         }
2614         *symptr = lookahead;
2615     }
2616     return beglist;
2617 }
2618 #undef NEXTFROM
2619
2620
2621 PP(pp_pack)
2622 {
2623     dSP; dMARK; dORIGMARK; dTARGET;
2624     register SV *cat = TARG;
2625     STRLEN fromlen;
2626     register char *pat = SvPVx(*++MARK, fromlen);
2627     register char *patend = pat + fromlen;
2628
2629     MARK++;
2630     sv_setpvn(cat, "", 0);
2631
2632     packlist(cat, pat, patend, MARK, SP + 1);
2633
2634     SvSETMAGIC(cat);
2635     SP = ORIGMARK;
2636     PUSHs(cat);
2637     RETURN;
2638 }
2639