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 aiv = SvIV(fromstr);
2544 if ((-128 > aiv || aiv > 127))
2545 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2546 "Character in 'c' format wrapped in pack");
2547 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2552 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
2558 aiv = SvIV(fromstr);
2559 if ((0 > aiv || aiv > 0xff))
2560 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2561 "Character in 'C' format wrapped in pack");
2562 PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
2567 U8 in_bytes = (U8)IN_BYTES;
2569 end = start+SvLEN(cat)-1;
2570 if (utf8) end -= UTF8_MAXLEN-1;
2574 auv = SvUV(fromstr);
2575 if (in_bytes) auv = auv % 0x100;
2580 SvCUR_set(cat, cur - start);
2582 GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2583 end = start+SvLEN(cat)-UTF8_MAXLEN;
2585 cur = (char *) uvchr_to_utf8_flags((U8 *) cur,
2588 0 : UNICODE_ALLOW_ANY);
2593 SvCUR_set(cat, cur - start);
2594 marked_upgrade(aTHX_ cat, symptr);
2595 lookahead.flags |= FLAG_DO_UTF8;
2596 lookahead.strbeg = symptr->strbeg;
2599 cur = start + SvCUR(cat);
2600 end = start+SvLEN(cat)-UTF8_MAXLEN;
2603 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
2604 "Character in 'W' format wrapped in pack");
2609 SvCUR_set(cat, cur - start);
2610 GROWING(0, cat, start, cur, len+1);
2611 end = start+SvLEN(cat)-1;
2613 *(U8 *) cur++ = (U8)auv;
2622 if (!(symptr->flags & FLAG_DO_UTF8)) {
2623 marked_upgrade(aTHX_ cat, symptr);
2624 lookahead.flags |= FLAG_DO_UTF8;
2625 lookahead.strbeg = symptr->strbeg;
2631 end = start+SvLEN(cat);
2632 if (!utf8) end -= UTF8_MAXLEN;
2636 auv = SvUV(fromstr);
2638 U8 buffer[UTF8_MAXLEN], *endb;
2639 endb = uvchr_to_utf8_flags(buffer, auv,
2641 0 : UNICODE_ALLOW_ANY);
2642 if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
2644 SvCUR_set(cat, cur - start);
2645 GROWING(0, cat, start, cur,
2646 len+(endb-buffer)*UTF8_EXPAND);
2647 end = start+SvLEN(cat);
2649 cur = S_bytes_to_uni(buffer, endb-buffer, cur, 0);
2653 SvCUR_set(cat, cur - start);
2654 GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
2655 end = start+SvLEN(cat)-UTF8_MAXLEN;
2657 cur = (char *) uvchr_to_utf8_flags((U8 *) cur, auv,
2659 0 : UNICODE_ALLOW_ANY);
2664 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2670 anv = SvNV(fromstr);
2671 # if defined(VMS) && !defined(_IEEE_FP)
2672 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2673 * on Alpha; fake it if we don't have them.
2677 else if (anv < -FLT_MAX)
2679 else afloat = (float)anv;
2681 afloat = (float)anv;
2683 PUSH_VAR(utf8, cur, afloat, needs_swap);
2691 anv = SvNV(fromstr);
2692 # if defined(VMS) && !defined(_IEEE_FP)
2693 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2694 * on Alpha; fake it if we don't have them.
2698 else if (anv < -DBL_MAX)
2700 else adouble = (double)anv;
2702 adouble = (double)anv;
2704 PUSH_VAR(utf8, cur, adouble, needs_swap);
2709 Zero(&anv, 1, NV); /* can be long double with unused bits */
2713 /* to work round a gcc/x86 bug; don't use SvNV */
2714 anv.nv = sv_2nv(fromstr);
2716 anv.nv = SvNV(fromstr);
2718 PUSH_BYTES(utf8, cur, anv.bytes, sizeof(anv.bytes), needs_swap);
2722 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2725 /* long doubles can have unused bits, which may be nonzero */
2726 Zero(&aldouble, 1, long double);
2730 /* to work round a gcc/x86 bug; don't use SvNV */
2731 aldouble.ld = (long double)sv_2nv(fromstr);
2733 aldouble.ld = (long double)SvNV(fromstr);
2735 PUSH_BYTES(utf8, cur, aldouble.bytes, sizeof(aldouble.bytes),
2741 case 'n' | TYPE_IS_SHRIEKING:
2746 ai16 = (I16)SvIV(fromstr);
2747 ai16 = PerlSock_htons(ai16);
2748 PUSH16(utf8, cur, &ai16, FALSE);
2751 case 'v' | TYPE_IS_SHRIEKING:
2756 ai16 = (I16)SvIV(fromstr);
2758 PUSH16(utf8, cur, &ai16, FALSE);
2761 case 'S' | TYPE_IS_SHRIEKING:
2762 #if SHORTSIZE != SIZE16
2764 unsigned short aushort;
2766 aushort = SvUV(fromstr);
2767 PUSH_VAR(utf8, cur, aushort, needs_swap);
2777 au16 = (U16)SvUV(fromstr);
2778 PUSH16(utf8, cur, &au16, needs_swap);
2781 case 's' | TYPE_IS_SHRIEKING:
2782 #if SHORTSIZE != SIZE16
2786 ashort = SvIV(fromstr);
2787 PUSH_VAR(utf8, cur, ashort, needs_swap);
2797 ai16 = (I16)SvIV(fromstr);
2798 PUSH16(utf8, cur, &ai16, needs_swap);
2802 case 'I' | TYPE_IS_SHRIEKING:
2806 auint = SvUV(fromstr);
2807 PUSH_VAR(utf8, cur, auint, needs_swap);
2814 aiv = SvIV(fromstr);
2815 PUSH_VAR(utf8, cur, aiv, needs_swap);
2822 auv = SvUV(fromstr);
2823 PUSH_VAR(utf8, cur, auv, needs_swap);
2830 anv = SvNV(fromstr);
2834 SvCUR_set(cat, cur - start);
2835 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2838 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2839 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2840 any negative IVs will have already been got by the croak()
2841 above. IOK is untrue for fractions, so we test them
2842 against UV_MAX_P1. */
2843 if (SvIOK(fromstr) || anv < UV_MAX_P1) {
2844 char buf[(sizeof(UV)*CHAR_BIT)/7+1];
2845 char *in = buf + sizeof(buf);
2846 UV auv = SvUV(fromstr);
2849 *--in = (char)((auv & 0x7f) | 0x80);
2852 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2853 PUSH_GROWING_BYTES(utf8, cat, start, cur,
2854 in, (buf + sizeof(buf)) - in);
2855 } else if (SvPOKp(fromstr))
2857 else if (SvNOKp(fromstr)) {
2858 /* 10**NV_MAX_10_EXP is the largest power of 10
2859 so 10**(NV_MAX_10_EXP+1) is definitely unrepresentable
2860 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2861 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2862 And with that many bytes only Inf can overflow.
2863 Some C compilers are strict about integral constant
2864 expressions so we conservatively divide by a slightly
2865 smaller integer instead of multiplying by the exact
2866 floating-point value.
2868 #ifdef NV_MAX_10_EXP
2869 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2870 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2872 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2873 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2875 char *in = buf + sizeof(buf);
2877 anv = Perl_floor(anv);
2879 const NV next = Perl_floor(anv / 128);
2880 if (in <= buf) /* this cannot happen ;-) */
2881 Perl_croak(aTHX_ "Cannot compress integer in pack");
2882 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2885 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2886 PUSH_GROWING_BYTES(utf8, cat, start, cur,
2887 in, (buf + sizeof(buf)) - in);
2896 /* Copy string and check for compliance */
2897 from = SvPV_const(fromstr, len);
2898 if ((norm = is_an_int(from, len)) == NULL)
2899 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2901 Newx(result, len, char);
2904 while (!done) *--in = div128(norm, &done) | 0x80;
2905 result[len - 1] &= 0x7F; /* clear continue bit */
2906 PUSH_GROWING_BYTES(utf8, cat, start, cur,
2907 in, (result + len) - in);
2909 SvREFCNT_dec(norm); /* free norm */
2914 case 'i' | TYPE_IS_SHRIEKING:
2918 aint = SvIV(fromstr);
2919 PUSH_VAR(utf8, cur, aint, needs_swap);
2922 case 'N' | TYPE_IS_SHRIEKING:
2927 au32 = SvUV(fromstr);
2928 au32 = PerlSock_htonl(au32);
2929 PUSH32(utf8, cur, &au32, FALSE);
2932 case 'V' | TYPE_IS_SHRIEKING:
2937 au32 = SvUV(fromstr);
2939 PUSH32(utf8, cur, &au32, FALSE);
2942 case 'L' | TYPE_IS_SHRIEKING:
2943 #if LONGSIZE != SIZE32
2945 unsigned long aulong;
2947 aulong = SvUV(fromstr);
2948 PUSH_VAR(utf8, cur, aulong, needs_swap);
2958 au32 = SvUV(fromstr);
2959 PUSH32(utf8, cur, &au32, needs_swap);
2962 case 'l' | TYPE_IS_SHRIEKING:
2963 #if LONGSIZE != SIZE32
2967 along = SvIV(fromstr);
2968 PUSH_VAR(utf8, cur, along, needs_swap);
2978 ai32 = SvIV(fromstr);
2979 PUSH32(utf8, cur, &ai32, needs_swap);
2982 #if defined(HAS_QUAD) && IVSIZE >= 8
2987 auquad = (Uquad_t) SvUV(fromstr);
2988 PUSH_VAR(utf8, cur, auquad, needs_swap);
2995 aquad = (Quad_t)SvIV(fromstr);
2996 PUSH_VAR(utf8, cur, aquad, needs_swap);
3001 len = 1; /* assume SV is correct length */
3002 GROWING(utf8, cat, start, cur, sizeof(char *));
3009 SvGETMAGIC(fromstr);
3010 if (!SvOK(fromstr)) aptr = NULL;
3012 /* XXX better yet, could spirit away the string to
3013 * a safe spot and hang on to it until the result
3014 * of pack() (and all copies of the result) are
3017 if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
3018 !SvREADONLY(fromstr)))) {
3019 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3020 "Attempt to pack pointer to temporary value");
3022 if (SvPOK(fromstr) || SvNIOK(fromstr))
3023 aptr = SvPV_nomg_const_nolen(fromstr);
3025 aptr = SvPV_force_flags_nolen(fromstr, 0);
3027 PUSH_VAR(utf8, cur, aptr, needs_swap);
3031 const char *aptr, *aend;
3035 if (len <= 2) len = 45;
3036 else len = len / 3 * 3;
3038 Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
3039 "Field too wide in 'u' format in pack");
3042 aptr = SvPV_const(fromstr, fromlen);
3043 from_utf8 = DO_UTF8(fromstr);
3045 aend = aptr + fromlen;
3046 fromlen = sv_len_utf8_nomg(fromstr);
3047 } else aend = NULL; /* Unused, but keep compilers happy */
3048 GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2);
3049 while (fromlen > 0) {
3052 U8 hunk[1+63/3*4+1];
3054 if ((I32)fromlen > len)
3060 if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo,
3061 'u' | TYPE_IS_PACK)) {
3063 SvCUR_set(cat, cur - start);
3064 Perl_croak(aTHX_ "panic: string is shorter than advertised, "
3065 "aptr=%p, aend=%p, buffer=%p, todo=%ld",
3066 aptr, aend, buffer, (long) todo);
3068 end = doencodes(hunk, buffer, todo);
3070 end = doencodes(hunk, aptr, todo);
3073 PUSH_BYTES(utf8, cur, hunk, end-hunk, 0);
3080 SvCUR_set(cat, cur - start);
3082 *symptr = lookahead;
3091 dSP; dMARK; dORIGMARK; dTARGET;
3094 SV *pat_sv = *++MARK;
3095 const char *pat = SvPV_const(pat_sv, fromlen);
3096 const char *patend = pat + fromlen;
3102 packlist(cat, pat, patend, MARK, SP + 1);
3112 * c-indentation-style: bsd
3114 * indent-tabs-mode: nil
3117 * ex: set ts=8 sts=4 sw=4 et: