This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
/* NOTREACHED */ belongs *before* the unreachable.
[perl5.git] / pp_pack.c
1 /*    pp_pack.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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  *     [p.653 of _The Lord of the Rings_, IV/iv: "Of Herbs and Stewed Rabbit"]
19  */
20
21 /* This file contains pp ("push/pop") functions that
22  * execute the opcodes that make up a perl program. A typical pp function
23  * expects to find its arguments on the stack, and usually pushes its
24  * results onto the stack, hence the 'pp' terminology. Each OP structure
25  * contains a pointer to the relevant pp_foo() function.
26  *
27  * This particular file just contains pp_pack() and pp_unpack(). See the
28  * other pp*.c files for the rest of the pp_ functions.
29  */
30
31 #include "EXTERN.h"
32 #define PERL_IN_PP_PACK_C
33 #include "perl.h"
34
35 /* Types used by pack/unpack */ 
36 typedef enum {
37   e_no_len,     /* no length  */
38   e_number,     /* number, [] */
39   e_star        /* asterisk   */
40 } howlen_t;
41
42 typedef struct tempsym {
43   const char*    patptr;   /* current template char */
44   const char*    patend;   /* one after last char   */
45   const char*    grpbeg;   /* 1st char of ()-group  */
46   const char*    grpend;   /* end of ()-group       */
47   I32      code;     /* template code (!<>)   */
48   I32      length;   /* length/repeat count   */
49   howlen_t howlen;   /* how length is given   */ 
50   int      level;    /* () nesting level      */
51   U32      flags;    /* /=4, comma=2, pack=1  */
52                      /*   and group modifiers */
53   STRLEN   strbeg;   /* offset of group start */
54   struct tempsym *previous; /* previous group */
55 } tempsym_t;
56
57 #define TEMPSYM_INIT(symptr, p, e, f) \
58     STMT_START {        \
59         (symptr)->patptr   = (p);       \
60         (symptr)->patend   = (e);       \
61         (symptr)->grpbeg   = NULL;      \
62         (symptr)->grpend   = NULL;      \
63         (symptr)->grpend   = NULL;      \
64         (symptr)->code     = 0;         \
65         (symptr)->length   = 0;         \
66         (symptr)->howlen   = e_no_len;  \
67         (symptr)->level    = 0;         \
68         (symptr)->flags    = (f);       \
69         (symptr)->strbeg   = 0;         \
70         (symptr)->previous = NULL;      \
71    } STMT_END
72
73 typedef union {
74     NV nv;
75     U8 bytes[sizeof(NV)];
76 } NV_bytes;
77
78 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
79 typedef union {
80     long double ld;
81     U8 bytes[sizeof(long double)];
82 } ld_bytes;
83 #endif
84
85 #ifndef CHAR_BIT
86 # define CHAR_BIT       8
87 #endif
88 /* Maximum number of bytes to which a byte can grow due to upgrade */
89 #define UTF8_EXPAND     2
90
91 /*
92  * Offset for integer pack/unpack.
93  *
94  * On architectures where I16 and I32 aren't really 16 and 32 bits,
95  * which for now are all Crays, pack and unpack have to play games.
96  */
97
98 /*
99  * These values are required for portability of pack() output.
100  * If they're not right on your machine, then pack() and unpack()
101  * wouldn't work right anyway; you'll need to apply the Cray hack.
102  * (I'd like to check them with #if, but you can't use sizeof() in
103  * the preprocessor.)  --???
104  */
105 /*
106     The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
107     defines are now in config.h.  --Andy Dougherty  April 1998
108  */
109 #define SIZE16 2
110 #define SIZE32 4
111
112 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
113    --jhi Feb 1999 */
114
115 #if U16SIZE > SIZE16 || U32SIZE > SIZE32
116 #  if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678    /* little-endian */
117 #    define OFF16(p)    ((char*)(p))
118 #    define OFF32(p)    ((char*)(p))
119 #  else
120 #    if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321  /* big-endian */
121 #      define OFF16(p)  ((char*)(p) + (sizeof(U16) - SIZE16))
122 #      define OFF32(p)  ((char*)(p) + (sizeof(U32) - SIZE32))
123 #    else
124        ++++ bad cray byte order
125 #    endif
126 #  endif
127 #else
128 #  define OFF16(p)     ((char *) (p))
129 #  define OFF32(p)     ((char *) (p))
130 #endif
131
132 #define PUSH16(utf8, cur, p, needs_swap)                        \
133        PUSH_BYTES(utf8, cur, OFF16(p), SIZE16, needs_swap)
134 #define PUSH32(utf8, cur, p, needs_swap)                        \
135        PUSH_BYTES(utf8, cur, OFF32(p), SIZE32, needs_swap)
136
137 #if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321  /* big-endian */
138 #  define NEEDS_SWAP(d)     (TYPE_ENDIANNESS(d) == TYPE_IS_LITTLE_ENDIAN)
139 #elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678  /* little-endian */
140 #  define NEEDS_SWAP(d)     (TYPE_ENDIANNESS(d) == TYPE_IS_BIG_ENDIAN)
141 #else
142 #  error "Unsupported byteorder"
143         /* Need to add code here to re-instate mixed endian support.
144            NEEDS_SWAP would need to hold a flag indicating which action to
145            take, and S_reverse_copy and the code in uni_to_bytes would need
146            logic adding to deal with any mixed-endian transformations needed.
147         */
148 #endif
149
150 /* Only to be used inside a loop (see the break) */
151 #define SHIFT_BYTES(utf8, s, strend, buf, len, datumtype, needs_swap)   \
152 STMT_START {                                            \
153     if (UNLIKELY(utf8)) {                               \
154         if (!uni_to_bytes(aTHX_ &s, strend,             \
155           (char *) (buf), len, datumtype)) break;       \
156     } else {                                            \
157         if (UNLIKELY(needs_swap))                       \
158             S_reverse_copy(s, (char *) (buf), len);     \
159         else                                            \
160             Copy(s, (char *) (buf), len, char);         \
161         s += len;                                       \
162     }                                                   \
163 } STMT_END
164
165 #define SHIFT16(utf8, s, strend, p, datumtype, needs_swap)              \
166        SHIFT_BYTES(utf8, s, strend, OFF16(p), SIZE16, datumtype, needs_swap)
167
168 #define SHIFT32(utf8, s, strend, p, datumtype, needs_swap)              \
169        SHIFT_BYTES(utf8, s, strend, OFF32(p), SIZE32, datumtype, needs_swap)
170
171 #define SHIFT_VAR(utf8, s, strend, var, datumtype, needs_swap)          \
172        SHIFT_BYTES(utf8, s, strend, &(var), sizeof(var), datumtype, needs_swap)
173
174 #define PUSH_VAR(utf8, aptr, var, needs_swap)           \
175        PUSH_BYTES(utf8, aptr, &(var), sizeof(var), needs_swap)
176
177 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
178 #define MAX_SUB_TEMPLATE_LEVEL 100
179
180 /* flags (note that type modifiers can also be used as flags!) */
181 #define FLAG_WAS_UTF8         0x40
182 #define FLAG_PARSE_UTF8       0x20      /* Parse as utf8 */
183 #define FLAG_UNPACK_ONLY_ONE  0x10
184 #define FLAG_DO_UTF8          0x08      /* The underlying string is utf8 */
185 #define FLAG_SLASH            0x04
186 #define FLAG_COMMA            0x02
187 #define FLAG_PACK             0x01
188
189 STATIC SV *
190 S_mul128(pTHX_ SV *sv, U8 m)
191 {
192   STRLEN          len;
193   char           *s = SvPV(sv, len);
194   char           *t;
195
196   PERL_ARGS_ASSERT_MUL128;
197
198   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
199     SV * const tmpNew = newSVpvs("0000000000");
200
201     sv_catsv(tmpNew, sv);
202     SvREFCNT_dec(sv);           /* free old sv */
203     sv = tmpNew;
204     s = SvPV(sv, len);
205   }
206   t = s + len - 1;
207   while (!*t)                   /* trailing '\0'? */
208     t--;
209   while (t > s) {
210     const U32 i = ((*t - '0') << 7) + m;
211     *(t--) = '0' + (char)(i % 10);
212     m = (char)(i / 10);
213   }
214   return (sv);
215 }
216
217 /* Explosives and implosives. */
218
219 #if 'I' == 73 && 'J' == 74
220 /* On an ASCII/ISO kind of system */
221 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
222 #else
223 /*
224   Some other sort of character set - use memchr() so we don't match
225   the null byte.
226  */
227 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
228 #endif
229
230 /* type modifiers */
231 #define TYPE_IS_SHRIEKING       0x100
232 #define TYPE_IS_BIG_ENDIAN      0x200
233 #define TYPE_IS_LITTLE_ENDIAN   0x400
234 #define TYPE_IS_PACK            0x800
235 #define TYPE_ENDIANNESS_MASK    (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
236 #define TYPE_MODIFIERS(t)       ((t) & ~0xFF)
237 #define TYPE_NO_MODIFIERS(t)    ((t) & 0xFF)
238
239 # define TYPE_ENDIANNESS(t)     ((t) & TYPE_ENDIANNESS_MASK)
240 # define TYPE_NO_ENDIANNESS(t)  ((t) & ~TYPE_ENDIANNESS_MASK)
241
242 # define ENDIANNESS_ALLOWED_TYPES   "sSiIlLqQjJfFdDpP("
243
244 #define PACK_SIZE_CANNOT_CSUM           0x80
245 #define PACK_SIZE_UNPREDICTABLE         0x40    /* Not a fixed size element */
246 #define PACK_SIZE_MASK                  0x3F
247
248 #include "packsizetables.c"
249
250 static void
251 S_reverse_copy(const char *src, char *dest, STRLEN len)
252 {
253     dest += len;
254     while (len--)
255         *--dest = *src++;
256 }
257
258 STATIC U8
259 uni_to_byte(pTHX_ const char **s, const char *end, I32 datumtype)
260 {
261     STRLEN retlen;
262     UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen,
263                          ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
264     /* We try to process malformed UTF-8 as much as possible (preferably with
265        warnings), but these two mean we make no progress in the string and
266        might enter an infinite loop */
267     if (retlen == (STRLEN) -1 || retlen == 0)
268         Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack",
269                    (int) TYPE_NO_MODIFIERS(datumtype));
270     if (val >= 0x100) {
271         Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK),
272                        "Character in '%c' format wrapped in unpack",
273                        (int) TYPE_NO_MODIFIERS(datumtype));
274         val &= 0xff;
275     }
276     *s += retlen;
277     return (U8)val;
278 }
279
280 #define SHIFT_BYTE(utf8, s, strend, datumtype) ((utf8) ? \
281         uni_to_byte(aTHX_ &(s), (strend), (datumtype)) : \
282         *(U8 *)(s)++)
283
284 STATIC bool
285 uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len, I32 datumtype)
286 {
287     UV val;
288     STRLEN retlen;
289     const char *from = *s;
290     int bad = 0;
291     const U32 flags = ckWARN(WARN_UTF8) ?
292         UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY | UTF8_ALLOW_ANY);
293     const bool needs_swap = NEEDS_SWAP(datumtype);
294
295     if (UNLIKELY(needs_swap))
296         buf += buf_len;
297
298     for (;buf_len > 0; buf_len--) {
299         if (from >= end) return FALSE;
300         val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags);
301         if (retlen == (STRLEN) -1 || retlen == 0) {
302             from += UTF8SKIP(from);
303             bad |= 1;
304         } else from += retlen;
305         if (val >= 0x100) {
306             bad |= 2;
307             val &= 0xff;
308         }
309         if (UNLIKELY(needs_swap))
310             *(U8 *)--buf = (U8)val;
311         else
312             *(U8 *)buf++ = (U8)val;
313     }
314     /* We have enough characters for the buffer. Did we have problems ? */
315     if (bad) {
316         if (bad & 1) {
317             /* Rewalk the string fragment while warning */
318             const char *ptr;
319             const int flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
320             for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) {
321                 if (ptr >= end) break;
322                 utf8n_to_uvchr((U8 *) ptr, end-ptr, &retlen, flags);
323             }
324             if (from > end) from = end;
325         }
326         if ((bad & 2))
327             Perl_ck_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ?
328                                        WARN_PACK : WARN_UNPACK),
329                            "Character(s) in '%c' format wrapped in %s",
330                            (int) TYPE_NO_MODIFIERS(datumtype),
331                            datumtype & TYPE_IS_PACK ? "pack" : "unpack");
332     }
333     *s = from;
334     return TRUE;
335 }
336
337 STATIC bool
338 next_uni_uu(pTHX_ const char **s, const char *end, I32 *out)
339 {
340     dVAR;
341     STRLEN retlen;
342     const UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY);
343     if (val >= 0x100 || !ISUUCHAR(val) ||
344         retlen == (STRLEN) -1 || retlen == 0) {
345         *out = 0;
346         return FALSE;
347     }
348     *out = PL_uudmap[val] & 077;
349     *s += retlen;
350     return TRUE;
351 }
352
353 STATIC char *
354 S_bytes_to_uni(const U8 *start, STRLEN len, char *dest, const bool needs_swap) {
355     PERL_ARGS_ASSERT_BYTES_TO_UNI;
356
357     if (UNLIKELY(needs_swap)) {
358         const U8 *p = start + len;
359         while (p-- > start) {
360             append_utf8_from_native_byte(*p, (U8 **) & dest);
361         }
362     } else {
363         const U8 * const end = start + len;
364         while (start < end) {
365             append_utf8_from_native_byte(*start, (U8 **) & dest);
366             start++;
367         }
368     }
369     return dest;
370 }
371
372 #define PUSH_BYTES(utf8, cur, buf, len, needs_swap)             \
373 STMT_START {                                                    \
374     if (UNLIKELY(utf8))                                         \
375         (cur) = S_bytes_to_uni((U8 *) buf, len, (cur), needs_swap);       \
376     else {                                                      \
377         if (UNLIKELY(needs_swap))                               \
378             S_reverse_copy((char *)(buf), cur, len);            \
379         else                                                    \
380             Copy(buf, cur, len, char);                          \
381         (cur) += (len);                                         \
382     }                                                           \
383 } STMT_END
384
385 #define GROWING(utf8, cat, start, cur, in_len)  \
386 STMT_START {                                    \
387     STRLEN glen = (in_len);                     \
388     if (utf8) glen *= UTF8_EXPAND;              \
389     if ((cur) + glen >= (start) + SvLEN(cat)) { \
390         (start) = sv_exp_grow(cat, glen);       \
391         (cur) = (start) + SvCUR(cat);           \
392     }                                           \
393 } STMT_END
394
395 #define PUSH_GROWING_BYTES(utf8, cat, start, cur, buf, in_len) \
396 STMT_START {                                    \
397     const STRLEN glen = (in_len);               \
398     STRLEN gl = glen;                           \
399     if (utf8) gl *= UTF8_EXPAND;                \
400     if ((cur) + gl >= (start) + SvLEN(cat)) {   \
401         *cur = '\0';                            \
402         SvCUR_set((cat), (cur) - (start));      \
403         (start) = sv_exp_grow(cat, gl);         \
404         (cur) = (start) + SvCUR(cat);           \
405     }                                           \
406     PUSH_BYTES(utf8, cur, buf, glen, 0);        \
407 } STMT_END
408
409 #define PUSH_BYTE(utf8, s, byte)                \
410 STMT_START {                                    \
411     if (utf8) {                                 \
412         const U8 au8 = (byte);                  \
413         (s) = S_bytes_to_uni(&au8, 1, (s), 0);  \
414     } else *(U8 *)(s)++ = (byte);               \
415 } STMT_END
416
417 /* Only to be used inside a loop (see the break) */
418 #define NEXT_UNI_VAL(val, cur, str, end, utf8_flags)            \
419 STMT_START {                                                    \
420     STRLEN retlen;                                              \
421     if (str >= end) break;                                      \
422     val = utf8n_to_uvchr((U8 *) str, end-str, &retlen, utf8_flags);     \
423     if (retlen == (STRLEN) -1 || retlen == 0) {                 \
424         *cur = '\0';                                            \
425         Perl_croak(aTHX_ "Malformed UTF-8 string in pack");     \
426     }                                                           \
427     str += retlen;                                              \
428 } STMT_END
429
430 static const char *_action( const tempsym_t* symptr )
431 {
432     return (const char *)(( symptr->flags & FLAG_PACK ) ? "pack" : "unpack");
433 }
434
435 /* Returns the sizeof() struct described by pat */
436 STATIC I32
437 S_measure_struct(pTHX_ tempsym_t* symptr)
438 {
439     I32 total = 0;
440
441     PERL_ARGS_ASSERT_MEASURE_STRUCT;
442
443     while (next_symbol(symptr)) {
444         I32 len;
445         int size;
446
447         switch (symptr->howlen) {
448           case e_star:
449             Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
450                         _action( symptr ) );
451
452           default:
453             /* e_no_len and e_number */
454             len = symptr->length;
455             break;
456         }
457
458         size = packprops[TYPE_NO_ENDIANNESS(symptr->code)] & PACK_SIZE_MASK;
459         if (!size) {
460             int star;
461             /* endianness doesn't influence the size of a type */
462             switch(TYPE_NO_ENDIANNESS(symptr->code)) {
463             default:
464                 Perl_croak(aTHX_ "Invalid type '%c' in %s",
465                            (int)TYPE_NO_MODIFIERS(symptr->code),
466                            _action( symptr ) );
467             case '.' | TYPE_IS_SHRIEKING:
468             case '@' | TYPE_IS_SHRIEKING:
469             case '@':
470             case '.':
471             case '/':
472             case 'U':                   /* XXXX Is it correct? */
473             case 'w':
474             case 'u':
475                 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
476                            (int) TYPE_NO_MODIFIERS(symptr->code),
477                            _action( symptr ) );
478             case '%':
479                 size = 0;
480                 break;
481             case '(':
482             {
483                 tempsym_t savsym = *symptr;
484                 symptr->patptr = savsym.grpbeg;
485                 symptr->patend = savsym.grpend;
486                 /* XXXX Theoretically, we need to measure many times at
487                    different positions, since the subexpression may contain
488                    alignment commands, but be not of aligned length.
489                    Need to detect this and croak().  */
490                 size = measure_struct(symptr);
491                 *symptr = savsym;
492                 break;
493             }
494             case 'X' | TYPE_IS_SHRIEKING:
495                 /* XXXX Is this useful?  Then need to treat MEASURE_BACKWARDS.
496                  */
497                 if (!len)               /* Avoid division by 0 */
498                     len = 1;
499                 len = total % len;      /* Assumed: the start is aligned. */
500                 /* FALLTHROUGH */
501             case 'X':
502                 size = -1;
503                 if (total < len)
504                     Perl_croak(aTHX_ "'X' outside of string in %s", _action( symptr ) );
505                 break;
506             case 'x' | TYPE_IS_SHRIEKING:
507                 if (!len)               /* Avoid division by 0 */
508                     len = 1;
509                 star = total % len;     /* Assumed: the start is aligned. */
510                 if (star)               /* Other portable ways? */
511                     len = len - star;
512                 else
513                     len = 0;
514                 /* FALLTHROUGH */
515             case 'x':
516             case 'A':
517             case 'Z':
518             case 'a':
519                 size = 1;
520                 break;
521             case 'B':
522             case 'b':
523                 len = (len + 7)/8;
524                 size = 1;
525                 break;
526             case 'H':
527             case 'h':
528                 len = (len + 1)/2;
529                 size = 1;
530                 break;
531
532             case 'P':
533                 len = 1;
534                 size = sizeof(char*);
535                 break;
536             }
537         }
538         total += len * size;
539     }
540     return total;
541 }
542
543
544 /* locate matching closing parenthesis or bracket
545  * returns char pointer to char after match, or NULL
546  */
547 STATIC const char *
548 S_group_end(pTHX_ const char *patptr, const char *patend, char ender)
549 {
550     PERL_ARGS_ASSERT_GROUP_END;
551
552     while (patptr < patend) {
553         const char c = *patptr++;
554
555         if (isSPACE(c))
556             continue;
557         else if (c == ender)
558             return patptr-1;
559         else if (c == '#') {
560             while (patptr < patend && *patptr != '\n')
561                 patptr++;
562             continue;
563         } else if (c == '(')
564             patptr = group_end(patptr, patend, ')') + 1;
565         else if (c == '[')
566             patptr = group_end(patptr, patend, ']') + 1;
567     }
568     Perl_croak(aTHX_ "No group ending character '%c' found in template",
569                ender);
570     /* NOTREACHED */
571     NOT_REACHED;
572 }
573
574
575 /* Convert unsigned decimal number to binary.
576  * Expects a pointer to the first digit and address of length variable
577  * Advances char pointer to 1st non-digit char and returns number
578  */
579 STATIC const char *
580 S_get_num(pTHX_ const char *patptr, I32 *lenptr )
581 {
582   I32 len = *patptr++ - '0';
583
584   PERL_ARGS_ASSERT_GET_NUM;
585
586   while (isDIGIT(*patptr)) {
587     if (len >= 0x7FFFFFFF/10)
588       Perl_croak(aTHX_ "pack/unpack repeat count overflow");
589     len = (len * 10) + (*patptr++ - '0');
590   }
591   *lenptr = len;
592   return patptr;
593 }
594
595 /* The marvellous template parsing routine: Using state stored in *symptr,
596  * locates next template code and count
597  */
598 STATIC bool
599 S_next_symbol(pTHX_ tempsym_t* symptr )
600 {
601   const char* patptr = symptr->patptr;
602   const char* const patend = symptr->patend;
603
604   PERL_ARGS_ASSERT_NEXT_SYMBOL;
605
606   symptr->flags &= ~FLAG_SLASH;
607
608   while (patptr < patend) {
609     if (isSPACE(*patptr))
610       patptr++;
611     else if (*patptr == '#') {
612       patptr++;
613       while (patptr < patend && *patptr != '\n')
614         patptr++;
615       if (patptr < patend)
616         patptr++;
617     } else {
618       /* We should have found a template code */
619       I32 code = *patptr++ & 0xFF;
620       U32 inherited_modifiers = 0;
621
622       if (code == ','){ /* grandfather in commas but with a warning */
623         if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
624           symptr->flags |= FLAG_COMMA;
625           Perl_warner(aTHX_ packWARN(WARN_UNPACK),
626                       "Invalid type ',' in %s", _action( symptr ) );
627         }
628         continue;
629       }
630
631       /* for '(', skip to ')' */
632       if (code == '(') {
633         if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
634           Perl_croak(aTHX_ "()-group starts with a count in %s",
635                         _action( symptr ) );
636         symptr->grpbeg = patptr;
637         patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
638         if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
639           Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
640                         _action( symptr ) );
641       }
642
643       /* look for group modifiers to inherit */
644       if (TYPE_ENDIANNESS(symptr->flags)) {
645         if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
646           inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
647       }
648
649       /* look for modifiers */
650       while (patptr < patend) {
651         const char *allowed;
652         I32 modifier;
653         switch (*patptr) {
654           case '!':
655             modifier = TYPE_IS_SHRIEKING;
656             allowed = "sSiIlLxXnNvV@.";
657             break;
658           case '>':
659             modifier = TYPE_IS_BIG_ENDIAN;
660             allowed = ENDIANNESS_ALLOWED_TYPES;
661             break;
662           case '<':
663             modifier = TYPE_IS_LITTLE_ENDIAN;
664             allowed = ENDIANNESS_ALLOWED_TYPES;
665             break;
666           default:
667             allowed = "";
668             modifier = 0;
669             break;
670         }
671
672         if (modifier == 0)
673           break;
674
675         if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
676           Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
677                         allowed, _action( symptr ) );
678
679         if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
680           Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
681                      (int) TYPE_NO_MODIFIERS(code), _action( symptr ) );
682         else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
683                  TYPE_ENDIANNESS_MASK)
684           Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
685                      *patptr, _action( symptr ) );
686
687         if ((code & modifier)) {
688             Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK),
689                            "Duplicate modifier '%c' after '%c' in %s",
690                            *patptr, (int) TYPE_NO_MODIFIERS(code),
691                            _action( symptr ) );
692         }
693
694         code |= modifier;
695         patptr++;
696       }
697
698       /* inherit modifiers */
699       code |= inherited_modifiers;
700
701       /* look for count and/or / */
702       if (patptr < patend) {
703         if (isDIGIT(*patptr)) {
704           patptr = get_num( patptr, &symptr->length );
705           symptr->howlen = e_number;
706
707         } else if (*patptr == '*') {
708           patptr++;
709           symptr->howlen = e_star;
710
711         } else if (*patptr == '[') {
712           const char* lenptr = ++patptr;
713           symptr->howlen = e_number;
714           patptr = group_end( patptr, patend, ']' ) + 1;
715           /* what kind of [] is it? */
716           if (isDIGIT(*lenptr)) {
717             lenptr = get_num( lenptr, &symptr->length );
718             if( *lenptr != ']' )
719               Perl_croak(aTHX_ "Malformed integer in [] in %s",
720                             _action( symptr ) );
721           } else {
722             tempsym_t savsym = *symptr;
723             symptr->patend = patptr-1;
724             symptr->patptr = lenptr;
725             savsym.length = measure_struct(symptr);
726             *symptr = savsym;
727           }
728         } else {
729           symptr->howlen = e_no_len;
730           symptr->length = 1;
731         }
732
733         /* try to find / */
734         while (patptr < patend) {
735           if (isSPACE(*patptr))
736             patptr++;
737           else if (*patptr == '#') {
738             patptr++;
739             while (patptr < patend && *patptr != '\n')
740               patptr++;
741             if (patptr < patend)
742               patptr++;
743           } else {
744             if (*patptr == '/') {
745               symptr->flags |= FLAG_SLASH;
746               patptr++;
747               if (patptr < patend &&
748                   (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
749                 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
750                             _action( symptr ) );
751             }
752             break;
753           }
754         }
755       } else {
756         /* at end - no count, no / */
757         symptr->howlen = e_no_len;
758         symptr->length = 1;
759       }
760
761       symptr->code = code;
762       symptr->patptr = patptr;
763       return TRUE;
764     }
765   }
766   symptr->patptr = patptr;
767   return FALSE;
768 }
769
770 /*
771    There is no way to cleanly handle the case where we should process the
772    string per byte in its upgraded form while it's really in downgraded form
773    (e.g. estimates like strend-s as an upper bound for the number of
774    characters left wouldn't work). So if we foresee the need of this
775    (pattern starts with U or contains U0), we want to work on the encoded
776    version of the string. Users are advised to upgrade their pack string
777    themselves if they need to do a lot of unpacks like this on it
778 */
779 STATIC bool
780 need_utf8(const char *pat, const char *patend)
781 {
782     bool first = TRUE;
783
784     PERL_ARGS_ASSERT_NEED_UTF8;
785
786     while (pat < patend) {
787         if (pat[0] == '#') {
788             pat++;
789             pat = (const char *) memchr(pat, '\n', patend-pat);
790             if (!pat) return FALSE;
791         } else if (pat[0] == 'U') {
792             if (first || pat[1] == '0') return TRUE;
793         } else first = FALSE;
794         pat++;
795     }
796     return FALSE;
797 }
798
799 STATIC char
800 first_symbol(const char *pat, const char *patend) {
801     PERL_ARGS_ASSERT_FIRST_SYMBOL;
802
803     while (pat < patend) {
804         if (pat[0] != '#') return pat[0];
805         pat++;
806         pat = (const char *) memchr(pat, '\n', patend-pat);
807         if (!pat) return 0;
808         pat++;
809     }
810     return 0;
811 }
812
813 /*
814
815 =head1 Pack and Unpack
816
817 =for apidoc unpackstring
818
819 The engine implementing the unpack() Perl function.
820
821 Using the template pat..patend, this function unpacks the string
822 s..strend into a number of mortal SVs, which it pushes onto the perl
823 argument (@_) stack (so you will need to issue a C<PUTBACK> before and
824 C<SPAGAIN> after the call to this function).  It returns the number of
825 pushed elements.
826
827 The strend and patend pointers should point to the byte following the last
828 character of each string.
829
830 Although this function returns its values on the perl argument stack, it
831 doesn't take any parameters from that stack (and thus in particular
832 there's no need to do a PUSHMARK before calling it, unlike L</call_pv> for
833 example).
834
835 =cut */
836
837 I32
838 Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, const char *strend, U32 flags)
839 {
840     tempsym_t sym;
841
842     PERL_ARGS_ASSERT_UNPACKSTRING;
843
844     if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8;
845     else if (need_utf8(pat, patend)) {
846         /* We probably should try to avoid this in case a scalar context call
847            wouldn't get to the "U0" */
848         STRLEN len = strend - s;
849         s = (char *) bytes_to_utf8((U8 *) s, &len);
850         SAVEFREEPV(s);
851         strend = s + len;
852         flags |= FLAG_DO_UTF8;
853     }
854
855     if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8))
856         flags |= FLAG_PARSE_UTF8;
857
858     TEMPSYM_INIT(&sym, pat, patend, flags);
859
860     return unpack_rec(&sym, s, s, strend, NULL );
861 }
862
863 STATIC I32
864 S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s )
865 {
866     dVAR; dSP;
867     SV *sv = NULL;
868     const I32 start_sp_offset = SP - PL_stack_base;
869     howlen_t howlen;
870     I32 checksum = 0;
871     UV cuv = 0;
872     NV cdouble = 0.0;
873     const int bits_in_uv = CHAR_BIT * sizeof(cuv);
874     bool beyond = FALSE;
875     bool explicit_length;
876     const bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
877     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
878
879     PERL_ARGS_ASSERT_UNPACK_REC;
880
881     symptr->strbeg = s - strbeg;
882
883     while (next_symbol(symptr)) {
884         packprops_t props;
885         I32 len;
886         I32 datumtype = symptr->code;
887         bool needs_swap;
888         /* do first one only unless in list context
889            / is implemented by unpacking the count, then popping it from the
890            stack, so must check that we're not in the middle of a /  */
891         if ( unpack_only_one
892              && (SP - PL_stack_base == start_sp_offset + 1)
893              && (datumtype != '/') )   /* XXX can this be omitted */
894             break;
895
896         switch (howlen = symptr->howlen) {
897           case e_star:
898             len = strend - strbeg;      /* long enough */
899             break;
900           default:
901             /* e_no_len and e_number */
902             len = symptr->length;
903             break;
904         }
905
906         explicit_length = TRUE;
907       redo_switch:
908         beyond = s >= strend;
909
910         props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
911         if (props) {
912             /* props nonzero means we can process this letter. */
913             const long size = props & PACK_SIZE_MASK;
914             const long howmany = (strend - s) / size;
915             if (len > howmany)
916                 len = howmany;
917
918             if (!checksum || (props & PACK_SIZE_CANNOT_CSUM)) {
919                 if (len && unpack_only_one) len = 1;
920                 EXTEND(SP, len);
921                 EXTEND_MORTAL(len);
922             }
923         }
924
925         needs_swap = NEEDS_SWAP(datumtype);
926
927         switch(TYPE_NO_ENDIANNESS(datumtype)) {
928         default:
929             Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
930
931         case '%':
932             if (howlen == e_no_len)
933                 len = 16;               /* len is not specified */
934             checksum = len;
935             cuv = 0;
936             cdouble = 0;
937             continue;
938
939         case '(':
940         {
941             tempsym_t savsym = *symptr;
942             const U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
943             symptr->flags |= group_modifiers;
944             symptr->patend = savsym.grpend;
945             symptr->previous = &savsym;
946             symptr->level++;
947             PUTBACK;
948             if (len && unpack_only_one) len = 1;
949             while (len--) {
950                 symptr->patptr = savsym.grpbeg;
951                 if (utf8) symptr->flags |=  FLAG_PARSE_UTF8;
952                 else      symptr->flags &= ~FLAG_PARSE_UTF8;
953                 unpack_rec(symptr, s, strbeg, strend, &s);
954                 if (s == strend && savsym.howlen == e_star)
955                     break; /* No way to continue */
956             }
957             SPAGAIN;
958             savsym.flags = symptr->flags & ~group_modifiers;
959             *symptr = savsym;
960             break;
961         }
962         case '.' | TYPE_IS_SHRIEKING:
963         case '.': {
964             const char *from;
965             SV *sv;
966             const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING);
967             if (howlen == e_star) from = strbeg;
968             else if (len <= 0) from = s;
969             else {
970                 tempsym_t *group = symptr;
971
972                 while (--len && group) group = group->previous;
973                 from = group ? strbeg + group->strbeg : strbeg;
974             }
975             sv = from <= s ?
976                 newSVuv(  u8 ? (UV) utf8_length((const U8*)from, (const U8*)s) : (UV) (s-from)) :
977                 newSViv(-(u8 ? (IV) utf8_length((const U8*)s, (const U8*)from) : (IV) (from-s)));
978             mXPUSHs(sv);
979             break;
980         }
981         case '@' | TYPE_IS_SHRIEKING:
982         case '@':
983             s = strbeg + symptr->strbeg;
984             if (utf8  && !(datumtype & TYPE_IS_SHRIEKING))
985             {
986                 while (len > 0) {
987                     if (s >= strend)
988                         Perl_croak(aTHX_ "'@' outside of string in unpack");
989                     s += UTF8SKIP(s);
990                     len--;
991                 }
992                 if (s > strend)
993                     Perl_croak(aTHX_ "'@' outside of string with malformed UTF-8 in unpack");
994             } else {
995                 if (strend-s < len)
996                     Perl_croak(aTHX_ "'@' outside of string in unpack");
997                 s += len;
998             }
999             break;
1000         case 'X' | TYPE_IS_SHRIEKING:
1001             if (!len)                   /* Avoid division by 0 */
1002                 len = 1;
1003             if (utf8) {
1004                 const char *hop, *last;
1005                 I32 l = len;
1006                 hop = last = strbeg;
1007                 while (hop < s) {
1008                     hop += UTF8SKIP(hop);
1009                     if (--l == 0) {
1010                         last = hop;
1011                         l = len;
1012                     }
1013                 }
1014                 if (last > s)
1015                     Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1016                 s = last;
1017                 break;
1018             }
1019             len = (s - strbeg) % len;
1020             /* FALLTHROUGH */
1021         case 'X':
1022             if (utf8) {
1023                 while (len > 0) {
1024                     if (s <= strbeg)
1025                         Perl_croak(aTHX_ "'X' outside of string in unpack");
1026                     while (--s, UTF8_IS_CONTINUATION(*s)) {
1027                         if (s <= strbeg)
1028                             Perl_croak(aTHX_ "'X' outside of string in unpack");
1029                     }
1030                     len--;
1031                 }
1032             } else {
1033                 if (len > s - strbeg)
1034                     Perl_croak(aTHX_ "'X' outside of string in unpack" );
1035                 s -= len;
1036             }
1037             break;
1038         case 'x' | TYPE_IS_SHRIEKING: {
1039             I32 ai32;
1040             if (!len)                   /* Avoid division by 0 */
1041                 len = 1;
1042             if (utf8) ai32 = utf8_length((U8 *) strbeg, (U8 *) s) % len;
1043             else      ai32 = (s - strbeg)                         % len;
1044             if (ai32 == 0) break;
1045             len -= ai32;
1046             }
1047             /* FALLTHROUGH */
1048         case 'x':
1049             if (utf8) {
1050                 while (len>0) {
1051                     if (s >= strend)
1052                         Perl_croak(aTHX_ "'x' outside of string in unpack");
1053                     s += UTF8SKIP(s);
1054                     len--;
1055                 }
1056             } else {
1057                 if (len > strend - s)
1058                     Perl_croak(aTHX_ "'x' outside of string in unpack");
1059                 s += len;
1060             }
1061             break;
1062         case '/':
1063             Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1064
1065         case 'A':
1066         case 'Z':
1067         case 'a':
1068             if (checksum) {
1069                 /* Preliminary length estimate is assumed done in 'W' */
1070                 if (len > strend - s) len = strend - s;
1071                 goto W_checksum;
1072             }
1073             if (utf8) {
1074                 I32 l;
1075                 const char *hop;
1076                 for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) {
1077                     if (hop >= strend) {
1078                         if (hop > strend)
1079                             Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1080                         break;
1081                     }
1082                 }
1083                 if (hop > strend)
1084                     Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1085                 len = hop - s;
1086             } else if (len > strend - s)
1087                 len = strend - s;
1088
1089             if (datumtype == 'Z') {
1090                 /* 'Z' strips stuff after first null */
1091                 const char *ptr, *end;
1092                 end = s + len;
1093                 for (ptr = s; ptr < end; ptr++) if (*ptr == 0) break;
1094                 sv = newSVpvn(s, ptr-s);
1095                 if (howlen == e_star) /* exact for 'Z*' */
1096                     len = ptr-s + (ptr != strend ? 1 : 0);
1097             } else if (datumtype == 'A') {
1098                 /* 'A' strips both nulls and spaces */
1099                 const char *ptr;
1100                 if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) {
1101                     for (ptr = s+len-1; ptr >= s; ptr--)
1102                         if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) &&
1103                             !isSPACE_utf8(ptr)) break;
1104                     if (ptr >= s) ptr += UTF8SKIP(ptr);
1105                     else ptr++;
1106                     if (ptr > s+len)
1107                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1108                 } else {
1109                     for (ptr = s+len-1; ptr >= s; ptr--)
1110                         if (*ptr != 0 && !isSPACE(*ptr)) break;
1111                     ptr++;
1112                 }
1113                 sv = newSVpvn(s, ptr-s);
1114             } else sv = newSVpvn(s, len);
1115
1116             if (utf8) {
1117                 SvUTF8_on(sv);
1118                 /* Undo any upgrade done due to need_utf8() */
1119                 if (!(symptr->flags & FLAG_WAS_UTF8))
1120                     sv_utf8_downgrade(sv, 0);
1121             }
1122             mXPUSHs(sv);
1123             s += len;
1124             break;
1125         case 'B':
1126         case 'b': {
1127             char *str;
1128             if (howlen == e_star || len > (strend - s) * 8)
1129                 len = (strend - s) * 8;
1130             if (checksum) {
1131                 if (utf8)
1132                     while (len >= 8 && s < strend) {
1133                         cuv += PL_bitcount[uni_to_byte(aTHX_ &s, strend, datumtype)];
1134                         len -= 8;
1135                     }
1136                 else
1137                     while (len >= 8) {
1138                         cuv += PL_bitcount[*(U8 *)s++];
1139                         len -= 8;
1140                     }
1141                 if (len && s < strend) {
1142                     U8 bits;
1143                     bits = SHIFT_BYTE(utf8, s, strend, datumtype);
1144                     if (datumtype == 'b')
1145                         while (len-- > 0) {
1146                             if (bits & 1) cuv++;
1147                             bits >>= 1;
1148                         }
1149                     else
1150                         while (len-- > 0) {
1151                             if (bits & 0x80) cuv++;
1152                             bits <<= 1;
1153                         }
1154                 }
1155                 break;
1156             }
1157
1158             sv = sv_2mortal(newSV(len ? len : 1));
1159             SvPOK_on(sv);
1160             str = SvPVX(sv);
1161             if (datumtype == 'b') {
1162                 U8 bits = 0;
1163                 const I32 ai32 = len;
1164                 for (len = 0; len < ai32; len++) {
1165                     if (len & 7) bits >>= 1;
1166                     else if (utf8) {
1167                         if (s >= strend) break;
1168                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1169                     } else bits = *(U8 *) s++;
1170                     *str++ = bits & 1 ? '1' : '0';
1171                 }
1172             } else {
1173                 U8 bits = 0;
1174                 const I32 ai32 = len;
1175                 for (len = 0; len < ai32; len++) {
1176                     if (len & 7) bits <<= 1;
1177                     else if (utf8) {
1178                         if (s >= strend) break;
1179                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1180                     } else bits = *(U8 *) s++;
1181                     *str++ = bits & 0x80 ? '1' : '0';
1182                 }
1183             }
1184             *str = '\0';
1185             SvCUR_set(sv, str - SvPVX_const(sv));
1186             XPUSHs(sv);
1187             break;
1188         }
1189         case 'H':
1190         case 'h': {
1191             char *str = NULL;
1192             /* Preliminary length estimate, acceptable for utf8 too */
1193             if (howlen == e_star || len > (strend - s) * 2)
1194                 len = (strend - s) * 2;
1195             if (!checksum) {
1196                 sv = sv_2mortal(newSV(len ? len : 1));
1197                 SvPOK_on(sv);
1198                 str = SvPVX(sv);
1199             }
1200             if (datumtype == 'h') {
1201                 U8 bits = 0;
1202                 I32 ai32 = len;
1203                 for (len = 0; len < ai32; len++) {
1204                     if (len & 1) bits >>= 4;
1205                     else if (utf8) {
1206                         if (s >= strend) break;
1207                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1208                     } else bits = * (U8 *) s++;
1209                     if (!checksum)
1210                         *str++ = PL_hexdigit[bits & 15];
1211                 }
1212             } else {
1213                 U8 bits = 0;
1214                 const I32 ai32 = len;
1215                 for (len = 0; len < ai32; len++) {
1216                     if (len & 1) bits <<= 4;
1217                     else if (utf8) {
1218                         if (s >= strend) break;
1219                         bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1220                     } else bits = *(U8 *) s++;
1221                     if (!checksum)
1222                         *str++ = PL_hexdigit[(bits >> 4) & 15];
1223                 }
1224             }
1225             if (!checksum) {
1226                 *str = '\0';
1227                 SvCUR_set(sv, str - SvPVX_const(sv));
1228                 XPUSHs(sv);
1229             }
1230             break;
1231         }
1232         case 'C':
1233             if (len == 0) {
1234                 if (explicit_length)
1235                     /* Switch to "character" mode */
1236                     utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
1237                 break;
1238             }
1239             /* FALLTHROUGH */
1240         case 'c':
1241             while (len-- > 0 && s < strend) {
1242                 int aint;
1243                 if (utf8)
1244                   {
1245                     STRLEN retlen;
1246                     aint = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
1247                                  ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1248                     if (retlen == (STRLEN) -1 || retlen == 0)
1249                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1250                     s += retlen;
1251                   }
1252                 else
1253                   aint = *(U8 *)(s)++;
1254                 if (aint >= 128 && datumtype != 'C')    /* fake up signed chars */
1255                     aint -= 256;
1256                 if (!checksum)
1257                     mPUSHi(aint);
1258                 else if (checksum > bits_in_uv)
1259                     cdouble += (NV)aint;
1260                 else
1261                     cuv += aint;
1262             }
1263             break;
1264         case 'W':
1265           W_checksum:
1266             if (utf8) {
1267                 while (len-- > 0 && s < strend) {
1268                     STRLEN retlen;
1269                     const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
1270                                          ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1271                     if (retlen == (STRLEN) -1 || retlen == 0)
1272                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1273                     s += retlen;
1274                     if (!checksum)
1275                         mPUSHu(val);
1276                     else if (checksum > bits_in_uv)
1277                         cdouble += (NV) val;
1278                     else
1279                         cuv += val;
1280                 }
1281             } else if (!checksum)
1282                 while (len-- > 0) {
1283                     const U8 ch = *(U8 *) s++;
1284                     mPUSHu(ch);
1285             }
1286             else if (checksum > bits_in_uv)
1287                 while (len-- > 0) cdouble += (NV) *(U8 *) s++;
1288             else
1289                 while (len-- > 0) cuv += *(U8 *) s++;
1290             break;
1291         case 'U':
1292             if (len == 0) {
1293                 if (explicit_length && howlen != e_star) {
1294                     /* Switch to "bytes in UTF-8" mode */
1295                     if (symptr->flags & FLAG_DO_UTF8) utf8 = 0;
1296                     else
1297                         /* Should be impossible due to the need_utf8() test */
1298                         Perl_croak(aTHX_ "U0 mode on a byte string");
1299                 }
1300                 break;
1301             }
1302             if (len > strend - s) len = strend - s;
1303             if (!checksum) {
1304                 if (len && unpack_only_one) len = 1;
1305                 EXTEND(SP, len);
1306                 EXTEND_MORTAL(len);
1307             }
1308             while (len-- > 0 && s < strend) {
1309                 STRLEN retlen;
1310                 UV auv;
1311                 if (utf8) {
1312                     U8 result[UTF8_MAXLEN];
1313                     const char *ptr = s;
1314                     STRLEN len;
1315                     /* Bug: warns about bad utf8 even if we are short on bytes
1316                        and will break out of the loop */
1317                     if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) result, 1,
1318                                       'U'))
1319                         break;
1320                     len = UTF8SKIP(result);
1321                     if (!uni_to_bytes(aTHX_ &ptr, strend,
1322                                       (char *) &result[1], len-1, 'U')) break;
1323                     auv = utf8n_to_uvchr(result, len, &retlen, UTF8_ALLOW_DEFAULT);
1324                     s = ptr;
1325                 } else {
1326                     auv = utf8n_to_uvchr((U8*)s, strend - s, &retlen, UTF8_ALLOW_DEFAULT);
1327                     if (retlen == (STRLEN) -1 || retlen == 0)
1328                         Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1329                     s += retlen;
1330                 }
1331                 if (!checksum)
1332                     mPUSHu(auv);
1333                 else if (checksum > bits_in_uv)
1334                     cdouble += (NV) auv;
1335                 else
1336                     cuv += auv;
1337             }
1338             break;
1339         case 's' | TYPE_IS_SHRIEKING:
1340 #if SHORTSIZE != SIZE16
1341             while (len-- > 0) {
1342                 short ashort;
1343                 SHIFT_VAR(utf8, s, strend, ashort, datumtype, needs_swap);
1344                 if (!checksum)
1345                     mPUSHi(ashort);
1346                 else if (checksum > bits_in_uv)
1347                     cdouble += (NV)ashort;
1348                 else
1349                     cuv += ashort;
1350             }
1351             break;
1352 #else
1353             /* FALLTHROUGH */
1354 #endif
1355         case 's':
1356             while (len-- > 0) {
1357                 I16 ai16;
1358
1359 #if U16SIZE > SIZE16
1360                 ai16 = 0;
1361 #endif
1362                 SHIFT16(utf8, s, strend, &ai16, datumtype, needs_swap);
1363 #if U16SIZE > SIZE16
1364                 if (ai16 > 32767)
1365                     ai16 -= 65536;
1366 #endif
1367                 if (!checksum)
1368                     mPUSHi(ai16);
1369                 else if (checksum > bits_in_uv)
1370                     cdouble += (NV)ai16;
1371                 else
1372                     cuv += ai16;
1373             }
1374             break;
1375         case 'S' | TYPE_IS_SHRIEKING:
1376 #if SHORTSIZE != SIZE16
1377             while (len-- > 0) {
1378                 unsigned short aushort;
1379                 SHIFT_VAR(utf8, s, strend, aushort, datumtype, needs_swap,
1380                           needs_swap);
1381                 if (!checksum)
1382                     mPUSHu(aushort);
1383                 else if (checksum > bits_in_uv)
1384                     cdouble += (NV)aushort;
1385                 else
1386                     cuv += aushort;
1387             }
1388             break;
1389 #else
1390             /* FALLTHROUGH */
1391 #endif
1392         case 'v':
1393         case 'n':
1394         case 'S':
1395             while (len-- > 0) {
1396                 U16 au16;
1397 #if U16SIZE > SIZE16
1398                 au16 = 0;
1399 #endif
1400                 SHIFT16(utf8, s, strend, &au16, datumtype, needs_swap);
1401                 if (datumtype == 'n')
1402                     au16 = PerlSock_ntohs(au16);
1403                 if (datumtype == 'v')
1404                     au16 = vtohs(au16);
1405                 if (!checksum)
1406                     mPUSHu(au16);
1407                 else if (checksum > bits_in_uv)
1408                     cdouble += (NV) au16;
1409                 else
1410                     cuv += au16;
1411             }
1412             break;
1413         case 'v' | TYPE_IS_SHRIEKING:
1414         case 'n' | TYPE_IS_SHRIEKING:
1415             while (len-- > 0) {
1416                 I16 ai16;
1417 # if U16SIZE > SIZE16
1418                 ai16 = 0;
1419 # endif
1420                 SHIFT16(utf8, s, strend, &ai16, datumtype, needs_swap);
1421                 /* There should never be any byte-swapping here.  */
1422                 assert(!TYPE_ENDIANNESS(datumtype));
1423                 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1424                     ai16 = (I16) PerlSock_ntohs((U16) ai16);
1425                 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1426                     ai16 = (I16) vtohs((U16) ai16);
1427                 if (!checksum)
1428                     mPUSHi(ai16);
1429                 else if (checksum > bits_in_uv)
1430                     cdouble += (NV) ai16;
1431                 else
1432                     cuv += ai16;
1433             }
1434             break;
1435         case 'i':
1436         case 'i' | TYPE_IS_SHRIEKING:
1437             while (len-- > 0) {
1438                 int aint;
1439                 SHIFT_VAR(utf8, s, strend, aint, datumtype, needs_swap);
1440                 if (!checksum)
1441                     mPUSHi(aint);
1442                 else if (checksum > bits_in_uv)
1443                     cdouble += (NV)aint;
1444                 else
1445                     cuv += aint;
1446             }
1447             break;
1448         case 'I':
1449         case 'I' | TYPE_IS_SHRIEKING:
1450             while (len-- > 0) {
1451                 unsigned int auint;
1452                 SHIFT_VAR(utf8, s, strend, auint, datumtype, needs_swap);
1453                 if (!checksum)
1454                     mPUSHu(auint);
1455                 else if (checksum > bits_in_uv)
1456                     cdouble += (NV)auint;
1457                 else
1458                     cuv += auint;
1459             }
1460             break;
1461         case 'j':
1462             while (len-- > 0) {
1463                 IV aiv;
1464                 SHIFT_VAR(utf8, s, strend, aiv, datumtype, needs_swap);
1465                 if (!checksum)
1466                     mPUSHi(aiv);
1467                 else if (checksum > bits_in_uv)
1468                     cdouble += (NV)aiv;
1469                 else
1470                     cuv += aiv;
1471             }
1472             break;
1473         case 'J':
1474             while (len-- > 0) {
1475                 UV auv;
1476                 SHIFT_VAR(utf8, s, strend, auv, datumtype, needs_swap);
1477                 if (!checksum)
1478                     mPUSHu(auv);
1479                 else if (checksum > bits_in_uv)
1480                     cdouble += (NV)auv;
1481                 else
1482                     cuv += auv;
1483             }
1484             break;
1485         case 'l' | TYPE_IS_SHRIEKING:
1486 #if LONGSIZE != SIZE32
1487             while (len-- > 0) {
1488                 long along;
1489                 SHIFT_VAR(utf8, s, strend, along, datumtype, needs_swap);
1490                 if (!checksum)
1491                     mPUSHi(along);
1492                 else if (checksum > bits_in_uv)
1493                     cdouble += (NV)along;
1494                 else
1495                     cuv += along;
1496             }
1497             break;
1498 #else
1499             /* FALLTHROUGH */
1500 #endif
1501         case 'l':
1502             while (len-- > 0) {
1503                 I32 ai32;
1504 #if U32SIZE > SIZE32
1505                 ai32 = 0;
1506 #endif
1507                 SHIFT32(utf8, s, strend, &ai32, datumtype, needs_swap);
1508 #if U32SIZE > SIZE32
1509                 if (ai32 > 2147483647) ai32 -= 4294967296;
1510 #endif
1511                 if (!checksum)
1512                     mPUSHi(ai32);
1513                 else if (checksum > bits_in_uv)
1514                     cdouble += (NV)ai32;
1515                 else
1516                     cuv += ai32;
1517             }
1518             break;
1519         case 'L' | TYPE_IS_SHRIEKING:
1520 #if LONGSIZE != SIZE32
1521             while (len-- > 0) {
1522                 unsigned long aulong;
1523                 SHIFT_VAR(utf8, s, strend, aulong, datumtype, needs_swap);
1524                 if (!checksum)
1525                     mPUSHu(aulong);
1526                 else if (checksum > bits_in_uv)
1527                     cdouble += (NV)aulong;
1528                 else
1529                     cuv += aulong;
1530             }
1531             break;
1532 #else
1533             /* FALLTHROUGH */
1534 #endif
1535         case 'V':
1536         case 'N':
1537         case 'L':
1538             while (len-- > 0) {
1539                 U32 au32;
1540 #if U32SIZE > SIZE32
1541                 au32 = 0;
1542 #endif
1543                 SHIFT32(utf8, s, strend, &au32, datumtype, needs_swap);
1544                 if (datumtype == 'N')
1545                     au32 = PerlSock_ntohl(au32);
1546                 if (datumtype == 'V')
1547                     au32 = vtohl(au32);
1548                 if (!checksum)
1549                     mPUSHu(au32);
1550                 else if (checksum > bits_in_uv)
1551                     cdouble += (NV)au32;
1552                 else
1553                     cuv += au32;
1554             }
1555             break;
1556         case 'V' | TYPE_IS_SHRIEKING:
1557         case 'N' | TYPE_IS_SHRIEKING:
1558             while (len-- > 0) {
1559                 I32 ai32;
1560 #if U32SIZE > SIZE32
1561                 ai32 = 0;
1562 #endif
1563                 SHIFT32(utf8, s, strend, &ai32, datumtype, needs_swap);
1564                 /* There should never be any byte swapping here.  */
1565                 assert(!TYPE_ENDIANNESS(datumtype));
1566                 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1567                     ai32 = (I32)PerlSock_ntohl((U32)ai32);
1568                 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1569                     ai32 = (I32)vtohl((U32)ai32);
1570                 if (!checksum)
1571                     mPUSHi(ai32);
1572                 else if (checksum > bits_in_uv)
1573                     cdouble += (NV)ai32;
1574                 else
1575                     cuv += ai32;
1576             }
1577             break;
1578         case 'p':
1579             while (len-- > 0) {
1580                 const char *aptr;
1581                 SHIFT_VAR(utf8, s, strend, aptr, datumtype, needs_swap);
1582                 /* newSVpv generates undef if aptr is NULL */
1583                 mPUSHs(newSVpv(aptr, 0));
1584             }
1585             break;
1586         case 'w':
1587             {
1588                 UV auv = 0;
1589                 U32 bytes = 0;
1590
1591                 while (len > 0 && s < strend) {
1592                     U8 ch;
1593                     ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1594                     auv = (auv << 7) | (ch & 0x7f);
1595                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1596                     if (ch < 0x80) {
1597                         bytes = 0;
1598                         mPUSHu(auv);
1599                         len--;
1600                         auv = 0;
1601                         continue;
1602                     }
1603                     if (++bytes >= sizeof(UV)) {        /* promote to string */
1604                         const char *t;
1605
1606                         sv = Perl_newSVpvf(aTHX_ "%.*"UVuf, (int)TYPE_DIGITS(UV), auv);
1607                         while (s < strend) {
1608                             ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1609                             sv = mul128(sv, (U8)(ch & 0x7f));
1610                             if (!(ch & 0x80)) {
1611                                 bytes = 0;
1612                                 break;
1613                             }
1614                         }
1615                         t = SvPV_nolen_const(sv);
1616                         while (*t == '0')
1617                             t++;
1618                         sv_chop(sv, t);
1619                         mPUSHs(sv);
1620                         len--;
1621                         auv = 0;
1622                     }
1623                 }
1624                 if ((s >= strend) && bytes)
1625                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1626             }
1627             break;
1628         case 'P':
1629             if (symptr->howlen == e_star)
1630                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1631             EXTEND(SP, 1);
1632             if (s + sizeof(char*) <= strend) {
1633                 char *aptr;
1634                 SHIFT_VAR(utf8, s, strend, aptr, datumtype, needs_swap);
1635                 /* newSVpvn generates undef if aptr is NULL */
1636                 PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP));
1637             }
1638             break;
1639 #if defined(HAS_QUAD) && IVSIZE >= 8
1640         case 'q':
1641             while (len-- > 0) {
1642                 Quad_t aquad;
1643                 SHIFT_VAR(utf8, s, strend, aquad, datumtype, needs_swap);
1644                 if (!checksum)
1645                     mPUSHs(newSViv((IV)aquad));
1646                 else if (checksum > bits_in_uv)
1647                     cdouble += (NV)aquad;
1648                 else
1649                     cuv += aquad;
1650             }
1651             break;
1652         case 'Q':
1653             while (len-- > 0) {
1654                 Uquad_t auquad;
1655                 SHIFT_VAR(utf8, s, strend, auquad, datumtype, needs_swap);
1656                 if (!checksum)
1657                     mPUSHs(newSVuv((UV)auquad));
1658                 else if (checksum > bits_in_uv)
1659                     cdouble += (NV)auquad;
1660                 else
1661                     cuv += auquad;
1662             }
1663             break;
1664 #endif
1665         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1666         case 'f':
1667             while (len-- > 0) {
1668                 float afloat;
1669                 SHIFT_VAR(utf8, s, strend, afloat, datumtype, needs_swap);
1670                 if (!checksum)
1671                     mPUSHn(afloat);
1672                 else
1673                     cdouble += afloat;
1674             }
1675             break;
1676         case 'd':
1677             while (len-- > 0) {
1678                 double adouble;
1679                 SHIFT_VAR(utf8, s, strend, adouble, datumtype, needs_swap);
1680                 if (!checksum)
1681                     mPUSHn(adouble);
1682                 else
1683                     cdouble += adouble;
1684             }
1685             break;
1686         case 'F':
1687             while (len-- > 0) {
1688                 NV_bytes anv;
1689                 SHIFT_BYTES(utf8, s, strend, anv.bytes, sizeof(anv.bytes),
1690                             datumtype, needs_swap);
1691                 if (!checksum)
1692                     mPUSHn(anv.nv);
1693                 else
1694                     cdouble += anv.nv;
1695             }
1696             break;
1697 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1698         case 'D':
1699             while (len-- > 0) {
1700                 ld_bytes aldouble;
1701                 SHIFT_BYTES(utf8, s, strend, aldouble.bytes,
1702                             sizeof(aldouble.bytes), datumtype, needs_swap);
1703                 if (!checksum)
1704                     mPUSHn(aldouble.ld);
1705                 else
1706                     cdouble += aldouble.ld;
1707             }
1708             break;
1709 #endif
1710         case 'u':
1711             if (!checksum) {
1712                 const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
1713                 sv = sv_2mortal(newSV(l));
1714                 if (l) SvPOK_on(sv);
1715             }
1716             if (utf8) {
1717                 while (next_uni_uu(aTHX_ &s, strend, &len)) {
1718                     I32 a, b, c, d;
1719                     char hunk[3];
1720
1721                     while (len > 0) {
1722                         next_uni_uu(aTHX_ &s, strend, &a);
1723                         next_uni_uu(aTHX_ &s, strend, &b);
1724                         next_uni_uu(aTHX_ &s, strend, &c);
1725                         next_uni_uu(aTHX_ &s, strend, &d);
1726                         hunk[0] = (char)((a << 2) | (b >> 4));
1727                         hunk[1] = (char)((b << 4) | (c >> 2));
1728                         hunk[2] = (char)((c << 6) | d);
1729                         if (!checksum)
1730                             sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1731                         len -= 3;
1732                     }
1733                     if (s < strend) {
1734                         if (*s == '\n') {
1735                             s++;
1736                         }
1737                         else {
1738                             /* possible checksum byte */
1739                             const char *skip = s+UTF8SKIP(s);
1740                             if (skip < strend && *skip == '\n')
1741                                 s = skip+1;
1742                         }
1743                     }
1744                 }
1745             } else {
1746                 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1747                     I32 a, b, c, d;
1748                     char hunk[3];
1749
1750                     len = PL_uudmap[*(U8*)s++] & 077;
1751                     while (len > 0) {
1752                         if (s < strend && ISUUCHAR(*s))
1753                             a = PL_uudmap[*(U8*)s++] & 077;
1754                         else
1755                             a = 0;
1756                         if (s < strend && ISUUCHAR(*s))
1757                             b = PL_uudmap[*(U8*)s++] & 077;
1758                         else
1759                             b = 0;
1760                         if (s < strend && ISUUCHAR(*s))
1761                             c = PL_uudmap[*(U8*)s++] & 077;
1762                         else
1763                             c = 0;
1764                         if (s < strend && ISUUCHAR(*s))
1765                             d = PL_uudmap[*(U8*)s++] & 077;
1766                         else
1767                             d = 0;
1768                         hunk[0] = (char)((a << 2) | (b >> 4));
1769                         hunk[1] = (char)((b << 4) | (c >> 2));
1770                         hunk[2] = (char)((c << 6) | d);
1771                         if (!checksum)
1772                             sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1773                         len -= 3;
1774                     }
1775                     if (*s == '\n')
1776                         s++;
1777                     else        /* possible checksum byte */
1778                         if (s + 1 < strend && s[1] == '\n')
1779                             s += 2;
1780                 }
1781             }
1782             if (!checksum)
1783                 XPUSHs(sv);
1784             break;
1785         }
1786
1787         if (checksum) {
1788             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1789               (checksum > bits_in_uv &&
1790                strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1791                 NV trouble, anv;
1792
1793                 anv = (NV) (1 << (checksum & 15));
1794                 while (checksum >= 16) {
1795                     checksum -= 16;
1796                     anv *= 65536.0;
1797                 }
1798                 while (cdouble < 0.0)
1799                     cdouble += anv;
1800                 cdouble = Perl_modf(cdouble / anv, &trouble) * anv;
1801                 sv = newSVnv(cdouble);
1802             }
1803             else {
1804                 if (checksum < bits_in_uv) {
1805                     UV mask = ((UV)1 << checksum) - 1;
1806                     cuv &= mask;
1807                 }
1808                 sv = newSVuv(cuv);
1809             }
1810             mXPUSHs(sv);
1811             checksum = 0;
1812         }
1813
1814         if (symptr->flags & FLAG_SLASH){
1815             if (SP - PL_stack_base - start_sp_offset <= 0)
1816                 break;
1817             if( next_symbol(symptr) ){
1818               if( symptr->howlen == e_number )
1819                 Perl_croak(aTHX_ "Count after length/code in unpack" );
1820               if( beyond ){
1821                 /* ...end of char buffer then no decent length available */
1822                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1823               } else {
1824                 /* take top of stack (hope it's numeric) */
1825                 len = POPi;
1826                 if( len < 0 )
1827                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
1828               }
1829             } else {
1830                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1831             }
1832             datumtype = symptr->code;
1833             explicit_length = FALSE;
1834             goto redo_switch;
1835         }
1836     }
1837
1838     if (new_s)
1839         *new_s = s;
1840     PUTBACK;
1841     return SP - PL_stack_base - start_sp_offset;
1842 }
1843
1844 PP(pp_unpack)
1845 {
1846     dVAR;
1847     dSP;
1848     dPOPPOPssrl;
1849     I32 gimme = GIMME_V;
1850     STRLEN llen;
1851     STRLEN rlen;
1852     const char *pat = SvPV_const(left,  llen);
1853     const char *s   = SvPV_const(right, rlen);
1854     const char *strend = s + rlen;
1855     const char *patend = pat + llen;
1856     I32 cnt;
1857
1858     PUTBACK;
1859     cnt = unpackstring(pat, patend, s, strend,
1860                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1861                      | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0));
1862
1863     SPAGAIN;
1864     if ( !cnt && gimme == G_SCALAR )
1865        PUSHs(&PL_sv_undef);
1866     RETURN;
1867 }
1868
1869 STATIC U8 *
1870 doencodes(U8 *h, const char *s, I32 len)
1871 {
1872     *h++ = PL_uuemap[len];
1873     while (len > 2) {
1874         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
1875         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))];
1876         *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1877         *h++ = PL_uuemap[(077 & (s[2] & 077))];
1878         s += 3;
1879         len -= 3;
1880     }
1881     if (len > 0) {
1882         const char r = (len > 1 ? s[1] : '\0');
1883         *h++ = PL_uuemap[(077 & (s[0] >> 2))];
1884         *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))];
1885         *h++ = PL_uuemap[(077 & ((r << 2) & 074))];
1886         *h++ = PL_uuemap[0];
1887     }
1888     *h++ = '\n';
1889     return h;
1890 }
1891
1892 STATIC SV *
1893 S_is_an_int(pTHX_ const char *s, STRLEN l)
1894 {
1895   SV *result = newSVpvn(s, l);
1896   char *const result_c = SvPV_nolen(result);    /* convenience */
1897   char *out = result_c;
1898   bool skip = 1;
1899   bool ignore = 0;
1900
1901   PERL_ARGS_ASSERT_IS_AN_INT;
1902
1903   while (*s) {
1904     switch (*s) {
1905     case ' ':
1906       break;
1907     case '+':
1908       if (!skip) {
1909         SvREFCNT_dec(result);
1910         return (NULL);
1911       }
1912       break;
1913     case '0':
1914     case '1':
1915     case '2':
1916     case '3':
1917     case '4':
1918     case '5':
1919     case '6':
1920     case '7':
1921     case '8':
1922     case '9':
1923       skip = 0;
1924       if (!ignore) {
1925         *(out++) = *s;
1926       }
1927       break;
1928     case '.':
1929       ignore = 1;
1930       break;
1931     default:
1932       SvREFCNT_dec(result);
1933       return (NULL);
1934     }
1935     s++;
1936   }
1937   *(out++) = '\0';
1938   SvCUR_set(result, out - result_c);
1939   return (result);
1940 }
1941
1942 /* pnum must be '\0' terminated */
1943 STATIC int
1944 S_div128(pTHX_ SV *pnum, bool *done)
1945 {
1946     STRLEN len;
1947     char * const s = SvPV(pnum, len);
1948     char *t = s;
1949     int m = 0;
1950
1951     PERL_ARGS_ASSERT_DIV128;
1952
1953     *done = 1;
1954     while (*t) {
1955         const int i = m * 10 + (*t - '0');
1956         const int r = (i >> 7); /* r < 10 */
1957         m = i & 0x7F;
1958         if (r) {
1959             *done = 0;
1960         }
1961         *(t++) = '0' + r;
1962     }
1963     *(t++) = '\0';
1964     SvCUR_set(pnum, (STRLEN) (t - s));
1965     return (m);
1966 }
1967
1968 /*
1969 =for apidoc packlist
1970
1971 The engine implementing pack() Perl function.
1972
1973 =cut
1974 */
1975
1976 void
1977 Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist )
1978 {
1979     dVAR;
1980     tempsym_t sym;
1981
1982     PERL_ARGS_ASSERT_PACKLIST;
1983
1984     TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
1985
1986     /* We're going to do changes through SvPVX(cat). Make sure it's valid.
1987        Also make sure any UTF8 flag is loaded */
1988     SvPV_force_nolen(cat);
1989     if (DO_UTF8(cat))
1990         sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8;
1991
1992     (void)pack_rec( cat, &sym, beglist, endlist );
1993 }
1994
1995 /* like sv_utf8_upgrade, but also repoint the group start markers */
1996 STATIC void
1997 marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) {
1998     STRLEN len;
1999     tempsym_t *group;
2000     const char *from_ptr, *from_start, *from_end, **marks, **m;
2001     char *to_start, *to_ptr;
2002
2003     if (SvUTF8(sv)) return;
2004
2005     from_start = SvPVX_const(sv);
2006     from_end = from_start + SvCUR(sv);
2007     for (from_ptr = from_start; from_ptr < from_end; from_ptr++)
2008         if (!NATIVE_BYTE_IS_INVARIANT(*from_ptr)) break;
2009     if (from_ptr == from_end) {
2010         /* Simple case: no character needs to be changed */
2011         SvUTF8_on(sv);
2012         return;
2013     }
2014
2015     len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1;
2016     Newx(to_start, len, char);
2017     Copy(from_start, to_start, from_ptr-from_start, char);
2018     to_ptr = to_start + (from_ptr-from_start);
2019
2020     Newx(marks, sym_ptr->level+2, const char *);
2021     for (group=sym_ptr; group; group = group->previous)
2022         marks[group->level] = from_start + group->strbeg;
2023     marks[sym_ptr->level+1] = from_end+1;
2024     for (m = marks; *m < from_ptr; m++)
2025         *m = to_start + (*m-from_start);
2026
2027     for (;from_ptr < from_end; from_ptr++) {
2028         while (*m == from_ptr) *m++ = to_ptr;
2029         to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr);
2030     }
2031     *to_ptr = 0;
2032
2033     while (*m == from_ptr) *m++ = to_ptr;
2034     if (m != marks + sym_ptr->level+1) {
2035         Safefree(marks);
2036         Safefree(to_start);
2037         Perl_croak(aTHX_ "panic: marks beyond string end, m=%p, marks=%p, "
2038                    "level=%d", m, marks, sym_ptr->level);
2039     }
2040     for (group=sym_ptr; group; group = group->previous)
2041         group->strbeg = marks[group->level] - to_start;
2042     Safefree(marks);
2043
2044     if (SvOOK(sv)) {
2045         if (SvIVX(sv)) {
2046             SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2047             from_start -= SvIVX(sv);
2048             SvIV_set(sv, 0);
2049         }
2050         SvFLAGS(sv) &= ~SVf_OOK;
2051     }
2052     if (SvLEN(sv) != 0)
2053         Safefree(from_start);
2054     SvPV_set(sv, to_start);
2055     SvCUR_set(sv, to_ptr - to_start);
2056     SvLEN_set(sv, len);
2057     SvUTF8_on(sv);
2058 }
2059
2060 /* Exponential string grower. Makes string extension effectively O(n)
2061    needed says how many extra bytes we need (not counting the final '\0')
2062    Only grows the string if there is an actual lack of space
2063 */
2064 STATIC char *
2065 S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) {
2066     const STRLEN cur = SvCUR(sv);
2067     const STRLEN len = SvLEN(sv);
2068     STRLEN extend;
2069
2070     PERL_ARGS_ASSERT_SV_EXP_GROW;
2071
2072     if (len - cur > needed) return SvPVX(sv);
2073     extend = needed > len ? needed : len;
2074     return SvGROW(sv, len+extend+1);
2075 }
2076
2077 STATIC
2078 SV **
2079 S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
2080 {
2081     dVAR;
2082     tempsym_t lookahead;
2083     I32 items  = endlist - beglist;
2084     bool found = next_symbol(symptr);
2085     bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
2086     bool warn_utf8 = ckWARN(WARN_UTF8);
2087     char* from;
2088
2089     PERL_ARGS_ASSERT_PACK_REC;
2090
2091     if (symptr->level == 0 && found && symptr->code == 'U') {
2092         marked_upgrade(aTHX_ cat, symptr);
2093         symptr->flags |= FLAG_DO_UTF8;
2094         utf8 = 0;
2095     }
2096     symptr->strbeg = SvCUR(cat);
2097
2098     while (found) {
2099         SV *fromstr;
2100         STRLEN fromlen;
2101         I32 len;
2102         SV *lengthcode = NULL;
2103         I32 datumtype = symptr->code;
2104         howlen_t howlen = symptr->howlen;
2105         char *start = SvPVX(cat);
2106         char *cur   = start + SvCUR(cat);
2107         bool needs_swap;
2108
2109 #define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2110
2111         switch (howlen) {
2112           case e_star:
2113             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ?
2114                 0 : items;
2115             break;
2116           default:
2117             /* e_no_len and e_number */
2118             len = symptr->length;
2119             break;
2120         }
2121
2122         if (len) {
2123             packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
2124
2125             if (props && !(props & PACK_SIZE_UNPREDICTABLE)) {
2126                 /* We can process this letter. */
2127                 STRLEN size = props & PACK_SIZE_MASK;
2128                 GROWING(utf8, cat, start, cur, (STRLEN) len * size);
2129             }
2130         }
2131
2132         /* Look ahead for next symbol. Do we have code/code? */
2133         lookahead = *symptr;
2134         found = next_symbol(&lookahead);
2135         if (symptr->flags & FLAG_SLASH) {
2136             IV count;
2137             if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack");
2138             if (strchr("aAZ", lookahead.code)) {
2139                 if (lookahead.howlen == e_number) count = lookahead.length;
2140                 else {
2141                     if (items > 0) {
2142                         count = sv_len_utf8(*beglist);
2143                     }
2144                     else count = 0;
2145                     if (lookahead.code == 'Z') count++;
2146                 }
2147             } else {
2148                 if (lookahead.howlen == e_number && lookahead.length < items)
2149                     count = lookahead.length;
2150                 else count = items;
2151             }
2152             lookahead.howlen = e_number;
2153             lookahead.length = count;
2154             lengthcode = sv_2mortal(newSViv(count));
2155         }
2156
2157         needs_swap = NEEDS_SWAP(datumtype);
2158
2159         /* Code inside the switch must take care to properly update
2160            cat (CUR length and '\0' termination) if it updated *cur and
2161            doesn't simply leave using break */
2162         switch(TYPE_NO_ENDIANNESS(datumtype)) {
2163         default:
2164             Perl_croak(aTHX_ "Invalid type '%c' in pack",
2165                        (int) TYPE_NO_MODIFIERS(datumtype));
2166         case '%':
2167             Perl_croak(aTHX_ "'%%' may not be used in pack");
2168
2169         case '.' | TYPE_IS_SHRIEKING:
2170         case '.':
2171             if (howlen == e_star) from = start;
2172             else if (len == 0) from = cur;
2173             else {
2174                 tempsym_t *group = symptr;
2175
2176                 while (--len && group) group = group->previous;
2177                 from = group ? start + group->strbeg : start;
2178             }
2179             fromstr = NEXTFROM;
2180             len = SvIV(fromstr);
2181             goto resize;
2182         case '@' | TYPE_IS_SHRIEKING:
2183         case '@':
2184             from = start + symptr->strbeg;
2185           resize:
2186             if (utf8  && !(datumtype & TYPE_IS_SHRIEKING))
2187                 if (len >= 0) {
2188                     while (len && from < cur) {
2189                         from += UTF8SKIP(from);
2190                         len--;
2191                     }
2192                     if (from > cur)
2193                         Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2194                     if (len) {
2195                         /* Here we know from == cur */
2196                       grow:
2197                         GROWING(0, cat, start, cur, len);
2198                         Zero(cur, len, char);
2199                         cur += len;
2200                     } else if (from < cur) {
2201                         len = cur - from;
2202                         goto shrink;
2203                     } else goto no_change;
2204                 } else {
2205                     cur = from;
2206                     len = -len;
2207                     goto utf8_shrink;
2208                 }
2209             else {
2210                 len -= cur - from;
2211                 if (len > 0) goto grow;
2212                 if (len == 0) goto no_change;
2213                 len = -len;
2214                 goto shrink;
2215             }
2216             break;
2217
2218         case '(': {
2219             tempsym_t savsym = *symptr;
2220             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2221             symptr->flags |= group_modifiers;
2222             symptr->patend = savsym.grpend;
2223             symptr->level++;
2224             symptr->previous = &lookahead;
2225             while (len--) {
2226                 U32 was_utf8;
2227                 if (utf8) symptr->flags |=  FLAG_PARSE_UTF8;
2228                 else      symptr->flags &= ~FLAG_PARSE_UTF8;
2229                 was_utf8 = SvUTF8(cat);
2230                 symptr->patptr = savsym.grpbeg;
2231                 beglist = pack_rec(cat, symptr, beglist, endlist);
2232                 if (SvUTF8(cat) != was_utf8)
2233                     /* This had better be an upgrade while in utf8==0 mode */
2234                     utf8 = 1;
2235
2236                 if (savsym.howlen == e_star && beglist == endlist)
2237                     break;              /* No way to continue */
2238             }
2239             items = endlist - beglist;
2240             lookahead.flags  = symptr->flags & ~group_modifiers;
2241             goto no_change;
2242         }
2243         case 'X' | TYPE_IS_SHRIEKING:
2244             if (!len)                   /* Avoid division by 0 */
2245                 len = 1;
2246             if (utf8) {
2247                 char *hop, *last;
2248                 I32 l = len;
2249                 hop = last = start;
2250                 while (hop < cur) {
2251                     hop += UTF8SKIP(hop);
2252                     if (--l == 0) {
2253                         last = hop;
2254                         l = len;
2255                     }
2256                 }
2257                 if (last > cur)
2258                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2259                 cur = last;
2260                 break;
2261             }
2262             len = (cur-start) % len;
2263             /* FALLTHROUGH */
2264         case 'X':
2265             if (utf8) {
2266                 if (len < 1) goto no_change;
2267               utf8_shrink:
2268                 while (len > 0) {
2269                     if (cur <= start)
2270                         Perl_croak(aTHX_ "'%c' outside of string in pack",
2271                                    (int) TYPE_NO_MODIFIERS(datumtype));
2272                     while (--cur, UTF8_IS_CONTINUATION(*cur)) {
2273                         if (cur <= start)
2274                             Perl_croak(aTHX_ "'%c' outside of string in pack",
2275                                        (int) TYPE_NO_MODIFIERS(datumtype));
2276                     }
2277                     len--;
2278                 }
2279             } else {
2280               shrink:
2281                 if (cur - start < len)
2282                     Perl_croak(aTHX_ "'%c' outside of string in pack",
2283                                (int) TYPE_NO_MODIFIERS(datumtype));
2284                 cur -= len;
2285             }
2286             if (cur < start+symptr->strbeg) {
2287                 /* Make sure group starts don't point into the void */
2288                 tempsym_t *group;
2289                 const STRLEN length = cur-start;
2290                 for (group = symptr;
2291                      group && length < group->strbeg;
2292                      group = group->previous) group->strbeg = length;
2293                 lookahead.strbeg = length;
2294             }
2295             break;
2296         case 'x' | TYPE_IS_SHRIEKING: {
2297             I32 ai32;
2298             if (!len)                   /* Avoid division by 0 */
2299                 len = 1;
2300             if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len;
2301             else      ai32 = (cur - start) % len;
2302             if (ai32 == 0) goto no_change;
2303             len -= ai32;
2304         }
2305         /* FALLTHROUGH */
2306         case 'x':
2307             goto grow;
2308         case 'A':
2309         case 'Z':
2310         case 'a': {
2311             const char *aptr;
2312
2313             fromstr = NEXTFROM;
2314             aptr = SvPV_const(fromstr, fromlen);
2315             if (DO_UTF8(fromstr)) {
2316                 const char *end, *s;
2317
2318                 if (!utf8 && !SvUTF8(cat)) {
2319                     marked_upgrade(aTHX_ cat, symptr);
2320                     lookahead.flags |= FLAG_DO_UTF8;
2321                     lookahead.strbeg = symptr->strbeg;
2322                     utf8 = 1;
2323                     start = SvPVX(cat);
2324                     cur = start + SvCUR(cat);
2325                 }
2326                 if (howlen == e_star) {
2327                     if (utf8) goto string_copy;
2328                     len = fromlen+1;
2329                 }
2330                 s = aptr;
2331                 end = aptr + fromlen;
2332                 fromlen = datumtype == 'Z' ? len-1 : len;
2333                 while ((I32) fromlen > 0 && s < end) {
2334                     s += UTF8SKIP(s);
2335                     fromlen--;
2336                 }
2337                 if (s > end)
2338                     Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2339                 if (utf8) {
2340                     len = fromlen;
2341                     if (datumtype == 'Z') len++;
2342                     fromlen = s-aptr;
2343                     len += fromlen;
2344
2345                     goto string_copy;
2346                 }
2347                 fromlen = len - fromlen;
2348                 if (datumtype == 'Z') fromlen--;
2349                 if (howlen == e_star) {
2350                     len = fromlen;
2351                     if (datumtype == 'Z') len++;
2352                 }
2353                 GROWING(0, cat, start, cur, len);
2354                 if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
2355                                   datumtype | TYPE_IS_PACK))
2356                     Perl_croak(aTHX_ "panic: predicted utf8 length not available, "
2357                                "for '%c', aptr=%p end=%p cur=%p, fromlen=%"UVuf,
2358                                (int)datumtype, aptr, end, cur, (UV)fromlen);
2359                 cur += fromlen;
2360                 len -= fromlen;
2361             } else if (utf8) {
2362                 if (howlen == e_star) {
2363                     len = fromlen;
2364                     if (datumtype == 'Z') len++;
2365                 }
2366                 if (len <= (I32) fromlen) {
2367                     fromlen = len;
2368                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2369                 }
2370                 /* assumes a byte expands to at most UTF8_EXPAND bytes on
2371                    upgrade, so:
2372                    expected_length <= from_len*UTF8_EXPAND + (len-from_len) */
2373                 GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len);
2374                 len -= fromlen;
2375                 while (fromlen > 0) {
2376                     cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr);
2377                     aptr++;
2378                     fromlen--;
2379                 }
2380             } else {
2381               string_copy:
2382                 if (howlen == e_star) {
2383                     len = fromlen;
2384                     if (datumtype == 'Z') len++;
2385                 }
2386                 if (len <= (I32) fromlen) {
2387                     fromlen = len;
2388                     if (datumtype == 'Z' && fromlen > 0) fromlen--;
2389                 }
2390                 GROWING(0, cat, start, cur, len);
2391                 Copy(aptr, cur, fromlen, char);
2392                 cur += fromlen;
2393                 len -= fromlen;
2394             }
2395             memset(cur, datumtype == 'A' ? ' ' : '\0', len);
2396             cur += len;
2397             SvTAINT(cat);
2398             break;
2399         }
2400         case 'B':
2401         case 'b': {
2402             const char *str, *end;
2403             I32 l, field_len;
2404             U8 bits;
2405             bool utf8_source;
2406             U32 utf8_flags;
2407
2408             fromstr = NEXTFROM;
2409             str = SvPV_const(fromstr, fromlen);
2410             end = str + fromlen;
2411             if (DO_UTF8(fromstr)) {
2412                 utf8_source = TRUE;
2413                 utf8_flags  = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2414             } else {
2415                 utf8_source = FALSE;
2416                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2417             }
2418             if (howlen == e_star) len = fromlen;
2419             field_len = (len+7)/8;
2420             GROWING(utf8, cat, start, cur, field_len);
2421             if (len > (I32)fromlen) len = fromlen;
2422             bits = 0;
2423             l = 0;
2424             if (datumtype == 'B')
2425                 while (l++ < len) {
2426                     if (utf8_source) {
2427                         UV val = 0;
2428                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2429                         bits |= val & 1;
2430                     } else bits |= *str++ & 1;
2431                     if (l & 7) bits <<= 1;
2432                     else {
2433                         PUSH_BYTE(utf8, cur, bits);
2434                         bits = 0;
2435                     }
2436                 }
2437             else
2438                 /* datumtype == 'b' */
2439                 while (l++ < len) {
2440                     if (utf8_source) {
2441                         UV val = 0;
2442                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2443                         if (val & 1) bits |= 0x80;
2444                     } else if (*str++ & 1)
2445                         bits |= 0x80;
2446                     if (l & 7) bits >>= 1;
2447                     else {
2448                         PUSH_BYTE(utf8, cur, bits);
2449                         bits = 0;
2450                     }
2451                 }
2452             l--;
2453             if (l & 7) {
2454                 if (datumtype == 'B')
2455                     bits <<= 7 - (l & 7);
2456                 else
2457                     bits >>= 7 - (l & 7);
2458                 PUSH_BYTE(utf8, cur, bits);
2459                 l += 7;
2460             }
2461             /* Determine how many chars are left in the requested field */
2462             l /= 8;
2463             if (howlen == e_star) field_len = 0;
2464             else field_len -= l;
2465             Zero(cur, field_len, char);
2466             cur += field_len;
2467             break;
2468         }
2469         case 'H':
2470         case 'h': {
2471             const char *str, *end;
2472             I32 l, field_len;
2473             U8 bits;
2474             bool utf8_source;
2475             U32 utf8_flags;
2476
2477             fromstr = NEXTFROM;
2478             str = SvPV_const(fromstr, fromlen);
2479             end = str + fromlen;
2480             if (DO_UTF8(fromstr)) {
2481                 utf8_source = TRUE;
2482                 utf8_flags  = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2483             } else {
2484                 utf8_source = FALSE;
2485                 utf8_flags  = 0; /* Unused, but keep compilers happy */
2486             }
2487             if (howlen == e_star) len = fromlen;
2488             field_len = (len+1)/2;
2489             GROWING(utf8, cat, start, cur, field_len);
2490             if (!utf8 && len > (I32)fromlen) len = fromlen;
2491             bits = 0;
2492             l = 0;
2493             if (datumtype == 'H')
2494                 while (l++ < len) {
2495                     if (utf8_source) {
2496                         UV val = 0;
2497                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2498                         if (val < 256 && isALPHA(val))
2499                             bits |= (val + 9) & 0xf;
2500                         else
2501                             bits |= val & 0xf;
2502                     } else if (isALPHA(*str))
2503                         bits |= (*str++ + 9) & 0xf;
2504                     else
2505                         bits |= *str++ & 0xf;
2506                     if (l & 1) bits <<= 4;
2507                     else {
2508                         PUSH_BYTE(utf8, cur, bits);
2509                         bits = 0;
2510                     }
2511                 }
2512             else
2513                 while (l++ < len) {
2514                     if (utf8_source) {
2515                         UV val = 0;
2516                         NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2517                         if (val < 256 && isALPHA(val))
2518                             bits |= ((val + 9) & 0xf) << 4;
2519                         else
2520                             bits |= (val & 0xf) << 4;
2521                     } else if (isALPHA(*str))
2522                         bits |= ((*str++ + 9) & 0xf) << 4;
2523                     else
2524                         bits |= (*str++ & 0xf) << 4;
2525                     if (l & 1) bits >>= 4;
2526                     else {
2527                         PUSH_BYTE(utf8, cur, bits);
2528                         bits = 0;
2529                     }
2530                 }
2531             l--;
2532             if (l & 1) {
2533                 PUSH_BYTE(utf8, cur, bits);
2534                 l++;
2535             }
2536             /* Determine how many chars are left in the requested field */
2537             l /= 2;
2538             if (howlen == e_star) field_len = 0;
2539             else field_len -= l;
2540             Zero(cur, field_len, char);
2541             cur += field_len;
2542             break;
2543         }
2544         case 'c':
2545             while (len-- > 0) {
2546                 IV aiv;
2547                 fromstr = NEXTFROM;
2548                 aiv = SvIV(fromstr);
2549                 if ((-128 > aiv || aiv > 127))
2550                     Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2551                                    "Character in 'c' format wrapped in pack");
2552                 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2553             }
2554             break;
2555         case 'C':
2556             if (len == 0) {
2557                 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
2558                 break;
2559             }
2560             while (len-- > 0) {
2561                 IV aiv;
2562                 fromstr = NEXTFROM;
2563                 aiv = SvIV(fromstr);
2564                 if ((0 > aiv || aiv > 0xff))
2565                     Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2566                                    "Character in 'C' format wrapped in pack");
2567                 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2568             }
2569             break;
2570         case 'W': {
2571             char *end;
2572             U8 in_bytes = (U8)IN_BYTES;
2573
2574             end = start+SvLEN(cat)-1;
2575             if (utf8) end -= UTF8_MAXLEN-1;
2576             while (len-- > 0) {
2577                 UV auv;
2578                 fromstr = NEXTFROM;
2579                 auv = SvUV(fromstr);
2580                 if (in_bytes) auv = auv % 0x100;
2581                 if (utf8) {
2582                   W_utf8:
2583                     if (cur > end) {
2584                         *cur = '\0';
2585                         SvCUR_set(cat, cur - start);
2586
2587                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2588                         end = start+SvLEN(cat)-UTF8_MAXLEN;
2589                     }
2590                     cur = (char *) uvchr_to_utf8_flags((U8 *) cur,
2591                                                        auv,
2592                                                        warn_utf8 ?
2593                                                        0 : UNICODE_ALLOW_ANY);
2594                 } else {
2595                     if (auv >= 0x100) {
2596                         if (!SvUTF8(cat)) {
2597                             *cur = '\0';
2598                             SvCUR_set(cat, cur - start);
2599                             marked_upgrade(aTHX_ cat, symptr);
2600                             lookahead.flags |= FLAG_DO_UTF8;
2601                             lookahead.strbeg = symptr->strbeg;
2602                             utf8 = 1;
2603                             start = SvPVX(cat);
2604                             cur = start + SvCUR(cat);
2605                             end = start+SvLEN(cat)-UTF8_MAXLEN;
2606                             goto W_utf8;
2607                         }
2608                         Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2609                                        "Character in 'W' format wrapped in pack");
2610                         auv &= 0xff;
2611                     }
2612                     if (cur >= end) {
2613                         *cur = '\0';
2614                         SvCUR_set(cat, cur - start);
2615                         GROWING(0, cat, start, cur, len+1);
2616                         end = start+SvLEN(cat)-1;
2617                     }
2618                     *(U8 *) cur++ = (U8)auv;
2619                 }
2620             }
2621             break;
2622         }
2623         case 'U': {
2624             char *end;
2625
2626             if (len == 0) {
2627                 if (!(symptr->flags & FLAG_DO_UTF8)) {
2628                     marked_upgrade(aTHX_ cat, symptr);
2629                     lookahead.flags |= FLAG_DO_UTF8;
2630                     lookahead.strbeg = symptr->strbeg;
2631                 }
2632                 utf8 = 0;
2633                 goto no_change;
2634             }
2635
2636             end = start+SvLEN(cat);
2637             if (!utf8) end -= UTF8_MAXLEN;
2638             while (len-- > 0) {
2639                 UV auv;
2640                 fromstr = NEXTFROM;
2641                 auv = SvUV(fromstr);
2642                 if (utf8) {
2643                     U8 buffer[UTF8_MAXLEN], *endb;
2644                     endb = uvchr_to_utf8_flags(buffer, auv,
2645                                                warn_utf8 ?
2646                                                0 : UNICODE_ALLOW_ANY);
2647                     if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
2648                         *cur = '\0';
2649                         SvCUR_set(cat, cur - start);
2650                         GROWING(0, cat, start, cur,
2651                                 len+(endb-buffer)*UTF8_EXPAND);
2652                         end = start+SvLEN(cat);
2653                     }
2654                     cur = S_bytes_to_uni(buffer, endb-buffer, cur, 0);
2655                 } else {
2656                     if (cur >= end) {
2657                         *cur = '\0';
2658                         SvCUR_set(cat, cur - start);
2659                         GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2660                         end = start+SvLEN(cat)-UTF8_MAXLEN;
2661                     }
2662                     cur = (char *) uvchr_to_utf8_flags((U8 *) cur, auv,
2663                                                        warn_utf8 ?
2664                                                        0 : UNICODE_ALLOW_ANY);
2665                 }
2666             }
2667             break;
2668         }
2669         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2670         case 'f':
2671             while (len-- > 0) {
2672                 float afloat;
2673                 NV anv;
2674                 fromstr = NEXTFROM;
2675                 anv = SvNV(fromstr);
2676 # if defined(VMS) && !defined(_IEEE_FP)
2677                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2678                  * on Alpha; fake it if we don't have them.
2679                  */
2680                 if (anv > FLT_MAX)
2681                     afloat = FLT_MAX;
2682                 else if (anv < -FLT_MAX)
2683                     afloat = -FLT_MAX;
2684                 else afloat = (float)anv;
2685 # else
2686                 afloat = (float)anv;
2687 # endif
2688                 PUSH_VAR(utf8, cur, afloat, needs_swap);
2689             }
2690             break;
2691         case 'd':
2692             while (len-- > 0) {
2693                 double adouble;
2694                 NV anv;
2695                 fromstr = NEXTFROM;
2696                 anv = SvNV(fromstr);
2697 # if defined(VMS) && !defined(_IEEE_FP)
2698                 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2699                  * on Alpha; fake it if we don't have them.
2700                  */
2701                 if (anv > DBL_MAX)
2702                     adouble = DBL_MAX;
2703                 else if (anv < -DBL_MAX)
2704                     adouble = -DBL_MAX;
2705                 else adouble = (double)anv;
2706 # else
2707                 adouble = (double)anv;
2708 # endif
2709                 PUSH_VAR(utf8, cur, adouble, needs_swap);
2710             }
2711             break;
2712         case 'F': {
2713             NV_bytes anv;
2714             Zero(&anv, 1, NV); /* can be long double with unused bits */
2715             while (len-- > 0) {
2716                 fromstr = NEXTFROM;
2717 #ifdef __GNUC__
2718                 /* to work round a gcc/x86 bug; don't use SvNV */
2719                 anv.nv = sv_2nv(fromstr);
2720 #else
2721                 anv.nv = SvNV(fromstr);
2722 #endif
2723                 PUSH_BYTES(utf8, cur, anv.bytes, sizeof(anv.bytes), needs_swap);
2724             }
2725             break;
2726         }
2727 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2728         case 'D': {
2729             ld_bytes aldouble;
2730             /* long doubles can have unused bits, which may be nonzero */
2731             Zero(&aldouble, 1, long double);
2732             while (len-- > 0) {
2733                 fromstr = NEXTFROM;
2734 #  ifdef __GNUC__
2735                 /* to work round a gcc/x86 bug; don't use SvNV */
2736                 aldouble.ld = (long double)sv_2nv(fromstr);
2737 #  else
2738                 aldouble.ld = (long double)SvNV(fromstr);
2739 #  endif
2740                 PUSH_BYTES(utf8, cur, aldouble.bytes, sizeof(aldouble.bytes),
2741                            needs_swap);
2742             }
2743             break;
2744         }
2745 #endif
2746         case 'n' | TYPE_IS_SHRIEKING:
2747         case 'n':
2748             while (len-- > 0) {
2749                 I16 ai16;
2750                 fromstr = NEXTFROM;
2751                 ai16 = (I16)SvIV(fromstr);
2752                 ai16 = PerlSock_htons(ai16);
2753                 PUSH16(utf8, cur, &ai16, FALSE);
2754             }
2755             break;
2756         case 'v' | TYPE_IS_SHRIEKING:
2757         case 'v':
2758             while (len-- > 0) {
2759                 I16 ai16;
2760                 fromstr = NEXTFROM;
2761                 ai16 = (I16)SvIV(fromstr);
2762                 ai16 = htovs(ai16);
2763                 PUSH16(utf8, cur, &ai16, FALSE);
2764             }
2765             break;
2766         case 'S' | TYPE_IS_SHRIEKING:
2767 #if SHORTSIZE != SIZE16
2768             while (len-- > 0) {
2769                 unsigned short aushort;
2770                 fromstr = NEXTFROM;
2771                 aushort = SvUV(fromstr);
2772                 PUSH_VAR(utf8, cur, aushort, needs_swap);
2773             }
2774             break;
2775 #else
2776             /* FALLTHROUGH */
2777 #endif
2778         case 'S':
2779             while (len-- > 0) {
2780                 U16 au16;
2781                 fromstr = NEXTFROM;
2782                 au16 = (U16)SvUV(fromstr);
2783                 PUSH16(utf8, cur, &au16, needs_swap);
2784             }
2785             break;
2786         case 's' | TYPE_IS_SHRIEKING:
2787 #if SHORTSIZE != SIZE16
2788             while (len-- > 0) {
2789                 short ashort;
2790                 fromstr = NEXTFROM;
2791                 ashort = SvIV(fromstr);
2792                 PUSH_VAR(utf8, cur, ashort, needs_swap);
2793             }
2794             break;
2795 #else
2796             /* FALLTHROUGH */
2797 #endif
2798         case 's':
2799             while (len-- > 0) {
2800                 I16 ai16;
2801                 fromstr = NEXTFROM;
2802                 ai16 = (I16)SvIV(fromstr);
2803                 PUSH16(utf8, cur, &ai16, needs_swap);
2804             }
2805             break;
2806         case 'I':
2807         case 'I' | TYPE_IS_SHRIEKING:
2808             while (len-- > 0) {
2809                 unsigned int auint;
2810                 fromstr = NEXTFROM;
2811                 auint = SvUV(fromstr);
2812                 PUSH_VAR(utf8, cur, auint, needs_swap);
2813             }
2814             break;
2815         case 'j':
2816             while (len-- > 0) {
2817                 IV aiv;
2818                 fromstr = NEXTFROM;
2819                 aiv = SvIV(fromstr);
2820                 PUSH_VAR(utf8, cur, aiv, needs_swap);
2821             }
2822             break;
2823         case 'J':
2824             while (len-- > 0) {
2825                 UV auv;
2826                 fromstr = NEXTFROM;
2827                 auv = SvUV(fromstr);
2828                 PUSH_VAR(utf8, cur, auv, needs_swap);
2829             }
2830             break;
2831         case 'w':
2832             while (len-- > 0) {
2833                 NV anv;
2834                 fromstr = NEXTFROM;
2835                 anv = SvNV(fromstr);
2836
2837                 if (anv < 0) {
2838                     *cur = '\0';
2839                     SvCUR_set(cat, cur - start);
2840                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2841                 }
2842
2843                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2844                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2845                    any negative IVs will have already been got by the croak()
2846                    above. IOK is untrue for fractions, so we test them
2847                    against UV_MAX_P1.  */
2848                 if (SvIOK(fromstr) || anv < UV_MAX_P1) {
2849                     char   buf[(sizeof(UV)*CHAR_BIT)/7+1];
2850                     char  *in = buf + sizeof(buf);
2851                     UV     auv = SvUV(fromstr);
2852
2853                     do {
2854                         *--in = (char)((auv & 0x7f) | 0x80);
2855                         auv >>= 7;
2856                     } while (auv);
2857                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2858                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
2859                                        in, (buf + sizeof(buf)) - in);
2860                 } else if (SvPOKp(fromstr))
2861                     goto w_string;
2862                 else if (SvNOKp(fromstr)) {
2863                     /* 10**NV_MAX_10_EXP is the largest power of 10
2864                        so 10**(NV_MAX_10_EXP+1) is definitely unrepresentable
2865                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2866                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2867                        And with that many bytes only Inf can overflow.
2868                        Some C compilers are strict about integral constant
2869                        expressions so we conservatively divide by a slightly
2870                        smaller integer instead of multiplying by the exact
2871                        floating-point value.
2872                     */
2873 #ifdef NV_MAX_10_EXP
2874                     /* char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2875                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2876 #else
2877                     /* char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2878                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2879 #endif
2880                     char  *in = buf + sizeof(buf);
2881
2882                     anv = Perl_floor(anv);
2883                     do {
2884                         const NV next = Perl_floor(anv / 128);
2885                         if (in <= buf)  /* this cannot happen ;-) */
2886                             Perl_croak(aTHX_ "Cannot compress integer in pack");
2887                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2888                         anv = next;
2889                     } while (anv > 0);
2890                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2891                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
2892                                        in, (buf + sizeof(buf)) - in);
2893                 } else {
2894                     const char     *from;
2895                     char           *result, *in;
2896                     SV             *norm;
2897                     STRLEN          len;
2898                     bool            done;
2899
2900                   w_string:
2901                     /* Copy string and check for compliance */
2902                     from = SvPV_const(fromstr, len);
2903                     if ((norm = is_an_int(from, len)) == NULL)
2904                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2905
2906                     Newx(result, len, char);
2907                     in = result + len;
2908                     done = FALSE;
2909                     while (!done) *--in = div128(norm, &done) | 0x80;
2910                     result[len - 1] &= 0x7F; /* clear continue bit */
2911                     PUSH_GROWING_BYTES(utf8, cat, start, cur,
2912                                        in, (result + len) - in);
2913                     Safefree(result);
2914                     SvREFCNT_dec(norm); /* free norm */
2915                 }
2916             }
2917             break;
2918         case 'i':
2919         case 'i' | TYPE_IS_SHRIEKING:
2920             while (len-- > 0) {
2921                 int aint;
2922                 fromstr = NEXTFROM;
2923                 aint = SvIV(fromstr);
2924                 PUSH_VAR(utf8, cur, aint, needs_swap);
2925             }
2926             break;
2927         case 'N' | TYPE_IS_SHRIEKING:
2928         case 'N':
2929             while (len-- > 0) {
2930                 U32 au32;
2931                 fromstr = NEXTFROM;
2932                 au32 = SvUV(fromstr);
2933                 au32 = PerlSock_htonl(au32);
2934                 PUSH32(utf8, cur, &au32, FALSE);
2935             }
2936             break;
2937         case 'V' | TYPE_IS_SHRIEKING:
2938         case 'V':
2939             while (len-- > 0) {
2940                 U32 au32;
2941                 fromstr = NEXTFROM;
2942                 au32 = SvUV(fromstr);
2943                 au32 = htovl(au32);
2944                 PUSH32(utf8, cur, &au32, FALSE);
2945             }
2946             break;
2947         case 'L' | TYPE_IS_SHRIEKING:
2948 #if LONGSIZE != SIZE32
2949             while (len-- > 0) {
2950                 unsigned long aulong;
2951                 fromstr = NEXTFROM;
2952                 aulong = SvUV(fromstr);
2953                 PUSH_VAR(utf8, cur, aulong, needs_swap);
2954             }
2955             break;
2956 #else
2957             /* Fall though! */
2958 #endif
2959         case 'L':
2960             while (len-- > 0) {
2961                 U32 au32;
2962                 fromstr = NEXTFROM;
2963                 au32 = SvUV(fromstr);
2964                 PUSH32(utf8, cur, &au32, needs_swap);
2965             }
2966             break;
2967         case 'l' | TYPE_IS_SHRIEKING:
2968 #if LONGSIZE != SIZE32
2969             while (len-- > 0) {
2970                 long along;
2971                 fromstr = NEXTFROM;
2972                 along = SvIV(fromstr);
2973                 PUSH_VAR(utf8, cur, along, needs_swap);
2974             }
2975             break;
2976 #else
2977             /* Fall though! */
2978 #endif
2979         case 'l':
2980             while (len-- > 0) {
2981                 I32 ai32;
2982                 fromstr = NEXTFROM;
2983                 ai32 = SvIV(fromstr);
2984                 PUSH32(utf8, cur, &ai32, needs_swap);
2985             }
2986             break;
2987 #if defined(HAS_QUAD) && IVSIZE >= 8
2988         case 'Q':
2989             while (len-- > 0) {
2990                 Uquad_t auquad;
2991                 fromstr = NEXTFROM;
2992                 auquad = (Uquad_t) SvUV(fromstr);
2993                 PUSH_VAR(utf8, cur, auquad, needs_swap);
2994             }
2995             break;
2996         case 'q':
2997             while (len-- > 0) {
2998                 Quad_t aquad;
2999                 fromstr = NEXTFROM;
3000                 aquad = (Quad_t)SvIV(fromstr);
3001                 PUSH_VAR(utf8, cur, aquad, needs_swap);
3002             }
3003             break;
3004 #endif
3005         case 'P':
3006             len = 1;            /* assume SV is correct length */
3007             GROWING(utf8, cat, start, cur, sizeof(char *));
3008             /* FALLTHROUGH */
3009         case 'p':
3010             while (len-- > 0) {
3011                 const char *aptr;
3012
3013                 fromstr = NEXTFROM;
3014                 SvGETMAGIC(fromstr);
3015                 if (!SvOK(fromstr)) aptr = NULL;
3016                 else {
3017                     /* XXX better yet, could spirit away the string to
3018                      * a safe spot and hang on to it until the result
3019                      * of pack() (and all copies of the result) are
3020                      * gone.
3021                      */
3022                     if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
3023                              !SvREADONLY(fromstr)))) {
3024                         Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3025                                        "Attempt to pack pointer to temporary value");
3026                     }
3027                     if (SvPOK(fromstr) || SvNIOK(fromstr))
3028                         aptr = SvPV_nomg_const_nolen(fromstr);
3029                     else
3030                         aptr = SvPV_force_flags_nolen(fromstr, 0);
3031                 }
3032                 PUSH_VAR(utf8, cur, aptr, needs_swap);
3033             }
3034             break;
3035         case 'u': {
3036             const char *aptr, *aend;
3037             bool from_utf8;
3038
3039             fromstr = NEXTFROM;
3040             if (len <= 2) len = 45;
3041             else len = len / 3 * 3;
3042             if (len >= 64) {
3043                 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3044                                "Field too wide in 'u' format in pack");
3045                 len = 63;
3046             }
3047             aptr = SvPV_const(fromstr, fromlen);
3048             from_utf8 = DO_UTF8(fromstr);
3049             if (from_utf8) {
3050                 aend = aptr + fromlen;
3051                 fromlen = sv_len_utf8_nomg(fromstr);
3052             } else aend = NULL; /* Unused, but keep compilers happy */
3053             GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2);
3054             while (fromlen > 0) {
3055                 U8 *end;
3056                 I32 todo;
3057                 U8 hunk[1+63/3*4+1];
3058
3059                 if ((I32)fromlen > len)
3060                     todo = len;
3061                 else
3062                     todo = fromlen;
3063                 if (from_utf8) {
3064                     char buffer[64];
3065                     if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo,
3066                                       'u' | TYPE_IS_PACK)) {
3067                         *cur = '\0';
3068                         SvCUR_set(cat, cur - start);
3069                         Perl_croak(aTHX_ "panic: string is shorter than advertised, "
3070                                    "aptr=%p, aend=%p, buffer=%p, todo=%ld",
3071                                    aptr, aend, buffer, (long) todo);
3072                     }
3073                     end = doencodes(hunk, buffer, todo);
3074                 } else {
3075                     end = doencodes(hunk, aptr, todo);
3076                     aptr += todo;
3077                 }
3078                 PUSH_BYTES(utf8, cur, hunk, end-hunk, 0);
3079                 fromlen -= todo;
3080             }
3081             break;
3082         }
3083         }
3084         *cur = '\0';
3085         SvCUR_set(cat, cur - start);
3086       no_change:
3087         *symptr = lookahead;
3088     }
3089     return beglist;
3090 }
3091 #undef NEXTFROM
3092
3093
3094 PP(pp_pack)
3095 {
3096     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3097     SV *cat = TARG;
3098     STRLEN fromlen;
3099     SV *pat_sv = *++MARK;
3100     const char *pat = SvPV_const(pat_sv, fromlen);
3101     const char *patend = pat + fromlen;
3102
3103     MARK++;
3104     sv_setpvs(cat, "");
3105     SvUTF8_off(cat);
3106
3107     packlist(cat, pat, patend, MARK, SP + 1);
3108
3109     SvSETMAGIC(cat);
3110     SP = ORIGMARK;
3111     PUSHs(cat);
3112     RETURN;
3113 }
3114
3115 /*
3116  * Local variables:
3117  * c-indentation-style: bsd
3118  * c-basic-offset: 4
3119  * indent-tabs-mode: nil
3120  * End:
3121  *
3122  * ex: set ts=8 sts=4 sw=4 et:
3123  */