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; \
78 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
81 U8 bytes[sizeof(long double)];
88 /* Maximum number of bytes to which a byte can grow due to upgrade */
92 * Offset for integer pack/unpack.
94 * On architectures where I16 and I32 aren't really 16 and 32 bits,
95 * which for now are all Crays, pack and unpack have to play games.
99 * These values are required for portability of pack() output.
100 * If they're not right on your machine, then pack() and unpack()
101 * wouldn't work right anyway; you'll need to apply the Cray hack.
102 * (I'd like to check them with #if, but you can't use sizeof() in
103 * the preprocessor.) --???
106 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
107 defines are now in config.h. --Andy Dougherty April 1998
112 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
115 #if U16SIZE > SIZE16 || U32SIZE > SIZE32
116 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
117 # define OFF16(p) ((char*)(p))
118 # define OFF32(p) ((char*)(p))
120 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
121 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
122 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
124 ++++ bad cray byte order
128 # define OFF16(p) ((char *) (p))
129 # define OFF32(p) ((char *) (p))
132 #define PUSH16(utf8, cur, p, needs_swap) \
133 PUSH_BYTES(utf8, cur, OFF16(p), SIZE16, needs_swap)
134 #define PUSH32(utf8, cur, p, needs_swap) \
135 PUSH_BYTES(utf8, cur, OFF32(p), SIZE32, needs_swap)
137 #if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
138 # define NEEDS_SWAP(d) (TYPE_ENDIANNESS(d) == TYPE_IS_LITTLE_ENDIAN)
139 #elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
140 # define NEEDS_SWAP(d) (TYPE_ENDIANNESS(d) == TYPE_IS_BIG_ENDIAN)
142 # error "Unsupported byteorder"
143 /* Need to add code here to re-instate mixed endian support.
144 NEEDS_SWAP would need to hold a flag indicating which action to
145 take, and S_reverse_copy and the code in uni_to_bytes would need
146 logic adding to deal with any mixed-endian transformations needed.
150 /* Only to be used inside a loop (see the break) */
151 #define SHIFT_BYTES(utf8, s, strend, buf, len, datumtype, needs_swap) \
153 if (UNLIKELY(utf8)) { \
154 if (!uni_to_bytes(aTHX_ &s, strend, \
155 (char *) (buf), len, datumtype)) break; \
157 if (UNLIKELY(needs_swap)) \
158 S_reverse_copy(s, (char *) (buf), len); \
160 Copy(s, (char *) (buf), len, char); \
165 #define SHIFT16(utf8, s, strend, p, datumtype, needs_swap) \
166 SHIFT_BYTES(utf8, s, strend, OFF16(p), SIZE16, datumtype, needs_swap)
168 #define SHIFT32(utf8, s, strend, p, datumtype, needs_swap) \
169 SHIFT_BYTES(utf8, s, strend, OFF32(p), SIZE32, datumtype, needs_swap)
171 #define SHIFT_VAR(utf8, s, strend, var, datumtype, needs_swap) \
172 SHIFT_BYTES(utf8, s, strend, &(var), sizeof(var), datumtype, needs_swap)
174 #define PUSH_VAR(utf8, aptr, var, needs_swap) \
175 PUSH_BYTES(utf8, aptr, &(var), sizeof(var), needs_swap)
177 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
178 #define MAX_SUB_TEMPLATE_LEVEL 100
180 /* flags (note that type modifiers can also be used as flags!) */
181 #define FLAG_WAS_UTF8 0x40
182 #define FLAG_PARSE_UTF8 0x20 /* Parse as utf8 */
183 #define FLAG_UNPACK_ONLY_ONE 0x10
184 #define FLAG_DO_UTF8 0x08 /* The underlying string is utf8 */
185 #define FLAG_SLASH 0x04
186 #define FLAG_COMMA 0x02
187 #define FLAG_PACK 0x01
190 S_mul128(pTHX_ SV *sv, U8 m)
193 char *s = SvPV(sv, len);
196 PERL_ARGS_ASSERT_MUL128;
198 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
199 SV * const tmpNew = newSVpvs("0000000000");
201 sv_catsv(tmpNew, sv);
202 SvREFCNT_dec(sv); /* free old sv */
207 while (!*t) /* trailing '\0'? */
210 const U32 i = ((*t - '0') << 7) + m;
211 *(t--) = '0' + (char)(i % 10);
217 /* Explosives and implosives. */
219 #if 'I' == 73 && 'J' == 74
220 /* On an ASCII/ISO kind of system */
221 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
224 Some other sort of character set - use memchr() so we don't match
227 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
231 #define TYPE_IS_SHRIEKING 0x100
232 #define TYPE_IS_BIG_ENDIAN 0x200
233 #define TYPE_IS_LITTLE_ENDIAN 0x400
234 #define TYPE_IS_PACK 0x800
235 #define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
236 #define TYPE_MODIFIERS(t) ((t) & ~0xFF)
237 #define TYPE_NO_MODIFIERS(t) ((t) & 0xFF)
239 # define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK)
240 # define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK)
242 # define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP("
244 #define PACK_SIZE_CANNOT_CSUM 0x80
245 #define PACK_SIZE_UNPREDICTABLE 0x40 /* Not a fixed size element */
246 #define PACK_SIZE_MASK 0x3F
248 #include "packsizetables.c"
251 S_reverse_copy(const char *src, char *dest, STRLEN len)
259 uni_to_byte(pTHX_ const char **s, const char *end, I32 datumtype)
262 UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen,
263 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
264 /* We try to process malformed UTF-8 as much as possible (preferably with
265 warnings), but these two mean we make no progress in the string and
266 might enter an infinite loop */
267 if (retlen == (STRLEN) -1 || retlen == 0)
268 Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack",
269 (int) TYPE_NO_MODIFIERS(datumtype));
271 Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK),
272 "Character in '%c' format wrapped in unpack",
273 (int) TYPE_NO_MODIFIERS(datumtype));
280 #define SHIFT_BYTE(utf8, s, strend, datumtype) ((utf8) ? \
281 uni_to_byte(aTHX_ &(s), (strend), (datumtype)) : \
285 uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len, I32 datumtype)
289 const char *from = *s;
291 const U32 flags = ckWARN(WARN_UTF8) ?
292 UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY | UTF8_ALLOW_ANY);
293 const bool needs_swap = NEEDS_SWAP(datumtype);
295 if (UNLIKELY(needs_swap))
298 for (;buf_len > 0; buf_len--) {
299 if (from >= end) return FALSE;
300 val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags);
301 if (retlen == (STRLEN) -1 || retlen == 0) {
302 from += UTF8SKIP(from);
304 } else from += retlen;
309 if (UNLIKELY(needs_swap))
310 *(U8 *)--buf = (U8)val;
312 *(U8 *)buf++ = (U8)val;
314 /* We have enough characters for the buffer. Did we have problems ? */
317 /* Rewalk the string fragment while warning */
319 const int flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
320 for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) {
321 if (ptr >= end) break;
322 utf8n_to_uvchr((U8 *) ptr, end-ptr, &retlen, flags);
324 if (from > end) from = end;
327 Perl_ck_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ?
328 WARN_PACK : WARN_UNPACK),
329 "Character(s) in '%c' format wrapped in %s",
330 (int) TYPE_NO_MODIFIERS(datumtype),
331 datumtype & TYPE_IS_PACK ? "pack" : "unpack");
338 next_uni_uu(pTHX_ const char **s, const char *end, I32 *out)
341 const UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY);
342 if (val >= 0x100 || !ISUUCHAR(val) ||
343 retlen == (STRLEN) -1 || retlen == 0) {
347 *out = PL_uudmap[val] & 077;
353 S_bytes_to_uni(const U8 *start, STRLEN len, char *dest, const bool needs_swap) {
354 PERL_ARGS_ASSERT_BYTES_TO_UNI;
356 if (UNLIKELY(needs_swap)) {
357 const U8 *p = start + len;
358 while (p-- > start) {
359 append_utf8_from_native_byte(*p, (U8 **) & dest);
362 const U8 * const end = start + len;
363 while (start < end) {
364 append_utf8_from_native_byte(*start, (U8 **) & dest);
371 #define PUSH_BYTES(utf8, cur, buf, len, needs_swap) \
373 if (UNLIKELY(utf8)) \
374 (cur) = S_bytes_to_uni((U8 *) buf, len, (cur), needs_swap); \
376 if (UNLIKELY(needs_swap)) \
377 S_reverse_copy((char *)(buf), cur, len); \
379 Copy(buf, cur, len, char); \
384 #define GROWING(utf8, cat, start, cur, in_len) \
386 STRLEN glen = (in_len); \
387 if (utf8) glen *= UTF8_EXPAND; \
388 if ((cur) + glen >= (start) + SvLEN(cat)) { \
389 (start) = sv_exp_grow(cat, glen); \
390 (cur) = (start) + SvCUR(cat); \
394 #define PUSH_GROWING_BYTES(utf8, cat, start, cur, buf, in_len) \
396 const STRLEN glen = (in_len); \
398 if (utf8) gl *= UTF8_EXPAND; \
399 if ((cur) + gl >= (start) + SvLEN(cat)) { \
401 SvCUR_set((cat), (cur) - (start)); \
402 (start) = sv_exp_grow(cat, gl); \
403 (cur) = (start) + SvCUR(cat); \
405 PUSH_BYTES(utf8, cur, buf, glen, 0); \
408 #define PUSH_BYTE(utf8, s, byte) \
411 const U8 au8 = (byte); \
412 (s) = S_bytes_to_uni(&au8, 1, (s), 0); \
413 } else *(U8 *)(s)++ = (byte); \
416 /* Only to be used inside a loop (see the break) */
417 #define NEXT_UNI_VAL(val, cur, str, end, utf8_flags) \
420 if (str >= end) break; \
421 val = utf8n_to_uvchr((U8 *) str, end-str, &retlen, utf8_flags); \
422 if (retlen == (STRLEN) -1 || retlen == 0) { \
424 Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); \
429 static const char *_action( const tempsym_t* symptr )
431 return (const char *)(( symptr->flags & FLAG_PACK ) ? "pack" : "unpack");
434 /* Returns the sizeof() struct described by pat */
436 S_measure_struct(pTHX_ tempsym_t* symptr)
440 PERL_ARGS_ASSERT_MEASURE_STRUCT;
442 while (next_symbol(symptr)) {
446 switch (symptr->howlen) {
448 Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
452 /* e_no_len and e_number */
453 len = symptr->length;
457 size = packprops[TYPE_NO_ENDIANNESS(symptr->code)] & PACK_SIZE_MASK;
460 /* endianness doesn't influence the size of a type */
461 switch(TYPE_NO_ENDIANNESS(symptr->code)) {
463 Perl_croak(aTHX_ "Invalid type '%c' in %s",
464 (int)TYPE_NO_MODIFIERS(symptr->code),
466 case '.' | TYPE_IS_SHRIEKING:
467 case '@' | TYPE_IS_SHRIEKING:
471 case 'U': /* XXXX Is it correct? */
474 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
475 (int) TYPE_NO_MODIFIERS(symptr->code),
482 tempsym_t savsym = *symptr;
483 symptr->patptr = savsym.grpbeg;
484 symptr->patend = savsym.grpend;
485 /* XXXX Theoretically, we need to measure many times at
486 different positions, since the subexpression may contain
487 alignment commands, but be not of aligned length.
488 Need to detect this and croak(). */
489 size = measure_struct(symptr);
493 case 'X' | TYPE_IS_SHRIEKING:
494 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS.
496 if (!len) /* Avoid division by 0 */
498 len = total % len; /* Assumed: the start is aligned. */
503 Perl_croak(aTHX_ "'X' outside of string in %s", _action( symptr ) );
505 case 'x' | TYPE_IS_SHRIEKING:
506 if (!len) /* Avoid division by 0 */
508 star = total % len; /* Assumed: the start is aligned. */
509 if (star) /* Other portable ways? */
533 size = sizeof(char*);
543 /* locate matching closing parenthesis or bracket
544 * returns char pointer to char after match, or NULL
547 S_group_end(pTHX_ const char *patptr, const char *patend, char ender)
549 PERL_ARGS_ASSERT_GROUP_END;
551 while (patptr < patend) {
552 const char c = *patptr++;
559 while (patptr < patend && *patptr != '\n')
563 patptr = group_end(patptr, patend, ')') + 1;
565 patptr = group_end(patptr, patend, ']') + 1;
567 Perl_croak(aTHX_ "No group ending character '%c' found in template",
569 NOT_REACHED; /* NOTREACHED */
573 /* Convert unsigned decimal number to binary.
574 * Expects a pointer to the first digit and address of length variable
575 * Advances char pointer to 1st non-digit char and returns number
578 S_get_num(pTHX_ const char *patptr, I32 *lenptr )
580 I32 len = *patptr++ - '0';
582 PERL_ARGS_ASSERT_GET_NUM;
584 while (isDIGIT(*patptr)) {
585 if (len >= 0x7FFFFFFF/10)
586 Perl_croak(aTHX_ "pack/unpack repeat count overflow");
587 len = (len * 10) + (*patptr++ - '0');
593 /* The marvellous template parsing routine: Using state stored in *symptr,
594 * locates next template code and count
597 S_next_symbol(pTHX_ tempsym_t* symptr )
599 const char* patptr = symptr->patptr;
600 const char* const patend = symptr->patend;
602 PERL_ARGS_ASSERT_NEXT_SYMBOL;
604 symptr->flags &= ~FLAG_SLASH;
606 while (patptr < patend) {
607 if (isSPACE(*patptr))
609 else if (*patptr == '#') {
611 while (patptr < patend && *patptr != '\n')
616 /* We should have found a template code */
617 I32 code = *patptr++ & 0xFF;
618 U32 inherited_modifiers = 0;
620 if (code == ','){ /* grandfather in commas but with a warning */
621 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
622 symptr->flags |= FLAG_COMMA;
623 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
624 "Invalid type ',' in %s", _action( symptr ) );
629 /* for '(', skip to ')' */
631 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
632 Perl_croak(aTHX_ "()-group starts with a count in %s",
634 symptr->grpbeg = patptr;
635 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
636 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
637 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
641 /* look for group modifiers to inherit */
642 if (TYPE_ENDIANNESS(symptr->flags)) {
643 if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
644 inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
647 /* look for modifiers */
648 while (patptr < patend) {
653 modifier = TYPE_IS_SHRIEKING;
654 allowed = "sSiIlLxXnNvV@.";
657 modifier = TYPE_IS_BIG_ENDIAN;
658 allowed = ENDIANNESS_ALLOWED_TYPES;
661 modifier = TYPE_IS_LITTLE_ENDIAN;
662 allowed = ENDIANNESS_ALLOWED_TYPES;
673 if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
674 Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
675 allowed, _action( symptr ) );
677 if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
678 Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
679 (int) TYPE_NO_MODIFIERS(code), _action( symptr ) );
680 else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
681 TYPE_ENDIANNESS_MASK)
682 Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
683 *patptr, _action( symptr ) );
685 if ((code & modifier)) {
686 Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK),
687 "Duplicate modifier '%c' after '%c' in %s",
688 *patptr, (int) TYPE_NO_MODIFIERS(code),
696 /* inherit modifiers */
697 code |= inherited_modifiers;
699 /* look for count and/or / */
700 if (patptr < patend) {
701 if (isDIGIT(*patptr)) {
702 patptr = get_num( patptr, &symptr->length );
703 symptr->howlen = e_number;
705 } else if (*patptr == '*') {
707 symptr->howlen = e_star;
709 } else if (*patptr == '[') {
710 const char* lenptr = ++patptr;
711 symptr->howlen = e_number;
712 patptr = group_end( patptr, patend, ']' ) + 1;
713 /* what kind of [] is it? */
714 if (isDIGIT(*lenptr)) {
715 lenptr = get_num( lenptr, &symptr->length );
717 Perl_croak(aTHX_ "Malformed integer in [] in %s",
720 tempsym_t savsym = *symptr;
721 symptr->patend = patptr-1;
722 symptr->patptr = lenptr;
723 savsym.length = measure_struct(symptr);
727 symptr->howlen = e_no_len;
732 while (patptr < patend) {
733 if (isSPACE(*patptr))
735 else if (*patptr == '#') {
737 while (patptr < patend && *patptr != '\n')
742 if (*patptr == '/') {
743 symptr->flags |= FLAG_SLASH;
745 if (patptr < patend &&
746 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
747 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
754 /* at end - no count, no / */
755 symptr->howlen = e_no_len;
760 symptr->patptr = patptr;
764 symptr->patptr = patptr;
769 There is no way to cleanly handle the case where we should process the
770 string per byte in its upgraded form while it's really in downgraded form
771 (e.g. estimates like strend-s as an upper bound for the number of
772 characters left wouldn't work). So if we foresee the need of this
773 (pattern starts with U or contains U0), we want to work on the encoded
774 version of the string. Users are advised to upgrade their pack string
775 themselves if they need to do a lot of unpacks like this on it
778 need_utf8(const char *pat, const char *patend)
782 PERL_ARGS_ASSERT_NEED_UTF8;
784 while (pat < patend) {
787 pat = (const char *) memchr(pat, '\n', patend-pat);
788 if (!pat) return FALSE;
789 } else if (pat[0] == 'U') {
790 if (first || pat[1] == '0') return TRUE;
791 } else first = FALSE;
798 first_symbol(const char *pat, const char *patend) {
799 PERL_ARGS_ASSERT_FIRST_SYMBOL;
801 while (pat < patend) {
802 if (pat[0] != '#') return pat[0];
804 pat = (const char *) memchr(pat, '\n', patend-pat);
813 =head1 Pack and Unpack
815 =for apidoc unpackstring
817 The engine implementing the unpack() Perl function.
819 Using the template pat..patend, this function unpacks the string
820 s..strend into a number of mortal SVs, which it pushes onto the perl
821 argument (@_) stack (so you will need to issue a C<PUTBACK> before and
822 C<SPAGAIN> after the call to this function). It returns the number of
825 The strend and patend pointers should point to the byte following the last
826 character of each string.
828 Although this function returns its values on the perl argument stack, it
829 doesn't take any parameters from that stack (and thus in particular
830 there's no need to do a PUSHMARK before calling it, unlike L</call_pv> for
836 Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, const char *strend, U32 flags)
840 PERL_ARGS_ASSERT_UNPACKSTRING;
842 if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8;
843 else if (need_utf8(pat, patend)) {
844 /* We probably should try to avoid this in case a scalar context call
845 wouldn't get to the "U0" */
846 STRLEN len = strend - s;
847 s = (char *) bytes_to_utf8((U8 *) s, &len);
850 flags |= FLAG_DO_UTF8;
853 if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8))
854 flags |= FLAG_PARSE_UTF8;
856 TEMPSYM_INIT(&sym, pat, patend, flags);
858 return unpack_rec(&sym, s, s, strend, NULL );
862 S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s )
866 const I32 start_sp_offset = SP - PL_stack_base;
871 const int bits_in_uv = CHAR_BIT * sizeof(cuv);
873 bool explicit_length;
874 const bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
875 bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
877 PERL_ARGS_ASSERT_UNPACK_REC;
879 symptr->strbeg = s - strbeg;
881 while (next_symbol(symptr)) {
884 I32 datumtype = symptr->code;
886 /* do first one only unless in list context
887 / is implemented by unpacking the count, then popping it from the
888 stack, so must check that we're not in the middle of a / */
890 && (SP - PL_stack_base == start_sp_offset + 1)
891 && (datumtype != '/') ) /* XXX can this be omitted */
894 switch (howlen = symptr->howlen) {
896 len = strend - strbeg; /* long enough */
899 /* e_no_len and e_number */
900 len = symptr->length;
904 explicit_length = TRUE;
906 beyond = s >= strend;
908 props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
910 /* props nonzero means we can process this letter. */
911 const long size = props & PACK_SIZE_MASK;
912 const long howmany = (strend - s) / size;
916 if (!checksum || (props & PACK_SIZE_CANNOT_CSUM)) {
917 if (len && unpack_only_one) len = 1;
923 needs_swap = NEEDS_SWAP(datumtype);
925 switch(TYPE_NO_ENDIANNESS(datumtype)) {
927 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
930 if (howlen == e_no_len)
931 len = 16; /* len is not specified */
939 tempsym_t savsym = *symptr;
940 const U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
941 symptr->flags |= group_modifiers;
942 symptr->patend = savsym.grpend;
943 symptr->previous = &savsym;
946 if (len && unpack_only_one) len = 1;
948 symptr->patptr = savsym.grpbeg;
949 if (utf8) symptr->flags |= FLAG_PARSE_UTF8;
950 else symptr->flags &= ~FLAG_PARSE_UTF8;
951 unpack_rec(symptr, s, strbeg, strend, &s);
952 if (s == strend && savsym.howlen == e_star)
953 break; /* No way to continue */
956 savsym.flags = symptr->flags & ~group_modifiers;
960 case '.' | TYPE_IS_SHRIEKING:
964 const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING);
965 if (howlen == e_star) from = strbeg;
966 else if (len <= 0) from = s;
968 tempsym_t *group = symptr;
970 while (--len && group) group = group->previous;
971 from = group ? strbeg + group->strbeg : strbeg;
974 newSVuv( u8 ? (UV) utf8_length((const U8*)from, (const U8*)s) : (UV) (s-from)) :
975 newSViv(-(u8 ? (IV) utf8_length((const U8*)s, (const U8*)from) : (IV) (from-s)));
979 case '@' | TYPE_IS_SHRIEKING:
981 s = strbeg + symptr->strbeg;
982 if (utf8 && !(datumtype & TYPE_IS_SHRIEKING))
986 Perl_croak(aTHX_ "'@' outside of string in unpack");
991 Perl_croak(aTHX_ "'@' outside of string with malformed UTF-8 in unpack");
994 Perl_croak(aTHX_ "'@' outside of string in unpack");
998 case 'X' | TYPE_IS_SHRIEKING:
999 if (!len) /* Avoid division by 0 */
1002 const char *hop, *last;
1004 hop = last = strbeg;
1006 hop += UTF8SKIP(hop);
1013 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1017 len = (s - strbeg) % len;
1023 Perl_croak(aTHX_ "'X' outside of string in unpack");
1024 while (--s, UTF8_IS_CONTINUATION(*s)) {
1026 Perl_croak(aTHX_ "'X' outside of string in unpack");
1031 if (len > s - strbeg)
1032 Perl_croak(aTHX_ "'X' outside of string in unpack" );
1036 case 'x' | TYPE_IS_SHRIEKING: {
1038 if (!len) /* Avoid division by 0 */
1040 if (utf8) ai32 = utf8_length((U8 *) strbeg, (U8 *) s) % len;
1041 else ai32 = (s - strbeg) % len;
1042 if (ai32 == 0) break;
1050 Perl_croak(aTHX_ "'x' outside of string in unpack");
1055 if (len > strend - s)
1056 Perl_croak(aTHX_ "'x' outside of string in unpack");
1061 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1067 /* Preliminary length estimate is assumed done in 'W' */
1068 if (len > strend - s) len = strend - s;
1074 for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) {
1075 if (hop >= strend) {
1077 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1082 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1084 } else if (len > strend - s)
1087 if (datumtype == 'Z') {
1088 /* 'Z' strips stuff after first null */
1089 const char *ptr, *end;
1091 for (ptr = s; ptr < end; ptr++) if (*ptr == 0) break;
1092 sv = newSVpvn(s, ptr-s);
1093 if (howlen == e_star) /* exact for 'Z*' */
1094 len = ptr-s + (ptr != strend ? 1 : 0);
1095 } else if (datumtype == 'A') {
1096 /* 'A' strips both nulls and spaces */
1098 if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) {
1099 for (ptr = s+len-1; ptr >= s; ptr--)
1100 if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) &&
1101 !isSPACE_utf8(ptr)) break;
1102 if (ptr >= s) ptr += UTF8SKIP(ptr);
1105 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1107 for (ptr = s+len-1; ptr >= s; ptr--)
1108 if (*ptr != 0 && !isSPACE(*ptr)) break;
1111 sv = newSVpvn(s, ptr-s);
1112 } else sv = newSVpvn(s, len);
1116 /* Undo any upgrade done due to need_utf8() */
1117 if (!(symptr->flags & FLAG_WAS_UTF8))
1118 sv_utf8_downgrade(sv, 0);
1126 if (howlen == e_star || len > (strend - s) * 8)
1127 len = (strend - s) * 8;
1130 while (len >= 8 && s < strend) {
1131 cuv += PL_bitcount[uni_to_byte(aTHX_ &s, strend, datumtype)];
1136 cuv += PL_bitcount[*(U8 *)s++];
1139 if (len && s < strend) {
1141 bits = SHIFT_BYTE(utf8, s, strend, datumtype);
1142 if (datumtype == 'b')
1144 if (bits & 1) cuv++;
1149 if (bits & 0x80) cuv++;
1156 sv = sv_2mortal(newSV(len ? len : 1));
1159 if (datumtype == 'b') {
1161 const I32 ai32 = len;
1162 for (len = 0; len < ai32; len++) {
1163 if (len & 7) bits >>= 1;
1165 if (s >= strend) break;
1166 bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1167 } else bits = *(U8 *) s++;
1168 *str++ = bits & 1 ? '1' : '0';
1172 const I32 ai32 = len;
1173 for (len = 0; len < ai32; len++) {
1174 if (len & 7) bits <<= 1;
1176 if (s >= strend) break;
1177 bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1178 } else bits = *(U8 *) s++;
1179 *str++ = bits & 0x80 ? '1' : '0';
1183 SvCUR_set(sv, str - SvPVX_const(sv));
1190 /* Preliminary length estimate, acceptable for utf8 too */
1191 if (howlen == e_star || len > (strend - s) * 2)
1192 len = (strend - s) * 2;
1194 sv = sv_2mortal(newSV(len ? len : 1));
1198 if (datumtype == 'h') {
1201 for (len = 0; len < ai32; len++) {
1202 if (len & 1) bits >>= 4;
1204 if (s >= strend) break;
1205 bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1206 } else bits = * (U8 *) s++;
1208 *str++ = PL_hexdigit[bits & 15];
1212 const I32 ai32 = len;
1213 for (len = 0; len < ai32; len++) {
1214 if (len & 1) bits <<= 4;
1216 if (s >= strend) break;
1217 bits = uni_to_byte(aTHX_ &s, strend, datumtype);
1218 } else bits = *(U8 *) s++;
1220 *str++ = PL_hexdigit[(bits >> 4) & 15];
1225 SvCUR_set(sv, str - SvPVX_const(sv));
1232 if (explicit_length)
1233 /* Switch to "character" mode */
1234 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
1239 while (len-- > 0 && s < strend) {
1244 aint = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
1245 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1246 if (retlen == (STRLEN) -1 || retlen == 0)
1247 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1251 aint = *(U8 *)(s)++;
1252 if (aint >= 128 && datumtype != 'C') /* fake up signed chars */
1256 else if (checksum > bits_in_uv)
1257 cdouble += (NV)aint;
1265 while (len-- > 0 && s < strend) {
1267 const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
1268 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1269 if (retlen == (STRLEN) -1 || retlen == 0)
1270 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1274 else if (checksum > bits_in_uv)
1275 cdouble += (NV) val;
1279 } else if (!checksum)
1281 const U8 ch = *(U8 *) s++;
1284 else if (checksum > bits_in_uv)
1285 while (len-- > 0) cdouble += (NV) *(U8 *) s++;
1287 while (len-- > 0) cuv += *(U8 *) s++;
1291 if (explicit_length && howlen != e_star) {
1292 /* Switch to "bytes in UTF-8" mode */
1293 if (symptr->flags & FLAG_DO_UTF8) utf8 = 0;
1295 /* Should be impossible due to the need_utf8() test */
1296 Perl_croak(aTHX_ "U0 mode on a byte string");
1300 if (len > strend - s) len = strend - s;
1302 if (len && unpack_only_one) len = 1;
1306 while (len-- > 0 && s < strend) {
1310 U8 result[UTF8_MAXLEN];
1311 const char *ptr = s;
1313 /* Bug: warns about bad utf8 even if we are short on bytes
1314 and will break out of the loop */
1315 if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) result, 1,
1318 len = UTF8SKIP(result);
1319 if (!uni_to_bytes(aTHX_ &ptr, strend,
1320 (char *) &result[1], len-1, 'U')) break;
1321 auv = utf8n_to_uvchr(result, len, &retlen, UTF8_ALLOW_DEFAULT);
1324 auv = utf8n_to_uvchr((U8*)s, strend - s, &retlen, UTF8_ALLOW_DEFAULT);
1325 if (retlen == (STRLEN) -1 || retlen == 0)
1326 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1331 else if (checksum > bits_in_uv)
1332 cdouble += (NV) auv;
1337 case 's' | TYPE_IS_SHRIEKING:
1338 #if SHORTSIZE != SIZE16
1341 SHIFT_VAR(utf8, s, strend, ashort, datumtype, needs_swap);
1344 else if (checksum > bits_in_uv)
1345 cdouble += (NV)ashort;
1357 #if U16SIZE > SIZE16
1360 SHIFT16(utf8, s, strend, &ai16, datumtype, needs_swap);
1361 #if U16SIZE > SIZE16
1367 else if (checksum > bits_in_uv)
1368 cdouble += (NV)ai16;
1373 case 'S' | TYPE_IS_SHRIEKING:
1374 #if SHORTSIZE != SIZE16
1376 unsigned short aushort;
1377 SHIFT_VAR(utf8, s, strend, aushort, datumtype, needs_swap,
1381 else if (checksum > bits_in_uv)
1382 cdouble += (NV)aushort;
1395 #if U16SIZE > SIZE16
1398 SHIFT16(utf8, s, strend, &au16, datumtype, needs_swap);
1399 if (datumtype == 'n')
1400 au16 = PerlSock_ntohs(au16);
1401 if (datumtype == 'v')
1405 else if (checksum > bits_in_uv)
1406 cdouble += (NV) au16;
1411 case 'v' | TYPE_IS_SHRIEKING:
1412 case 'n' | TYPE_IS_SHRIEKING:
1415 # if U16SIZE > SIZE16
1418 SHIFT16(utf8, s, strend, &ai16, datumtype, needs_swap);
1419 /* There should never be any byte-swapping here. */
1420 assert(!TYPE_ENDIANNESS(datumtype));
1421 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1422 ai16 = (I16) PerlSock_ntohs((U16) ai16);
1423 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1424 ai16 = (I16) vtohs((U16) ai16);
1427 else if (checksum > bits_in_uv)
1428 cdouble += (NV) ai16;
1434 case 'i' | TYPE_IS_SHRIEKING:
1437 SHIFT_VAR(utf8, s, strend, aint, datumtype, needs_swap);
1440 else if (checksum > bits_in_uv)
1441 cdouble += (NV)aint;
1447 case 'I' | TYPE_IS_SHRIEKING:
1450 SHIFT_VAR(utf8, s, strend, auint, datumtype, needs_swap);
1453 else if (checksum > bits_in_uv)
1454 cdouble += (NV)auint;
1462 SHIFT_VAR(utf8, s, strend, aiv, datumtype, needs_swap);
1465 else if (checksum > bits_in_uv)
1474 SHIFT_VAR(utf8, s, strend, auv, datumtype, needs_swap);
1477 else if (checksum > bits_in_uv)
1483 case 'l' | TYPE_IS_SHRIEKING:
1484 #if LONGSIZE != SIZE32
1487 SHIFT_VAR(utf8, s, strend, along, datumtype, needs_swap);
1490 else if (checksum > bits_in_uv)
1491 cdouble += (NV)along;
1502 #if U32SIZE > SIZE32
1505 SHIFT32(utf8, s, strend, &ai32, datumtype, needs_swap);
1506 #if U32SIZE > SIZE32
1507 if (ai32 > 2147483647) ai32 -= 4294967296;
1511 else if (checksum > bits_in_uv)
1512 cdouble += (NV)ai32;
1517 case 'L' | TYPE_IS_SHRIEKING:
1518 #if LONGSIZE != SIZE32
1520 unsigned long aulong;
1521 SHIFT_VAR(utf8, s, strend, aulong, datumtype, needs_swap);
1524 else if (checksum > bits_in_uv)
1525 cdouble += (NV)aulong;
1538 #if U32SIZE > SIZE32
1541 SHIFT32(utf8, s, strend, &au32, datumtype, needs_swap);
1542 if (datumtype == 'N')
1543 au32 = PerlSock_ntohl(au32);
1544 if (datumtype == 'V')
1548 else if (checksum > bits_in_uv)
1549 cdouble += (NV)au32;
1554 case 'V' | TYPE_IS_SHRIEKING:
1555 case 'N' | TYPE_IS_SHRIEKING:
1558 #if U32SIZE > SIZE32
1561 SHIFT32(utf8, s, strend, &ai32, datumtype, needs_swap);
1562 /* There should never be any byte swapping here. */
1563 assert(!TYPE_ENDIANNESS(datumtype));
1564 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1565 ai32 = (I32)PerlSock_ntohl((U32)ai32);
1566 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1567 ai32 = (I32)vtohl((U32)ai32);
1570 else if (checksum > bits_in_uv)
1571 cdouble += (NV)ai32;
1579 SHIFT_VAR(utf8, s, strend, aptr, datumtype, needs_swap);
1580 /* newSVpv generates undef if aptr is NULL */
1581 mPUSHs(newSVpv(aptr, 0));
1589 while (len > 0 && s < strend) {
1591 ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1592 auv = (auv << 7) | (ch & 0x7f);
1593 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1601 if (++bytes >= sizeof(UV)) { /* promote to string */
1604 sv = Perl_newSVpvf(aTHX_ "%.*"UVuf, (int)TYPE_DIGITS(UV), auv);
1605 while (s < strend) {
1606 ch = SHIFT_BYTE(utf8, s, strend, datumtype);
1607 sv = mul128(sv, (U8)(ch & 0x7f));
1613 t = SvPV_nolen_const(sv);
1622 if ((s >= strend) && bytes)
1623 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1627 if (symptr->howlen == e_star)
1628 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1630 if (s + sizeof(char*) <= strend) {
1632 SHIFT_VAR(utf8, s, strend, aptr, datumtype, needs_swap);
1633 /* newSVpvn generates undef if aptr is NULL */
1634 PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP));
1637 #if defined(HAS_QUAD) && IVSIZE >= 8
1641 SHIFT_VAR(utf8, s, strend, aquad, datumtype, needs_swap);
1643 mPUSHs(newSViv((IV)aquad));
1644 else if (checksum > bits_in_uv)
1645 cdouble += (NV)aquad;
1653 SHIFT_VAR(utf8, s, strend, auquad, datumtype, needs_swap);
1655 mPUSHs(newSVuv((UV)auquad));
1656 else if (checksum > bits_in_uv)
1657 cdouble += (NV)auquad;
1663 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1667 SHIFT_VAR(utf8, s, strend, afloat, datumtype, needs_swap);
1677 SHIFT_VAR(utf8, s, strend, adouble, datumtype, needs_swap);
1687 SHIFT_BYTES(utf8, s, strend, anv.bytes, sizeof(anv.bytes),
1688 datumtype, needs_swap);
1695 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1699 SHIFT_BYTES(utf8, s, strend, aldouble.bytes,
1700 sizeof(aldouble.bytes), datumtype, needs_swap);
1702 mPUSHn(aldouble.ld);
1704 cdouble += aldouble.ld;
1710 const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
1711 sv = sv_2mortal(newSV(l));
1712 if (l) SvPOK_on(sv);
1715 while (next_uni_uu(aTHX_ &s, strend, &len)) {
1720 next_uni_uu(aTHX_ &s, strend, &a);
1721 next_uni_uu(aTHX_ &s, strend, &b);
1722 next_uni_uu(aTHX_ &s, strend, &c);
1723 next_uni_uu(aTHX_ &s, strend, &d);
1724 hunk[0] = (char)((a << 2) | (b >> 4));
1725 hunk[1] = (char)((b << 4) | (c >> 2));
1726 hunk[2] = (char)((c << 6) | d);
1728 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1736 /* possible checksum byte */
1737 const char *skip = s+UTF8SKIP(s);
1738 if (skip < strend && *skip == '\n')
1744 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1748 len = PL_uudmap[*(U8*)s++] & 077;
1750 if (s < strend && ISUUCHAR(*s))
1751 a = PL_uudmap[*(U8*)s++] & 077;
1754 if (s < strend && ISUUCHAR(*s))
1755 b = PL_uudmap[*(U8*)s++] & 077;
1758 if (s < strend && ISUUCHAR(*s))
1759 c = PL_uudmap[*(U8*)s++] & 077;
1762 if (s < strend && ISUUCHAR(*s))
1763 d = PL_uudmap[*(U8*)s++] & 077;
1766 hunk[0] = (char)((a << 2) | (b >> 4));
1767 hunk[1] = (char)((b << 4) | (c >> 2));
1768 hunk[2] = (char)((c << 6) | d);
1770 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1775 else /* possible checksum byte */
1776 if (s + 1 < strend && s[1] == '\n')
1786 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1787 (checksum > bits_in_uv &&
1788 strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1791 anv = (NV) (1 << (checksum & 15));
1792 while (checksum >= 16) {
1796 while (cdouble < 0.0)
1798 cdouble = Perl_modf(cdouble / anv, &trouble) * anv;
1799 sv = newSVnv(cdouble);
1802 if (checksum < bits_in_uv) {
1803 UV mask = ((UV)1 << checksum) - 1;
1812 if (symptr->flags & FLAG_SLASH){
1813 if (SP - PL_stack_base - start_sp_offset <= 0)
1815 if( next_symbol(symptr) ){
1816 if( symptr->howlen == e_number )
1817 Perl_croak(aTHX_ "Count after length/code in unpack" );
1819 /* ...end of char buffer then no decent length available */
1820 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1822 /* take top of stack (hope it's numeric) */
1825 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1828 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1830 datumtype = symptr->code;
1831 explicit_length = FALSE;
1839 return SP - PL_stack_base - start_sp_offset;
1846 I32 gimme = GIMME_V;
1849 const char *pat = SvPV_const(left, llen);
1850 const char *s = SvPV_const(right, rlen);
1851 const char *strend = s + rlen;
1852 const char *patend = pat + llen;
1856 cnt = unpackstring(pat, patend, s, strend,
1857 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1858 | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0));
1861 if ( !cnt && gimme == G_SCALAR )
1862 PUSHs(&PL_sv_undef);
1867 doencodes(U8 *h, const char *s, I32 len)
1869 *h++ = PL_uuemap[len];
1871 *h++ = PL_uuemap[(077 & (s[0] >> 2))];
1872 *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))];
1873 *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1874 *h++ = PL_uuemap[(077 & (s[2] & 077))];
1879 const char r = (len > 1 ? s[1] : '\0');
1880 *h++ = PL_uuemap[(077 & (s[0] >> 2))];
1881 *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))];
1882 *h++ = PL_uuemap[(077 & ((r << 2) & 074))];
1883 *h++ = PL_uuemap[0];
1890 S_is_an_int(pTHX_ const char *s, STRLEN l)
1892 SV *result = newSVpvn(s, l);
1893 char *const result_c = SvPV_nolen(result); /* convenience */
1894 char *out = result_c;
1898 PERL_ARGS_ASSERT_IS_AN_INT;
1906 SvREFCNT_dec(result);
1929 SvREFCNT_dec(result);
1935 SvCUR_set(result, out - result_c);
1939 /* pnum must be '\0' terminated */
1941 S_div128(pTHX_ SV *pnum, bool *done)
1944 char * const s = SvPV(pnum, len);
1948 PERL_ARGS_ASSERT_DIV128;
1952 const int i = m * 10 + (*t - '0');
1953 const int r = (i >> 7); /* r < 10 */
1961 SvCUR_set(pnum, (STRLEN) (t - s));
1966 =for apidoc packlist
1968 The engine implementing pack() Perl function.
1974 Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist )
1978 PERL_ARGS_ASSERT_PACKLIST;
1980 TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
1982 /* We're going to do changes through SvPVX(cat). Make sure it's valid.
1983 Also make sure any UTF8 flag is loaded */
1984 SvPV_force_nolen(cat);
1986 sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8;
1988 (void)pack_rec( cat, &sym, beglist, endlist );
1991 /* like sv_utf8_upgrade, but also repoint the group start markers */
1993 marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) {
1996 const char *from_ptr, *from_start, *from_end, **marks, **m;
1997 char *to_start, *to_ptr;
1999 if (SvUTF8(sv)) return;
2001 from_start = SvPVX_const(sv);
2002 from_end = from_start + SvCUR(sv);
2003 for (from_ptr = from_start; from_ptr < from_end; from_ptr++)
2004 if (!NATIVE_BYTE_IS_INVARIANT(*from_ptr)) break;
2005 if (from_ptr == from_end) {
2006 /* Simple case: no character needs to be changed */
2011 len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1;
2012 Newx(to_start, len, char);
2013 Copy(from_start, to_start, from_ptr-from_start, char);
2014 to_ptr = to_start + (from_ptr-from_start);
2016 Newx(marks, sym_ptr->level+2, const char *);
2017 for (group=sym_ptr; group; group = group->previous)
2018 marks[group->level] = from_start + group->strbeg;
2019 marks[sym_ptr->level+1] = from_end+1;
2020 for (m = marks; *m < from_ptr; m++)
2021 *m = to_start + (*m-from_start);
2023 for (;from_ptr < from_end; from_ptr++) {
2024 while (*m == from_ptr) *m++ = to_ptr;
2025 to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr);
2029 while (*m == from_ptr) *m++ = to_ptr;
2030 if (m != marks + sym_ptr->level+1) {
2033 Perl_croak(aTHX_ "panic: marks beyond string end, m=%p, marks=%p, "
2034 "level=%d", m, marks, sym_ptr->level);
2036 for (group=sym_ptr; group; group = group->previous)
2037 group->strbeg = marks[group->level] - to_start;
2042 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2043 from_start -= SvIVX(sv);
2046 SvFLAGS(sv) &= ~SVf_OOK;
2049 Safefree(from_start);
2050 SvPV_set(sv, to_start);
2051 SvCUR_set(sv, to_ptr - to_start);
2056 /* Exponential string grower. Makes string extension effectively O(n)
2057 needed says how many extra bytes we need (not counting the final '\0')
2058 Only grows the string if there is an actual lack of space
2061 S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) {
2062 const STRLEN cur = SvCUR(sv);
2063 const STRLEN len = SvLEN(sv);
2066 PERL_ARGS_ASSERT_SV_EXP_GROW;
2068 if (len - cur > needed) return SvPVX(sv);
2069 extend = needed > len ? needed : len;
2070 return SvGROW(sv, len+extend+1);
2075 S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
2077 tempsym_t lookahead;
2078 I32 items = endlist - beglist;
2079 bool found = next_symbol(symptr);
2080 bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
2081 bool warn_utf8 = ckWARN(WARN_UTF8);
2084 PERL_ARGS_ASSERT_PACK_REC;
2086 if (symptr->level == 0 && found && symptr->code == 'U') {
2087 marked_upgrade(aTHX_ cat, symptr);
2088 symptr->flags |= FLAG_DO_UTF8;
2091 symptr->strbeg = SvCUR(cat);
2097 SV *lengthcode = NULL;
2098 I32 datumtype = symptr->code;
2099 howlen_t howlen = symptr->howlen;
2100 char *start = SvPVX(cat);
2101 char *cur = start + SvCUR(cat);
2104 #define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2108 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ?
2112 /* e_no_len and e_number */
2113 len = symptr->length;
2118 packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
2120 if (props && !(props & PACK_SIZE_UNPREDICTABLE)) {
2121 /* We can process this letter. */
2122 STRLEN size = props & PACK_SIZE_MASK;
2123 GROWING(utf8, cat, start, cur, (STRLEN) len * size);
2127 /* Look ahead for next symbol. Do we have code/code? */
2128 lookahead = *symptr;
2129 found = next_symbol(&lookahead);
2130 if (symptr->flags & FLAG_SLASH) {
2132 if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack");
2133 if (strchr("aAZ", lookahead.code)) {
2134 if (lookahead.howlen == e_number) count = lookahead.length;
2137 count = sv_len_utf8(*beglist);
2140 if (lookahead.code == 'Z') count++;
2143 if (lookahead.howlen == e_number && lookahead.length < items)
2144 count = lookahead.length;
2147 lookahead.howlen = e_number;
2148 lookahead.length = count;
2149 lengthcode = sv_2mortal(newSViv(count));
2152 needs_swap = NEEDS_SWAP(datumtype);
2154 /* Code inside the switch must take care to properly update
2155 cat (CUR length and '\0' termination) if it updated *cur and
2156 doesn't simply leave using break */
2157 switch(TYPE_NO_ENDIANNESS(datumtype)) {
2159 Perl_croak(aTHX_ "Invalid type '%c' in pack",
2160 (int) TYPE_NO_MODIFIERS(datumtype));
2162 Perl_croak(aTHX_ "'%%' may not be used in pack");
2164 case '.' | TYPE_IS_SHRIEKING:
2166 if (howlen == e_star) from = start;
2167 else if (len == 0) from = cur;
2169 tempsym_t *group = symptr;
2171 while (--len && group) group = group->previous;
2172 from = group ? start + group->strbeg : start;
2175 len = SvIV(fromstr);
2177 case '@' | TYPE_IS_SHRIEKING:
2179 from = start + symptr->strbeg;
2181 if (utf8 && !(datumtype & TYPE_IS_SHRIEKING))
2183 while (len && from < cur) {
2184 from += UTF8SKIP(from);
2188 Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2190 /* Here we know from == cur */
2192 GROWING(0, cat, start, cur, len);
2193 Zero(cur, len, char);
2195 } else if (from < cur) {
2198 } else goto no_change;
2206 if (len > 0) goto grow;
2207 if (len == 0) goto no_change;
2214 tempsym_t savsym = *symptr;
2215 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2216 symptr->flags |= group_modifiers;
2217 symptr->patend = savsym.grpend;
2219 symptr->previous = &lookahead;
2222 if (utf8) symptr->flags |= FLAG_PARSE_UTF8;
2223 else symptr->flags &= ~FLAG_PARSE_UTF8;
2224 was_utf8 = SvUTF8(cat);
2225 symptr->patptr = savsym.grpbeg;
2226 beglist = pack_rec(cat, symptr, beglist, endlist);
2227 if (SvUTF8(cat) != was_utf8)
2228 /* This had better be an upgrade while in utf8==0 mode */
2231 if (savsym.howlen == e_star && beglist == endlist)
2232 break; /* No way to continue */
2234 items = endlist - beglist;
2235 lookahead.flags = symptr->flags & ~group_modifiers;
2238 case 'X' | TYPE_IS_SHRIEKING:
2239 if (!len) /* Avoid division by 0 */
2246 hop += UTF8SKIP(hop);
2253 Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2257 len = (cur-start) % len;
2261 if (len < 1) goto no_change;
2265 Perl_croak(aTHX_ "'%c' outside of string in pack",
2266 (int) TYPE_NO_MODIFIERS(datumtype));
2267 while (--cur, UTF8_IS_CONTINUATION(*cur)) {
2269 Perl_croak(aTHX_ "'%c' outside of string in pack",
2270 (int) TYPE_NO_MODIFIERS(datumtype));
2276 if (cur - start < len)
2277 Perl_croak(aTHX_ "'%c' outside of string in pack",
2278 (int) TYPE_NO_MODIFIERS(datumtype));
2281 if (cur < start+symptr->strbeg) {
2282 /* Make sure group starts don't point into the void */
2284 const STRLEN length = cur-start;
2285 for (group = symptr;
2286 group && length < group->strbeg;
2287 group = group->previous) group->strbeg = length;
2288 lookahead.strbeg = length;
2291 case 'x' | TYPE_IS_SHRIEKING: {
2293 if (!len) /* Avoid division by 0 */
2295 if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len;
2296 else ai32 = (cur - start) % len;
2297 if (ai32 == 0) goto no_change;
2309 aptr = SvPV_const(fromstr, fromlen);
2310 if (DO_UTF8(fromstr)) {
2311 const char *end, *s;
2313 if (!utf8 && !SvUTF8(cat)) {
2314 marked_upgrade(aTHX_ cat, symptr);
2315 lookahead.flags |= FLAG_DO_UTF8;
2316 lookahead.strbeg = symptr->strbeg;
2319 cur = start + SvCUR(cat);
2321 if (howlen == e_star) {
2322 if (utf8) goto string_copy;
2326 end = aptr + fromlen;
2327 fromlen = datumtype == 'Z' ? len-1 : len;
2328 while ((I32) fromlen > 0 && s < end) {
2333 Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
2336 if (datumtype == 'Z') len++;
2342 fromlen = len - fromlen;
2343 if (datumtype == 'Z') fromlen--;
2344 if (howlen == e_star) {
2346 if (datumtype == 'Z') len++;
2348 GROWING(0, cat, start, cur, len);
2349 if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
2350 datumtype | TYPE_IS_PACK))
2351 Perl_croak(aTHX_ "panic: predicted utf8 length not available, "
2352 "for '%c', aptr=%p end=%p cur=%p, fromlen=%"UVuf,
2353 (int)datumtype, aptr, end, cur, (UV)fromlen);
2357 if (howlen == e_star) {
2359 if (datumtype == 'Z') len++;
2361 if (len <= (I32) fromlen) {
2363 if (datumtype == 'Z' && fromlen > 0) fromlen--;
2365 /* assumes a byte expands to at most UTF8_EXPAND bytes on
2367 expected_length <= from_len*UTF8_EXPAND + (len-from_len) */
2368 GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len);
2370 while (fromlen > 0) {
2371 cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr);
2377 if (howlen == e_star) {
2379 if (datumtype == 'Z') len++;
2381 if (len <= (I32) fromlen) {
2383 if (datumtype == 'Z' && fromlen > 0) fromlen--;
2385 GROWING(0, cat, start, cur, len);
2386 Copy(aptr, cur, fromlen, char);
2390 memset(cur, datumtype == 'A' ? ' ' : '\0', len);
2397 const char *str, *end;
2404 str = SvPV_const(fromstr, fromlen);
2405 end = str + fromlen;
2406 if (DO_UTF8(fromstr)) {
2408 utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2410 utf8_source = FALSE;
2411 utf8_flags = 0; /* Unused, but keep compilers happy */
2413 if (howlen == e_star) len = fromlen;
2414 field_len = (len+7)/8;
2415 GROWING(utf8, cat, start, cur, field_len);
2416 if (len > (I32)fromlen) len = fromlen;
2419 if (datumtype == 'B')
2423 NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2425 } else bits |= *str++ & 1;
2426 if (l & 7) bits <<= 1;
2428 PUSH_BYTE(utf8, cur, bits);
2433 /* datumtype == 'b' */
2437 NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2438 if (val & 1) bits |= 0x80;
2439 } else if (*str++ & 1)
2441 if (l & 7) bits >>= 1;
2443 PUSH_BYTE(utf8, cur, bits);
2449 if (datumtype == 'B')
2450 bits <<= 7 - (l & 7);
2452 bits >>= 7 - (l & 7);
2453 PUSH_BYTE(utf8, cur, bits);
2456 /* Determine how many chars are left in the requested field */
2458 if (howlen == e_star) field_len = 0;
2459 else field_len -= l;
2460 Zero(cur, field_len, char);
2466 const char *str, *end;
2473 str = SvPV_const(fromstr, fromlen);
2474 end = str + fromlen;
2475 if (DO_UTF8(fromstr)) {
2477 utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
2479 utf8_source = FALSE;
2480 utf8_flags = 0; /* Unused, but keep compilers happy */
2482 if (howlen == e_star) len = fromlen;
2483 field_len = (len+1)/2;
2484 GROWING(utf8, cat, start, cur, field_len);
2485 if (!utf8 && len > (I32)fromlen) len = fromlen;
2488 if (datumtype == 'H')
2492 NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2493 if (val < 256 && isALPHA(val))
2494 bits |= (val + 9) & 0xf;
2497 } else if (isALPHA(*str))
2498 bits |= (*str++ + 9) & 0xf;
2500 bits |= *str++ & 0xf;
2501 if (l & 1) bits <<= 4;
2503 PUSH_BYTE(utf8, cur, bits);
2511 NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
2512 if (val < 256 && isALPHA(val))
2513 bits |= ((val + 9) & 0xf) << 4;
2515 bits |= (val & 0xf) << 4;
2516 } else if (isALPHA(*str))
2517 bits |= ((*str++ + 9) & 0xf) << 4;
2519 bits |= (*str++ & 0xf) << 4;
2520 if (l & 1) bits >>= 4;
2522 PUSH_BYTE(utf8, cur, bits);
2528 PUSH_BYTE(utf8, cur, bits);
2531 /* Determine how many chars are left in the requested field */
2533 if (howlen == e_star) field_len = 0;
2534 else field_len -= l;
2535 Zero(cur, field_len, char);
2543 if (SvNOK(fromstr) && Perl_isinfnan(SvNV(fromstr))) {
2544 /* 255 is a pretty arbitrary choice, but with
2545 * inf/-inf/nan and 256 bytes there is not much room. */
2547 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2548 "Character in 'c' format overflow in pack");
2551 aiv = SvIV(fromstr);
2552 if ((-128 > aiv || aiv > 127))
2553 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2554 "Character in 'c' format wrapped in pack");
2555 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2560 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
2566 if (SvNOK(fromstr) && Perl_isinfnan(SvNV(fromstr))) {
2567 /* See the 'c' case. */
2569 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2570 "Character in 'C' format overflow in pack");
2573 aiv = SvIV(fromstr);
2574 if ((0 > aiv || aiv > 0xff))
2575 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2576 "Character in 'C' format wrapped in pack");
2577 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2582 U8 in_bytes = (U8)IN_BYTES;
2584 end = start+SvLEN(cat)-1;
2585 if (utf8) end -= UTF8_MAXLEN-1;
2589 auv = SvUV(fromstr);
2590 if (in_bytes) auv = auv % 0x100;
2595 SvCUR_set(cat, cur - start);
2597 GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2598 end = start+SvLEN(cat)-UTF8_MAXLEN;
2600 cur = (char *) uvchr_to_utf8_flags((U8 *) cur,
2603 0 : UNICODE_ALLOW_ANY);
2608 SvCUR_set(cat, cur - start);
2609 marked_upgrade(aTHX_ cat, symptr);
2610 lookahead.flags |= FLAG_DO_UTF8;
2611 lookahead.strbeg = symptr->strbeg;
2614 cur = start + SvCUR(cat);
2615 end = start+SvLEN(cat)-UTF8_MAXLEN;
2618 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2619 "Character in 'W' format wrapped in pack");
2624 SvCUR_set(cat, cur - start);
2625 GROWING(0, cat, start, cur, len+1);
2626 end = start+SvLEN(cat)-1;
2628 *(U8 *) cur++ = (U8)auv;
2637 if (!(symptr->flags & FLAG_DO_UTF8)) {
2638 marked_upgrade(aTHX_ cat, symptr);
2639 lookahead.flags |= FLAG_DO_UTF8;
2640 lookahead.strbeg = symptr->strbeg;
2646 end = start+SvLEN(cat);
2647 if (!utf8) end -= UTF8_MAXLEN;
2651 auv = SvUV(fromstr);
2653 U8 buffer[UTF8_MAXLEN], *endb;
2654 endb = uvchr_to_utf8_flags(buffer, auv,
2656 0 : UNICODE_ALLOW_ANY);
2657 if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
2659 SvCUR_set(cat, cur - start);
2660 GROWING(0, cat, start, cur,
2661 len+(endb-buffer)*UTF8_EXPAND);
2662 end = start+SvLEN(cat);
2664 cur = S_bytes_to_uni(buffer, endb-buffer, cur, 0);
2668 SvCUR_set(cat, cur - start);
2669 GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2670 end = start+SvLEN(cat)-UTF8_MAXLEN;
2672 cur = (char *) uvchr_to_utf8_flags((U8 *) cur, auv,
2674 0 : UNICODE_ALLOW_ANY);
2679 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2685 anv = SvNV(fromstr);
2686 # if defined(VMS) && !defined(_IEEE_FP)
2687 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2688 * on Alpha; fake it if we don't have them.
2692 else if (anv < -FLT_MAX)
2694 else afloat = (float)anv;
2696 afloat = (float)anv;
2698 PUSH_VAR(utf8, cur, afloat, needs_swap);
2706 anv = SvNV(fromstr);
2707 # if defined(VMS) && !defined(_IEEE_FP)
2708 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2709 * on Alpha; fake it if we don't have them.
2713 else if (anv < -DBL_MAX)
2715 else adouble = (double)anv;
2717 adouble = (double)anv;
2719 PUSH_VAR(utf8, cur, adouble, needs_swap);
2724 Zero(&anv, 1, NV); /* can be long double with unused bits */
2728 /* to work round a gcc/x86 bug; don't use SvNV */
2729 anv.nv = sv_2nv(fromstr);
2731 anv.nv = SvNV(fromstr);
2733 PUSH_BYTES(utf8, cur, anv.bytes, sizeof(anv.bytes), needs_swap);
2737 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2740 /* long doubles can have unused bits, which may be nonzero */
2741 Zero(&aldouble, 1, long double);
2745 /* to work round a gcc/x86 bug; don't use SvNV */
2746 aldouble.ld = (long double)sv_2nv(fromstr);
2748 aldouble.ld = (long double)SvNV(fromstr);
2750 PUSH_BYTES(utf8, cur, aldouble.bytes, sizeof(aldouble.bytes),
2756 case 'n' | TYPE_IS_SHRIEKING:
2761 ai16 = (I16)SvIV(fromstr);
2762 ai16 = PerlSock_htons(ai16);
2763 PUSH16(utf8, cur, &ai16, FALSE);
2766 case 'v' | TYPE_IS_SHRIEKING:
2771 ai16 = (I16)SvIV(fromstr);
2773 PUSH16(utf8, cur, &ai16, FALSE);
2776 case 'S' | TYPE_IS_SHRIEKING:
2777 #if SHORTSIZE != SIZE16
2779 unsigned short aushort;
2781 aushort = SvUV(fromstr);
2782 PUSH_VAR(utf8, cur, aushort, needs_swap);
2792 au16 = (U16)SvUV(fromstr);
2793 PUSH16(utf8, cur, &au16, needs_swap);
2796 case 's' | TYPE_IS_SHRIEKING:
2797 #if SHORTSIZE != SIZE16
2801 ashort = SvIV(fromstr);
2802 PUSH_VAR(utf8, cur, ashort, needs_swap);
2812 ai16 = (I16)SvIV(fromstr);
2813 PUSH16(utf8, cur, &ai16, needs_swap);
2817 case 'I' | TYPE_IS_SHRIEKING:
2821 auint = SvUV(fromstr);
2822 PUSH_VAR(utf8, cur, auint, needs_swap);
2829 aiv = SvIV(fromstr);
2830 PUSH_VAR(utf8, cur, aiv, needs_swap);
2837 auv = SvUV(fromstr);
2838 PUSH_VAR(utf8, cur, auv, needs_swap);
2845 anv = SvNV(fromstr);
2849 SvCUR_set(cat, cur - start);
2850 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2853 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2854 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2855 any negative IVs will have already been got by the croak()
2856 above. IOK is untrue for fractions, so we test them
2857 against UV_MAX_P1. */
2858 if (SvIOK(fromstr) || anv < UV_MAX_P1) {
2859 char buf[(sizeof(UV)*CHAR_BIT)/7+1];
2860 char *in = buf + sizeof(buf);
2861 UV auv = SvUV(fromstr);
2864 *--in = (char)((auv & 0x7f) | 0x80);
2867 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2868 PUSH_GROWING_BYTES(utf8, cat, start, cur,
2869 in, (buf + sizeof(buf)) - in);
2870 } else if (SvPOKp(fromstr))
2872 else if (SvNOKp(fromstr)) {
2873 /* 10**NV_MAX_10_EXP is the largest power of 10
2874 so 10**(NV_MAX_10_EXP+1) is definitely unrepresentable
2875 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2876 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2877 And with that many bytes only Inf can overflow.
2878 Some C compilers are strict about integral constant
2879 expressions so we conservatively divide by a slightly
2880 smaller integer instead of multiplying by the exact
2881 floating-point value.
2883 #ifdef NV_MAX_10_EXP
2884 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2885 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2887 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2888 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2890 char *in = buf + sizeof(buf);
2892 anv = Perl_floor(anv);
2894 const NV next = Perl_floor(anv / 128);
2895 if (in <= buf) /* this cannot happen ;-) */
2896 Perl_croak(aTHX_ "Cannot compress integer in pack");
2897 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2900 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2901 PUSH_GROWING_BYTES(utf8, cat, start, cur,
2902 in, (buf + sizeof(buf)) - in);
2911 /* Copy string and check for compliance */
2912 from = SvPV_const(fromstr, len);
2913 if ((norm = is_an_int(from, len)) == NULL)
2914 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2916 Newx(result, len, char);
2919 while (!done) *--in = div128(norm, &done) | 0x80;
2920 result[len - 1] &= 0x7F; /* clear continue bit */
2921 PUSH_GROWING_BYTES(utf8, cat, start, cur,
2922 in, (result + len) - in);
2924 SvREFCNT_dec(norm); /* free norm */
2929 case 'i' | TYPE_IS_SHRIEKING:
2933 aint = SvIV(fromstr);
2934 PUSH_VAR(utf8, cur, aint, needs_swap);
2937 case 'N' | TYPE_IS_SHRIEKING:
2942 au32 = SvUV(fromstr);
2943 au32 = PerlSock_htonl(au32);
2944 PUSH32(utf8, cur, &au32, FALSE);
2947 case 'V' | TYPE_IS_SHRIEKING:
2952 au32 = SvUV(fromstr);
2954 PUSH32(utf8, cur, &au32, FALSE);
2957 case 'L' | TYPE_IS_SHRIEKING:
2958 #if LONGSIZE != SIZE32
2960 unsigned long aulong;
2962 aulong = SvUV(fromstr);
2963 PUSH_VAR(utf8, cur, aulong, needs_swap);
2973 au32 = SvUV(fromstr);
2974 PUSH32(utf8, cur, &au32, needs_swap);
2977 case 'l' | TYPE_IS_SHRIEKING:
2978 #if LONGSIZE != SIZE32
2982 along = SvIV(fromstr);
2983 PUSH_VAR(utf8, cur, along, needs_swap);
2993 ai32 = SvIV(fromstr);
2994 PUSH32(utf8, cur, &ai32, needs_swap);
2997 #if defined(HAS_QUAD) && IVSIZE >= 8
3002 auquad = (Uquad_t) SvUV(fromstr);
3003 PUSH_VAR(utf8, cur, auquad, needs_swap);
3010 aquad = (Quad_t)SvIV(fromstr);
3011 PUSH_VAR(utf8, cur, aquad, needs_swap);
3016 len = 1; /* assume SV is correct length */
3017 GROWING(utf8, cat, start, cur, sizeof(char *));
3024 SvGETMAGIC(fromstr);
3025 if (!SvOK(fromstr)) aptr = NULL;
3027 /* XXX better yet, could spirit away the string to
3028 * a safe spot and hang on to it until the result
3029 * of pack() (and all copies of the result) are
3032 if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
3033 !SvREADONLY(fromstr)))) {
3034 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3035 "Attempt to pack pointer to temporary value");
3037 if (SvPOK(fromstr) || SvNIOK(fromstr))
3038 aptr = SvPV_nomg_const_nolen(fromstr);
3040 aptr = SvPV_force_flags_nolen(fromstr, 0);
3042 PUSH_VAR(utf8, cur, aptr, needs_swap);
3046 const char *aptr, *aend;
3050 if (len <= 2) len = 45;
3051 else len = len / 3 * 3;
3053 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3054 "Field too wide in 'u' format in pack");
3057 aptr = SvPV_const(fromstr, fromlen);
3058 from_utf8 = DO_UTF8(fromstr);
3060 aend = aptr + fromlen;
3061 fromlen = sv_len_utf8_nomg(fromstr);
3062 } else aend = NULL; /* Unused, but keep compilers happy */
3063 GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2);
3064 while (fromlen > 0) {
3067 U8 hunk[1+63/3*4+1];
3069 if ((I32)fromlen > len)
3075 if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo,
3076 'u' | TYPE_IS_PACK)) {
3078 SvCUR_set(cat, cur - start);
3079 Perl_croak(aTHX_ "panic: string is shorter than advertised, "
3080 "aptr=%p, aend=%p, buffer=%p, todo=%ld",
3081 aptr, aend, buffer, (long) todo);
3083 end = doencodes(hunk, buffer, todo);
3085 end = doencodes(hunk, aptr, todo);
3088 PUSH_BYTES(utf8, cur, hunk, end-hunk, 0);
3095 SvCUR_set(cat, cur - start);
3097 *symptr = lookahead;
3106 dSP; dMARK; dORIGMARK; dTARGET;
3109 SV *pat_sv = *++MARK;
3110 const char *pat = SvPV_const(pat_sv, fromlen);
3111 const char *patend = pat + fromlen;
3117 packlist(cat, pat, patend, MARK, SP + 1);
3127 * c-indentation-style: bsd
3129 * indent-tabs-mode: nil
3132 * ex: set ts=8 sts=4 sw=4 et: