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