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