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 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                 if (sizeof(char*) > strend - s)
1415                     break;
1416                 else {
1417                     Copy(s, &aptr, 1, char*);
1418                     DO_BO_UNPACK_P(aptr);
1419                     s += sizeof(char*);
1420                 }
1421                 /* newSVpv generates undef if aptr is NULL */
1422                 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1423             }
1424             break;
1425         case 'w':
1426             {
1427                 UV auv = 0;
1428                 U32 bytes = 0;
1429
1430                 while ((len > 0) && (s < strend)) {
1431                     auv = (auv << 7) | (*s & 0x7f);
1432                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1433                     if ((U8)(*s++) < 0x80) {
1434                         bytes = 0;
1435                         PUSHs(sv_2mortal(newSVuv(auv)));
1436                         len--;
1437                         auv = 0;
1438                     }
1439                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
1440                         char *t;
1441                         STRLEN n_a;
1442
1443                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1444                         while (s < strend) {
1445                             sv = mul128(sv, (U8)(*s & 0x7f));
1446                             if (!(*s++ & 0x80)) {
1447                                 bytes = 0;
1448                                 break;
1449                             }
1450                         }
1451                         t = SvPV(sv, n_a);
1452                         while (*t == '0')
1453                             t++;
1454                         sv_chop(sv, t);
1455                         PUSHs(sv_2mortal(sv));
1456                         len--;
1457                         auv = 0;
1458                     }
1459                 }
1460                 if ((s >= strend) && bytes)
1461                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1462             }
1463             break;
1464         case 'P':
1465             if (symptr->howlen == e_star)
1466                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1467             EXTEND(SP, 1);
1468             if (sizeof(char*) > strend - s)
1469                 break;
1470             else {
1471                 Copy(s, &aptr, 1, char*);
1472                 DO_BO_UNPACK_P(aptr);
1473                 s += sizeof(char*);
1474             }
1475             /* newSVpvn generates undef if aptr is NULL */
1476             PUSHs(sv_2mortal(newSVpvn(aptr, len)));
1477             break;
1478 #ifdef HAS_QUAD
1479         case 'q':
1480             while (len-- > 0) {
1481                 assert (s + sizeof(Quad_t) <= strend);
1482                 Copy(s, &aquad, 1, Quad_t);
1483                 DO_BO_UNPACK(aquad, 64);
1484                 s += sizeof(Quad_t);
1485                 if (!checksum) {
1486                     PUSHs(sv_2mortal((aquad >= IV_MIN && aquad <= IV_MAX) ?
1487                                      newSViv((IV)aquad) : newSVnv((NV)aquad)));
1488                 }
1489                 else if (checksum > bits_in_uv)
1490                     cdouble += (NV)aquad;
1491                 else
1492                     cuv += aquad;
1493             }
1494             break;
1495         case 'Q':
1496             while (len-- > 0) {
1497                 assert (s + sizeof(Uquad_t) <= strend);
1498                 Copy(s, &auquad, 1, Uquad_t);
1499                 DO_BO_UNPACK(auquad, 64);
1500                 s += sizeof(Uquad_t);
1501                 if (!checksum) {
1502                     PUSHs(sv_2mortal((auquad <= UV_MAX) ?
1503                                      newSVuv((UV)auquad) : newSVnv((NV)auquad)));
1504                 }
1505                 else if (checksum > bits_in_uv)
1506                     cdouble += (NV)auquad;
1507                 else
1508                     cuv += auquad;
1509             }
1510             break;
1511 #endif
1512         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1513         case 'f':
1514             while (len-- > 0) {
1515                 Copy(s, &afloat, 1, float);
1516                 DO_BO_UNPACK_N(afloat, float);
1517                 s += sizeof(float);
1518                 if (!checksum) {
1519                     PUSHs(sv_2mortal(newSVnv((NV)afloat)));
1520                 }
1521                 else {
1522                     cdouble += afloat;
1523                 }
1524             }
1525             break;
1526         case 'd':
1527             while (len-- > 0) {
1528                 Copy(s, &adouble, 1, double);
1529                 DO_BO_UNPACK_N(adouble, double);
1530                 s += sizeof(double);
1531                 if (!checksum) {
1532                     PUSHs(sv_2mortal(newSVnv((NV)adouble)));
1533                 }
1534                 else {
1535                     cdouble += adouble;
1536                 }
1537             }
1538             break;
1539         case 'F':
1540             while (len-- > 0) {
1541                 Copy(s, &anv, 1, NV);
1542                 DO_BO_UNPACK_N(anv, NV);
1543                 s += NVSIZE;
1544                 if (!checksum) {
1545                     PUSHs(sv_2mortal(newSVnv(anv)));
1546                 }
1547                 else {
1548                     cdouble += anv;
1549                 }
1550             }
1551             break;
1552 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1553         case 'D':
1554             while (len-- > 0) {
1555                 Copy(s, &aldouble, 1, long double);
1556                 DO_BO_UNPACK_N(aldouble, long double);
1557                 s += LONG_DOUBLESIZE;
1558                 if (!checksum) {
1559                     PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
1560                 }
1561                 else {cdouble += aldouble;
1562                 }
1563             }
1564             break;
1565 #endif
1566         case 'u':
1567             /* MKS:
1568              * Initialise the decode mapping.  By using a table driven
1569              * algorithm, the code will be character-set independent
1570              * (and just as fast as doing character arithmetic)
1571              */
1572             if (PL_uudmap['M'] == 0) {
1573                 int i;
1574
1575                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1576                     PL_uudmap[(U8)PL_uuemap[i]] = i;
1577                 /*
1578                  * Because ' ' and '`' map to the same value,
1579                  * we need to decode them both the same.
1580                  */
1581                 PL_uudmap[' '] = 0;
1582             }
1583
1584             along = (strend - s) * 3 / 4;
1585             sv = NEWSV(42, along);
1586             if (along)
1587                 SvPOK_on(sv);
1588             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1589                 I32 a, b, c, d;
1590                 char hunk[4];
1591
1592                 hunk[3] = '\0';
1593                 len = PL_uudmap[*(U8*)s++] & 077;
1594                 while (len > 0) {
1595                     if (s < strend && ISUUCHAR(*s))
1596                         a = PL_uudmap[*(U8*)s++] & 077;
1597                     else
1598                         a = 0;
1599                     if (s < strend && ISUUCHAR(*s))
1600                         b = PL_uudmap[*(U8*)s++] & 077;
1601                     else
1602                         b = 0;
1603                     if (s < strend && ISUUCHAR(*s))
1604                         c = PL_uudmap[*(U8*)s++] & 077;
1605                     else
1606                         c = 0;
1607                     if (s < strend && ISUUCHAR(*s))
1608                         d = PL_uudmap[*(U8*)s++] & 077;
1609                     else
1610                         d = 0;
1611                     hunk[0] = (char)((a << 2) | (b >> 4));
1612                     hunk[1] = (char)((b << 4) | (c >> 2));
1613                     hunk[2] = (char)((c << 6) | d);
1614                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1615                     len -= 3;
1616                 }
1617                 if (*s == '\n')
1618                     s++;
1619                 else    /* possible checksum byte */
1620                     if (s + 1 < strend && s[1] == '\n')
1621                         s += 2;
1622             }
1623             XPUSHs(sv_2mortal(sv));
1624             break;
1625         }
1626
1627         if (checksum) {
1628             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1629               (checksum > bits_in_uv &&
1630                strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1631                 NV trouble;
1632
1633                 adouble = (NV) (1 << (checksum & 15));
1634                 while (checksum >= 16) {
1635                     checksum -= 16;
1636                     adouble *= 65536.0;
1637                 }
1638                 while (cdouble < 0.0)
1639                     cdouble += adouble;
1640                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1641                 sv = newSVnv(cdouble);
1642             }
1643             else {
1644                 if (checksum < bits_in_uv) {
1645                     UV mask = ((UV)1 << checksum) - 1;
1646                     cuv &= mask;
1647                 }
1648                 sv = newSVuv(cuv);
1649             }
1650             XPUSHs(sv_2mortal(sv));
1651             checksum = 0;
1652         }
1653
1654         if (symptr->flags & FLAG_SLASH){
1655             if (SP - PL_stack_base - start_sp_offset <= 0)
1656                 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1657             if( next_symbol(symptr) ){
1658               if( symptr->howlen == e_number )
1659                 Perl_croak(aTHX_ "Count after length/code in unpack" );
1660               if( beyond ){
1661                 /* ...end of char buffer then no decent length available */
1662                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1663               } else {
1664                 /* take top of stack (hope it's numeric) */
1665                 len = POPi;
1666                 if( len < 0 )
1667                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
1668               }
1669             } else {
1670                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1671             }
1672             datumtype = symptr->code;
1673             goto redo_switch;
1674         }
1675     }
1676
1677     if (new_s)
1678         *new_s = s;
1679     PUTBACK;
1680     return SP - PL_stack_base - start_sp_offset;
1681 }
1682
1683 PP(pp_unpack)
1684 {
1685     dSP;
1686     dPOPPOPssrl;
1687     I32 gimme = GIMME_V;
1688     STRLEN llen;
1689     STRLEN rlen;
1690     register char *pat = SvPV(left, llen);
1691 #ifdef PACKED_IS_OCTETS
1692     /* Packed side is assumed to be octets - so force downgrade if it
1693        has been UTF-8 encoded by accident
1694      */
1695     register char *s = SvPVbyte(right, rlen);
1696 #else
1697     register char *s = SvPV(right, rlen);
1698 #endif
1699     char *strend = s + rlen;
1700     register char *patend = pat + llen;
1701     register I32 cnt;
1702
1703     PUTBACK;
1704     cnt = unpackstring(pat, patend, s, strend,
1705                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1706                      | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1707
1708     SPAGAIN;
1709     if ( !cnt && gimme == G_SCALAR )
1710        PUSHs(&PL_sv_undef);
1711     RETURN;
1712 }
1713
1714 STATIC void
1715 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1716 {
1717     char hunk[5];
1718
1719     *hunk = PL_uuemap[len];
1720     sv_catpvn(sv, hunk, 1);
1721     hunk[4] = '\0';
1722     while (len > 2) {
1723         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1724         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1725         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1726         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1727         sv_catpvn(sv, hunk, 4);
1728         s += 3;
1729         len -= 3;
1730     }
1731     if (len > 0) {
1732         char r = (len > 1 ? s[1] : '\0');
1733         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1734         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1735         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1736         hunk[3] = PL_uuemap[0];
1737         sv_catpvn(sv, hunk, 4);
1738     }
1739     sv_catpvn(sv, "\n", 1);
1740 }
1741
1742 STATIC SV *
1743 S_is_an_int(pTHX_ char *s, STRLEN l)
1744 {
1745   STRLEN         n_a;
1746   SV             *result = newSVpvn(s, l);
1747   char           *result_c = SvPV(result, n_a); /* convenience */
1748   char           *out = result_c;
1749   bool            skip = 1;
1750   bool            ignore = 0;
1751
1752   while (*s) {
1753     switch (*s) {
1754     case ' ':
1755       break;
1756     case '+':
1757       if (!skip) {
1758         SvREFCNT_dec(result);
1759         return (NULL);
1760       }
1761       break;
1762     case '0':
1763     case '1':
1764     case '2':
1765     case '3':
1766     case '4':
1767     case '5':
1768     case '6':
1769     case '7':
1770     case '8':
1771     case '9':
1772       skip = 0;
1773       if (!ignore) {
1774         *(out++) = *s;
1775       }
1776       break;
1777     case '.':
1778       ignore = 1;
1779       break;
1780     default:
1781       SvREFCNT_dec(result);
1782       return (NULL);
1783     }
1784     s++;
1785   }
1786   *(out++) = '\0';
1787   SvCUR_set(result, out - result_c);
1788   return (result);
1789 }
1790
1791 /* pnum must be '\0' terminated */
1792 STATIC int
1793 S_div128(pTHX_ SV *pnum, bool *done)
1794 {
1795   STRLEN          len;
1796   char           *s = SvPV(pnum, len);
1797   int             m = 0;
1798   int             r = 0;
1799   char           *t = s;
1800
1801   *done = 1;
1802   while (*t) {
1803     int             i;
1804
1805     i = m * 10 + (*t - '0');
1806     m = i & 0x7F;
1807     r = (i >> 7);               /* r < 10 */
1808     if (r) {
1809       *done = 0;
1810     }
1811     *(t++) = '0' + r;
1812   }
1813   *(t++) = '\0';
1814   SvCUR_set(pnum, (STRLEN) (t - s));
1815   return (m);
1816 }
1817
1818
1819
1820 /*
1821 =for apidoc pack_cat
1822
1823 The engine implementing pack() Perl function. Note: parameters next_in_list and
1824 flags are not used. This call should not be used; use packlist instead.
1825
1826 =cut */
1827
1828
1829 void
1830 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1831 {
1832     tempsym_t sym = { 0 };
1833     sym.patptr = pat;
1834     sym.patend = patend;
1835     sym.flags  = FLAG_PACK;
1836
1837     (void)pack_rec( cat, &sym, beglist, endlist );
1838 }
1839
1840
1841 /*
1842 =for apidoc packlist
1843
1844 The engine implementing pack() Perl function.
1845
1846 =cut */
1847
1848
1849 void
1850 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1851 {
1852     tempsym_t sym = { 0 };
1853     sym.patptr = pat;
1854     sym.patend = patend;
1855     sym.flags  = FLAG_PACK;
1856
1857     (void)pack_rec( cat, &sym, beglist, endlist );
1858 }
1859
1860
1861 STATIC
1862 SV **
1863 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1864 {
1865     register I32 items;
1866     STRLEN fromlen;
1867     register I32 len = 0;
1868     SV *fromstr;
1869     /*SUPPRESS 442*/
1870     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1871     static char *space10 = "          ";
1872     bool found;
1873
1874     /* These must not be in registers: */
1875     char achar;
1876     I16 ai16;
1877     U16 au16;
1878     I32 ai32;
1879     U32 au32;
1880 #ifdef HAS_QUAD
1881     Quad_t aquad;
1882     Uquad_t auquad;
1883 #endif
1884 #if SHORTSIZE != SIZE16
1885     short ashort;
1886     unsigned short aushort;
1887 #endif
1888     int aint;
1889     unsigned int auint;
1890 #if LONGSIZE != SIZE32
1891     long along;
1892     unsigned long aulong;
1893 #endif
1894     char *aptr;
1895     float afloat;
1896     double adouble;
1897 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1898     long double aldouble;
1899 #endif
1900     IV aiv;
1901     UV auv;
1902     NV anv;
1903
1904     int strrelbeg = SvCUR(cat);
1905     tempsym_t lookahead;
1906
1907     items = endlist - beglist;
1908     found = next_symbol( symptr );
1909
1910 #ifndef PACKED_IS_OCTETS
1911     if (symptr->level == 0 && found && symptr->code == 'U' ){
1912         SvUTF8_on(cat);
1913     }
1914 #endif
1915
1916     while (found) {
1917         SV *lengthcode = Nullsv;
1918 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1919
1920         I32 datumtype = symptr->code;
1921         howlen_t howlen;
1922
1923         switch( howlen = symptr->howlen ){
1924         case e_no_len:
1925         case e_number:
1926             len = symptr->length;
1927             break;
1928         case e_star:
1929             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
1930             break;
1931         }
1932
1933         /* Look ahead for next symbol. Do we have code/code? */
1934         lookahead = *symptr;
1935         found = next_symbol(&lookahead);
1936         if ( symptr->flags & FLAG_SLASH ) {
1937             if (found){
1938                 if ( 0 == strchr( "aAZ", lookahead.code ) ||
1939                      e_star != lookahead.howlen )
1940                     Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
1941                 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1942                                                    ? *beglist : &PL_sv_no)
1943                                            + (lookahead.code == 'Z' ? 1 : 0)));
1944             } else {
1945                 Perl_croak(aTHX_ "Code missing after '/' in pack");
1946             }
1947         }
1948
1949         switch(TYPE_NO_ENDIANNESS(datumtype)) {
1950         default:
1951             Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
1952         case '%':
1953             Perl_croak(aTHX_ "'%%' may not be used in pack");
1954         case '@':
1955             len += strrelbeg - SvCUR(cat);
1956             if (len > 0)
1957                 goto grow;
1958             len = -len;
1959             if (len > 0)
1960                 goto shrink;
1961             break;
1962         case '(':
1963         {
1964             tempsym_t savsym = *symptr;
1965             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
1966             symptr->flags |= group_modifiers;
1967             symptr->patend = savsym.grpend;
1968             symptr->level++;
1969             while (len--) {
1970                 symptr->patptr = savsym.grpbeg;
1971                 beglist = pack_rec(cat, symptr, beglist, endlist );
1972                 if (savsym.howlen == e_star && beglist == endlist)
1973                     break;              /* No way to continue */
1974             }
1975             symptr->flags &= ~group_modifiers;
1976             lookahead.flags = symptr->flags;
1977             *symptr = savsym;
1978             break;
1979         }
1980         case 'X' | TYPE_IS_SHRIEKING:
1981             if (!len)                   /* Avoid division by 0 */
1982                 len = 1;
1983             len = (SvCUR(cat)) % len;
1984             /* FALL THROUGH */
1985         case 'X':
1986           shrink:
1987             if ((I32)SvCUR(cat) < len)
1988                 Perl_croak(aTHX_ "'X' outside of string in pack");
1989             SvCUR(cat) -= len;
1990             *SvEND(cat) = '\0';
1991             break;
1992         case 'x' | TYPE_IS_SHRIEKING:
1993             if (!len)                   /* Avoid division by 0 */
1994                 len = 1;
1995             aint = (SvCUR(cat)) % len;
1996             if (aint)                   /* Other portable ways? */
1997                 len = len - aint;
1998             else
1999                 len = 0;
2000             /* FALL THROUGH */
2001
2002         case 'x':
2003           grow:
2004             while (len >= 10) {
2005                 sv_catpvn(cat, null10, 10);
2006                 len -= 10;
2007             }
2008             sv_catpvn(cat, null10, len);
2009             break;
2010         case 'A':
2011         case 'Z':
2012         case 'a':
2013             fromstr = NEXTFROM;
2014             aptr = SvPV(fromstr, fromlen);
2015             if (howlen == e_star) {
2016                 len = fromlen;
2017                 if (datumtype == 'Z')
2018                     ++len;
2019             }
2020             if ((I32)fromlen >= len) {
2021                 sv_catpvn(cat, aptr, len);
2022                 if (datumtype == 'Z')
2023                     *(SvEND(cat)-1) = '\0';
2024             }
2025             else {
2026                 sv_catpvn(cat, aptr, fromlen);
2027                 len -= fromlen;
2028                 if (datumtype == 'A') {
2029                     while (len >= 10) {
2030                         sv_catpvn(cat, space10, 10);
2031                         len -= 10;
2032                     }
2033                     sv_catpvn(cat, space10, len);
2034                 }
2035                 else {
2036                     while (len >= 10) {
2037                         sv_catpvn(cat, null10, 10);
2038                         len -= 10;
2039                     }
2040                     sv_catpvn(cat, null10, len);
2041                 }
2042             }
2043             break;
2044         case 'B':
2045         case 'b':
2046             {
2047                 register char *str;
2048                 I32 saveitems;
2049
2050                 fromstr = NEXTFROM;
2051                 saveitems = items;
2052                 str = SvPV(fromstr, fromlen);
2053                 if (howlen == e_star)
2054                     len = fromlen;
2055                 aint = SvCUR(cat);
2056                 SvCUR(cat) += (len+7)/8;
2057                 SvGROW(cat, SvCUR(cat) + 1);
2058                 aptr = SvPVX(cat) + aint;
2059                 if (len > (I32)fromlen)
2060                     len = fromlen;
2061                 aint = len;
2062                 items = 0;
2063                 if (datumtype == 'B') {
2064                     for (len = 0; len++ < aint;) {
2065                         items |= *str++ & 1;
2066                         if (len & 7)
2067                             items <<= 1;
2068                         else {
2069                             *aptr++ = items & 0xff;
2070                             items = 0;
2071                         }
2072                     }
2073                 }
2074                 else {
2075                     for (len = 0; len++ < aint;) {
2076                         if (*str++ & 1)
2077                             items |= 128;
2078                         if (len & 7)
2079                             items >>= 1;
2080                         else {
2081                             *aptr++ = items & 0xff;
2082                             items = 0;
2083                         }
2084                     }
2085                 }
2086                 if (aint & 7) {
2087                     if (datumtype == 'B')
2088                         items <<= 7 - (aint & 7);
2089                     else
2090                         items >>= 7 - (aint & 7);
2091                     *aptr++ = items & 0xff;
2092                 }
2093                 str = SvPVX(cat) + SvCUR(cat);
2094                 while (aptr <= str)
2095                     *aptr++ = '\0';
2096
2097                 items = saveitems;
2098             }
2099             break;
2100         case 'H':
2101         case 'h':
2102             {
2103                 register char *str;
2104                 I32 saveitems;
2105
2106                 fromstr = NEXTFROM;
2107                 saveitems = items;
2108                 str = SvPV(fromstr, fromlen);
2109                 if (howlen == e_star)
2110                     len = fromlen;
2111                 aint = SvCUR(cat);
2112                 SvCUR(cat) += (len+1)/2;
2113                 SvGROW(cat, SvCUR(cat) + 1);
2114                 aptr = SvPVX(cat) + aint;
2115                 if (len > (I32)fromlen)
2116                     len = fromlen;
2117                 aint = len;
2118                 items = 0;
2119                 if (datumtype == 'H') {
2120                     for (len = 0; len++ < aint;) {
2121                         if (isALPHA(*str))
2122                             items |= ((*str++ & 15) + 9) & 15;
2123                         else
2124                             items |= *str++ & 15;
2125                         if (len & 1)
2126                             items <<= 4;
2127                         else {
2128                             *aptr++ = items & 0xff;
2129                             items = 0;
2130                         }
2131                     }
2132                 }
2133                 else {
2134                     for (len = 0; len++ < aint;) {
2135                         if (isALPHA(*str))
2136                             items |= (((*str++ & 15) + 9) & 15) << 4;
2137                         else
2138                             items |= (*str++ & 15) << 4;
2139                         if (len & 1)
2140                             items >>= 4;
2141                         else {
2142                             *aptr++ = items & 0xff;
2143                             items = 0;
2144                         }
2145                     }
2146                 }
2147                 if (aint & 1)
2148                     *aptr++ = items & 0xff;
2149                 str = SvPVX(cat) + SvCUR(cat);
2150                 while (aptr <= str)
2151                     *aptr++ = '\0';
2152
2153                 items = saveitems;
2154             }
2155             break;
2156         case 'C':
2157         case 'c':
2158             while (len-- > 0) {
2159                 fromstr = NEXTFROM;
2160                 switch (TYPE_NO_MODIFIERS(datumtype)) {
2161                 case 'C':
2162                     aint = SvIV(fromstr);
2163                     if ((aint < 0 || aint > 255) &&
2164                         ckWARN(WARN_PACK))
2165                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2166                                     "Character in 'C' format wrapped in pack");
2167                     achar = aint & 255;
2168                     sv_catpvn(cat, &achar, sizeof(char));
2169                     break;
2170                 case 'c':
2171                     aint = SvIV(fromstr);
2172                     if ((aint < -128 || aint > 127) &&
2173                         ckWARN(WARN_PACK))
2174                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2175                                     "Character in 'c' format wrapped in pack" );
2176                     achar = aint & 255;
2177                     sv_catpvn(cat, &achar, sizeof(char));
2178                     break;
2179                 }
2180             }
2181             break;
2182         case 'U':
2183             while (len-- > 0) {
2184                 fromstr = NEXTFROM;
2185                 auint = UNI_TO_NATIVE(SvUV(fromstr));
2186                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2187                 SvCUR_set(cat,
2188                           (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2189                                                      auint,
2190                                                      ckWARN(WARN_UTF8) ?
2191                                                      0 : UNICODE_ALLOW_ANY)
2192                           - SvPVX(cat));
2193             }
2194             *SvEND(cat) = '\0';
2195             break;
2196         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2197         case 'f':
2198             while (len-- > 0) {
2199                 fromstr = NEXTFROM;
2200 #ifdef __VOS__
2201 /* VOS does not automatically map a floating-point overflow
2202    during conversion from double to float into infinity, so we
2203    do it by hand.  This code should either be generalized for
2204    any OS that needs it, or removed if and when VOS implements
2205    posix-976 (suggestion to support mapping to infinity).
2206    Paul.Green@stratus.com 02-04-02.  */
2207                 if (SvNV(fromstr) > FLT_MAX)
2208                      afloat = _float_constants[0];   /* single prec. inf. */
2209                 else if (SvNV(fromstr) < -FLT_MAX)
2210                      afloat = _float_constants[0];   /* single prec. inf. */
2211                 else afloat = (float)SvNV(fromstr);
2212 #else
2213 # if defined(VMS) && !defined(__IEEE_FP)
2214 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2215  * on Alpha; fake it if we don't have them.
2216  */
2217                 if (SvNV(fromstr) > FLT_MAX)
2218                      afloat = FLT_MAX;
2219                 else if (SvNV(fromstr) < -FLT_MAX)
2220                      afloat = -FLT_MAX;
2221                 else afloat = (float)SvNV(fromstr);
2222 # else
2223                 afloat = (float)SvNV(fromstr);
2224 # endif
2225 #endif
2226                 DO_BO_PACK_N(afloat, float);
2227                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2228             }
2229             break;
2230         case 'd':
2231             while (len-- > 0) {
2232                 fromstr = NEXTFROM;
2233 #ifdef __VOS__
2234 /* VOS does not automatically map a floating-point overflow
2235    during conversion from long double to double into infinity,
2236    so we do it by hand.  This code should either be generalized
2237    for any OS that needs it, or removed if and when VOS
2238    implements posix-976 (suggestion to support mapping to
2239    infinity).  Paul.Green@stratus.com 02-04-02.  */
2240                 if (SvNV(fromstr) > DBL_MAX)
2241                      adouble = _double_constants[0];   /* double prec. inf. */
2242                 else if (SvNV(fromstr) < -DBL_MAX)
2243                      adouble = _double_constants[0];   /* double prec. inf. */
2244                 else adouble = (double)SvNV(fromstr);
2245 #else
2246 # if defined(VMS) && !defined(__IEEE_FP)
2247 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2248  * on Alpha; fake it if we don't have them.
2249  */
2250                 if (SvNV(fromstr) > DBL_MAX)
2251                      adouble = DBL_MAX;
2252                 else if (SvNV(fromstr) < -DBL_MAX)
2253                      adouble = -DBL_MAX;
2254                 else adouble = (double)SvNV(fromstr);
2255 # else
2256                 adouble = (double)SvNV(fromstr);
2257 # endif
2258 #endif
2259                 DO_BO_PACK_N(adouble, double);
2260                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2261             }
2262             break;
2263         case 'F':
2264             Zero(&anv, 1, NV); /* can be long double with unused bits */
2265             while (len-- > 0) {
2266                 fromstr = NEXTFROM;
2267                 anv = SvNV(fromstr);
2268                 DO_BO_PACK_N(anv, NV);
2269                 sv_catpvn(cat, (char *)&anv, NVSIZE);
2270             }
2271             break;
2272 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2273         case 'D':
2274             /* long doubles can have unused bits, which may be nonzero */
2275             Zero(&aldouble, 1, long double);
2276             while (len-- > 0) {
2277                 fromstr = NEXTFROM;
2278                 aldouble = (long double)SvNV(fromstr);
2279                 DO_BO_PACK_N(aldouble, long double);
2280                 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2281             }
2282             break;
2283 #endif
2284         case 'n' | TYPE_IS_SHRIEKING:
2285         case 'n':
2286             while (len-- > 0) {
2287                 fromstr = NEXTFROM;
2288                 ai16 = (I16)SvIV(fromstr);
2289 #ifdef HAS_HTONS
2290                 ai16 = PerlSock_htons(ai16);
2291 #endif
2292                 CAT16(cat, &ai16);
2293             }
2294             break;
2295         case 'v' | TYPE_IS_SHRIEKING:
2296         case 'v':
2297             while (len-- > 0) {
2298                 fromstr = NEXTFROM;
2299                 ai16 = (I16)SvIV(fromstr);
2300 #ifdef HAS_HTOVS
2301                 ai16 = htovs(ai16);
2302 #endif
2303                 CAT16(cat, &ai16);
2304             }
2305             break;
2306         case 'S' | TYPE_IS_SHRIEKING:
2307 #if SHORTSIZE != SIZE16
2308             {
2309                 while (len-- > 0) {
2310                     fromstr = NEXTFROM;
2311                     aushort = SvUV(fromstr);
2312                     DO_BO_PACK(aushort, s);
2313                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2314                 }
2315             }
2316             break;
2317 #else
2318             /* Fall through! */
2319 #endif
2320         case 'S':
2321             {
2322                 while (len-- > 0) {
2323                     fromstr = NEXTFROM;
2324                     au16 = (U16)SvUV(fromstr);
2325                     DO_BO_PACK(au16, 16);
2326                     CAT16(cat, &au16);
2327                 }
2328
2329             }
2330             break;
2331         case 's' | TYPE_IS_SHRIEKING:
2332 #if SHORTSIZE != SIZE16
2333             {
2334                 while (len-- > 0) {
2335                     fromstr = NEXTFROM;
2336                     ashort = SvIV(fromstr);
2337                     DO_BO_PACK(ashort, s);
2338                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
2339                 }
2340             }
2341             break;
2342 #else
2343             /* Fall through! */
2344 #endif
2345         case 's':
2346             while (len-- > 0) {
2347                 fromstr = NEXTFROM;
2348                 ai16 = (I16)SvIV(fromstr);
2349                 DO_BO_PACK(ai16, 16);
2350                 CAT16(cat, &ai16);
2351             }
2352             break;
2353         case 'I':
2354         case 'I' | TYPE_IS_SHRIEKING:
2355             while (len-- > 0) {
2356                 fromstr = NEXTFROM;
2357                 auint = SvUV(fromstr);
2358                 DO_BO_PACK(auint, i);
2359                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2360             }
2361             break;
2362         case 'j':
2363             while (len-- > 0) {
2364                 fromstr = NEXTFROM;
2365                 aiv = SvIV(fromstr);
2366 #if IVSIZE == INTSIZE
2367                 DO_BO_PACK(aiv, i);
2368 #elif IVSIZE == LONGSIZE
2369                 DO_BO_PACK(aiv, l);
2370 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2371                 DO_BO_PACK(aiv, 64);
2372 #endif
2373                 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2374             }
2375             break;
2376         case 'J':
2377             while (len-- > 0) {
2378                 fromstr = NEXTFROM;
2379                 auv = SvUV(fromstr);
2380 #if UVSIZE == INTSIZE
2381                 DO_BO_PACK(auv, i);
2382 #elif UVSIZE == LONGSIZE
2383                 DO_BO_PACK(auv, l);
2384 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2385                 DO_BO_PACK(auv, 64);
2386 #endif
2387                 sv_catpvn(cat, (char*)&auv, UVSIZE);
2388             }
2389             break;
2390         case 'w':
2391             while (len-- > 0) {
2392                 fromstr = NEXTFROM;
2393                 anv = SvNV(fromstr);
2394
2395                 if (anv < 0)
2396                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2397
2398                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2399                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2400                    any negative IVs will have already been got by the croak()
2401                    above. IOK is untrue for fractions, so we test them
2402                    against UV_MAX_P1.  */
2403                 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2404                 {
2405                     char   buf[(sizeof(UV)*8)/7+1];
2406                     char  *in = buf + sizeof(buf);
2407                     UV     auv = SvUV(fromstr);
2408
2409                     do {
2410                         *--in = (char)((auv & 0x7f) | 0x80);
2411                         auv >>= 7;
2412                     } while (auv);
2413                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2414                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2415                 }
2416                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
2417                     char           *from, *result, *in;
2418                     SV             *norm;
2419                     STRLEN          len;
2420                     bool            done;
2421
2422                     /* Copy string and check for compliance */
2423                     from = SvPV(fromstr, len);
2424                     if ((norm = is_an_int(from, len)) == NULL)
2425                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2426
2427                     New('w', result, len, char);
2428                     in = result + len;
2429                     done = FALSE;
2430                     while (!done)
2431                         *--in = div128(norm, &done) | 0x80;
2432                     result[len - 1] &= 0x7F; /* clear continue bit */
2433                     sv_catpvn(cat, in, (result + len) - in);
2434                     Safefree(result);
2435                     SvREFCNT_dec(norm); /* free norm */
2436                 }
2437                 else if (SvNOKp(fromstr)) {
2438                     /* 10**NV_MAX_10_EXP is the largest power of 10
2439                        so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2440                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2441                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2442                        And with that many bytes only Inf can overflow.
2443                        Some C compilers are strict about integral constant
2444                        expressions so we conservatively divide by a slightly
2445                        smaller integer instead of multiplying by the exact
2446                        floating-point value.
2447                     */
2448 #ifdef NV_MAX_10_EXP
2449 /*                  char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2450                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2451 #else
2452 /*                  char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2453                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2454 #endif
2455                     char  *in = buf + sizeof(buf);
2456
2457                     anv = Perl_floor(anv);
2458                     do {
2459                         NV next = Perl_floor(anv / 128);
2460                         if (in <= buf)  /* this cannot happen ;-) */
2461                             Perl_croak(aTHX_ "Cannot compress integer in pack");
2462                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2463                         anv = next;
2464                     } while (anv > 0);
2465                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2466                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2467                 }
2468                 else {
2469                     char           *from, *result, *in;
2470                     SV             *norm;
2471                     STRLEN          len;
2472                     bool            done;
2473
2474                     /* Copy string and check for compliance */
2475                     from = SvPV(fromstr, len);
2476                     if ((norm = is_an_int(from, len)) == NULL)
2477                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2478
2479                     New('w', result, len, char);
2480                     in = result + len;
2481                     done = FALSE;
2482                     while (!done)
2483                         *--in = div128(norm, &done) | 0x80;
2484                     result[len - 1] &= 0x7F; /* clear continue bit */
2485                     sv_catpvn(cat, in, (result + len) - in);
2486                     Safefree(result);
2487                     SvREFCNT_dec(norm); /* free norm */
2488                }
2489             }
2490             break;
2491         case 'i':
2492         case 'i' | TYPE_IS_SHRIEKING:
2493             while (len-- > 0) {
2494                 fromstr = NEXTFROM;
2495                 aint = SvIV(fromstr);
2496                 DO_BO_PACK(aint, i);
2497                 sv_catpvn(cat, (char*)&aint, sizeof(int));
2498             }
2499             break;
2500         case 'N' | TYPE_IS_SHRIEKING:
2501         case 'N':
2502             while (len-- > 0) {
2503                 fromstr = NEXTFROM;
2504                 au32 = SvUV(fromstr);
2505 #ifdef HAS_HTONL
2506                 au32 = PerlSock_htonl(au32);
2507 #endif
2508                 CAT32(cat, &au32);
2509             }
2510             break;
2511         case 'V' | TYPE_IS_SHRIEKING:
2512         case 'V':
2513             while (len-- > 0) {
2514                 fromstr = NEXTFROM;
2515                 au32 = SvUV(fromstr);
2516 #ifdef HAS_HTOVL
2517                 au32 = htovl(au32);
2518 #endif
2519                 CAT32(cat, &au32);
2520             }
2521             break;
2522         case 'L' | TYPE_IS_SHRIEKING:
2523 #if LONGSIZE != SIZE32
2524             {
2525                 while (len-- > 0) {
2526                     fromstr = NEXTFROM;
2527                     aulong = SvUV(fromstr);
2528                     DO_BO_PACK(aulong, l);
2529                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2530                 }
2531             }
2532             break;
2533 #else
2534             /* Fall though! */
2535 #endif
2536         case 'L':
2537             {
2538                 while (len-- > 0) {
2539                     fromstr = NEXTFROM;
2540                     au32 = SvUV(fromstr);
2541                     DO_BO_PACK(au32, 32);
2542                     CAT32(cat, &au32);
2543                 }
2544             }
2545             break;
2546         case 'l' | TYPE_IS_SHRIEKING:
2547 #if LONGSIZE != SIZE32
2548             {
2549                 while (len-- > 0) {
2550                     fromstr = NEXTFROM;
2551                     along = SvIV(fromstr);
2552                     DO_BO_PACK(along, l);
2553                     sv_catpvn(cat, (char *)&along, sizeof(long));
2554                 }
2555             }
2556             break;
2557 #else
2558             /* Fall though! */
2559 #endif
2560         case 'l':
2561             while (len-- > 0) {
2562                 fromstr = NEXTFROM;
2563                 ai32 = SvIV(fromstr);
2564                 DO_BO_PACK(ai32, 32);
2565                 CAT32(cat, &ai32);
2566             }
2567             break;
2568 #ifdef HAS_QUAD
2569         case 'Q':
2570             while (len-- > 0) {
2571                 fromstr = NEXTFROM;
2572                 auquad = (Uquad_t)SvUV(fromstr);
2573                 DO_BO_PACK(auquad, 64);
2574                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2575             }
2576             break;
2577         case 'q':
2578             while (len-- > 0) {
2579                 fromstr = NEXTFROM;
2580                 aquad = (Quad_t)SvIV(fromstr);
2581                 DO_BO_PACK(aquad, 64);
2582                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2583             }
2584             break;
2585 #endif
2586         case 'P':
2587             len = 1;            /* assume SV is correct length */
2588             /* Fall through! */
2589         case 'p':
2590             while (len-- > 0) {
2591                 fromstr = NEXTFROM;
2592                 if (fromstr == &PL_sv_undef)
2593                     aptr = NULL;
2594                 else {
2595                     STRLEN n_a;
2596                     /* XXX better yet, could spirit away the string to
2597                      * a safe spot and hang on to it until the result
2598                      * of pack() (and all copies of the result) are
2599                      * gone.
2600                      */
2601                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2602                                                 || (SvPADTMP(fromstr)
2603                                                     && !SvREADONLY(fromstr))))
2604                     {
2605                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2606                                 "Attempt to pack pointer to temporary value");
2607                     }
2608                     if (SvPOK(fromstr) || SvNIOK(fromstr))
2609                         aptr = SvPV(fromstr,n_a);
2610                     else
2611                         aptr = SvPV_force(fromstr,n_a);
2612                 }
2613                 DO_BO_PACK_P(aptr);
2614                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2615             }
2616             break;
2617         case 'u':
2618             fromstr = NEXTFROM;
2619             aptr = SvPV(fromstr, fromlen);
2620             SvGROW(cat, fromlen * 4 / 3);
2621             if (len <= 2)
2622                 len = 45;
2623             else
2624                 len = len / 3 * 3;
2625             while (fromlen > 0) {
2626                 I32 todo;
2627
2628                 if ((I32)fromlen > len)
2629                     todo = len;
2630                 else
2631                     todo = fromlen;
2632                 doencodes(cat, aptr, todo);
2633                 fromlen -= todo;
2634                 aptr += todo;
2635             }
2636             break;
2637         }
2638         *symptr = lookahead;
2639     }
2640     return beglist;
2641 }
2642 #undef NEXTFROM
2643
2644
2645 PP(pp_pack)
2646 {
2647     dSP; dMARK; dORIGMARK; dTARGET;
2648     register SV *cat = TARG;
2649     STRLEN fromlen;
2650     register char *pat = SvPVx(*++MARK, fromlen);
2651     register char *patend = pat + fromlen;
2652
2653     MARK++;
2654     sv_setpvn(cat, "", 0);
2655
2656     packlist(cat, pat, patend, MARK, SP + 1);
2657
2658     SvSETMAGIC(cat);
2659     SP = ORIGMARK;
2660     PUSHs(cat);
2661     RETURN;
2662 }
2663
2664 /*
2665  * Local variables:
2666  * c-indentation-style: bsd
2667  * c-basic-offset: 4
2668  * indent-tabs-mode: t
2669  * End:
2670  *
2671  * vim: shiftwidth=4:
2672 */