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