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