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