3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
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.
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,
18 * [p.653 of _The Lord of the Rings_, IV/iv: "Of Herbs and Stewed Rabbit"]
21 /* This file contains pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
27 * This particular file just contains pp_pack() and pp_unpack(). See the
28 * other pp*.c files for the rest of the pp_ functions.
32 #define PERL_IN_PP_PACK_C
35 /* Types used by pack/unpack */
37 e_no_len, /* no length */
38 e_number, /* number, [] */
42 typedef struct tempsym {
43 const char* patptr; /* current template char */
44 const char* patend; /* one after last char */
45 const char* grpbeg; /* 1st char of ()-group */
46 const char* grpend; /* end of ()-group */
47 I32 code; /* template code (!<>) */
48 I32 length; /* length/repeat count */
49 howlen_t howlen; /* how length is given */
50 int level; /* () nesting level */
51 U32 flags; /* /=4, comma=2, pack=1 */
52 /* and group modifiers */
53 STRLEN strbeg; /* offset of group start */
54 struct tempsym *previous; /* previous group */
57 #define TEMPSYM_INIT(symptr, p, e, f) \
59 (symptr)->patptr = (p); \
60 (symptr)->patend = (e); \
61 (symptr)->grpbeg = NULL; \
62 (symptr)->grpend = NULL; \
63 (symptr)->grpend = NULL; \
65 (symptr)->length = 0; \
66 (symptr)->howlen = e_no_len; \
67 (symptr)->level = 0; \
68 (symptr)->flags = (f); \
69 (symptr)->strbeg = 0; \
70 (symptr)->previous = NULL; \
74 # define PERL_PACK_CAN_BYTEORDER
75 # define PERL_PACK_CAN_SHRIEKSIGN
81 /* Maximum number of bytes to which a byte can grow due to upgrade */
85 * Offset for integer pack/unpack.
87 * On architectures where I16 and I32 aren't really 16 and 32 bits,
88 * which for now are all Crays, pack and unpack have to play games.
92 * These values are required for portability of pack() output.
93 * If they're not right on your machine, then pack() and unpack()
94 * wouldn't work right anyway; you'll need to apply the Cray hack.
95 * (I'd like to check them with #if, but you can't use sizeof() in
96 * the preprocessor.) --???
99 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
100 defines are now in config.h. --Andy Dougherty April 1998
105 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
108 #if U16SIZE > SIZE16 || U32SIZE > SIZE32
109 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
110 # define OFF16(p) ((char*)(p))
111 # define OFF32(p) ((char*)(p))
113 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
114 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
115 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
117 ++++ bad cray byte order
121 # define OFF16(p) ((char *) (p))
122 # define OFF32(p) ((char *) (p))
125 /* Only to be used inside a loop (see the break) */
126 #define SHIFT16(utf8, s, strend, p, datumtype) STMT_START { \
128 if (!uni_to_bytes(aTHX_ &(s), strend, OFF16(p), SIZE16, datumtype)) break; \
130 Copy(s, OFF16(p), SIZE16, char); \
135 /* Only to be used inside a loop (see the break) */
136 #define SHIFT32(utf8, s, strend, p, datumtype) STMT_START { \
138 if (!uni_to_bytes(aTHX_ &(s), strend, OFF32(p), SIZE32, datumtype)) break; \
140 Copy(s, OFF32(p), SIZE32, char); \
145 #define PUSH16(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF16(p), SIZE16)
146 #define PUSH32(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF32(p), SIZE32)
148 /* Only to be used inside a loop (see the break) */
149 #define SHIFT_VAR(utf8, s, strend, var, datumtype) \
152 if (!uni_to_bytes(aTHX_ &s, strend, \
153 (char *) &var, sizeof(var), datumtype)) break;\
155 Copy(s, (char *) &var, sizeof(var), char); \
160 #define PUSH_VAR(utf8, aptr, var) \
161 PUSH_BYTES(utf8, aptr, &(var), sizeof(var))
163 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
164 #define MAX_SUB_TEMPLATE_LEVEL 100
166 /* flags (note that type modifiers can also be used as flags!) */
167 #define FLAG_WAS_UTF8 0x40
168 #define FLAG_PARSE_UTF8 0x20 /* Parse as utf8 */
169 #define FLAG_UNPACK_ONLY_ONE 0x10
170 #define FLAG_DO_UTF8 0x08 /* The underlying string is utf8 */
171 #define FLAG_SLASH 0x04
172 #define FLAG_COMMA 0x02
173 #define FLAG_PACK 0x01
176 S_mul128(pTHX_ SV *sv, U8 m)
179 char *s = SvPV(sv, len);
182 PERL_ARGS_ASSERT_MUL128;
184 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
185 SV * const tmpNew = newSVpvs("0000000000");
187 sv_catsv(tmpNew, sv);
188 SvREFCNT_dec(sv); /* free old sv */
193 while (!*t) /* trailing '\0'? */
196 const U32 i = ((*t - '0') << 7) + m;
197 *(t--) = '0' + (char)(i % 10);
203 /* Explosives and implosives. */
205 #if 'I' == 73 && 'J' == 74
206 /* On an ASCII/ISO kind of system */
207 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
210 Some other sort of character set - use memchr() so we don't match
213 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
217 #define TYPE_IS_SHRIEKING 0x100
218 #define TYPE_IS_BIG_ENDIAN 0x200
219 #define TYPE_IS_LITTLE_ENDIAN 0x400
220 #define TYPE_IS_PACK 0x800
221 #define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
222 #define TYPE_MODIFIERS(t) ((t) & ~0xFF)
223 #define TYPE_NO_MODIFIERS(t) ((t) & 0xFF)
225 #ifdef PERL_PACK_CAN_SHRIEKSIGN
226 # define SHRIEKING_ALLOWED_TYPES "sSiIlLxXnNvV@."
228 # define SHRIEKING_ALLOWED_TYPES "sSiIlLxX"
231 #ifndef PERL_PACK_CAN_BYTEORDER
232 /* Put "can't" first because it is shorter */
233 # define TYPE_ENDIANNESS(t) 0
234 # define TYPE_NO_ENDIANNESS(t) (t)
236 # define ENDIANNESS_ALLOWED_TYPES ""
238 # define DO_BO_UNPACK(var, type)
239 # define DO_BO_PACK(var, type)
240 # define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast)
241 # define DO_BO_PACK_PTR(var, type, pre_cast, post_cast)
242 # define DO_BO_UNPACK_N(var, type)
243 # define DO_BO_PACK_N(var, type)
244 # define DO_BO_UNPACK_P(var)
245 # define DO_BO_PACK_P(var)
246 # define DO_BO_UNPACK_PC(var)
247 # define DO_BO_PACK_PC(var)
249 #else /* PERL_PACK_CAN_BYTEORDER */
251 # define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK)
252 # define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK)
254 # define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP("
256 # define DO_BO_UNPACK(var, type) \
258 switch (TYPE_ENDIANNESS(datumtype)) { \
259 case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \
260 case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \
265 # define DO_BO_PACK(var, type) \
267 switch (TYPE_ENDIANNESS(datumtype)) { \
268 case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \
269 case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \
274 # define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast) \
276 switch (TYPE_ENDIANNESS(datumtype)) { \
277 case TYPE_IS_BIG_ENDIAN: \
278 var = (post_cast*) my_betoh ## type ((pre_cast) var); \
280 case TYPE_IS_LITTLE_ENDIAN: \
281 var = (post_cast *) my_letoh ## type ((pre_cast) var); \
288 # define DO_BO_PACK_PTR(var, type, pre_cast, post_cast) \
290 switch (TYPE_ENDIANNESS(datumtype)) { \
291 case TYPE_IS_BIG_ENDIAN: \
292 var = (post_cast *) my_htobe ## type ((pre_cast) var); \
294 case TYPE_IS_LITTLE_ENDIAN: \
295 var = (post_cast *) my_htole ## type ((pre_cast) var); \
302 # define BO_CANT_DOIT(action, type) \
304 switch (TYPE_ENDIANNESS(datumtype)) { \
305 case TYPE_IS_BIG_ENDIAN: \
306 Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \
307 "platform", #action, #type); \
309 case TYPE_IS_LITTLE_ENDIAN: \
310 Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \
311 "platform", #action, #type); \
318 # if PTRSIZE == INTSIZE
319 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, i, int, void)
320 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, i, int, void)
321 # define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, i, int, char)
322 # define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, i, int, char)
323 # elif PTRSIZE == LONGSIZE
324 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long, void)
325 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long, void)
326 # define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, long, char)
327 # define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, long, char)
328 # elif PTRSIZE == IVSIZE
329 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, IV, void)
330 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, IV, void)
331 # define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, IV, char)
332 # define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, IV, char)
334 # define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer)
335 # define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer)
336 # define DO_BO_UNPACK_PC(var) BO_CANT_DOIT(unpack, pointer)
337 # define DO_BO_PACK_PC(var) BO_CANT_DOIT(pack, pointer)
340 # if defined(my_htolen) && defined(my_letohn) && \
341 defined(my_htoben) && defined(my_betohn)
342 # define DO_BO_UNPACK_N(var, type) \
344 switch (TYPE_ENDIANNESS(datumtype)) { \
345 case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\
346 case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
351 # define DO_BO_PACK_N(var, type) \
353 switch (TYPE_ENDIANNESS(datumtype)) { \
354 case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\
355 case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
360 # define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type)
361 # define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type)
364 #endif /* PERL_PACK_CAN_BYTEORDER */
366 #define PACK_SIZE_CANNOT_CSUM 0x80
367 #define PACK_SIZE_UNPREDICTABLE 0x40 /* Not a fixed size element */
368 #define PACK_SIZE_MASK 0x3F
370 /* These tables are regenerated by genpacksizetables.pl (and then hand pasted
371 in). You're unlikely ever to need to regenerate them. */
373 #if TYPE_IS_SHRIEKING != 0x100
374 ++++shriek offset should be 256
377 typedef U8 packprops_t;
380 STATIC const packprops_t packprops[512] = {
382 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
383 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
384 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
385 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
387 /* C */ sizeof(unsigned char),
388 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
389 /* D */ LONG_DOUBLESIZE,
396 /* I */ sizeof(unsigned int),
403 #if defined(HAS_QUAD)
404 /* Q */ sizeof(Uquad_t),
411 /* U */ sizeof(char) | PACK_SIZE_UNPREDICTABLE,
413 /* W */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE,
414 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
415 /* c */ sizeof(char),
416 /* d */ sizeof(double),
418 /* f */ sizeof(float),
427 /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM,
428 #if defined(HAS_QUAD)
429 /* q */ sizeof(Quad_t),
437 /* w */ sizeof(char) | PACK_SIZE_UNPREDICTABLE | PACK_SIZE_CANNOT_CSUM,
438 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
439 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
440 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
441 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
442 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
443 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
444 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
445 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
446 0, 0, 0, 0, 0, 0, 0, 0,
448 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
449 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
450 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
451 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
452 0, 0, 0, 0, 0, 0, 0, 0, 0,
453 /* I */ sizeof(unsigned int),
455 /* L */ sizeof(unsigned long),
457 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
463 /* S */ sizeof(unsigned short),
465 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
470 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
474 /* l */ sizeof(long),
476 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
482 /* s */ sizeof(short),
484 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
489 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
490 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
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
500 /* EBCDIC (or bust) */
501 STATIC const packprops_t packprops[512] = {
503 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
504 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
505 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
506 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
507 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
508 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
509 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
510 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
512 /* c */ sizeof(char),
513 /* d */ sizeof(double),
515 /* f */ sizeof(float),
525 /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM,
526 #if defined(HAS_QUAD)
527 /* q */ sizeof(Quad_t),
531 0, 0, 0, 0, 0, 0, 0, 0, 0,
535 /* w */ sizeof(char) | PACK_SIZE_UNPREDICTABLE | PACK_SIZE_CANNOT_CSUM,
536 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
537 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
538 /* C */ sizeof(unsigned char),
539 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
540 /* D */ LONG_DOUBLESIZE,
547 /* I */ sizeof(unsigned int),
555 #if defined(HAS_QUAD)
556 /* Q */ sizeof(Uquad_t),
560 0, 0, 0, 0, 0, 0, 0, 0, 0,
563 /* U */ sizeof(char) | PACK_SIZE_UNPREDICTABLE,
565 /* W */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE,
566 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
567 0, 0, 0, 0, 0, 0, 0, 0, 0,
569 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
570 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
571 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
572 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
573 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
574 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
575 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
576 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
577 0, 0, 0, 0, 0, 0, 0, 0, 0,
579 0, 0, 0, 0, 0, 0, 0, 0, 0,
580 /* l */ sizeof(long),
582 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
587 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
588 /* s */ sizeof(short),
590 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
595 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
596 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
598 /* I */ sizeof(unsigned int),
599 0, 0, 0, 0, 0, 0, 0, 0, 0,
600 /* L */ sizeof(unsigned long),
602 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
607 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
608 /* S */ sizeof(unsigned short),
610 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
615 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
616 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
621 uni_to_byte(pTHX_ const char **s, const char *end, I32 datumtype)
624 UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen,
625 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
626 /* We try to process malformed UTF-8 as much as possible (preferrably with
627 warnings), but these two mean we make no progress in the string and
628 might enter an infinite loop */
629 if (retlen == (STRLEN) -1 || retlen == 0)
630 Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack",
631 (int) TYPE_NO_MODIFIERS(datumtype));
633 Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK),
634 "Character in '%c' format wrapped in unpack",
635 (int) TYPE_NO_MODIFIERS(datumtype));
642 #define SHIFT_BYTE(utf8, s, strend, datumtype) ((utf8) ? \
643 uni_to_byte(aTHX_ &(s), (strend), (datumtype)) : \
647 uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len, I32 datumtype)
651 const char *from = *s;
653 const U32 flags = ckWARN(WARN_UTF8) ?
654 UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY | UTF8_ALLOW_ANY);
655 for (;buf_len > 0; buf_len--) {
656 if (from >= end) return FALSE;
657 val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags);
658 if (retlen == (STRLEN) -1 || retlen == 0) {
659 from += UTF8SKIP(from);
661 } else from += retlen;
666 *(U8 *)buf++ = (U8)val;
668 /* We have enough characters for the buffer. Did we have problems ? */
671 /* Rewalk the string fragment while warning */
673 const int flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
674 for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) {
675 if (ptr >= end) break;
676 utf8n_to_uvuni((U8 *) ptr, end-ptr, &retlen, flags);
678 if (from > end) from = end;
681 Perl_ck_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ?
682 WARN_PACK : WARN_UNPACK),
683 "Character(s) in '%c' format wrapped in %s",
684 (int) TYPE_NO_MODIFIERS(datumtype),
685 datumtype & TYPE_IS_PACK ? "pack" : "unpack");
692 next_uni_uu(pTHX_ const char **s, const char *end, I32 *out)
696 const UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY);
697 if (val >= 0x100 || !ISUUCHAR(val) ||
698 retlen == (STRLEN) -1 || retlen == 0) {
702 *out = PL_uudmap[val] & 077;
708 S_bytes_to_uni(const U8 *start, STRLEN len, char *dest) {
709 const U8 * const end = start + len;
711 PERL_ARGS_ASSERT_BYTES_TO_UNI;
713 while (start < end) {
714 const UV uv = NATIVE_TO_ASCII(*start);
715 if (UNI_IS_INVARIANT(uv))
716 *dest++ = (char)(U8)UTF_TO_NATIVE(uv);
718 *dest++ = (char)(U8)UTF8_EIGHT_BIT_HI(uv);
719 *dest++ = (char)(U8)UTF8_EIGHT_BIT_LO(uv);
726 #define PUSH_BYTES(utf8, cur, buf, len) \
729 (cur) = bytes_to_uni((U8 *) buf, len, (cur)); \
731 Copy(buf, cur, len, char); \
736 #define GROWING(utf8, cat, start, cur, in_len) \
738 STRLEN glen = (in_len); \
739 if (utf8) glen *= UTF8_EXPAND; \
740 if ((cur) + glen >= (start) + SvLEN(cat)) { \
741 (start) = sv_exp_grow(cat, glen); \
742 (cur) = (start) + SvCUR(cat); \
746 #define PUSH_GROWING_BYTES(utf8, cat, start, cur, buf, in_len) \
748 const STRLEN glen = (in_len); \
750 if (utf8) gl *= UTF8_EXPAND; \
751 if ((cur) + gl >= (start) + SvLEN(cat)) { \
753 SvCUR_set((cat), (cur) - (start)); \
754 (start) = sv_exp_grow(cat, gl); \
755 (cur) = (start) + SvCUR(cat); \
757 PUSH_BYTES(utf8, cur, buf, glen); \
760 #define PUSH_BYTE(utf8, s, byte) \
763 const U8 au8 = (byte); \
764 (s) = bytes_to_uni(&au8, 1, (s)); \
765 } else *(U8 *)(s)++ = (byte); \
768 /* Only to be used inside a loop (see the break) */
769 #define NEXT_UNI_VAL(val, cur, str, end, utf8_flags) \
772 if (str >= end) break; \
773 val = utf8n_to_uvchr((U8 *) str, end-str, &retlen, utf8_flags); \
774 if (retlen == (STRLEN) -1 || retlen == 0) { \
776 Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); \
781 static const char *_action( const tempsym_t* symptr )
783 return (const char *)(( symptr->flags & FLAG_PACK ) ? "pack" : "unpack");
786 /* Returns the sizeof() struct described by pat */
788 S_measure_struct(pTHX_ tempsym_t* symptr)
792 PERL_ARGS_ASSERT_MEASURE_STRUCT;
794 while (next_symbol(symptr)) {
798 switch (symptr->howlen) {
800 Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
804 /* e_no_len and e_number */
805 len = symptr->length;
809 size = packprops[TYPE_NO_ENDIANNESS(symptr->code)] & PACK_SIZE_MASK;
812 /* endianness doesn't influence the size of a type */
813 switch(TYPE_NO_ENDIANNESS(symptr->code)) {
815 Perl_croak(aTHX_ "Invalid type '%c' in %s",
816 (int)TYPE_NO_MODIFIERS(symptr->code),
818 #ifdef PERL_PACK_CAN_SHRIEKSIGN
819 case '.' | TYPE_IS_SHRIEKING:
820 case '@' | TYPE_IS_SHRIEKING:
825 case 'U': /* XXXX Is it correct? */
828 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
829 (int) TYPE_NO_MODIFIERS(symptr->code),
836 tempsym_t savsym = *symptr;
837 symptr->patptr = savsym.grpbeg;
838 symptr->patend = savsym.grpend;
839 /* XXXX Theoretically, we need to measure many times at
840 different positions, since the subexpression may contain
841 alignment commands, but be not of aligned length.
842 Need to detect this and croak(). */
843 size = measure_struct(symptr);
847 case 'X' | TYPE_IS_SHRIEKING:
848 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS.
850 if (!len) /* Avoid division by 0 */
852 len = total % len; /* Assumed: the start is aligned. */
857 Perl_croak(aTHX_ "'X' outside of string in %s", _action( symptr ) );
859 case 'x' | TYPE_IS_SHRIEKING:
860 if (!len) /* Avoid division by 0 */
862 star = total % len; /* Assumed: the start is aligned. */
863 if (star) /* Other portable ways? */
887 size = sizeof(char*);
897 /* locate matching closing parenthesis or bracket
898 * returns char pointer to char after match, or NULL
901 S_group_end(pTHX_ register const char *patptr, register const char *patend, char ender)
903 PERL_ARGS_ASSERT_GROUP_END;
905 while (patptr < patend) {
906 const char c = *patptr++;
913 while (patptr < patend && *patptr != '\n')
917 patptr = group_end(patptr, patend, ')') + 1;
919 patptr = group_end(patptr, patend, ']') + 1;
921 Perl_croak(aTHX_ "No group ending character '%c' found in template",
927 /* Convert unsigned decimal number to binary.
928 * Expects a pointer to the first digit and address of length variable
929 * Advances char pointer to 1st non-digit char and returns number
932 S_get_num(pTHX_ register const char *patptr, I32 *lenptr )
934 I32 len = *patptr++ - '0';
936 PERL_ARGS_ASSERT_GET_NUM;
938 while (isDIGIT(*patptr)) {
939 if (len >= 0x7FFFFFFF/10)
940 Perl_croak(aTHX_ "pack/unpack repeat count overflow");
941 len = (len * 10) + (*patptr++ - '0');
947 /* The marvellous template parsing routine: Using state stored in *symptr,
948 * locates next template code and count
951 S_next_symbol(pTHX_ tempsym_t* symptr )
953 const char* patptr = symptr->patptr;
954 const char* const patend = symptr->patend;
956 PERL_ARGS_ASSERT_NEXT_SYMBOL;
958 symptr->flags &= ~FLAG_SLASH;
960 while (patptr < patend) {
961 if (isSPACE(*patptr))
963 else if (*patptr == '#') {
965 while (patptr < patend && *patptr != '\n')
970 /* We should have found a template code */
971 I32 code = *patptr++ & 0xFF;
972 U32 inherited_modifiers = 0;
974 if (code == ','){ /* grandfather in commas but with a warning */
975 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
976 symptr->flags |= FLAG_COMMA;
977 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
978 "Invalid type ',' in %s", _action( symptr ) );
983 /* for '(', skip to ')' */
985 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
986 Perl_croak(aTHX_ "()-group starts with a count in %s",
988 symptr->grpbeg = patptr;
989 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
990 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
991 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
995 /* look for group modifiers to inherit */
996 if (TYPE_ENDIANNESS(symptr->flags)) {
997 if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
998 inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
1001 /* look for modifiers */
1002 while (patptr < patend) {
1003 const char *allowed;
1007 modifier = TYPE_IS_SHRIEKING;
1008 allowed = SHRIEKING_ALLOWED_TYPES;
1010 #ifdef PERL_PACK_CAN_BYTEORDER
1012 modifier = TYPE_IS_BIG_ENDIAN;
1013 allowed = ENDIANNESS_ALLOWED_TYPES;
1016 modifier = TYPE_IS_LITTLE_ENDIAN;
1017 allowed = ENDIANNESS_ALLOWED_TYPES;
1019 #endif /* PERL_PACK_CAN_BYTEORDER */
1029 if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
1030 Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
1031 allowed, _action( symptr ) );
1033 if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
1034 Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
1035 (int) TYPE_NO_MODIFIERS(code), _action( symptr ) );
1036 else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
1037 TYPE_ENDIANNESS_MASK)
1038 Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
1039 *patptr, _action( symptr ) );
1041 if ((code & modifier)) {
1042 Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK),
1043 "Duplicate modifier '%c' after '%c' in %s",
1044 *patptr, (int) TYPE_NO_MODIFIERS(code),
1045 _action( symptr ) );
1052 /* inherit modifiers */
1053 code |= inherited_modifiers;
1055 /* look for count and/or / */
1056 if (patptr < patend) {
1057 if (isDIGIT(*patptr)) {
1058 patptr = get_num( patptr, &symptr->length );
1059 symptr->howlen = e_number;
1061 } else if (*patptr == '*') {
1063 symptr->howlen = e_star;
1065 } else if (*patptr == '[') {
1066 const char* lenptr = ++patptr;
1067 symptr->howlen = e_number;
1068 patptr = group_end( patptr, patend, ']' ) + 1;
1069 /* what kind of [] is it? */
1070 if (isDIGIT(*lenptr)) {
1071 lenptr = get_num( lenptr, &symptr->length );
1072 if( *lenptr != ']' )
1073 Perl_croak(aTHX_ "Malformed integer in [] in %s",
1074 _action( symptr ) );
1076 tempsym_t savsym = *symptr;
1077 symptr->patend = patptr-1;
1078 symptr->patptr = lenptr;
1079 savsym.length = measure_struct(symptr);
1083 symptr->howlen = e_no_len;
1088 while (patptr < patend) {
1089 if (isSPACE(*patptr))
1091 else if (*patptr == '#') {
1093 while (patptr < patend && *patptr != '\n')
1095 if (patptr < patend)
1098 if (*patptr == '/') {
1099 symptr->flags |= FLAG_SLASH;
1101 if (patptr < patend &&
1102 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
1103 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
1104 _action( symptr ) );
1110 /* at end - no count, no / */
1111 symptr->howlen = e_no_len;
1115 symptr->code = code;
1116 symptr->patptr = patptr;
1120 symptr->patptr = patptr;
1125 There is no way to cleanly handle the case where we should process the
1126 string per byte in its upgraded form while it's really in downgraded form
1127 (e.g. estimates like strend-s as an upper bound for the number of
1128 characters left wouldn't work). So if we foresee the need of this
1129 (pattern starts with U or contains U0), we want to work on the encoded
1130 version of the string. Users are advised to upgrade their pack string
1131 themselves if they need to do a lot of unpacks like this on it
1134 need_utf8(const char *pat, const char *patend)
1138 PERL_ARGS_ASSERT_NEED_UTF8;
1140 while (pat < patend) {
1141 if (pat[0] == '#') {
1143 pat = (const char *) memchr(pat, '\n', patend-pat);
1144 if (!pat) return FALSE;
1145 } else if (pat[0] == 'U') {
1146 if (first || pat[1] == '0') return TRUE;
1147 } else first = FALSE;
1154 first_symbol(const char *pat, const char *patend) {
1155 PERL_ARGS_ASSERT_FIRST_SYMBOL;
1157 while (pat < patend) {
1158 if (pat[0] != '#') return pat[0];
1160 pat = (const char *) memchr(pat, '\n', patend-pat);
1168 =for apidoc unpackstring
1170 The engine implementing unpack() Perl function. C<unpackstring> puts the
1171 extracted list items on the stack and returns the number of elements.
1172 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
1177 Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, const char *strend, U32 flags)
1181 PERL_ARGS_ASSERT_UNPACKSTRING;
1183 if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8;
1184 else if (need_utf8(pat, patend)) {
1185 /* We probably should try to avoid this in case a scalar context call
1186 wouldn't get to the "U0" */
1187 STRLEN len = strend - s;
1188 s = (char *) bytes_to_utf8((U8 *) s, &len);
1191 flags |= FLAG_DO_UTF8;
1194 if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8))
1195 flags |= FLAG_PARSE_UTF8;
1197 TEMPSYM_INIT(&sym, pat, patend, flags);
1199 return unpack_rec(&sym, s, s, strend, NULL );
1203 S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s )
1207 const I32 start_sp_offset = SP - PL_stack_base;
1212 const int bits_in_uv = CHAR_BIT * sizeof(cuv);
1213 bool beyond = FALSE;
1214 bool explicit_length;
1215 const bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
1216 bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
1218 PERL_ARGS_ASSERT_UNPACK_REC;
1220 symptr->strbeg = s - strbeg;
1222 while (next_symbol(symptr)) {
1225 I32 datumtype = symptr->code;
1226 /* do first one only unless in list context
1227 / is implemented by unpacking the count, then popping it from the
1228 stack, so must check that we're not in the middle of a / */
1229 if ( unpack_only_one
1230 && (SP - PL_stack_base == start_sp_offset + 1)
1231 && (datumtype != '/') ) /* XXX can this be omitted */
1234 switch (howlen = symptr->howlen) {
1236 len = strend - strbeg; /* long enough */
1239 /* e_no_len and e_number */
1240 len = symptr->length;
1244 explicit_length = TRUE;
1246 beyond = s >= strend;
1248 props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
1250 /* props nonzero means we can process this letter. */
1251 const long size = props & PACK_SIZE_MASK;
1252 const long howmany = (strend - s) / size;
1256 if (!checksum || (props & PACK_SIZE_CANNOT_CSUM)) {
1257 if (len && unpack_only_one) len = 1;
1263 switch(TYPE_NO_ENDIANNESS(datumtype)) {
1265 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
1268 if (howlen == e_no_len)
1269 len = 16; /* len is not specified */
1277 tempsym_t savsym = *symptr;
1278 const U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
1279 symptr->flags |= group_modifiers;
1280 symptr->patend = savsym.grpend;
1281 symptr->previous = &savsym;
1284 if (len && unpack_only_one) len = 1;
1286 symptr->patptr = savsym.grpbeg;
1287 if (utf8) symptr->flags |= FLAG_PARSE_UTF8;
1288 else symptr->flags &= ~FLAG_PARSE_UTF8;
1289 unpack_rec(symptr, s, strbeg, strend, &s);
1290 if (s == strend && savsym.howlen == e_star)
1291 break; /* No way to continue */
1294 savsym.flags = symptr->flags & ~group_modifiers;
1298 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1299 case '.' | TYPE_IS_SHRIEKING:
1304 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1305 const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING);
1306 #else /* PERL_PACK_CAN_SHRIEKSIGN */
1307 const bool u8 = utf8;
1309 if (howlen == e_star) from = strbeg;
1310 else if (len <= 0) from = s;
1312 tempsym_t *group = symptr;
1314 while (--len && group) group = group->previous;
1315 from = group ? strbeg + group->strbeg : strbeg;
1318 newSVuv( u8 ? (UV) utf8_length((const U8*)from, (const U8*)s) : (UV) (s-from)) :
1319 newSViv(-(u8 ? (IV) utf8_length((const U8*)s, (const U8*)from) : (IV) (from-s)));
1323 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1324 case '@' | TYPE_IS_SHRIEKING:
1327 s = strbeg + symptr->strbeg;
1328 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1329 if (utf8 && !(datumtype & TYPE_IS_SHRIEKING))
1330 #else /* PERL_PACK_CAN_SHRIEKSIGN */
1336 Perl_croak(aTHX_ "'@' outside of string in unpack");
1341 Perl_croak(aTHX_ "'@' outside of string with malformed UTF-8 in unpack");
1344 Perl_croak(aTHX_ "'@' outside of string in unpack");
1348 case 'X' | TYPE_IS_SHRIEKING:
1349 if (!len) /* Avoid division by 0 */
1352 const char *hop, *last;
1354 hop = last = strbeg;
1356 hop += UTF8SKIP(hop);
1363 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1367 len = (s - strbeg) % len;
1373 Perl_croak(aTHX_ "'X' outside of string in unpack");
1374 while (--s, UTF8_IS_CONTINUATION(*s)) {
1376 Perl_croak(aTHX_ "'X' outside of string in unpack");
1381 if (len > s - strbeg)
1382 Perl_croak(aTHX_ "'X' outside of string in unpack" );
1386 case 'x' | TYPE_IS_SHRIEKING: {
1388 if (!len) /* Avoid division by 0 */
1390 if (utf8) ai32 = utf8_length((U8 *) strbeg, (U8 *) s) % len;
1391 else ai32 = (s - strbeg) % len;
1392 if (ai32 == 0) break;
1400 Perl_croak(aTHX_ "'x' outside of string in unpack");
1405 if (len > strend - s)
1406 Perl_croak(aTHX_ "'x' outside of string in unpack");
1411 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1417 /* Preliminary length estimate is assumed done in 'W' */
1418 if (len > strend - s) len = strend - s;
1424 for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) {
1425 if (hop >= strend) {
1427 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1432 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1434 } else if (len > strend - s)
1437 if (datumtype == 'Z') {
1438 /* 'Z' strips stuff after first null */
1439 const char *ptr, *end;
1441 for (ptr = s; ptr < end; ptr++) if (*ptr == 0) break;
1442 sv = newSVpvn(s, ptr-s);
1443 if (howlen == e_star) /* exact for 'Z*' */
1444 len = ptr-s + (ptr != strend ? 1 : 0);
1445 } else if (datumtype == 'A') {
1446 /* 'A' strips both nulls and spaces */
1448 if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) {
1449 for (ptr = s+len-1; ptr >= s; ptr--)
1450 if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) &&
1451 !is_utf8_space((U8 *) ptr)) break;
1452 if (ptr >= s) ptr += UTF8SKIP(ptr);
1455 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1457 for (ptr = s+len-1; ptr >= s; ptr--)
1458 if (*ptr != 0 && !isSPACE(*ptr)) break;
1461 sv = newSVpvn(s, ptr-s);
1462 } else sv = newSVpvn(s, len);
1466 /* Undo any upgrade done due to need_utf8() */
1467 if (!(symptr->flags & FLAG_WAS_UTF8))
1468 sv_utf8_downgrade(sv, 0);
1476 if (howlen == e_star || len > (strend - s) * 8)
1477 len = (strend - s) * 8;
1480 while (len >= 8 && s < strend) {
1481 cuv += PL_bitcount[uni_to_byte(aTHX_ &s, strend, datumtype)];
1486 cuv += PL_bitcount[*(U8 *)s++];
1489 if (len && s < strend) {
1491 bits = SHIFT_BYTE(utf8, s, strend, datumtype);
1492 if (datumtype == 'b')
1494 if (bits & 1) cuv++;
1499 if (bits & 0x80) cuv++;
1506 sv = sv_2mortal(newSV(len ? len : 1));
1509 if (datumtype == 'b') {
1511 const I32 ai32 = len;
1512 for (len = 0; len < ai32; len++) {
1513 if (len & 7) bits >>= 1;
1515 if (s >= strend) break;
1516 bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1517 } else bits = *(U8 *) s++;
1518 *str++ = bits & 1 ? '1' : '0';
1522 const I32 ai32 = len;
1523 for (len = 0; len < ai32; len++) {
1524 if (len & 7) bits <<= 1;
1526 if (s >= strend) break;
1527 bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1528 } else bits = *(U8 *) s++;
1529 *str++ = bits & 0x80 ? '1' : '0';
1533 SvCUR_set(sv, str - SvPVX_const(sv));
1540 /* Preliminary length estimate, acceptable for utf8 too */
1541 if (howlen == e_star || len > (strend - s) * 2)
1542 len = (strend - s) * 2;
1543 sv = sv_2mortal(newSV(len ? len : 1));
1546 if (datumtype == 'h') {
1549 for (len = 0; len < ai32; len++) {
1550 if (len & 1) bits >>= 4;
1552 if (s >= strend) break;
1553 bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1554 } else bits = * (U8 *) s++;
1555 *str++ = PL_hexdigit[bits & 15];
1559 const I32 ai32 = len;
1560 for (len = 0; len < ai32; len++) {
1561 if (len & 1) bits <<= 4;
1563 if (s >= strend) break;
1564 bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1565 } else bits = *(U8 *) s++;
1566 *str++ = PL_hexdigit[(bits >> 4) & 15];
1570 SvCUR_set(sv, str - SvPVX_const(sv));
1576 if (explicit_length)
1577 /* Switch to "character" mode */
1578 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
1583 while (len-- > 0 && s < strend) {
1588 aint = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
1589 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1590 if (retlen == (STRLEN) -1 || retlen == 0)
1591 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1595 aint = *(U8 *)(s)++;
1596 if (aint >= 128 && datumtype != 'C') /* fake up signed chars */
1600 else if (checksum > bits_in_uv)
1601 cdouble += (NV)aint;
1609 while (len-- > 0 && s < strend) {
1611 const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
1612 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1613 if (retlen == (STRLEN) -1 || retlen == 0)
1614 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1618 else if (checksum > bits_in_uv)
1619 cdouble += (NV) val;
1623 } else if (!checksum)
1625 const U8 ch = *(U8 *) s++;
1628 else if (checksum > bits_in_uv)
1629 while (len-- > 0) cdouble += (NV) *(U8 *) s++;
1631 while (len-- > 0) cuv += *(U8 *) s++;
1635 if (explicit_length) {
1636 /* Switch to "bytes in UTF-8" mode */
1637 if (symptr->flags & FLAG_DO_UTF8) utf8 = 0;
1639 /* Should be impossible due to the need_utf8() test */
1640 Perl_croak(aTHX_ "U0 mode on a byte string");
1644 if (len > strend - s) len = strend - s;
1646 if (len && unpack_only_one) len = 1;
1650 while (len-- > 0 && s < strend) {
1654 U8 result[UTF8_MAXLEN];
1655 const char *ptr = s;
1657 /* Bug: warns about bad utf8 even if we are short on bytes
1658 and will break out of the loop */
1659 if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) result, 1,
1662 len = UTF8SKIP(result);
1663 if (!uni_to_bytes(aTHX_ &ptr, strend,
1664 (char *) &result[1], len-1, 'U')) break;
1665 auv = utf8n_to_uvuni(result, len, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
1668 auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
1669 if (retlen == (STRLEN) -1 || retlen == 0)
1670 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1675 else if (checksum > bits_in_uv)
1676 cdouble += (NV) auv;
1681 case 's' | TYPE_IS_SHRIEKING:
1682 #if SHORTSIZE != SIZE16
1685 SHIFT_VAR(utf8, s, strend, ashort, datumtype);
1686 DO_BO_UNPACK(ashort, s);
1689 else if (checksum > bits_in_uv)
1690 cdouble += (NV)ashort;
1702 #if U16SIZE > SIZE16
1705 SHIFT16(utf8, s, strend, &ai16, datumtype);
1706 DO_BO_UNPACK(ai16, 16);
1707 #if U16SIZE > SIZE16
1713 else if (checksum > bits_in_uv)
1714 cdouble += (NV)ai16;
1719 case 'S' | TYPE_IS_SHRIEKING:
1720 #if SHORTSIZE != SIZE16
1722 unsigned short aushort;
1723 SHIFT_VAR(utf8, s, strend, aushort, datumtype);
1724 DO_BO_UNPACK(aushort, s);
1727 else if (checksum > bits_in_uv)
1728 cdouble += (NV)aushort;
1741 #if U16SIZE > SIZE16
1744 SHIFT16(utf8, s, strend, &au16, datumtype);
1745 DO_BO_UNPACK(au16, 16);
1747 if (datumtype == 'n')
1748 au16 = PerlSock_ntohs(au16);
1751 if (datumtype == 'v')
1756 else if (checksum > bits_in_uv)
1757 cdouble += (NV) au16;
1762 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1763 case 'v' | TYPE_IS_SHRIEKING:
1764 case 'n' | TYPE_IS_SHRIEKING:
1767 # if U16SIZE > SIZE16
1770 SHIFT16(utf8, s, strend, &ai16, datumtype);
1772 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1773 ai16 = (I16) PerlSock_ntohs((U16) ai16);
1774 # endif /* HAS_NTOHS */
1776 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1777 ai16 = (I16) vtohs((U16) ai16);
1778 # endif /* HAS_VTOHS */
1781 else if (checksum > bits_in_uv)
1782 cdouble += (NV) ai16;
1787 #endif /* PERL_PACK_CAN_SHRIEKSIGN */
1789 case 'i' | TYPE_IS_SHRIEKING:
1792 SHIFT_VAR(utf8, s, strend, aint, datumtype);
1793 DO_BO_UNPACK(aint, i);
1796 else if (checksum > bits_in_uv)
1797 cdouble += (NV)aint;
1803 case 'I' | TYPE_IS_SHRIEKING:
1806 SHIFT_VAR(utf8, s, strend, auint, datumtype);
1807 DO_BO_UNPACK(auint, i);
1810 else if (checksum > bits_in_uv)
1811 cdouble += (NV)auint;
1819 SHIFT_VAR(utf8, s, strend, aiv, datumtype);
1820 #if IVSIZE == INTSIZE
1821 DO_BO_UNPACK(aiv, i);
1822 #elif IVSIZE == LONGSIZE
1823 DO_BO_UNPACK(aiv, l);
1824 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1825 DO_BO_UNPACK(aiv, 64);
1827 Perl_croak(aTHX_ "'j' not supported on this platform");
1831 else if (checksum > bits_in_uv)
1840 SHIFT_VAR(utf8, s, strend, auv, datumtype);
1841 #if IVSIZE == INTSIZE
1842 DO_BO_UNPACK(auv, i);
1843 #elif IVSIZE == LONGSIZE
1844 DO_BO_UNPACK(auv, l);
1845 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1846 DO_BO_UNPACK(auv, 64);
1848 Perl_croak(aTHX_ "'J' not supported on this platform");
1852 else if (checksum > bits_in_uv)
1858 case 'l' | TYPE_IS_SHRIEKING:
1859 #if LONGSIZE != SIZE32
1862 SHIFT_VAR(utf8, s, strend, along, datumtype);
1863 DO_BO_UNPACK(along, l);
1866 else if (checksum > bits_in_uv)
1867 cdouble += (NV)along;
1878 #if U32SIZE > SIZE32
1881 SHIFT32(utf8, s, strend, &ai32, datumtype);
1882 DO_BO_UNPACK(ai32, 32);
1883 #if U32SIZE > SIZE32
1884 if (ai32 > 2147483647) ai32 -= 4294967296;
1888 else if (checksum > bits_in_uv)
1889 cdouble += (NV)ai32;
1894 case 'L' | TYPE_IS_SHRIEKING:
1895 #if LONGSIZE != SIZE32
1897 unsigned long aulong;
1898 SHIFT_VAR(utf8, s, strend, aulong, datumtype);
1899 DO_BO_UNPACK(aulong, l);
1902 else if (checksum > bits_in_uv)
1903 cdouble += (NV)aulong;
1916 #if U32SIZE > SIZE32
1919 SHIFT32(utf8, s, strend, &au32, datumtype);
1920 DO_BO_UNPACK(au32, 32);
1922 if (datumtype == 'N')
1923 au32 = PerlSock_ntohl(au32);
1926 if (datumtype == 'V')
1931 else if (checksum > bits_in_uv)
1932 cdouble += (NV)au32;
1937 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1938 case 'V' | TYPE_IS_SHRIEKING:
1939 case 'N' | TYPE_IS_SHRIEKING:
1942 # if U32SIZE > SIZE32
1945 SHIFT32(utf8, s, strend, &ai32, datumtype);
1947 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1948 ai32 = (I32)PerlSock_ntohl((U32)ai32);
1951 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1952 ai32 = (I32)vtohl((U32)ai32);
1956 else if (checksum > bits_in_uv)
1957 cdouble += (NV)ai32;
1962 #endif /* PERL_PACK_CAN_SHRIEKSIGN */
1966 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
1967 DO_BO_UNPACK_PC(aptr);
1968 /* newSVpv generates undef if aptr is NULL */
1969 mPUSHs(newSVpv(aptr, 0));
1977 while (len > 0 && s < strend) {
1979 ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1980 auv = (auv << 7) | (ch & 0x7f);
1981 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1989 if (++bytes >= sizeof(UV)) { /* promote to string */
1992 sv = Perl_newSVpvf(aTHX_ "%.*"UVuf, (int)TYPE_DIGITS(UV), auv);
1993 while (s < strend) {
1994 ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1995 sv = mul128(sv, (U8)(ch & 0x7f));
2001 t = SvPV_nolen_const(sv);
2010 if ((s >= strend) && bytes)
2011 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
2015 if (symptr->howlen == e_star)
2016 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
2018 if (s + sizeof(char*) <= strend) {
2020 SHIFT_VAR(utf8, s, strend, aptr, datumtype);
2021 DO_BO_UNPACK_PC(aptr);
2022 /* newSVpvn generates undef if aptr is NULL */
2023 PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP));
2030 SHIFT_VAR(utf8, s, strend, aquad, datumtype);
2031 DO_BO_UNPACK(aquad, 64);
2033 mPUSHs(aquad >= IV_MIN && aquad <= IV_MAX ?
2034 newSViv((IV)aquad) : newSVnv((NV)aquad));
2035 else if (checksum > bits_in_uv)
2036 cdouble += (NV)aquad;
2044 SHIFT_VAR(utf8, s, strend, auquad, datumtype);
2045 DO_BO_UNPACK(auquad, 64);
2047 mPUSHs(auquad <= UV_MAX ?
2048 newSVuv((UV)auquad) : newSVnv((NV)auquad));
2049 else if (checksum > bits_in_uv)
2050 cdouble += (NV)auquad;
2055 #endif /* HAS_QUAD */
2056 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
2060 SHIFT_VAR(utf8, s, strend, afloat, datumtype);
2061 DO_BO_UNPACK_N(afloat, float);
2071 SHIFT_VAR(utf8, s, strend, adouble, datumtype);
2072 DO_BO_UNPACK_N(adouble, double);
2082 SHIFT_VAR(utf8, s, strend, anv, datumtype);
2083 DO_BO_UNPACK_N(anv, NV);
2090 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2093 long double aldouble;
2094 SHIFT_VAR(utf8, s, strend, aldouble, datumtype);
2095 DO_BO_UNPACK_N(aldouble, long double);
2099 cdouble += aldouble;
2105 const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
2106 sv = sv_2mortal(newSV(l));
2107 if (l) SvPOK_on(sv);
2110 while (next_uni_uu(aTHX_ &s, strend, &len)) {
2115 next_uni_uu(aTHX_ &s, strend, &a);
2116 next_uni_uu(aTHX_ &s, strend, &b);
2117 next_uni_uu(aTHX_ &s, strend, &c);
2118 next_uni_uu(aTHX_ &s, strend, &d);
2119 hunk[0] = (char)((a << 2) | (b >> 4));
2120 hunk[1] = (char)((b << 4) | (c >> 2));
2121 hunk[2] = (char)((c << 6) | d);
2122 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
2130 /* possible checksum byte */
2131 const char *skip = s+UTF8SKIP(s);
2132 if (skip < strend && *skip == '\n')
2138 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
2142 len = PL_uudmap[*(U8*)s++] & 077;
2144 if (s < strend && ISUUCHAR(*s))
2145 a = PL_uudmap[*(U8*)s++] & 077;
2148 if (s < strend && ISUUCHAR(*s))
2149 b = PL_uudmap[*(U8*)s++] & 077;
2152 if (s < strend && ISUUCHAR(*s))
2153 c = PL_uudmap[*(U8*)s++] & 077;
2156 if (s < strend && ISUUCHAR(*s))
2157 d = PL_uudmap[*(U8*)s++] & 077;
2160 hunk[0] = (char)((a << 2) | (b >> 4));
2161 hunk[1] = (char)((b << 4) | (c >> 2));
2162 hunk[2] = (char)((c << 6) | d);
2163 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
2168 else /* possible checksum byte */
2169 if (s + 1 < strend && s[1] == '\n')
2178 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
2179 (checksum > bits_in_uv &&
2180 strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
2183 anv = (NV) (1 << (checksum & 15));
2184 while (checksum >= 16) {
2188 while (cdouble < 0.0)
2190 cdouble = Perl_modf(cdouble / anv, &trouble) * anv;
2191 sv = newSVnv(cdouble);
2194 if (checksum < bits_in_uv) {
2195 UV mask = ((UV)1 << checksum) - 1;
2204 if (symptr->flags & FLAG_SLASH){
2205 if (SP - PL_stack_base - start_sp_offset <= 0)
2206 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
2207 if( next_symbol(symptr) ){
2208 if( symptr->howlen == e_number )
2209 Perl_croak(aTHX_ "Count after length/code in unpack" );
2211 /* ...end of char buffer then no decent length available */
2212 Perl_croak(aTHX_ "length/code after end of string in unpack" );
2214 /* take top of stack (hope it's numeric) */
2217 Perl_croak(aTHX_ "Negative '/' count in unpack" );
2220 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
2222 datumtype = symptr->code;
2223 explicit_length = FALSE;
2231 return SP - PL_stack_base - start_sp_offset;
2239 I32 gimme = GIMME_V;
2242 const char *pat = SvPV_const(left, llen);
2243 const char *s = SvPV_const(right, rlen);
2244 const char *strend = s + rlen;
2245 const char *patend = pat + llen;
2249 cnt = unpackstring(pat, patend, s, strend,
2250 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
2251 | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0));
2254 if ( !cnt && gimme == G_SCALAR )
2255 PUSHs(&PL_sv_undef);
2260 doencodes(U8 *h, const char *s, I32 len)
2262 *h++ = PL_uuemap[len];
2264 *h++ = PL_uuemap[(077 & (s[0] >> 2))];
2265 *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))];
2266 *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
2267 *h++ = PL_uuemap[(077 & (s[2] & 077))];
2272 const char r = (len > 1 ? s[1] : '\0');
2273 *h++ = PL_uuemap[(077 & (s[0] >> 2))];
2274 *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))];
2275 *h++ = PL_uuemap[(077 & ((r << 2) & 074))];
2276 *h++ = PL_uuemap[0];
2283 S_is_an_int(pTHX_ const char *s, STRLEN l)
2285 SV *result = newSVpvn(s, l);
2286 char *const result_c = SvPV_nolen(result); /* convenience */
2287 char *out = result_c;
2291 PERL_ARGS_ASSERT_IS_AN_INT;
2299 SvREFCNT_dec(result);
2322 SvREFCNT_dec(result);
2328 SvCUR_set(result, out - result_c);
2332 /* pnum must be '\0' terminated */
2334 S_div128(pTHX_ SV *pnum, bool *done)
2337 char * const s = SvPV(pnum, len);
2341 PERL_ARGS_ASSERT_DIV128;
2345 const int i = m * 10 + (*t - '0');
2346 const int r = (i >> 7); /* r < 10 */
2354 SvCUR_set(pnum, (STRLEN) (t - s));
2359 =for apidoc packlist
2361 The engine implementing pack() Perl function.
2367 Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist )
2372 PERL_ARGS_ASSERT_PACKLIST;
2374 TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
2376 /* We're going to do changes through SvPVX(cat). Make sure it's valid.
2377 Also make sure any UTF8 flag is loaded */
2378 SvPV_force_nolen(cat);
2380 sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8;
2382 (void)pack_rec( cat, &sym, beglist, endlist );
2385 /* like sv_utf8_upgrade, but also repoint the group start markers */
2387 marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) {
2390 const char *from_ptr, *from_start, *from_end, **marks, **m;
2391 char *to_start, *to_ptr;
2393 if (SvUTF8(sv)) return;
2395 from_start = SvPVX_const(sv);
2396 from_end = from_start + SvCUR(sv);
2397 for (from_ptr = from_start; from_ptr < from_end; from_ptr++)
2398 if (!NATIVE_IS_INVARIANT(*from_ptr)) break;
2399 if (from_ptr == from_end) {
2400 /* Simple case: no character needs to be changed */
2405 len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1;
2406 Newx(to_start, len, char);
2407 Copy(from_start, to_start, from_ptr-from_start, char);
2408 to_ptr = to_start + (from_ptr-from_start);
2410 Newx(marks, sym_ptr->level+2, const char *);
2411 for (group=sym_ptr; group; group = group->previous)
2412 marks[group->level] = from_start + group->strbeg;
2413 marks[sym_ptr->level+1] = from_end+1;
2414 for (m = marks; *m < from_ptr; m++)
2415 *m = to_start + (*m-from_start);
2417 for (;from_ptr < from_end; from_ptr++) {
2418 while (*m == from_ptr) *m++ = to_ptr;
2419 to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr);
2423 while (*m == from_ptr) *m++ = to_ptr;
2424 if (m != marks + sym_ptr->level+1) {
2427 Perl_croak(aTHX_ "panic: marks beyond string end");
2429 for (group=sym_ptr; group; group = group->previous)
2430 group->strbeg = marks[group->level] - to_start;
2435 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2436 from_start -= SvIVX(sv);
2439 SvFLAGS(sv) &= ~SVf_OOK;
2442 Safefree(from_start);
2443 SvPV_set(sv, to_start);
2444 SvCUR_set(sv, to_ptr - to_start);
2449 /* Exponential string grower. Makes string extension effectively O(n)
2450 needed says how many extra bytes we need (not counting the final '\0')
2451 Only grows the string if there is an actual lack of space
2454 S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) {
2455 const STRLEN cur = SvCUR(sv);
2456 const STRLEN len = SvLEN(sv);
2459 PERL_ARGS_ASSERT_SV_EXP_GROW;
2461 if (len - cur > needed) return SvPVX(sv);
2462 extend = needed > len ? needed : len;
2463 return SvGROW(sv, len+extend+1);
2468 S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
2471 tempsym_t lookahead;
2472 I32 items = endlist - beglist;
2473 bool found = next_symbol(symptr);
2474 bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
2475 bool warn_utf8 = ckWARN(WARN_UTF8);
2477 PERL_ARGS_ASSERT_PACK_REC;
2479 if (symptr->level == 0 && found && symptr->code == 'U') {
2480 marked_upgrade(aTHX_ cat, symptr);
2481 symptr->flags |= FLAG_DO_UTF8;
2484 symptr->strbeg = SvCUR(cat);
2490 SV *lengthcode = NULL;
2491 I32 datumtype = symptr->code;
2492 howlen_t howlen = symptr->howlen;
2493 char *start = SvPVX(cat);
2494 char *cur = start + SvCUR(cat);
2496 #define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2500 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ?
2504 /* e_no_len and e_number */
2505 len = symptr->length;
2510 packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
2512 if (props && !(props & PACK_SIZE_UNPREDICTABLE)) {
2513 /* We can process this letter. */
2514 STRLEN size = props & PACK_SIZE_MASK;
2515 GROWING(utf8, cat, start, cur, (STRLEN) len * size);
2519 /* Look ahead for next symbol. Do we have code/code? */
2520 lookahead = *symptr;
2521 found = next_symbol(&lookahead);
2522 if (symptr->flags & FLAG_SLASH) {
2524 if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack");
2525 if (strchr("aAZ", lookahead.code)) {
2526 if (lookahead.howlen == e_number) count = lookahead.length;
2529 if (SvGAMAGIC(*beglist)) {
2530 /* Avoid reading the active data more than once
2531 by copying it to a temporary. */
2533 const char *const pv = SvPV_const(*beglist, len);
2535 = newSVpvn_flags(pv, len,
2536 SVs_TEMP | SvUTF8(*beglist));
2539 count = DO_UTF8(*beglist) ?
2540 sv_len_utf8(*beglist) : sv_len(*beglist);
2543 if (lookahead.code == 'Z') count++;
2546 if (lookahead.howlen == e_number && lookahead.length < items)
2547 count = lookahead.length;
2550 lookahead.howlen = e_number;
2551 lookahead.length = count;
2552 lengthcode = sv_2mortal(newSViv(count));
2555 /* Code inside the switch must take care to properly update
2556 cat (CUR length and '\0' termination) if it updated *cur and
2557 doesn't simply leave using break */
2558 switch(TYPE_NO_ENDIANNESS(datumtype)) {
2560 Perl_croak(aTHX_ "Invalid type '%c' in pack",
2561 (int) TYPE_NO_MODIFIERS(datumtype));
2563 Perl_croak(aTHX_ "'%%' may not be used in pack");
2566 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2567 case '.' | TYPE_IS_SHRIEKING:
2570 if (howlen == e_star) from = start;
2571 else if (len == 0) from = cur;
2573 tempsym_t *group = symptr;
2575 while (--len && group) group = group->previous;
2576 from = group ? start + group->strbeg : start;
2579 len = SvIV(fromstr);
2581 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2582 case '@' | TYPE_IS_SHRIEKING:
2585 from = start + symptr->strbeg;
2587 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2588 if (utf8 && !(datumtype & TYPE_IS_SHRIEKING))
2589 #else /* PERL_PACK_CAN_SHRIEKSIGN */
2593 while (len && from < cur) {
2594 from += UTF8SKIP(from);
2598 Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2600 /* Here we know from == cur */
2602 GROWING(0, cat, start, cur, len);
2603 Zero(cur, len, char);
2605 } else if (from < cur) {
2608 } else goto no_change;
2616 if (len > 0) goto grow;
2617 if (len == 0) goto no_change;
2624 tempsym_t savsym = *symptr;
2625 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2626 symptr->flags |= group_modifiers;
2627 symptr->patend = savsym.grpend;
2629 symptr->previous = &lookahead;
2632 if (utf8) symptr->flags |= FLAG_PARSE_UTF8;
2633 else symptr->flags &= ~FLAG_PARSE_UTF8;
2634 was_utf8 = SvUTF8(cat);
2635 symptr->patptr = savsym.grpbeg;
2636 beglist = pack_rec(cat, symptr, beglist, endlist);
2637 if (SvUTF8(cat) != was_utf8)
2638 /* This had better be an upgrade while in utf8==0 mode */
2641 if (savsym.howlen == e_star && beglist == endlist)
2642 break; /* No way to continue */
2644 items = endlist - beglist;
2645 lookahead.flags = symptr->flags & ~group_modifiers;
2648 case 'X' | TYPE_IS_SHRIEKING:
2649 if (!len) /* Avoid division by 0 */
2656 hop += UTF8SKIP(hop);
2663 Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2667 len = (cur-start) % len;
2671 if (len < 1) goto no_change;
2675 Perl_croak(aTHX_ "'%c' outside of string in pack",
2676 (int) TYPE_NO_MODIFIERS(datumtype));
2677 while (--cur, UTF8_IS_CONTINUATION(*cur)) {
2679 Perl_croak(aTHX_ "'%c' outside of string in pack",
2680 (int) TYPE_NO_MODIFIERS(datumtype));
2686 if (cur - start < len)
2687 Perl_croak(aTHX_ "'%c' outside of string in pack",
2688 (int) TYPE_NO_MODIFIERS(datumtype));
2691 if (cur < start+symptr->strbeg) {
2692 /* Make sure group starts don't point into the void */
2694 const STRLEN length = cur-start;
2695 for (group = symptr;
2696 group && length < group->strbeg;
2697 group = group->previous) group->strbeg = length;
2698 lookahead.strbeg = length;
2701 case 'x' | TYPE_IS_SHRIEKING: {
2703 if (!len) /* Avoid division by 0 */
2705 if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len;
2706 else ai32 = (cur - start) % len;
2707 if (ai32 == 0) goto no_change;
2719 aptr = SvPV_const(fromstr, fromlen);
2720 if (DO_UTF8(fromstr)) {
2721 const char *end, *s;
2723 if (!utf8 && !SvUTF8(cat)) {
2724 marked_upgrade(aTHX_ cat, symptr);
2725 lookahead.flags |= FLAG_DO_UTF8;
2726 lookahead.strbeg = symptr->strbeg;
2729 cur = start + SvCUR(cat);
2731 if (howlen == e_star) {
2732 if (utf8) goto string_copy;
2736 end = aptr + fromlen;
2737 fromlen = datumtype == 'Z' ? len-1 : len;
2738 while ((I32) fromlen > 0 && s < end) {
2743 Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2746 if (datumtype == 'Z') len++;
2752 fromlen = len - fromlen;
2753 if (datumtype == 'Z') fromlen--;
2754 if (howlen == e_star) {
2756 if (datumtype == 'Z') len++;
2758 GROWING(0, cat, start, cur, len);
2759 if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
2760 datumtype | TYPE_IS_PACK))
2761 Perl_croak(aTHX_ "panic: predicted utf8 length not available");
2765 if (howlen == e_star) {
2767 if (datumtype == 'Z') len++;
2769 if (len <= (I32) fromlen) {
2771 if (datumtype == 'Z' && fromlen > 0) fromlen--;
2773 /* assumes a byte expands to at most UTF8_EXPAND bytes on
2775 expected_length <= from_len*UTF8_EXPAND + (len-from_len) */
2776 GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len);
2778 while (fromlen > 0) {
2779 cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr);
2785 if (howlen == e_star) {
2787 if (datumtype == 'Z') len++;
2789 if (len <= (I32) fromlen) {
2791 if (datumtype == 'Z' && fromlen > 0) fromlen--;
2793 GROWING(0, cat, start, cur, len);
2794 Copy(aptr, cur, fromlen, char);
2798 memset(cur, datumtype == 'A' ? ' ' : '\0', len);
2805 const char *str, *end;
2812 str = SvPV_const(fromstr, fromlen);
2813 end = str + fromlen;
2814 if (DO_UTF8(fromstr)) {
2816 utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2818 utf8_source = FALSE;
2819 utf8_flags = 0; /* Unused, but keep compilers happy */
2821 if (howlen == e_star) len = fromlen;
2822 field_len = (len+7)/8;
2823 GROWING(utf8, cat, start, cur, field_len);
2824 if (len > (I32)fromlen) len = fromlen;
2827 if (datumtype == 'B')
2831 NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2833 } else bits |= *str++ & 1;
2834 if (l & 7) bits <<= 1;
2836 PUSH_BYTE(utf8, cur, bits);
2841 /* datumtype == 'b' */
2845 NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2846 if (val & 1) bits |= 0x80;
2847 } else if (*str++ & 1)
2849 if (l & 7) bits >>= 1;
2851 PUSH_BYTE(utf8, cur, bits);
2857 if (datumtype == 'B')
2858 bits <<= 7 - (l & 7);
2860 bits >>= 7 - (l & 7);
2861 PUSH_BYTE(utf8, cur, bits);
2864 /* Determine how many chars are left in the requested field */
2866 if (howlen == e_star) field_len = 0;
2867 else field_len -= l;
2868 Zero(cur, field_len, char);
2874 const char *str, *end;
2881 str = SvPV_const(fromstr, fromlen);
2882 end = str + fromlen;
2883 if (DO_UTF8(fromstr)) {
2885 utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2887 utf8_source = FALSE;
2888 utf8_flags = 0; /* Unused, but keep compilers happy */
2890 if (howlen == e_star) len = fromlen;
2891 field_len = (len+1)/2;
2892 GROWING(utf8, cat, start, cur, field_len);
2893 if (!utf8 && len > (I32)fromlen) len = fromlen;
2896 if (datumtype == 'H')
2900 NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2901 if (val < 256 && isALPHA(val))
2902 bits |= (val + 9) & 0xf;
2905 } else if (isALPHA(*str))
2906 bits |= (*str++ + 9) & 0xf;
2908 bits |= *str++ & 0xf;
2909 if (l & 1) bits <<= 4;
2911 PUSH_BYTE(utf8, cur, bits);
2919 NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2920 if (val < 256 && isALPHA(val))
2921 bits |= ((val + 9) & 0xf) << 4;
2923 bits |= (val & 0xf) << 4;
2924 } else if (isALPHA(*str))
2925 bits |= ((*str++ + 9) & 0xf) << 4;
2927 bits |= (*str++ & 0xf) << 4;
2928 if (l & 1) bits >>= 4;
2930 PUSH_BYTE(utf8, cur, bits);
2936 PUSH_BYTE(utf8, cur, bits);
2939 /* Determine how many chars are left in the requested field */
2941 if (howlen == e_star) field_len = 0;
2942 else field_len -= l;
2943 Zero(cur, field_len, char);
2951 aiv = SvIV(fromstr);
2952 if ((-128 > aiv || aiv > 127))
2953 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2954 "Character in 'c' format wrapped in pack");
2955 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2960 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
2966 aiv = SvIV(fromstr);
2967 if ((0 > aiv || aiv > 0xff))
2968 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2969 "Character in 'C' format wrapped in pack");
2970 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2975 U8 in_bytes = (U8)IN_BYTES;
2977 end = start+SvLEN(cat)-1;
2978 if (utf8) end -= UTF8_MAXLEN-1;
2982 auv = SvUV(fromstr);
2983 if (in_bytes) auv = auv % 0x100;
2988 SvCUR_set(cat, cur - start);
2990 GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2991 end = start+SvLEN(cat)-UTF8_MAXLEN;
2993 cur = (char *) uvuni_to_utf8_flags((U8 *) cur,
2996 0 : UNICODE_ALLOW_ANY);
3001 SvCUR_set(cat, cur - start);
3002 marked_upgrade(aTHX_ cat, symptr);
3003 lookahead.flags |= FLAG_DO_UTF8;
3004 lookahead.strbeg = symptr->strbeg;
3007 cur = start + SvCUR(cat);
3008 end = start+SvLEN(cat)-UTF8_MAXLEN;
3011 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3012 "Character in 'W' format wrapped in pack");
3017 SvCUR_set(cat, cur - start);
3018 GROWING(0, cat, start, cur, len+1);
3019 end = start+SvLEN(cat)-1;
3021 *(U8 *) cur++ = (U8)auv;
3030 if (!(symptr->flags & FLAG_DO_UTF8)) {
3031 marked_upgrade(aTHX_ cat, symptr);
3032 lookahead.flags |= FLAG_DO_UTF8;
3033 lookahead.strbeg = symptr->strbeg;
3039 end = start+SvLEN(cat);
3040 if (!utf8) end -= UTF8_MAXLEN;
3044 auv = SvUV(fromstr);
3046 U8 buffer[UTF8_MAXLEN], *endb;
3047 endb = uvuni_to_utf8_flags(buffer, auv,
3049 0 : UNICODE_ALLOW_ANY);
3050 if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
3052 SvCUR_set(cat, cur - start);
3053 GROWING(0, cat, start, cur,
3054 len+(endb-buffer)*UTF8_EXPAND);
3055 end = start+SvLEN(cat);
3057 cur = bytes_to_uni(buffer, endb-buffer, cur);
3061 SvCUR_set(cat, cur - start);
3062 GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
3063 end = start+SvLEN(cat)-UTF8_MAXLEN;
3065 cur = (char *) uvuni_to_utf8_flags((U8 *) cur, auv,
3067 0 : UNICODE_ALLOW_ANY);
3072 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
3078 anv = SvNV(fromstr);
3080 /* VOS does not automatically map a floating-point overflow
3081 during conversion from double to float into infinity, so we
3082 do it by hand. This code should either be generalized for
3083 any OS that needs it, or removed if and when VOS implements
3084 posix-976 (suggestion to support mapping to infinity).
3085 Paul.Green@stratus.com 02-04-02. */
3087 extern const float _float_constants[];
3089 afloat = _float_constants[0]; /* single prec. inf. */
3090 else if (anv < -FLT_MAX)
3091 afloat = _float_constants[0]; /* single prec. inf. */
3092 else afloat = (float) anv;
3095 # if defined(VMS) && !defined(__IEEE_FP)
3096 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
3097 * on Alpha; fake it if we don't have them.
3101 else if (anv < -FLT_MAX)
3103 else afloat = (float)anv;
3105 afloat = (float)anv;
3107 #endif /* __VOS__ */
3108 DO_BO_PACK_N(afloat, float);
3109 PUSH_VAR(utf8, cur, afloat);
3117 anv = SvNV(fromstr);
3119 /* VOS does not automatically map a floating-point overflow
3120 during conversion from long double to double into infinity,
3121 so we do it by hand. This code should either be generalized
3122 for any OS that needs it, or removed if and when VOS
3123 implements posix-976 (suggestion to support mapping to
3124 infinity). Paul.Green@stratus.com 02-04-02. */
3126 extern const double _double_constants[];
3128 adouble = _double_constants[0]; /* double prec. inf. */
3129 else if (anv < -DBL_MAX)
3130 adouble = _double_constants[0]; /* double prec. inf. */
3131 else adouble = (double) anv;
3134 # if defined(VMS) && !defined(__IEEE_FP)
3135 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
3136 * on Alpha; fake it if we don't have them.
3140 else if (anv < -DBL_MAX)
3142 else adouble = (double)anv;
3144 adouble = (double)anv;
3146 #endif /* __VOS__ */
3147 DO_BO_PACK_N(adouble, double);
3148 PUSH_VAR(utf8, cur, adouble);
3153 Zero(&anv, 1, NV); /* can be long double with unused bits */
3156 anv = SvNV(fromstr);
3157 DO_BO_PACK_N(anv, NV);
3158 PUSH_VAR(utf8, cur, anv);
3162 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
3164 long double aldouble;
3165 /* long doubles can have unused bits, which may be nonzero */
3166 Zero(&aldouble, 1, long double);
3169 aldouble = (long double)SvNV(fromstr);
3170 DO_BO_PACK_N(aldouble, long double);
3171 PUSH_VAR(utf8, cur, aldouble);
3176 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3177 case 'n' | TYPE_IS_SHRIEKING:
3183 ai16 = (I16)SvIV(fromstr);
3185 ai16 = PerlSock_htons(ai16);
3187 PUSH16(utf8, cur, &ai16);
3190 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3191 case 'v' | TYPE_IS_SHRIEKING:
3197 ai16 = (I16)SvIV(fromstr);
3201 PUSH16(utf8, cur, &ai16);
3204 case 'S' | TYPE_IS_SHRIEKING:
3205 #if SHORTSIZE != SIZE16
3207 unsigned short aushort;
3209 aushort = SvUV(fromstr);
3210 DO_BO_PACK(aushort, s);
3211 PUSH_VAR(utf8, cur, aushort);
3221 au16 = (U16)SvUV(fromstr);
3222 DO_BO_PACK(au16, 16);
3223 PUSH16(utf8, cur, &au16);
3226 case 's' | TYPE_IS_SHRIEKING:
3227 #if SHORTSIZE != SIZE16
3231 ashort = SvIV(fromstr);
3232 DO_BO_PACK(ashort, s);
3233 PUSH_VAR(utf8, cur, ashort);
3243 ai16 = (I16)SvIV(fromstr);
3244 DO_BO_PACK(ai16, 16);
3245 PUSH16(utf8, cur, &ai16);
3249 case 'I' | TYPE_IS_SHRIEKING:
3253 auint = SvUV(fromstr);
3254 DO_BO_PACK(auint, i);
3255 PUSH_VAR(utf8, cur, auint);
3262 aiv = SvIV(fromstr);
3263 #if IVSIZE == INTSIZE
3265 #elif IVSIZE == LONGSIZE
3267 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
3268 DO_BO_PACK(aiv, 64);
3270 Perl_croak(aTHX_ "'j' not supported on this platform");
3272 PUSH_VAR(utf8, cur, aiv);
3279 auv = SvUV(fromstr);
3280 #if UVSIZE == INTSIZE
3282 #elif UVSIZE == LONGSIZE
3284 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
3285 DO_BO_PACK(auv, 64);
3287 Perl_croak(aTHX_ "'J' not supported on this platform");
3289 PUSH_VAR(utf8, cur, auv);
3296 anv = SvNV(fromstr);
3300 SvCUR_set(cat, cur - start);
3301 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
3304 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
3305 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
3306 any negative IVs will have already been got by the croak()
3307 above. IOK is untrue for fractions, so we test them
3308 against UV_MAX_P1. */
3309 if (SvIOK(fromstr) || anv < UV_MAX_P1) {
3310 char buf[(sizeof(UV)*CHAR_BIT)/7+1];
3311 char *in = buf + sizeof(buf);
3312 UV auv = SvUV(fromstr);
3315 *--in = (char)((auv & 0x7f) | 0x80);
3318 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3319 PUSH_GROWING_BYTES(utf8, cat, start, cur,
3320 in, (buf + sizeof(buf)) - in);
3321 } else if (SvPOKp(fromstr))
3323 else if (SvNOKp(fromstr)) {
3324 /* 10**NV_MAX_10_EXP is the largest power of 10
3325 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
3326 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
3327 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
3328 And with that many bytes only Inf can overflow.
3329 Some C compilers are strict about integral constant
3330 expressions so we conservatively divide by a slightly
3331 smaller integer instead of multiplying by the exact
3332 floating-point value.
3334 #ifdef NV_MAX_10_EXP
3335 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
3336 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
3338 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
3339 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
3341 char *in = buf + sizeof(buf);
3343 anv = Perl_floor(anv);
3345 const NV next = Perl_floor(anv / 128);
3346 if (in <= buf) /* this cannot happen ;-) */
3347 Perl_croak(aTHX_ "Cannot compress integer in pack");
3348 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
3351 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3352 PUSH_GROWING_BYTES(utf8, cat, start, cur,
3353 in, (buf + sizeof(buf)) - in);
3362 /* Copy string and check for compliance */
3363 from = SvPV_const(fromstr, len);
3364 if ((norm = is_an_int(from, len)) == NULL)
3365 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
3367 Newx(result, len, char);
3370 while (!done) *--in = div128(norm, &done) | 0x80;
3371 result[len - 1] &= 0x7F; /* clear continue bit */
3372 PUSH_GROWING_BYTES(utf8, cat, start, cur,
3373 in, (result + len) - in);
3375 SvREFCNT_dec(norm); /* free norm */
3380 case 'i' | TYPE_IS_SHRIEKING:
3384 aint = SvIV(fromstr);
3385 DO_BO_PACK(aint, i);
3386 PUSH_VAR(utf8, cur, aint);
3389 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3390 case 'N' | TYPE_IS_SHRIEKING:
3396 au32 = SvUV(fromstr);
3398 au32 = PerlSock_htonl(au32);
3400 PUSH32(utf8, cur, &au32);
3403 #ifdef PERL_PACK_CAN_SHRIEKSIGN
3404 case 'V' | TYPE_IS_SHRIEKING:
3410 au32 = SvUV(fromstr);
3414 PUSH32(utf8, cur, &au32);
3417 case 'L' | TYPE_IS_SHRIEKING:
3418 #if LONGSIZE != SIZE32
3420 unsigned long aulong;
3422 aulong = SvUV(fromstr);
3423 DO_BO_PACK(aulong, l);
3424 PUSH_VAR(utf8, cur, aulong);
3434 au32 = SvUV(fromstr);
3435 DO_BO_PACK(au32, 32);
3436 PUSH32(utf8, cur, &au32);
3439 case 'l' | TYPE_IS_SHRIEKING:
3440 #if LONGSIZE != SIZE32
3444 along = SvIV(fromstr);
3445 DO_BO_PACK(along, l);
3446 PUSH_VAR(utf8, cur, along);
3456 ai32 = SvIV(fromstr);
3457 DO_BO_PACK(ai32, 32);
3458 PUSH32(utf8, cur, &ai32);
3466 auquad = (Uquad_t) SvUV(fromstr);
3467 DO_BO_PACK(auquad, 64);
3468 PUSH_VAR(utf8, cur, auquad);
3475 aquad = (Quad_t)SvIV(fromstr);
3476 DO_BO_PACK(aquad, 64);
3477 PUSH_VAR(utf8, cur, aquad);
3480 #endif /* HAS_QUAD */
3482 len = 1; /* assume SV is correct length */
3483 GROWING(utf8, cat, start, cur, sizeof(char *));
3490 SvGETMAGIC(fromstr);
3491 if (!SvOK(fromstr)) aptr = NULL;
3493 /* XXX better yet, could spirit away the string to
3494 * a safe spot and hang on to it until the result
3495 * of pack() (and all copies of the result) are
3498 if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
3499 !SvREADONLY(fromstr)))) {
3500 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3501 "Attempt to pack pointer to temporary value");
3503 if (SvPOK(fromstr) || SvNIOK(fromstr))
3504 aptr = SvPV_nomg_const_nolen(fromstr);
3506 aptr = SvPV_force_flags_nolen(fromstr, 0);
3508 DO_BO_PACK_PC(aptr);
3509 PUSH_VAR(utf8, cur, aptr);
3513 const char *aptr, *aend;
3517 if (len <= 2) len = 45;
3518 else len = len / 3 * 3;
3520 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3521 "Field too wide in 'u' format in pack");
3524 aptr = SvPV_const(fromstr, fromlen);
3525 from_utf8 = DO_UTF8(fromstr);
3527 aend = aptr + fromlen;
3528 fromlen = sv_len_utf8(fromstr);
3529 } else aend = NULL; /* Unused, but keep compilers happy */
3530 GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2);
3531 while (fromlen > 0) {
3534 U8 hunk[1+63/3*4+1];
3536 if ((I32)fromlen > len)
3542 if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo,
3543 'u' | TYPE_IS_PACK)) {
3545 SvCUR_set(cat, cur - start);
3546 Perl_croak(aTHX_ "panic: string is shorter than advertised");
3548 end = doencodes(hunk, buffer, todo);
3550 end = doencodes(hunk, aptr, todo);
3553 PUSH_BYTES(utf8, cur, hunk, end-hunk);
3560 SvCUR_set(cat, cur - start);
3562 *symptr = lookahead;
3571 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3572 register SV *cat = TARG;
3574 SV *pat_sv = *++MARK;
3575 register const char *pat = SvPV_const(pat_sv, fromlen);
3576 register const char *patend = pat + fromlen;
3582 packlist(cat, pat, patend, MARK, SP + 1);
3592 * c-indentation-style: bsd
3594 * indent-tabs-mode: t
3597 * ex: set ts=8 sts=4 sw=4 noet: