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