pp_pack.c

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