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