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