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