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