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                     PUSHs(sv_2mortal(newSViv((IV)aint)));
 968                 }
 969                 else if (checksum > bits_in_uv)
 970                     cdouble += (NV)aint;
 971                 else
 972                     cuv += aint;
 973             }
 974             break;
 975         case 'C':
 976         unpack_C: /* unpack U will jump here if not UTF-8 */
 977             if (len == 0) {
 978                 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
 979                 break;
 980             }
 981             if (len > strend - s)
 982                 len = strend - s;
 983             if (checksum) {
 984               uchar_checksum:
 985                 while (len-- > 0) {
 986                     auint = *s++ & 255;
 987                     cuv += auint;
 988                 }
 989             }
 990             else {
 991                 if (len && unpack_only_one)
 992                     len = 1;
 993                 EXTEND(SP, len);
 994                 EXTEND_MORTAL(len);
 995                 while (len-- > 0) {
 996                     auint = *s++ & 255;
 997                     PUSHs(sv_2mortal(newSViv((IV)auint)));
 998                 }
 999             }
1000             break;
1001         case 'U':
1002             if (len == 0) {
1003                 symptr->flags |= FLAG_UNPACK_DO_UTF8;
1004                 break;
1005             }
1006             if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
1007                  goto unpack_C;
1008             if (len > strend - s)
1009                 len = strend - s;
1010             if (!checksum) {
1011                 if (len && unpack_only_one)
1012                     len = 1;
1013                 EXTEND(SP, len);
1014                 EXTEND_MORTAL(len);
1015             }
1016             while (len-- > 0 && s < strend) {
1017                 STRLEN alen;
1018                 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1019                 along = alen;
1020                 s += along;
1021                 if (!checksum) {
1022                     PUSHs(sv_2mortal(newSVuv((UV)auint)));
1023                 }
1024                 else if (checksum > bits_in_uv)
1025                     cdouble += (NV)auint;
1026                 else
1027                     cuv += auint;
1028             }
1029             break;
1030         case 's' | TYPE_IS_SHRIEKING:
1031 #if SHORTSIZE != SIZE16
1032             along = (strend - s) / sizeof(short);
1033             if (len > along)
1034                 len = along;
1035             if (!checksum) {
1036                 if (len && unpack_only_one)
1037                     len = 1;
1038                 EXTEND(SP, len);
1039                 EXTEND_MORTAL(len);
1040             }
1041             while (len-- > 0) {
1042                 COPYNN(s, &ashort, sizeof(short));
1043                 DO_BO_UNPACK(ashort, s);
1044                 s += sizeof(short);
1045                 if (!checksum) {
1046                     PUSHs(sv_2mortal(newSViv((IV)ashort)));
1047                 }
1048                 else if (checksum > bits_in_uv)
1049                     cdouble += (NV)ashort;
1050                 else
1051                     cuv += ashort;
1052             }
1053             break;
1054 #else
1055             /* Fallthrough! */
1056 #endif
1057         case 's':
1058             along = (strend - s) / SIZE16;
1059             if (len > along)
1060                 len = along;
1061             if (!checksum) {
1062                 if (len && unpack_only_one)
1063                     len = 1;
1064                 EXTEND(SP, len);
1065                 EXTEND_MORTAL(len);
1066             }
1067             while (len-- > 0) {
1068                 COPY16(s, &ai16);
1069                 DO_BO_UNPACK(ai16, 16);
1070 #if U16SIZE > SIZE16
1071                 if (ai16 > 32767)
1072                     ai16 -= 65536;
1073 #endif
1074                 s += SIZE16;
1075                 if (!checksum) {
1076                     PUSHs(sv_2mortal(newSViv((IV)ai16)));
1077                 }
1078                 else if (checksum > bits_in_uv)
1079                     cdouble += (NV)ai16;
1080                 else
1081                     cuv += ai16;
1082             }
1083             break;
1084         case 'S' | TYPE_IS_SHRIEKING:
1085 #if SHORTSIZE != SIZE16
1086             along = (strend - s) / sizeof(unsigned short);
1087             if (len > along)
1088                 len = along;
1089             if (!checksum) {
1090                 if (len && unpack_only_one)
1091                     len = 1;
1092                 EXTEND(SP, len);
1093                 EXTEND_MORTAL(len);
1094             }
1095             while (len-- > 0) {
1096                 COPYNN(s, &aushort, sizeof(unsigned short));
1097                 DO_BO_UNPACK(aushort, s);
1098                 s += sizeof(unsigned short);
1099                 if (!checksum) {
1100                     PUSHs(sv_2mortal(newSViv((UV)aushort)));
1101                 }
1102                 else if (checksum > bits_in_uv)
1103                     cdouble += (NV)aushort;
1104                 else
1105                     cuv += aushort;
1106             }
1107             break;
1108 #else
1109             /* Fallhrough! */
1110 #endif
1111         case 'v':
1112         case 'n':
1113         case 'S':
1114             along = (strend - s) / SIZE16;
1115             if (len > along)
1116                 len = along;
1117             if (!checksum) {
1118                 if (len && unpack_only_one)
1119                     len = 1;
1120                 EXTEND(SP, len);
1121                 EXTEND_MORTAL(len);
1122             }
1123             while (len-- > 0) {
1124                 COPY16(s, &au16);
1125                 DO_BO_UNPACK(au16, 16);
1126                 s += SIZE16;
1127 #ifdef HAS_NTOHS
1128                 if (datumtype == 'n')
1129                     au16 = PerlSock_ntohs(au16);
1130 #endif
1131 #ifdef HAS_VTOHS
1132                 if (datumtype == 'v')
1133                     au16 = vtohs(au16);
1134 #endif
1135                 if (!checksum) {
1136                     PUSHs(sv_2mortal(newSViv((UV)au16)));
1137                 }
1138                 else if (checksum > bits_in_uv)
1139                     cdouble += (NV)au16;
1140                 else
1141                     cuv += au16;
1142             }
1143             break;
1144         case 'v' | TYPE_IS_SHRIEKING:
1145         case 'n' | TYPE_IS_SHRIEKING:
1146             along = (strend - s) / SIZE16;
1147             if (len > along)
1148                 len = along;
1149             if (!checksum) {
1150                 if (len && unpack_only_one)
1151                     len = 1;
1152                 EXTEND(SP, len);
1153                 EXTEND_MORTAL(len);
1154             }
1155             while (len-- > 0) {
1156                 COPY16(s, &ai16);
1157                 s += SIZE16;
1158 #ifdef HAS_NTOHS
1159                 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1160                     ai16 = (I16)PerlSock_ntohs((U16)ai16);
1161 #endif
1162 #ifdef HAS_VTOHS
1163                 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1164                     ai16 = (I16)vtohs((U16)ai16);
1165 #endif
1166                 if (!checksum) {
1167                     PUSHs(sv_2mortal(newSViv((IV)ai16)));
1168                 }
1169                 else if (checksum > bits_in_uv)
1170                     cdouble += (NV)ai16;
1171                 else
1172                     cuv += ai16;
1173             }
1174             break;
1175         case 'i':
1176         case 'i' | TYPE_IS_SHRIEKING:
1177             along = (strend - s) / sizeof(int);
1178             if (len > along)
1179                 len = along;
1180             if (!checksum) {
1181                 if (len && unpack_only_one)
1182                     len = 1;
1183                 EXTEND(SP, len);
1184                 EXTEND_MORTAL(len);
1185             }
1186             while (len-- > 0) {
1187                 Copy(s, &aint, 1, int);
1188                 DO_BO_UNPACK(aint, i);
1189                 s += sizeof(int);
1190                 if (!checksum) {
1191                     PUSHs(sv_2mortal(newSViv((IV)aint)));
1192                 }
1193                 else if (checksum > bits_in_uv)
1194                     cdouble += (NV)aint;
1195                 else
1196                     cuv += aint;
1197             }
1198             break;
1199         case 'I':
1200         case 'I' | TYPE_IS_SHRIEKING:
1201             along = (strend - s) / sizeof(unsigned int);
1202             if (len > along)
1203                 len = along;
1204             if (!checksum) {
1205                 if (len && unpack_only_one)
1206                     len = 1;
1207                 EXTEND(SP, len);
1208                 EXTEND_MORTAL(len);
1209             }
1210             while (len-- > 0) {
1211                 Copy(s, &auint, 1, unsigned int);
1212                 DO_BO_UNPACK(auint, i);
1213                 s += sizeof(unsigned int);
1214                 if (!checksum) {
1215                     PUSHs(sv_2mortal(newSVuv((UV)auint)));
1216                 }
1217                 else if (checksum > bits_in_uv)
1218                     cdouble += (NV)auint;
1219                 else
1220                     cuv += auint;
1221             }
1222             break;
1223         case 'j':
1224             along = (strend - s) / IVSIZE;
1225             if (len > along)
1226                 len = along;
1227             if (!checksum) {
1228                 if (len && unpack_only_one)
1229                     len = 1;
1230                 EXTEND(SP, len);
1231                 EXTEND_MORTAL(len);
1232             }
1233             while (len-- > 0) {
1234                 Copy(s, &aiv, 1, IV);
1235 #if IVSIZE == INTSIZE
1236                 DO_BO_UNPACK(aiv, i);
1237 #elif IVSIZE == LONGSIZE
1238                 DO_BO_UNPACK(aiv, l);
1239 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1240                 DO_BO_UNPACK(aiv, 64);
1241 #endif
1242                 s += IVSIZE;
1243                 if (!checksum) {
1244                     PUSHs(sv_2mortal(newSViv(aiv)));
1245                 }
1246                 else if (checksum > bits_in_uv)
1247                     cdouble += (NV)aiv;
1248                 else
1249                     cuv += aiv;
1250             }
1251             break;
1252         case 'J':
1253             along = (strend - s) / UVSIZE;
1254             if (len > along)
1255                 len = along;
1256             if (!checksum) {
1257                 if (len && unpack_only_one)
1258                     len = 1;
1259                 EXTEND(SP, len);
1260                 EXTEND_MORTAL(len);
1261             }
1262             while (len-- > 0) {
1263                 Copy(s, &auv, 1, UV);
1264 #if UVSIZE == INTSIZE
1265                 DO_BO_UNPACK(auv, i);
1266 #elif UVSIZE == LONGSIZE
1267                 DO_BO_UNPACK(auv, l);
1268 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1269                 DO_BO_UNPACK(auv, 64);
1270 #endif
1271                 s += UVSIZE;
1272                 if (!checksum) {
1273                     PUSHs(sv_2mortal(newSVuv(auv)));
1274                 }
1275                 else if (checksum > bits_in_uv)
1276                     cdouble += (NV)auv;
1277                 else
1278                     cuv += auv;
1279             }
1280             break;
1281         case 'l' | TYPE_IS_SHRIEKING:
1282 #if LONGSIZE != SIZE32
1283             along = (strend - s) / sizeof(long);
1284             if (len > along)
1285                 len = along;
1286             if (!checksum) {
1287                 if (len && unpack_only_one)
1288                     len = 1;
1289                 EXTEND(SP, len);
1290                 EXTEND_MORTAL(len);
1291             }
1292             while (len-- > 0) {
1293                 COPYNN(s, &along, sizeof(long));
1294                 DO_BO_UNPACK(along, l);
1295                 s += sizeof(long);
1296                 if (!checksum) {
1297                     PUSHs(sv_2mortal(newSViv((IV)along)));
1298                 }
1299                 else if (checksum > bits_in_uv)
1300                     cdouble += (NV)along;
1301                 else
1302                     cuv += along;
1303             }
1304             break;
1305 #else
1306             /* Fallthrough! */
1307 #endif
1308         case 'l':
1309             along = (strend - s) / SIZE32;
1310             if (len > along)
1311                 len = along;
1312             if (!checksum) {
1313                 if (len && unpack_only_one)
1314                     len = 1;
1315                 EXTEND(SP, len);
1316                 EXTEND_MORTAL(len);
1317             }
1318             while (len-- > 0) {
1319                 COPY32(s, &ai32);
1320                 DO_BO_UNPACK(ai32, 32);
1321 #if U32SIZE > SIZE32
1322                 if (ai32 > 2147483647)
1323                     ai32 -= 4294967296;
1324 #endif
1325                 s += SIZE32;
1326                 if (!checksum) {
1327                     PUSHs(sv_2mortal(newSViv((IV)ai32)));
1328                 }
1329                 else if (checksum > bits_in_uv)
1330                     cdouble += (NV)ai32;
1331                 else
1332                     cuv += ai32;
1333             }
1334             break;
1335         case 'L' | TYPE_IS_SHRIEKING:
1336 #if LONGSIZE != SIZE32
1337             along = (strend - s) / sizeof(unsigned long);
1338             if (len > along)
1339                 len = along;
1340             if (!checksum) {
1341                 if (len && unpack_only_one)
1342                     len = 1;
1343                 EXTEND(SP, len);
1344                 EXTEND_MORTAL(len);
1345             }
1346             while (len-- > 0) {
1347                 COPYNN(s, &aulong, sizeof(unsigned long));
1348                 DO_BO_UNPACK(aulong, l);
1349                 s += sizeof(unsigned long);
1350                 if (!checksum) {
1351                     PUSHs(sv_2mortal(newSVuv((UV)aulong)));
1352                 }
1353                 else if (checksum > bits_in_uv)
1354                     cdouble += (NV)aulong;
1355                 else
1356                     cuv += aulong;
1357             }
1358             break;
1359 #else
1360             /* Fall through! */
1361 #endif
1362         case 'V':
1363         case 'N':
1364         case 'L':
1365             along = (strend - s) / SIZE32;
1366             if (len > along)
1367                 len = along;
1368             if (!checksum) {
1369                 if (len && unpack_only_one)
1370                     len = 1;
1371                 EXTEND(SP, len);
1372                 EXTEND_MORTAL(len);
1373             }
1374             while (len-- > 0) {
1375                 COPY32(s, &au32);
1376                 DO_BO_UNPACK(au32, 32);
1377                 s += SIZE32;
1378 #ifdef HAS_NTOHL
1379                 if (datumtype == 'N')
1380                     au32 = PerlSock_ntohl(au32);
1381 #endif
1382 #ifdef HAS_VTOHL
1383                 if (datumtype == 'V')
1384                     au32 = vtohl(au32);
1385 #endif
1386                  if (!checksum) {
1387                      PUSHs(sv_2mortal(newSVuv((UV)au32)));
1388                  }
1389                  else if (checksum > bits_in_uv)
1390                      cdouble += (NV)au32;
1391                  else
1392                      cuv += au32;
1393             }
1394             break;
1395         case 'V' | TYPE_IS_SHRIEKING:
1396         case 'N' | TYPE_IS_SHRIEKING:
1397             along = (strend - s) / SIZE32;
1398             if (len > along)
1399                 len = along;
1400             if (!checksum) {
1401                 if (len && unpack_only_one)
1402                     len = 1;
1403                 EXTEND(SP, len);
1404                 EXTEND_MORTAL(len);
1405             }
1406             while (len-- > 0) {
1407                 COPY32(s, &ai32);
1408                 s += SIZE32;
1409 #ifdef HAS_NTOHL
1410                 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1411                     ai32 = (I32)PerlSock_ntohl((U32)ai32);
1412 #endif
1413 #ifdef HAS_VTOHL
1414                 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1415                     ai32 = (I32)vtohl((U32)ai32);
1416 #endif
1417                 if (!checksum) {
1418                     PUSHs(sv_2mortal(newSViv((IV)ai32)));
1419                 }
1420                 else if (checksum > bits_in_uv)
1421                     cdouble += (NV)ai32;
1422                 else
1423                     cuv += ai32;
1424             }
1425             break;
1426         case 'p':
1427             along = (strend - s) / sizeof(char*);
1428             if (len > along)
1429                 len = along;
1430             EXTEND(SP, len);
1431             EXTEND_MORTAL(len);
1432             while (len-- > 0) {
1433                 if (sizeof(char*) > strend - s)
1434                     break;
1435                 else {
1436                     Copy(s, &aptr, 1, char*);
1437                     DO_BO_UNPACK_P(aptr);
1438                     s += sizeof(char*);
1439                 }
1440                 /* newSVpv generates undef if aptr is NULL */
1441                 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1442             }
1443             break;
1444         case 'w':
1445             if (len && unpack_only_one)
1446                 len = 1;
1447             EXTEND(SP, len);
1448             EXTEND_MORTAL(len);
1449             {
1450                 UV auv = 0;
1451                 U32 bytes = 0;
1452
1453                 while ((len > 0) && (s < strend)) {
1454                     auv = (auv << 7) | (*s & 0x7f);
1455                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1456                     if ((U8)(*s++) < 0x80) {
1457                         bytes = 0;
1458                         PUSHs(sv_2mortal(newSVuv(auv)));
1459                         len--;
1460                         auv = 0;
1461                     }
1462                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
1463                         char *t;
1464                         STRLEN n_a;
1465
1466                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1467                         while (s < strend) {
1468                             sv = mul128(sv, (U8)(*s & 0x7f));
1469                             if (!(*s++ & 0x80)) {
1470                                 bytes = 0;
1471                                 break;
1472                             }
1473                         }
1474                         t = SvPV(sv, n_a);
1475                         while (*t == '0')
1476                             t++;
1477                         sv_chop(sv, t);
1478                         PUSHs(sv_2mortal(sv));
1479                         len--;
1480                         auv = 0;
1481                     }
1482                 }
1483                 if ((s >= strend) && bytes)
1484                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1485             }
1486             break;
1487         case 'P':
1488             if (symptr->howlen == e_star)
1489                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1490             EXTEND(SP, 1);
1491             if (sizeof(char*) > strend - s)
1492                 break;
1493             else {
1494                 Copy(s, &aptr, 1, char*);
1495                 DO_BO_UNPACK_P(aptr);
1496                 s += sizeof(char*);
1497             }
1498             /* newSVpvn generates undef if aptr is NULL */
1499             PUSHs(sv_2mortal(newSVpvn(aptr, len)));
1500             break;
1501 #ifdef HAS_QUAD
1502         case 'q':
1503             along = (strend - s) / sizeof(Quad_t);
1504             if (len > along)
1505                 len = along;
1506             if (!checksum) {
1507                 if (len && unpack_only_one)
1508                     len = 1;
1509                 EXTEND(SP, len);
1510                 EXTEND_MORTAL(len);
1511             }
1512             while (len-- > 0) {
1513                 assert (s + sizeof(Quad_t) <= strend);
1514                 Copy(s, &aquad, 1, Quad_t);
1515                 DO_BO_UNPACK(aquad, 64);
1516                 s += sizeof(Quad_t);
1517                 if (!checksum) {
1518                     PUSHs(sv_2mortal((aquad >= IV_MIN && aquad <= IV_MAX) ?
1519                                      newSViv((IV)aquad) : newSVnv((NV)aquad)));
1520                 }
1521                 else if (checksum > bits_in_uv)
1522                     cdouble += (NV)aquad;
1523                 else
1524                     cuv += aquad;
1525             }
1526             break;
1527         case 'Q':
1528             along = (strend - s) / sizeof(Uquad_t);
1529             if (len > along)
1530                 len = along;
1531             if (!checksum) {
1532                 if (len && unpack_only_one)
1533                     len = 1;
1534                 EXTEND(SP, len);
1535                 EXTEND_MORTAL(len);
1536             }
1537             while (len-- > 0) {
1538                 assert (s + sizeof(Uquad_t) <= strend);
1539                 Copy(s, &auquad, 1, Uquad_t);
1540                 DO_BO_UNPACK(auquad, 64);
1541                 s += sizeof(Uquad_t);
1542                 if (!checksum) {
1543                     PUSHs(sv_2mortal((auquad <= UV_MAX) ?
1544                                      newSVuv((UV)auquad) : newSVnv((NV)auquad)));
1545                 }
1546                 else if (checksum > bits_in_uv)
1547                     cdouble += (NV)auquad;
1548                 else
1549                     cuv += auquad;
1550             }
1551             break;
1552 #endif
1553         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1554         case 'f':
1555             along = (strend - s) / sizeof(float);
1556             if (len > along)
1557                 len = along;
1558             if (!checksum) {
1559                 if (len && unpack_only_one)
1560                     len = 1;
1561                 EXTEND(SP, len);
1562                 EXTEND_MORTAL(len);
1563             }
1564             while (len-- > 0) {
1565                 Copy(s, &afloat, 1, float);
1566                 DO_BO_UNPACK_N(afloat, float);
1567                 s += sizeof(float);
1568                 if (!checksum) {
1569                     PUSHs(sv_2mortal(newSVnv((NV)afloat)));
1570                 }
1571                 else {
1572                     cdouble += afloat;
1573                 }
1574             }
1575             break;
1576         case 'd':
1577             along = (strend - s) / sizeof(double);
1578             if (len > along)
1579                 len = along;
1580             if (!checksum) {
1581                 if (len && unpack_only_one)
1582                     len = 1;
1583                 EXTEND(SP, len);
1584                 EXTEND_MORTAL(len);
1585             }
1586             while (len-- > 0) {
1587                 Copy(s, &adouble, 1, double);
1588                 DO_BO_UNPACK_N(adouble, double);
1589                 s += sizeof(double);
1590                 if (!checksum) {
1591                     PUSHs(sv_2mortal(newSVnv((NV)adouble)));
1592                 }
1593                 else {
1594                     cdouble += adouble;
1595                 }
1596             }
1597             break;
1598         case 'F':
1599             along = (strend - s) / NVSIZE;
1600             if (len > along)
1601                 len = along;
1602             if (!checksum) {
1603                 if (len && unpack_only_one)
1604                     len = 1;
1605                 EXTEND(SP, len);
1606                 EXTEND_MORTAL(len);
1607             }
1608             while (len-- > 0) {
1609                 Copy(s, &anv, 1, NV);
1610                 DO_BO_UNPACK_N(anv, NV);
1611                 s += NVSIZE;
1612                 if (!checksum) {
1613                     PUSHs(sv_2mortal(newSVnv(anv)));
1614                 }
1615                 else {
1616                     cdouble += anv;
1617                 }
1618             }
1619             break;
1620 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1621         case 'D':
1622             along = (strend - s) / LONG_DOUBLESIZE;
1623             if (len > along)
1624                 len = along;
1625             if (!checksum) {
1626                 if (len && unpack_only_one)
1627                     len = 1;
1628                 EXTEND(SP, len);
1629                 EXTEND_MORTAL(len);
1630             }
1631             while (len-- > 0) {
1632                 Copy(s, &aldouble, 1, long double);
1633                 DO_BO_UNPACK_N(aldouble, long double);
1634                 s += LONG_DOUBLESIZE;
1635                 if (!checksum) {
1636                     PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
1637                 }
1638                 else {cdouble += aldouble;
1639                 }
1640             }
1641             break;
1642 #endif
1643         case 'u':
1644             /* MKS:
1645              * Initialise the decode mapping.  By using a table driven
1646              * algorithm, the code will be character-set independent
1647              * (and just as fast as doing character arithmetic)
1648              */
1649             if (PL_uudmap['M'] == 0) {
1650                 int i;
1651
1652                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1653                     PL_uudmap[(U8)PL_uuemap[i]] = i;
1654                 /*
1655                  * Because ' ' and '`' map to the same value,
1656                  * we need to decode them both the same.
1657                  */
1658                 PL_uudmap[' '] = 0;
1659             }
1660
1661             along = (strend - s) * 3 / 4;
1662             sv = NEWSV(42, along);
1663             if (along)
1664                 SvPOK_on(sv);
1665             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1666                 I32 a, b, c, d;
1667                 char hunk[4];
1668
1669                 hunk[3] = '\0';
1670                 len = PL_uudmap[*(U8*)s++] & 077;
1671                 while (len > 0) {
1672                     if (s < strend && ISUUCHAR(*s))
1673                         a = PL_uudmap[*(U8*)s++] & 077;
1674                     else
1675                         a = 0;
1676                     if (s < strend && ISUUCHAR(*s))
1677                         b = PL_uudmap[*(U8*)s++] & 077;
1678                     else
1679                         b = 0;
1680                     if (s < strend && ISUUCHAR(*s))
1681                         c = PL_uudmap[*(U8*)s++] & 077;
1682                     else
1683                         c = 0;
1684                     if (s < strend && ISUUCHAR(*s))
1685                         d = PL_uudmap[*(U8*)s++] & 077;
1686                     else
1687                         d = 0;
1688                     hunk[0] = (char)((a << 2) | (b >> 4));
1689                     hunk[1] = (char)((b << 4) | (c >> 2));
1690                     hunk[2] = (char)((c << 6) | d);
1691                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1692                     len -= 3;
1693                 }
1694                 if (*s == '\n')
1695                     s++;
1696                 else    /* possible checksum byte */
1697                     if (s + 1 < strend && s[1] == '\n')
1698                         s += 2;
1699             }
1700             XPUSHs(sv_2mortal(sv));
1701             break;
1702         }
1703
1704         if (checksum) {
1705             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1706               (checksum > bits_in_uv &&
1707                strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1708                 NV trouble;
1709
1710                 adouble = (NV) (1 << (checksum & 15));
1711                 while (checksum >= 16) {
1712                     checksum -= 16;
1713                     adouble *= 65536.0;
1714                 }
1715                 while (cdouble < 0.0)
1716                     cdouble += adouble;
1717                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1718                 sv = newSVnv(cdouble);
1719             }
1720             else {
1721                 if (checksum < bits_in_uv) {
1722                     UV mask = ((UV)1 << checksum) - 1;
1723                     cuv &= mask;
1724                 }
1725                 sv = newSVuv(cuv);
1726             }
1727             XPUSHs(sv_2mortal(sv));
1728             checksum = 0;
1729         }
1730
1731         if (symptr->flags & FLAG_SLASH){
1732             if (SP - PL_stack_base - start_sp_offset <= 0)
1733                 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1734             if( next_symbol(symptr) ){
1735               if( symptr->howlen == e_number )
1736                 Perl_croak(aTHX_ "Count after length/code in unpack" );
1737               if( beyond ){
1738                 /* ...end of char buffer then no decent length available */
1739                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1740               } else {
1741                 /* take top of stack (hope it's numeric) */
1742                 len = POPi;
1743                 if( len < 0 )
1744                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
1745               }
1746             } else {
1747                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1748             }
1749             datumtype = symptr->code;
1750             goto redo_switch;
1751         }
1752     }
1753
1754     if (new_s)
1755         *new_s = s;
1756     PUTBACK;
1757     return SP - PL_stack_base - start_sp_offset;
1758 }
1759
1760 PP(pp_unpack)
1761 {
1762     dSP;
1763     dPOPPOPssrl;
1764     I32 gimme = GIMME_V;
1765     STRLEN llen;
1766     STRLEN rlen;
1767     register char *pat = SvPV(left, llen);
1768 #ifdef PACKED_IS_OCTETS
1769     /* Packed side is assumed to be octets - so force downgrade if it
1770        has been UTF-8 encoded by accident
1771      */
1772     register char *s = SvPVbyte(right, rlen);
1773 #else
1774     register char *s = SvPV(right, rlen);
1775 #endif
1776     char *strend = s + rlen;
1777     register char *patend = pat + llen;
1778     register I32 cnt;
1779
1780     PUTBACK;
1781     cnt = unpackstring(pat, patend, s, strend,
1782                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1783                      | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1784
1785     SPAGAIN;
1786     if ( !cnt && gimme == G_SCALAR )
1787        PUSHs(&PL_sv_undef);
1788     RETURN;
1789 }
1790
1791 STATIC void
1792 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1793 {
1794     char hunk[5];
1795
1796     *hunk = PL_uuemap[len];
1797     sv_catpvn(sv, hunk, 1);
1798     hunk[4] = '\0';
1799     while (len > 2) {
1800         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1801         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1802         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1803         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1804         sv_catpvn(sv, hunk, 4);
1805         s += 3;
1806         len -= 3;
1807     }
1808     if (len > 0) {
1809         char r = (len > 1 ? s[1] : '\0');
1810         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1811         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1812         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1813         hunk[3] = PL_uuemap[0];
1814         sv_catpvn(sv, hunk, 4);
1815     }
1816     sv_catpvn(sv, "\n", 1);
1817 }
1818
1819 STATIC SV *
1820 S_is_an_int(pTHX_ char *s, STRLEN l)
1821 {
1822   STRLEN         n_a;
1823   SV             *result = newSVpvn(s, l);
1824   char           *result_c = SvPV(result, n_a); /* convenience */
1825   char           *out = result_c;
1826   bool            skip = 1;
1827   bool            ignore = 0;
1828
1829   while (*s) {
1830     switch (*s) {
1831     case ' ':
1832       break;
1833     case '+':
1834       if (!skip) {
1835         SvREFCNT_dec(result);
1836         return (NULL);
1837       }
1838       break;
1839     case '0':
1840     case '1':
1841     case '2':
1842     case '3':
1843     case '4':
1844     case '5':
1845     case '6':
1846     case '7':
1847     case '8':
1848     case '9':
1849       skip = 0;
1850       if (!ignore) {
1851         *(out++) = *s;
1852       }
1853       break;
1854     case '.':
1855       ignore = 1;
1856       break;
1857     default:
1858       SvREFCNT_dec(result);
1859       return (NULL);
1860     }
1861     s++;
1862   }
1863   *(out++) = '\0';
1864   SvCUR_set(result, out - result_c);
1865   return (result);
1866 }
1867
1868 /* pnum must be '\0' terminated */
1869 STATIC int
1870 S_div128(pTHX_ SV *pnum, bool *done)
1871 {
1872   STRLEN          len;
1873   char           *s = SvPV(pnum, len);
1874   int             m = 0;
1875   int             r = 0;
1876   char           *t = s;
1877
1878   *done = 1;
1879   while (*t) {
1880     int             i;
1881
1882     i = m * 10 + (*t - '0');
1883     m = i & 0x7F;
1884     r = (i >> 7);               /* r < 10 */
1885     if (r) {
1886       *done = 0;
1887     }
1888     *(t++) = '0' + r;
1889   }
1890   *(t++) = '\0';
1891   SvCUR_set(pnum, (STRLEN) (t - s));
1892   return (m);
1893 }
1894
1895
1896
1897 /*
1898 =for apidoc pack_cat
1899
1900 The engine implementing pack() Perl function. Note: parameters next_in_list and
1901 flags are not used. This call should not be used; use packlist instead.
1902
1903 =cut */
1904
1905
1906 void
1907 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1908 {
1909     tempsym_t sym = { 0 };
1910     sym.patptr = pat;
1911     sym.patend = patend;
1912     sym.flags  = FLAG_PACK;
1913
1914     (void)pack_rec( cat, &sym, beglist, endlist );
1915 }
1916
1917
1918 /*
1919 =for apidoc packlist
1920
1921 The engine implementing pack() Perl function.
1922
1923 =cut */
1924
1925
1926 void
1927 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1928 {
1929     tempsym_t sym = { 0 };
1930     sym.patptr = pat;
1931     sym.patend = patend;
1932     sym.flags  = FLAG_PACK;
1933
1934     (void)pack_rec( cat, &sym, beglist, endlist );
1935 }
1936
1937
1938 STATIC
1939 SV **
1940 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1941 {
1942     register I32 items;
1943     STRLEN fromlen;
1944     register I32 len = 0;
1945     SV *fromstr;
1946     /*SUPPRESS 442*/
1947     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1948     static char *space10 = "          ";
1949     bool found;
1950
1951     /* These must not be in registers: */
1952     char achar;
1953     I16 ai16;
1954     U16 au16;
1955     I32 ai32;
1956     U32 au32;
1957 #ifdef HAS_QUAD
1958     Quad_t aquad;
1959     Uquad_t auquad;
1960 #endif
1961 #if SHORTSIZE != SIZE16
1962     short ashort;
1963     unsigned short aushort;
1964 #endif
1965     int aint;
1966     unsigned int auint;
1967 #if LONGSIZE != SIZE32
1968     long along;
1969     unsigned long aulong;
1970 #endif
1971     char *aptr;
1972     float afloat;
1973     double adouble;
1974 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1975     long double aldouble;
1976 #endif
1977     IV aiv;
1978     UV auv;
1979     NV anv;
1980
1981     int strrelbeg = SvCUR(cat);
1982     tempsym_t lookahead;
1983
1984     items = endlist - beglist;
1985     found = next_symbol( symptr );
1986
1987 #ifndef PACKED_IS_OCTETS
1988     if (symptr->level == 0 && found && symptr->code == 'U' ){
1989         SvUTF8_on(cat);
1990     }
1991 #endif
1992
1993     while (found) {
1994         SV *lengthcode = Nullsv;
1995 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1996
1997         I32 datumtype = symptr->code;
1998         howlen_t howlen;
1999
2000         switch( howlen = symptr->howlen ){
2001         case e_no_len:
2002         case e_number:
2003             len = symptr->length;
2004             break;
2005         case e_star:
2006             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
2007             break;
2008         }
2009
2010         /* Look ahead for next symbol. Do we have code/code? */
2011         lookahead = *symptr;
2012         found = next_symbol(&lookahead);
2013         if ( symptr->flags & FLAG_SLASH ) {
2014             if (found){
2015                 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2016                      e_star != lookahead.howlen )
2017                     Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2018                 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
2019                                                    ? *beglist : &PL_sv_no)
2020                                            + (lookahead.code == 'Z' ? 1 : 0)));
2021             } else {
2022                 Perl_croak(aTHX_ "Code missing after '/' in pack");
2023             }
2024         }
2025
2026         switch(TYPE_NO_ENDIANNESS(datumtype)) {
2027         default:
2028             Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
2029         case '%':
2030             Perl_croak(aTHX_ "'%%' may not be used in pack");
2031         case '@':
2032             len += strrelbeg - SvCUR(cat);
2033             if (len > 0)
2034                 goto grow;
2035             len = -len;
2036             if (len > 0)
2037                 goto shrink;
2038             break;
2039         case '(':
2040         {
2041             tempsym_t savsym = *symptr;
2042             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2043             symptr->flags |= group_modifiers;
2044             symptr->patend = savsym.grpend;
2045             symptr->level++;
2046             while (len--) {
2047                 symptr->patptr = savsym.grpbeg;
2048                 beglist = pack_rec(cat, symptr, beglist, endlist );
2049                 if (savsym.howlen == e_star && beglist == endlist)
2050                     break;              /* No way to continue */
2051             }
2052             symptr->flags &= ~group_modifiers;
2053             lookahead.flags = symptr->flags;
2054             *symptr = savsym;
2055             break;
2056         }
2057         case 'X' | TYPE_IS_SHRIEKING:
2058             if (!len)                   /* Avoid division by 0 */
2059                 len = 1;
2060             len = (SvCUR(cat)) % len;
2061             /* FALL THROUGH */
2062         case 'X':
2063           shrink:
2064             if ((I32)SvCUR(cat) < len)
2065                 Perl_croak(aTHX_ "'X' outside of string in pack");
2066             SvCUR(cat) -= len;
2067             *SvEND(cat) = '\0';
2068             break;
2069         case 'x' | TYPE_IS_SHRIEKING:
2070             if (!len)                   /* Avoid division by 0 */
2071                 len = 1;
2072             aint = (SvCUR(cat)) % len;
2073             if (aint)                   /* Other portable ways? */
2074                 len = len - aint;
2075             else
2076                 len = 0;
2077             /* FALL THROUGH */
2078
2079         case 'x':
2080           grow:
2081             while (len >= 10) {
2082                 sv_catpvn(cat, null10, 10);
2083                 len -= 10;
2084             }
2085             sv_catpvn(cat, null10, len);
2086             break;
2087         case 'A':
2088         case 'Z':
2089         case 'a':
2090             fromstr = NEXTFROM;
2091             aptr = SvPV(fromstr, fromlen);
2092             if (howlen == e_star) {
2093                 len = fromlen;
2094                 if (datumtype == 'Z')
2095                     ++len;
2096             }
2097             if ((I32)fromlen >= len) {
2098                 sv_catpvn(cat, aptr, len);
2099                 if (datumtype == 'Z')
2100                     *(SvEND(cat)-1) = '\0';
2101             }
2102             else {
2103                 sv_catpvn(cat, aptr, fromlen);
2104                 len -= fromlen;
2105                 if (datumtype == 'A') {
2106                     while (len >= 10) {
2107                         sv_catpvn(cat, space10, 10);
2108                         len -= 10;
2109                     }
2110                     sv_catpvn(cat, space10, len);
2111                 }
2112                 else {
2113                     while (len >= 10) {
2114                         sv_catpvn(cat, null10, 10);
2115                         len -= 10;
2116                     }
2117                     sv_catpvn(cat, null10, len);
2118                 }
2119             }
2120             break;
2121         case 'B':
2122         case 'b':
2123             {
2124                 register char *str;
2125                 I32 saveitems;
2126
2127                 fromstr = NEXTFROM;
2128                 saveitems = items;
2129                 str = SvPV(fromstr, fromlen);
2130                 if (howlen == e_star)
2131                     len = fromlen;
2132                 aint = SvCUR(cat);
2133                 SvCUR(cat) += (len+7)/8;
2134                 SvGROW(cat, SvCUR(cat) + 1);
2135                 aptr = SvPVX(cat) + aint;
2136                 if (len > (I32)fromlen)
2137                     len = fromlen;
2138                 aint = len;
2139                 items = 0;
2140                 if (datumtype == 'B') {
2141                     for (len = 0; len++ < aint;) {
2142                         items |= *str++ & 1;
2143                         if (len & 7)
2144                             items <<= 1;
2145                         else {
2146                             *aptr++ = items & 0xff;
2147                             items = 0;
2148                         }
2149                     }
2150                 }
2151                 else {
2152                     for (len = 0; len++ < aint;) {
2153                         if (*str++ & 1)
2154                             items |= 128;
2155                         if (len & 7)
2156                             items >>= 1;
2157                         else {
2158                             *aptr++ = items & 0xff;
2159                             items = 0;
2160                         }
2161                     }
2162                 }
2163                 if (aint & 7) {
2164                     if (datumtype == 'B')
2165                         items <<= 7 - (aint & 7);
2166                     else
2167                         items >>= 7 - (aint & 7);
2168                     *aptr++ = items & 0xff;
2169                 }
2170                 str = SvPVX(cat) + SvCUR(cat);
2171                 while (aptr <= str)
2172                     *aptr++ = '\0';
2173
2174                 items = saveitems;
2175             }
2176             break;
2177         case 'H':
2178         case 'h':
2179             {
2180                 register char *str;
2181                 I32 saveitems;
2182
2183                 fromstr = NEXTFROM;
2184                 saveitems = items;
2185                 str = SvPV(fromstr, fromlen);
2186                 if (howlen == e_star)
2187                     len = fromlen;
2188                 aint = SvCUR(cat);
2189                 SvCUR(cat) += (len+1)/2;
2190                 SvGROW(cat, SvCUR(cat) + 1);
2191                 aptr = SvPVX(cat) + aint;
2192                 if (len > (I32)fromlen)
2193                     len = fromlen;
2194                 aint = len;
2195                 items = 0;
2196                 if (datumtype == 'H') {
2197                     for (len = 0; len++ < aint;) {
2198                         if (isALPHA(*str))
2199                             items |= ((*str++ & 15) + 9) & 15;
2200                         else
2201                             items |= *str++ & 15;
2202                         if (len & 1)
2203                             items <<= 4;
2204                         else {
2205                             *aptr++ = items & 0xff;
2206                             items = 0;
2207                         }
2208                     }
2209                 }
2210                 else {
2211                     for (len = 0; len++ < aint;) {
2212                         if (isALPHA(*str))
2213                             items |= (((*str++ & 15) + 9) & 15) << 4;
2214                         else
2215                             items |= (*str++ & 15) << 4;
2216                         if (len & 1)
2217                             items >>= 4;
2218                         else {
2219                             *aptr++ = items & 0xff;
2220                             items = 0;
2221                         }
2222                     }
2223                 }
2224                 if (aint & 1)
2225                     *aptr++ = items & 0xff;
2226                 str = SvPVX(cat) + SvCUR(cat);
2227                 while (aptr <= str)
2228                     *aptr++ = '\0';
2229
2230                 items = saveitems;
2231             }
2232             break;
2233         case 'C':
2234         case 'c':
2235             while (len-- > 0) {
2236                 fromstr = NEXTFROM;
2237                 switch (TYPE_NO_MODIFIERS(datumtype)) {
2238                 case 'C':
2239                     aint = SvIV(fromstr);
2240                     if ((aint < 0 || aint > 255) &&
2241                         ckWARN(WARN_PACK))
2242                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2243                                     "Character in 'C' format wrapped in pack");
2244                     achar = aint & 255;
2245                     sv_catpvn(cat, &achar, sizeof(char));
2246                     break;
2247                 case 'c':
2248                     aint = SvIV(fromstr);
2249                     if ((aint < -128 || aint > 127) &&
2250                         ckWARN(WARN_PACK))
2251                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2252                                     "Character in 'c' format wrapped in pack" );
2253                     achar = aint & 255;
2254                     sv_catpvn(cat, &achar, sizeof(char));
2255                     break;
2256                 }
2257             }
2258             break;
2259         case 'U':
2260             while (len-- > 0) {
2261                 fromstr = NEXTFROM;
2262                 auint = UNI_TO_NATIVE(SvUV(fromstr));
2263                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2264                 SvCUR_set(cat,
2265                           (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2266                                                      auint,
2267                                                      ckWARN(WARN_UTF8) ?
2268                                                      0 : UNICODE_ALLOW_ANY)
2269                           - SvPVX(cat));
2270             }
2271             *SvEND(cat) = '\0';
2272             break;
2273         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2274         case 'f':
2275             while (len-- > 0) {
2276                 fromstr = NEXTFROM;
2277 #ifdef __VOS__
2278 /* VOS does not automatically map a floating-point overflow
2279    during conversion from double to float into infinity, so we
2280    do it by hand.  This code should either be generalized for
2281    any OS that needs it, or removed if and when VOS implements
2282    posix-976 (suggestion to support mapping to infinity).
2283    Paul.Green@stratus.com 02-04-02.  */
2284                 if (SvNV(fromstr) > FLT_MAX)
2285                      afloat = _float_constants[0];   /* single prec. inf. */
2286                 else if (SvNV(fromstr) < -FLT_MAX)
2287                      afloat = _float_constants[0];   /* single prec. inf. */
2288                 else afloat = (float)SvNV(fromstr);
2289 #else
2290 # if defined(VMS) && !defined(__IEEE_FP)
2291 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2292  * on Alpha; fake it if we don't have them.
2293  */
2294                 if (SvNV(fromstr) > FLT_MAX)
2295                      afloat = FLT_MAX;
2296                 else if (SvNV(fromstr) < -FLT_MAX)
2297                      afloat = -FLT_MAX;
2298                 else afloat = (float)SvNV(fromstr);
2299 # else
2300                 afloat = (float)SvNV(fromstr);
2301 # endif
2302 #endif
2303                 DO_BO_PACK_N(afloat, float);
2304                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2305             }
2306             break;
2307         case 'd':
2308             while (len-- > 0) {
2309                 fromstr = NEXTFROM;
2310 #ifdef __VOS__
2311 /* VOS does not automatically map a floating-point overflow
2312    during conversion from long double to double into infinity,
2313    so we do it by hand.  This code should either be generalized
2314    for any OS that needs it, or removed if and when VOS
2315    implements posix-976 (suggestion to support mapping to
2316    infinity).  Paul.Green@stratus.com 02-04-02.  */
2317                 if (SvNV(fromstr) > DBL_MAX)
2318                      adouble = _double_constants[0];   /* double prec. inf. */
2319                 else if (SvNV(fromstr) < -DBL_MAX)
2320                      adouble = _double_constants[0];   /* double prec. inf. */
2321                 else adouble = (double)SvNV(fromstr);
2322 #else
2323 # if defined(VMS) && !defined(__IEEE_FP)
2324 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2325  * on Alpha; fake it if we don't have them.
2326  */
2327                 if (SvNV(fromstr) > DBL_MAX)
2328                      adouble = DBL_MAX;
2329                 else if (SvNV(fromstr) < -DBL_MAX)
2330                      adouble = -DBL_MAX;
2331                 else adouble = (double)SvNV(fromstr);
2332 # else
2333                 adouble = (double)SvNV(fromstr);
2334 # endif
2335 #endif
2336                 DO_BO_PACK_N(adouble, double);
2337                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2338             }
2339             break;
2340         case 'F':
2341             Zero(&anv, 1, NV); /* can be long double with unused bits */
2342             while (len-- > 0) {
2343                 fromstr = NEXTFROM;
2344                 anv = SvNV(fromstr);
2345                 DO_BO_PACK_N(anv, NV);
2346                 sv_catpvn(cat, (char *)&anv, NVSIZE);
2347             }
2348             break;
2349 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2350         case 'D':
2351             /* long doubles can have unused bits, which may be nonzero */
2352             Zero(&aldouble, 1, long double);
2353             while (len-- > 0) {
2354                 fromstr = NEXTFROM;
2355                 aldouble = (long double)SvNV(fromstr);
2356                 DO_BO_PACK_N(aldouble, long double);
2357                 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2358             }
2359             break;
2360 #endif
2361         case 'n' | TYPE_IS_SHRIEKING:
2362         case 'n':
2363             while (len-- > 0) {
2364                 fromstr = NEXTFROM;
2365                 ai16 = (I16)SvIV(fromstr);
2366 #ifdef HAS_HTONS
2367                 ai16 = PerlSock_htons(ai16);
2368 #endif
2369                 CAT16(cat, &ai16);
2370             }
2371             break;
2372         case 'v' | TYPE_IS_SHRIEKING:
2373         case 'v':
2374             while (len-- > 0) {
2375                 fromstr = NEXTFROM;
2376                 ai16 = (I16)SvIV(fromstr);
2377 #ifdef HAS_HTOVS
2378                 ai16 = htovs(ai16);
2379 #endif
2380                 CAT16(cat, &ai16);
2381             }
2382             break;
2383         case 'S' | TYPE_IS_SHRIEKING:
2384 #if SHORTSIZE != SIZE16
2385             {
2386                 while (len-- > 0) {
2387                     fromstr = NEXTFROM;
2388                     aushort = SvUV(fromstr);
2389                     DO_BO_PACK(aushort, s);
2390                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2391                 }
2392             }
2393             break;
2394 #else
2395             /* Fall through! */
2396 #endif
2397         case 'S':
2398             {
2399                 while (len-- > 0) {
2400                     fromstr = NEXTFROM;
2401                     au16 = (U16)SvUV(fromstr);
2402                     DO_BO_PACK(au16, 16);
2403                     CAT16(cat, &au16);
2404                 }
2405
2406             }
2407             break;
2408         case 's' | TYPE_IS_SHRIEKING:
2409 #if SHORTSIZE != SIZE16
2410             {
2411                 while (len-- > 0) {
2412                     fromstr = NEXTFROM;
2413                     ashort = SvIV(fromstr);
2414                     DO_BO_PACK(ashort, s);
2415                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
2416                 }
2417             }
2418             break;
2419 #else
2420             /* Fall through! */
2421 #endif
2422         case 's':
2423             while (len-- > 0) {
2424                 fromstr = NEXTFROM;
2425                 ai16 = (I16)SvIV(fromstr);
2426                 DO_BO_PACK(ai16, 16);
2427                 CAT16(cat, &ai16);
2428             }
2429             break;
2430         case 'I':
2431         case 'I' | TYPE_IS_SHRIEKING:
2432             while (len-- > 0) {
2433                 fromstr = NEXTFROM;
2434                 auint = SvUV(fromstr);
2435                 DO_BO_PACK(auint, i);
2436                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2437             }
2438             break;
2439         case 'j':
2440             while (len-- > 0) {
2441                 fromstr = NEXTFROM;
2442                 aiv = SvIV(fromstr);
2443 #if IVSIZE == INTSIZE
2444                 DO_BO_PACK(aiv, i);
2445 #elif IVSIZE == LONGSIZE
2446                 DO_BO_PACK(aiv, l);
2447 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2448                 DO_BO_PACK(aiv, 64);
2449 #endif
2450                 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2451             }
2452             break;
2453         case 'J':
2454             while (len-- > 0) {
2455                 fromstr = NEXTFROM;
2456                 auv = SvUV(fromstr);
2457 #if UVSIZE == INTSIZE
2458                 DO_BO_PACK(auv, i);
2459 #elif UVSIZE == LONGSIZE
2460                 DO_BO_PACK(auv, l);
2461 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2462                 DO_BO_PACK(auv, 64);
2463 #endif
2464                 sv_catpvn(cat, (char*)&auv, UVSIZE);
2465             }
2466             break;
2467         case 'w':
2468             while (len-- > 0) {
2469                 fromstr = NEXTFROM;
2470                 anv = SvNV(fromstr);
2471
2472                 if (anv < 0)
2473                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2474
2475                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2476                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2477                    any negative IVs will have already been got by the croak()
2478                    above. IOK is untrue for fractions, so we test them
2479                    against UV_MAX_P1.  */
2480                 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2481                 {
2482                     char   buf[(sizeof(UV)*8)/7+1];
2483                     char  *in = buf + sizeof(buf);
2484                     UV     auv = SvUV(fromstr);
2485
2486                     do {
2487                         *--in = (char)((auv & 0x7f) | 0x80);
2488                         auv >>= 7;
2489                     } while (auv);
2490                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2491                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2492                 }
2493                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
2494                     char           *from, *result, *in;
2495                     SV             *norm;
2496                     STRLEN          len;
2497                     bool            done;
2498
2499                     /* Copy string and check for compliance */
2500                     from = SvPV(fromstr, len);
2501                     if ((norm = is_an_int(from, len)) == NULL)
2502                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2503
2504                     New('w', result, len, char);
2505                     in = result + len;
2506                     done = FALSE;
2507                     while (!done)
2508                         *--in = div128(norm, &done) | 0x80;
2509                     result[len - 1] &= 0x7F; /* clear continue bit */
2510                     sv_catpvn(cat, in, (result + len) - in);
2511                     Safefree(result);
2512                     SvREFCNT_dec(norm); /* free norm */
2513                 }
2514                 else if (SvNOKp(fromstr)) {
2515                     /* 10**NV_MAX_10_EXP is the largest power of 10
2516                        so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2517                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2518                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2519                        And with that many bytes only Inf can overflow.
2520                        Some C compilers are strict about integral constant
2521                        expressions so we conservatively divide by a slightly
2522                        smaller integer instead of multiplying by the exact
2523                        floating-point value.
2524                     */
2525 #ifdef NV_MAX_10_EXP
2526 /*                  char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2527                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2528 #else
2529 /*                  char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2530                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2531 #endif
2532                     char  *in = buf + sizeof(buf);
2533
2534                     anv = Perl_floor(anv);
2535                     do {
2536                         NV next = Perl_floor(anv / 128);
2537                         if (in <= buf)  /* this cannot happen ;-) */
2538                             Perl_croak(aTHX_ "Cannot compress integer in pack");
2539                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2540                         anv = next;
2541                     } while (anv > 0);
2542                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2543                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2544                 }
2545                 else {
2546                     char           *from, *result, *in;
2547                     SV             *norm;
2548                     STRLEN          len;
2549                     bool            done;
2550
2551                     /* Copy string and check for compliance */
2552                     from = SvPV(fromstr, len);
2553                     if ((norm = is_an_int(from, len)) == NULL)
2554                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2555
2556                     New('w', result, len, char);
2557                     in = result + len;
2558                     done = FALSE;
2559                     while (!done)
2560                         *--in = div128(norm, &done) | 0x80;
2561                     result[len - 1] &= 0x7F; /* clear continue bit */
2562                     sv_catpvn(cat, in, (result + len) - in);
2563                     Safefree(result);
2564                     SvREFCNT_dec(norm); /* free norm */
2565                }
2566             }
2567             break;
2568         case 'i':
2569         case 'i' | TYPE_IS_SHRIEKING:
2570             while (len-- > 0) {
2571                 fromstr = NEXTFROM;
2572                 aint = SvIV(fromstr);
2573                 DO_BO_PACK(aint, i);
2574                 sv_catpvn(cat, (char*)&aint, sizeof(int));
2575             }
2576             break;
2577         case 'N' | TYPE_IS_SHRIEKING:
2578         case 'N':
2579             while (len-- > 0) {
2580                 fromstr = NEXTFROM;
2581                 au32 = SvUV(fromstr);
2582 #ifdef HAS_HTONL
2583                 au32 = PerlSock_htonl(au32);
2584 #endif
2585                 CAT32(cat, &au32);
2586             }
2587             break;
2588         case 'V' | TYPE_IS_SHRIEKING:
2589         case 'V':
2590             while (len-- > 0) {
2591                 fromstr = NEXTFROM;
2592                 au32 = SvUV(fromstr);
2593 #ifdef HAS_HTOVL
2594                 au32 = htovl(au32);
2595 #endif
2596                 CAT32(cat, &au32);
2597             }
2598             break;
2599         case 'L' | TYPE_IS_SHRIEKING:
2600 #if LONGSIZE != SIZE32
2601             {
2602                 while (len-- > 0) {
2603                     fromstr = NEXTFROM;
2604                     aulong = SvUV(fromstr);
2605                     DO_BO_PACK(aulong, l);
2606                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2607                 }
2608             }
2609             break;
2610 #else
2611             /* Fall though! */
2612 #endif
2613         case 'L':
2614             {
2615                 while (len-- > 0) {
2616                     fromstr = NEXTFROM;
2617                     au32 = SvUV(fromstr);
2618                     DO_BO_PACK(au32, 32);
2619                     CAT32(cat, &au32);
2620                 }
2621             }
2622             break;
2623         case 'l' | TYPE_IS_SHRIEKING:
2624 #if LONGSIZE != SIZE32
2625             {
2626                 while (len-- > 0) {
2627                     fromstr = NEXTFROM;
2628                     along = SvIV(fromstr);
2629                     DO_BO_PACK(along, l);
2630                     sv_catpvn(cat, (char *)&along, sizeof(long));
2631                 }
2632             }
2633             break;
2634 #else
2635             /* Fall though! */
2636 #endif
2637         case 'l':
2638             while (len-- > 0) {
2639                 fromstr = NEXTFROM;
2640                 ai32 = SvIV(fromstr);
2641                 DO_BO_PACK(ai32, 32);
2642                 CAT32(cat, &ai32);
2643             }
2644             break;
2645 #ifdef HAS_QUAD
2646         case 'Q':
2647             while (len-- > 0) {
2648                 fromstr = NEXTFROM;
2649                 auquad = (Uquad_t)SvUV(fromstr);
2650                 DO_BO_PACK(auquad, 64);
2651                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2652             }
2653             break;
2654         case 'q':
2655             while (len-- > 0) {
2656                 fromstr = NEXTFROM;
2657                 aquad = (Quad_t)SvIV(fromstr);
2658                 DO_BO_PACK(aquad, 64);
2659                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2660             }
2661             break;
2662 #endif
2663         case 'P':
2664             len = 1;            /* assume SV is correct length */
2665             /* Fall through! */
2666         case 'p':
2667             while (len-- > 0) {
2668                 fromstr = NEXTFROM;
2669                 if (fromstr == &PL_sv_undef)
2670                     aptr = NULL;
2671                 else {
2672                     STRLEN n_a;
2673                     /* XXX better yet, could spirit away the string to
2674                      * a safe spot and hang on to it until the result
2675                      * of pack() (and all copies of the result) are
2676                      * gone.
2677                      */
2678                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2679                                                 || (SvPADTMP(fromstr)
2680                                                     && !SvREADONLY(fromstr))))
2681                     {
2682                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2683                                 "Attempt to pack pointer to temporary value");
2684                     }
2685                     if (SvPOK(fromstr) || SvNIOK(fromstr))
2686                         aptr = SvPV(fromstr,n_a);
2687                     else
2688                         aptr = SvPV_force(fromstr,n_a);
2689                 }
2690                 DO_BO_PACK_P(aptr);
2691                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2692             }
2693             break;
2694         case 'u':
2695             fromstr = NEXTFROM;
2696             aptr = SvPV(fromstr, fromlen);
2697             SvGROW(cat, fromlen * 4 / 3);
2698             if (len <= 2)
2699                 len = 45;
2700             else
2701                 len = len / 3 * 3;
2702             while (fromlen > 0) {
2703                 I32 todo;
2704
2705                 if ((I32)fromlen > len)
2706                     todo = len;
2707                 else
2708                     todo = fromlen;
2709                 doencodes(cat, aptr, todo);
2710                 fromlen -= todo;
2711                 aptr += todo;
2712             }
2713             break;
2714         }
2715         *symptr = lookahead;
2716     }
2717     return beglist;
2718 }
2719 #undef NEXTFROM
2720
2721
2722 PP(pp_pack)
2723 {
2724     dSP; dMARK; dORIGMARK; dTARGET;
2725     register SV *cat = TARG;
2726     STRLEN fromlen;
2727     register char *pat = SvPVx(*++MARK, fromlen);
2728     register char *patend = pat + fromlen;
2729
2730     MARK++;
2731     sv_setpvn(cat, "", 0);
2732
2733     packlist(cat, pat, patend, MARK, SP + 1);
2734
2735     SvSETMAGIC(cat);
2736     SP = ORIGMARK;
2737     PUSHs(cat);
2738     RETURN;
2739 }
2740
2741 /*
2742  * Local variables:
2743  * c-indentation-style: bsd
2744  * c-basic-offset: 4
2745  * indent-tabs-mode: t
2746  * End:
2747  *
2748  * vim: shiftwidth=4:
2749 */