3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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,
19 /* This file contains pp ("push/pop") functions that
20 * execute the opcodes that make up a perl program. A typical pp function
21 * expects to find its arguments on the stack, and usually pushes its
22 * results onto the stack, hence the 'pp' terminology. Each OP structure
23 * contains a pointer to the relevant pp_foo() function.
25 * This particular file just contains pp_pack() and pp_unpack(). See the
26 * other pp*.c files for the rest of the pp_ functions.
31 #define PERL_IN_PP_PACK_C
35 #define PERL_PACK_CAN_BYTEORDER
36 #define PERL_PACK_CAN_SHRIEKSIGN
40 * Offset for integer pack/unpack.
42 * On architectures where I16 and I32 aren't really 16 and 32 bits,
43 * which for now are all Crays, pack and unpack have to play games.
47 * These values are required for portability of pack() output.
48 * If they're not right on your machine, then pack() and unpack()
49 * wouldn't work right anyway; you'll need to apply the Cray hack.
50 * (I'd like to check them with #if, but you can't use sizeof() in
51 * the preprocessor.) --???
54 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
55 defines are now in config.h. --Andy Dougherty April 1998
60 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
63 #if U16SIZE > SIZE16 || U32SIZE > SIZE32
64 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
65 # define OFF16(p) ((char*)(p))
66 # define OFF32(p) ((char*)(p))
68 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
69 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
70 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
72 ++++ bad cray byte order
76 # define OFF16(p) ((char *) (p))
77 # define OFF32(p) ((char *) (p))
80 #define COPY16(s,p) Copy(s, OFF16(p), SIZE16, char)
81 #define COPY32(s,p) Copy(s, OFF32(p), SIZE32, char)
82 #define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
83 #define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
85 /* Only to be used inside a loop (see the break) */
86 #define COPYVAR(s,strend,utf8,var,format) \
89 if (!next_uni_bytes(aTHX_ &s, strend, \
90 (char *) &var, sizeof(var))) break; \
92 Copy(s, (char *) &var, sizeof(var), char); \
95 DO_BO_UNPACK(var, format); \
98 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
99 #define MAX_SUB_TEMPLATE_LEVEL 100
101 /* flags (note that type modifiers can also be used as flags!) */
102 #define FLAG_UNPACK_WAS_UTF8 0x40 /* original had FLAG_UNPACK_DO_UTF8 */
103 #define FLAG_UNPACK_PARSE_UTF8 0x20 /* Parse as utf8 */
104 #define FLAG_UNPACK_ONLY_ONE 0x10
105 #define FLAG_UNPACK_DO_UTF8 0x08 /* The underlying string is utf8 */
106 #define FLAG_SLASH 0x04
107 #define FLAG_COMMA 0x02
108 #define FLAG_PACK 0x01
111 S_mul128(pTHX_ SV *sv, U8 m)
114 char *s = SvPV(sv, len);
118 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
119 SV *tmpNew = newSVpvn("0000000000", 10);
121 sv_catsv(tmpNew, sv);
122 SvREFCNT_dec(sv); /* free old sv */
127 while (!*t) /* trailing '\0'? */
130 i = ((*t - '0') << 7) + m;
131 *(t--) = '0' + (char)(i % 10);
137 /* Explosives and implosives. */
139 #if 'I' == 73 && 'J' == 74
140 /* On an ASCII/ISO kind of system */
141 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
144 Some other sort of character set - use memchr() so we don't match
147 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
151 #define TYPE_IS_SHRIEKING 0x100
152 #define TYPE_IS_BIG_ENDIAN 0x200
153 #define TYPE_IS_LITTLE_ENDIAN 0x400
154 #define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
155 #define TYPE_MODIFIERS(t) ((t) & ~0xFF)
156 #define TYPE_NO_MODIFIERS(t) ((t) & 0xFF)
158 #ifdef PERL_PACK_CAN_SHRIEKSIGN
159 #define SHRIEKING_ALLOWED_TYPES "sSiIlLxXnNvV"
161 #define SHRIEKING_ALLOWED_TYPES "sSiIlLxX"
164 #ifndef PERL_PACK_CAN_BYTEORDER
165 /* Put "can't" first because it is shorter */
166 # define TYPE_ENDIANNESS(t) 0
167 # define TYPE_NO_ENDIANNESS(t) (t)
169 # define ENDIANNESS_ALLOWED_TYPES ""
171 # define DO_BO_UNPACK(var, type)
172 # define DO_BO_PACK(var, type)
173 # define DO_BO_UNPACK_PTR(var, type, pre_cast)
174 # define DO_BO_PACK_PTR(var, type, pre_cast)
175 # define DO_BO_UNPACK_N(var, type)
176 # define DO_BO_PACK_N(var, type)
177 # define DO_BO_UNPACK_P(var)
178 # define DO_BO_PACK_P(var)
182 # define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK)
183 # define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK)
185 # define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP("
187 # define DO_BO_UNPACK(var, type) \
189 switch (TYPE_ENDIANNESS(datumtype)) { \
190 case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \
191 case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \
196 # define DO_BO_PACK(var, type) \
198 switch (TYPE_ENDIANNESS(datumtype)) { \
199 case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \
200 case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \
205 # define DO_BO_UNPACK_PTR(var, type, pre_cast) \
207 switch (TYPE_ENDIANNESS(datumtype)) { \
208 case TYPE_IS_BIG_ENDIAN: \
209 var = (void *) my_betoh ## type ((pre_cast) var); \
211 case TYPE_IS_LITTLE_ENDIAN: \
212 var = (void *) my_letoh ## type ((pre_cast) var); \
219 # define DO_BO_PACK_PTR(var, type, pre_cast) \
221 switch (TYPE_ENDIANNESS(datumtype)) { \
222 case TYPE_IS_BIG_ENDIAN: \
223 var = (void *) my_htobe ## type ((pre_cast) var); \
225 case TYPE_IS_LITTLE_ENDIAN: \
226 var = (void *) my_htole ## type ((pre_cast) var); \
233 # define BO_CANT_DOIT(action, type) \
235 switch (TYPE_ENDIANNESS(datumtype)) { \
236 case TYPE_IS_BIG_ENDIAN: \
237 Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \
238 "platform", #action, #type); \
240 case TYPE_IS_LITTLE_ENDIAN: \
241 Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \
242 "platform", #action, #type); \
249 # if PTRSIZE == INTSIZE
250 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, i, int)
251 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, i, int)
252 # elif PTRSIZE == LONGSIZE
253 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long)
254 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long)
256 # define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer)
257 # define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer)
260 # if defined(my_htolen) && defined(my_letohn) && \
261 defined(my_htoben) && defined(my_betohn)
262 # define DO_BO_UNPACK_N(var, type) \
264 switch (TYPE_ENDIANNESS(datumtype)) { \
265 case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\
266 case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
271 # define DO_BO_PACK_N(var, type) \
273 switch (TYPE_ENDIANNESS(datumtype)) { \
274 case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\
275 case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
280 # define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type)
281 # define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type)
286 #define PACK_SIZE_CANNOT_CSUM 0x80
287 #define PACK_SIZE_SPARE 0x40
288 #define PACK_SIZE_MASK 0x3F
292 const unsigned char *array;
297 #define PACK_SIZE_NORMAL 0
298 #define PACK_SIZE_SHRIEKING 1
300 /* These tables are regenerated by genpacksizetables.pl (and then hand pasted
301 in). You're unlikely ever to need to regenerate them. */
304 unsigned char size_normal[53] = {
305 /* C */ sizeof(unsigned char),
306 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
307 /* D */ LONG_DOUBLESIZE,
314 /* I */ sizeof(unsigned int),
321 #if defined(HAS_QUAD)
322 /* Q */ sizeof(Uquad_t),
329 /* U */ sizeof(char),
331 /* W */ sizeof(unsigned char),
332 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
333 /* c */ sizeof(char),
334 /* d */ sizeof(double),
336 /* f */ sizeof(float),
345 /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM,
346 #if defined(HAS_QUAD)
347 /* q */ sizeof(Quad_t),
355 /* w */ sizeof(char) | PACK_SIZE_CANNOT_CSUM,
357 unsigned char size_shrieking[46] = {
358 /* I */ sizeof(unsigned int),
360 /* L */ sizeof(unsigned long),
362 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
368 /* S */ sizeof(unsigned short),
370 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
375 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
378 /* l */ sizeof(long),
380 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
386 /* s */ sizeof(short),
388 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
394 struct packsize_t packsize[2] = {
395 {size_normal, 67, 53},
396 {size_shrieking, 73, 46}
399 /* EBCDIC (or bust) */
400 unsigned char size_normal[100] = {
401 /* c */ sizeof(char),
402 /* d */ sizeof(double),
404 /* f */ sizeof(float),
414 /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM,
415 #if defined(HAS_QUAD)
416 /* q */ sizeof(Quad_t),
420 0, 0, 0, 0, 0, 0, 0, 0, 0,
424 /* w */ sizeof(char) | PACK_SIZE_CANNOT_CSUM,
425 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
427 /* C */ sizeof(unsigned char),
428 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
429 /* D */ LONG_DOUBLESIZE,
436 /* I */ sizeof(unsigned int),
444 #if defined(HAS_QUAD)
445 /* Q */ sizeof(Uquad_t),
449 0, 0, 0, 0, 0, 0, 0, 0, 0,
452 /* U */ sizeof(char),
454 /* W */ sizeof(unsigned char),
456 unsigned char size_shrieking[93] = {
458 0, 0, 0, 0, 0, 0, 0, 0, 0,
459 /* l */ sizeof(long),
461 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
466 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
467 /* s */ sizeof(short),
469 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
474 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
475 0, 0, 0, 0, 0, 0, 0, 0, 0,
476 /* I */ sizeof(unsigned int),
477 0, 0, 0, 0, 0, 0, 0, 0, 0,
478 /* L */ sizeof(unsigned long),
480 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
485 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
486 /* S */ sizeof(unsigned short),
488 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
494 struct packsize_t packsize[2] = {
495 {size_normal, 131, 100},
496 {size_shrieking, 137, 93}
501 next_uni_byte(pTHX_ char **s, const char *end, I32 datumtype)
506 UNI_TO_NATIVE(utf8n_to_uvuni(*s, end-*s, &retlen,
507 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY));
508 /* We try to process malformed UTF-8 as much as possible (preferrably with
509 warnings), but these two mean we make no progress in the string and
510 might enter an infinite loop */
511 if (retlen == (STRLEN) -1 || retlen == 0)
512 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
514 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
515 "Character in '%c' format wrapped in unpack",
523 #define NEXT_BYTE(utf8, s, strend, datumtype) ((utf8) ? \
524 next_uni_byte(aTHX_ &(s), (strend), (datumtype)) : \
528 next_uni_bytes(pTHX_ char **s, char *end, char *buf, int buf_len)
534 U32 flags = ckWARN(WARN_UTF8) ?
535 UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY | UTF8_ALLOW_ANY);
536 for (;buf_len > 0; buf_len--) {
537 if (from >= end) return FALSE;
538 val = UNI_TO_NATIVE(utf8n_to_uvuni(from, end-from, &retlen, flags));
539 if (retlen == (STRLEN) -1 || retlen == 0) {
540 from += UTF8SKIP(from);
542 } else from += retlen;
549 /* We have enough characters for the buffer. Did we have problems ? */
552 /* Rewalk the string fragment while warning */
554 flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
555 for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) {
556 if (ptr >= end) break;
557 utf8n_to_uvuni(ptr, end-ptr, &retlen, flags);
559 if (from > end) from = end;
561 if ((bad & 2) && ckWARN(WARN_UNPACK))
562 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
563 "Character(s) wrapped in unpack");
570 next_uni_uu(pTHX_ char **s, const char *end, I32 *out)
575 val = UNI_TO_NATIVE(utf8n_to_uvuni(*s, end-*s, &retlen, UTF8_CHECK_ONLY));
576 if (val >= 0x100 || !ISUUCHAR(val) ||
577 retlen == (STRLEN) -1 || retlen == 0) {
581 *out = PL_uudmap[val] & 077;
586 /* Returns the sizeof() struct described by pat */
588 S_measure_struct(pTHX_ register tempsym_t* symptr)
590 register I32 len = 0;
591 register I32 total = 0;
596 while (next_symbol(symptr)) {
597 int which = (symptr->code & TYPE_IS_SHRIEKING)
598 ? PACK_SIZE_SHRIEKING : PACK_SIZE_NORMAL;
600 = TYPE_NO_MODIFIERS(symptr->code) - packsize[which].first;
602 switch( symptr->howlen ){
605 len = symptr->length;
608 Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
609 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
613 if ((offset >= 0) && (offset < packsize[which].size))
614 size = packsize[which].array[offset] & PACK_SIZE_MASK;
619 /* endianness doesn't influence the size of a type */
620 switch(TYPE_NO_ENDIANNESS(symptr->code)) {
622 Perl_croak(aTHX_ "Invalid type '%c' in %s",
623 (int)TYPE_NO_MODIFIERS(symptr->code),
624 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
627 case 'U': /* XXXX Is it correct? */
630 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
632 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
638 tempsym_t savsym = *symptr;
639 symptr->patptr = savsym.grpbeg;
640 symptr->patend = savsym.grpend;
641 /* XXXX Theoretically, we need to measure many times at
642 different positions, since the subexpression may contain
643 alignment commands, but be not of aligned length.
644 Need to detect this and croak(). */
645 size = measure_struct(symptr);
649 case 'X' | TYPE_IS_SHRIEKING:
650 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS.
652 if (!len) /* Avoid division by 0 */
654 len = total % len; /* Assumed: the start is aligned. */
659 Perl_croak(aTHX_ "'X' outside of string in %s",
660 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
662 case 'x' | TYPE_IS_SHRIEKING:
663 if (!len) /* Avoid division by 0 */
665 star = total % len; /* Assumed: the start is aligned. */
666 if (star) /* Other portable ways? */
690 size = sizeof(char*);
700 /* locate matching closing parenthesis or bracket
701 * returns char pointer to char after match, or NULL
704 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
706 while (patptr < patend) {
714 while (patptr < patend && *patptr != '\n')
718 patptr = group_end(patptr, patend, ')') + 1;
720 patptr = group_end(patptr, patend, ']') + 1;
722 Perl_croak(aTHX_ "No group ending character '%c' found in template",
728 /* Convert unsigned decimal number to binary.
729 * Expects a pointer to the first digit and address of length variable
730 * Advances char pointer to 1st non-digit char and returns number
733 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
735 I32 len = *patptr++ - '0';
736 while (isDIGIT(*patptr)) {
737 if (len >= 0x7FFFFFFF/10)
738 Perl_croak(aTHX_ "pack/unpack repeat count overflow");
739 len = (len * 10) + (*patptr++ - '0');
745 /* The marvellous template parsing routine: Using state stored in *symptr,
746 * locates next template code and count
749 S_next_symbol(pTHX_ register tempsym_t* symptr )
751 register char* patptr = symptr->patptr;
752 register char* patend = symptr->patend;
754 symptr->flags &= ~FLAG_SLASH;
756 while (patptr < patend) {
757 if (isSPACE(*patptr))
759 else if (*patptr == '#') {
761 while (patptr < patend && *patptr != '\n')
766 /* We should have found a template code */
767 I32 code = *patptr++ & 0xFF;
768 U32 inherited_modifiers = 0;
770 if (code == ','){ /* grandfather in commas but with a warning */
771 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
772 symptr->flags |= FLAG_COMMA;
773 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
774 "Invalid type ',' in %s",
775 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
780 /* for '(', skip to ')' */
782 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
783 Perl_croak(aTHX_ "()-group starts with a count in %s",
784 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
785 symptr->grpbeg = patptr;
786 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
787 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
788 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
789 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
792 /* look for group modifiers to inherit */
793 if (TYPE_ENDIANNESS(symptr->flags)) {
794 if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
795 inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
798 /* look for modifiers */
799 while (patptr < patend) {
804 modifier = TYPE_IS_SHRIEKING;
805 allowed = SHRIEKING_ALLOWED_TYPES;
807 #ifdef PERL_PACK_CAN_BYTEORDER
809 modifier = TYPE_IS_BIG_ENDIAN;
810 allowed = ENDIANNESS_ALLOWED_TYPES;
813 modifier = TYPE_IS_LITTLE_ENDIAN;
814 allowed = ENDIANNESS_ALLOWED_TYPES;
824 if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
825 Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
826 allowed, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
828 if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
829 Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
830 (int) TYPE_NO_MODIFIERS(code),
831 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
832 else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
833 TYPE_ENDIANNESS_MASK)
834 Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
835 *patptr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
837 if (ckWARN(WARN_UNPACK)) {
839 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
840 "Duplicate modifier '%c' after '%c' in %s",
841 *patptr, (int) TYPE_NO_MODIFIERS(code),
842 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
849 /* inherit modifiers */
850 code |= inherited_modifiers;
852 /* look for count and/or / */
853 if (patptr < patend) {
854 if (isDIGIT(*patptr)) {
855 patptr = get_num( patptr, &symptr->length );
856 symptr->howlen = e_number;
858 } else if (*patptr == '*') {
860 symptr->howlen = e_star;
862 } else if (*patptr == '[') {
863 char* lenptr = ++patptr;
864 symptr->howlen = e_number;
865 patptr = group_end( patptr, patend, ']' ) + 1;
866 /* what kind of [] is it? */
867 if (isDIGIT(*lenptr)) {
868 lenptr = get_num( lenptr, &symptr->length );
870 Perl_croak(aTHX_ "Malformed integer in [] in %s",
871 symptr->flags & FLAG_PACK ? "pack" : "unpack");
873 tempsym_t savsym = *symptr;
874 symptr->patend = patptr-1;
875 symptr->patptr = lenptr;
876 savsym.length = measure_struct(symptr);
880 symptr->howlen = e_no_len;
885 while (patptr < patend) {
886 if (isSPACE(*patptr))
888 else if (*patptr == '#') {
890 while (patptr < patend && *patptr != '\n')
895 if (*patptr == '/') {
896 symptr->flags |= FLAG_SLASH;
898 if (patptr < patend &&
899 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
900 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
901 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
907 /* at end - no count, no / */
908 symptr->howlen = e_no_len;
913 symptr->patptr = patptr;
917 symptr->patptr = patptr;
922 There is no way to cleanly handle the case where we should process the
923 string per byte in its upgraded form while it's really in downgraded form
924 (e.g. estimates like strend-s as an upper bound for the number of
925 characters left wouldn't work). So if we foresee the need of this
926 (pattern starts with U or contains U0), we want to work on the encoded
927 version of the string. Users are advised to upgrade their pack string
928 themselves if they need to do a lot of unpacks like this on it
931 need_utf8(const char *pat, const char *patend)
934 while (pat < patend) {
937 pat = memchr(pat, '\n', patend-pat);
938 if (!pat) return FALSE;
939 } else if (pat[0] == 'U') {
940 if (first || pat[1] == '0') return TRUE;
941 } else first = FALSE;
948 first_symbol(const char *pat, const char *patend) {
949 while (pat < patend) {
950 if (pat[0] != '#') return pat[0];
952 pat = memchr(pat, '\n', patend-pat);
960 =for apidoc unpack_str
962 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
963 and ocnt are not used. This call should not be used, use unpackstring instead.
968 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
970 tempsym_t sym = { 0 };
972 if (flags & FLAG_UNPACK_DO_UTF8) flags |= FLAG_UNPACK_WAS_UTF8;
973 else if (need_utf8(pat, patend)) {
974 /* We probably should try to avoid this in case a scalar context call
975 wouldn't get to the "U0" */
976 STRLEN len = strend - s;
977 s = bytes_to_utf8(s, &len);
980 flags |= FLAG_UNPACK_DO_UTF8;
983 if (first_symbol(pat, patend) != 'U' && (flags & FLAG_UNPACK_DO_UTF8))
984 flags |= FLAG_UNPACK_PARSE_UTF8;
990 return unpack_rec(&sym, s, s, strend, NULL );
994 =for apidoc unpackstring
996 The engine implementing unpack() Perl function. C<unpackstring> puts the
997 extracted list items on the stack and returns the number of elements.
998 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
1003 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
1005 tempsym_t sym = { 0 };
1007 if (flags & FLAG_UNPACK_DO_UTF8) flags |= FLAG_UNPACK_WAS_UTF8;
1008 else if (need_utf8(pat, patend)) {
1009 /* We probably should try to avoid this in case a scalar context call
1010 wouldn't get to the "U0" */
1011 STRLEN len = strend - s;
1012 s = bytes_to_utf8(s, &len);
1015 flags |= FLAG_UNPACK_DO_UTF8;
1018 if (first_symbol(pat, patend) != 'U' && (flags & FLAG_UNPACK_DO_UTF8))
1019 flags |= FLAG_UNPACK_PARSE_UTF8;
1022 sym.patend = patend;
1025 return unpack_rec(&sym, s, s, strend, NULL );
1030 S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char **new_s )
1033 I32 datumtype, ai32;
1036 I32 start_sp_offset = SP - PL_stack_base;
1042 const int bits_in_uv = 8 * sizeof(cuv);
1043 char* strrelbeg = s;
1044 bool beyond = FALSE;
1045 bool explicit_length;
1046 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
1047 bool utf8 = (symptr->flags & FLAG_UNPACK_PARSE_UTF8) ? 1 : 0;
1049 while (next_symbol(symptr)) {
1050 datumtype = symptr->code;
1051 /* do first one only unless in list context
1052 / is implemented by unpacking the count, then popping it from the
1053 stack, so must check that we're not in the middle of a / */
1054 if ( unpack_only_one
1055 && (SP - PL_stack_base == start_sp_offset + 1)
1056 && (datumtype != '/') ) /* XXX can this be omitted */
1059 switch( howlen = symptr->howlen ){
1062 len = symptr->length;
1065 len = strend - strbeg; /* long enough */
1069 explicit_length = TRUE;
1071 beyond = s >= strend;
1073 int which = (symptr->code & TYPE_IS_SHRIEKING)
1074 ? PACK_SIZE_SHRIEKING : PACK_SIZE_NORMAL;
1075 const int rawtype = TYPE_NO_MODIFIERS(datumtype);
1076 int offset = rawtype - packsize[which].first;
1078 if (offset >= 0 && offset < packsize[which].size) {
1079 /* Data about this template letter */
1080 unsigned char data = packsize[which].array[offset];
1083 /* data nonzero means we can process this letter. */
1084 long size = data & PACK_SIZE_MASK;
1085 long howmany = (strend - s) / size;
1089 if (!checksum || (data & PACK_SIZE_CANNOT_CSUM)) {
1090 if (len && unpack_only_one) len = 1;
1097 switch(TYPE_NO_ENDIANNESS(datumtype)) {
1099 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
1102 if (howlen == e_no_len)
1103 len = 16; /* len is not specified */
1111 tempsym_t savsym = *symptr;
1112 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
1113 symptr->flags |= group_modifiers;
1114 symptr->patend = savsym.grpend;
1118 symptr->patptr = savsym.grpbeg;
1119 if (utf8) symptr->flags |= FLAG_UNPACK_PARSE_UTF8;
1120 else symptr->flags &= ~FLAG_UNPACK_PARSE_UTF8;
1121 unpack_rec(symptr, s, strbeg, strend, &s);
1122 if (s == strend && savsym.howlen == e_star)
1123 break; /* No way to continue */
1126 symptr->flags &= ~group_modifiers;
1127 savsym.flags = symptr->flags;
1136 Perl_croak(aTHX_ "'@' outside of string in unpack");
1141 Perl_croak(aTHX_ "'@' outside of string with malformed UTF-8 in unpack");
1143 if (len > strend - strrelbeg)
1144 Perl_croak(aTHX_ "'@' outside of string in unpack");
1145 s = strrelbeg + len;
1148 case 'X' | TYPE_IS_SHRIEKING:
1149 if (!len) /* Avoid division by 0 */
1154 for (l=len, hop = strbeg; hop < s; l++, hop += UTF8SKIP(hop))
1161 } else len = (s - strbeg) % len;
1167 Perl_croak(aTHX_ "'X' outside of string in unpack");
1168 while (UTF8_IS_CONTINUATION(*--s)) {
1170 Perl_croak(aTHX_ "'X' outside of string in unpack");
1175 if (len > s - strbeg)
1176 Perl_croak(aTHX_ "'X' outside of string in unpack" );
1180 case 'x' | TYPE_IS_SHRIEKING:
1181 if (!len) /* Avoid division by 0 */
1186 for (hop = strbeg; hop < s; hop += UTF8SKIP(hop)) l++;
1188 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1190 } else ai32 = (s - strbeg) % len;
1191 if (ai32 == 0) break;
1198 Perl_croak(aTHX_ "'x' outside of string in unpack");
1203 if (len > strend - s)
1204 Perl_croak(aTHX_ "'x' outside of string in unpack");
1209 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1215 /* Preliminary length estimate is assumed done in 'W' */
1216 if (len > strend - s) len = strend - s;
1222 for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) {
1223 if (hop >= strend) {
1225 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1230 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1232 } else if (len > strend - s)
1235 if (datumtype == 'Z') {
1236 /* 'Z' strips stuff after first null */
1238 for (ptr = s; ptr < strend; ptr++) if (*ptr == 0) break;
1239 sv = newSVpvn(s, ptr-s);
1240 if (howlen == e_star) /* exact for 'Z*' */
1241 len = ptr-s + (ptr != strend ? 1 : 0);
1242 } else if (datumtype == 'A') {
1243 /* 'A' strips both nulls and spaces */
1245 for (ptr = s+len-1; ptr >= s; ptr--)
1246 if (*ptr != 0 && !isSPACE(*ptr)) break;
1248 sv = newSVpvn(s, ptr-s);
1249 } else sv = newSVpvn(s, len);
1253 /* Undo any upgrade done due to need_utf8() */
1254 if (!(symptr->flags & FLAG_UNPACK_WAS_UTF8))
1255 sv_utf8_downgrade(sv, 0);
1257 XPUSHs(sv_2mortal(sv));
1263 if (howlen == e_star || len > (strend - s) * 8)
1264 len = (strend - s) * 8;
1268 Newz(601, PL_bitcount, 256, char);
1269 for (bits = 1; bits < 256; bits++) {
1270 if (bits & 1) PL_bitcount[bits]++;
1271 if (bits & 2) PL_bitcount[bits]++;
1272 if (bits & 4) PL_bitcount[bits]++;
1273 if (bits & 8) PL_bitcount[bits]++;
1274 if (bits & 16) PL_bitcount[bits]++;
1275 if (bits & 32) PL_bitcount[bits]++;
1276 if (bits & 64) PL_bitcount[bits]++;
1277 if (bits & 128) PL_bitcount[bits]++;
1281 while (len >= 8 && s < strend) {
1282 cuv += PL_bitcount[next_uni_byte(aTHX_ &s, strend, datumtype)];
1287 cuv += PL_bitcount[*(U8 *)s++];
1291 if (len && s < strend) {
1293 bits = NEXT_BYTE(utf8, s, strend, datumtype);
1294 if (datumtype == 'b') {
1296 if (bits & 1) cuv++;
1301 if (bits & 0x80) cuv++;
1309 sv = sv_2mortal(NEWSV(35, len ? len : 1));
1312 if (datumtype == 'b') {
1315 for (len = 0; len < ai32; len++) {
1316 if (len & 7) bits >>= 1;
1318 if (s >= strend) break;
1319 bits = next_uni_byte(aTHX_ &s, strend, datumtype);
1320 } else bits = *(U8 *) s++;
1321 *str++ = bits & 1 ? '1' : '0';
1326 for (len = 0; len < ai32; len++) {
1327 if (len & 7) bits <<= 1;
1329 if (s >= strend) break;
1330 bits = next_uni_byte(aTHX_ &s, strend, datumtype);
1331 } else bits = *(U8 *) s++;
1332 *str++ = bits & 0x80 ? '1' : '0';
1336 SvCUR_set(sv, str - SvPVX(sv));
1343 /* Preliminary length estimate, acceptable for utf8 too */
1344 if (howlen == e_star || len > (strend - s) * 2)
1345 len = (strend - s) * 2;
1346 sv = sv_2mortal(NEWSV(35, len ? len : 1));
1349 if (datumtype == 'h') {
1352 for (len = 0; len < ai32; len++) {
1353 if (len & 1) bits >>= 4;
1355 if (s >= strend) break;
1356 bits = next_uni_byte(aTHX_ &s, strend, datumtype);
1357 } else bits = * (U8 *) s++;
1358 *str++ = PL_hexdigit[bits & 15];
1363 for (len = 0; len < ai32; len++) {
1364 if (len & 1) bits <<= 4;
1366 if (s >= strend) break;
1367 bits = next_uni_byte(aTHX_ &s, strend, datumtype);
1368 } else bits = *(U8 *) s++;
1369 *str++ = PL_hexdigit[(bits >> 4) & 15];
1373 SvCUR_set(sv, str - SvPVX(sv));
1379 int aint = NEXT_BYTE(utf8, s, strend, datumtype);
1380 if (aint >= 128) /* fake up signed chars */
1383 PUSHs(sv_2mortal(newSViv((IV)aint)));
1384 else if (checksum > bits_in_uv)
1385 cdouble += (NV)aint;
1394 if (explicit_length && datumtype == 'C')
1395 /* Switch to "character" mode */
1396 utf8 = (symptr->flags & FLAG_UNPACK_DO_UTF8) ? 1 : 0;
1399 if (datumtype == 'C' ?
1400 (symptr->flags & FLAG_UNPACK_DO_UTF8) &&
1401 !(symptr->flags & FLAG_UNPACK_WAS_UTF8) : utf8) {
1402 while (len-- > 0 && s < strend) {
1406 UNI_TO_NATIVE(utf8n_to_uvuni(s, strend-s, &retlen,
1407 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY));
1408 if (retlen == (STRLEN) -1 || retlen == 0)
1409 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1412 PUSHs(sv_2mortal(newSVuv((UV) val)));
1413 else if (checksum > bits_in_uv)
1414 cdouble += (NV) val;
1418 } else if (!checksum)
1420 U8 ch = *(U8 *) s++;
1421 PUSHs(sv_2mortal(newSVuv((UV) ch)));
1423 else if (checksum > bits_in_uv)
1424 while (len-- > 0) cdouble += (NV) *(U8 *) s++;
1426 while (len-- > 0) cuv += *(U8 *) s++;
1430 if (explicit_length) {
1431 /* Switch to "bytes in UTF-8" mode */
1432 if (symptr->flags & FLAG_UNPACK_DO_UTF8) utf8 = 0;
1434 /* Should be impossible due to the need_utf8() test */
1435 Perl_croak(aTHX_ "U0 mode on a byte string");
1439 if (len > strend - s) len = strend - s;
1441 if (len && unpack_only_one) len = 1;
1445 while (len-- > 0 && s < strend) {
1449 U8 result[UTF8_MAXLEN];
1453 /* Bug: warns about bad utf8 even if we are short on bytes
1454 and will break out of the loop */
1455 if (!next_uni_bytes(aTHX_ &ptr, strend, result, 1))
1457 len = UTF8SKIP(result);
1458 if (!next_uni_bytes(aTHX_ &ptr, strend, &result[1], len-1))
1460 auv = utf8n_to_uvuni(result, len, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
1463 auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
1464 if (retlen == (STRLEN) -1 || retlen == 0)
1465 Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
1469 PUSHs(sv_2mortal(newSVuv((UV) auv)));
1470 else if (checksum > bits_in_uv)
1471 cdouble += (NV) auv;
1476 case 's' | TYPE_IS_SHRIEKING:
1477 #if SHORTSIZE != SIZE16
1480 COPYVAR(s, strend, utf8, ashort, s);
1482 PUSHs(sv_2mortal(newSViv((IV)ashort)));
1483 else if (checksum > bits_in_uv)
1484 cdouble += (NV)ashort;
1496 #if U16SIZE > SIZE16
1500 if (!next_uni_bytes(aTHX_ &s, strend,
1501 OFF16(&ai16), SIZE16)) break;
1506 DO_BO_UNPACK(ai16, 16);
1507 #if U16SIZE > SIZE16
1512 PUSHs(sv_2mortal(newSViv((IV)ai16)));
1513 else if (checksum > bits_in_uv)
1514 cdouble += (NV)ai16;
1519 case 'S' | TYPE_IS_SHRIEKING:
1520 #if SHORTSIZE != SIZE16
1522 unsigned short aushort;
1523 COPYVAR(s, strend, utf8, aushort, s);
1525 PUSHs(sv_2mortal(newSVuv((UV) aushort)));
1526 else if (checksum > bits_in_uv)
1527 cdouble += (NV)aushort;
1540 #if U16SIZE > SIZE16
1544 if (!next_uni_bytes(aTHX_ &s, strend,
1545 OFF16(&au16), SIZE16)) break;
1550 DO_BO_UNPACK(au16, 16);
1552 if (datumtype == 'n')
1553 au16 = PerlSock_ntohs(au16);
1556 if (datumtype == 'v')
1560 PUSHs(sv_2mortal(newSVuv((UV)au16)));
1561 else if (checksum > bits_in_uv)
1562 cdouble += (NV)au16;
1567 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1568 case 'v' | TYPE_IS_SHRIEKING:
1569 case 'n' | TYPE_IS_SHRIEKING:
1572 # if U16SIZE > SIZE16
1576 if (!next_uni_bytes(aTHX_ &s, strend,
1577 (char *) &ai16, sizeof(ai16))) break;
1583 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1584 ai16 = (I16) PerlSock_ntohs((U16) ai16);
1585 # endif /* HAS_NTOHS */
1587 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1588 ai16 = (I16) vtohs((U16) ai16);
1589 # endif /* HAS_VTOHS */
1591 PUSHs(sv_2mortal(newSViv((IV)ai16)));
1592 else if (checksum > bits_in_uv)
1593 cdouble += (NV) ai16;
1598 #endif /* PERL_PACK_CAN_SHRIEKSIGN */
1600 case 'i' | TYPE_IS_SHRIEKING:
1603 COPYVAR(s, strend, utf8, aint, i);
1605 PUSHs(sv_2mortal(newSViv((IV)aint)));
1606 else if (checksum > bits_in_uv)
1607 cdouble += (NV)aint;
1613 case 'I' | TYPE_IS_SHRIEKING:
1616 COPYVAR(s, strend, utf8, auint, i);
1618 PUSHs(sv_2mortal(newSVuv((UV)auint)));
1619 else if (checksum > bits_in_uv)
1620 cdouble += (NV)auint;
1628 #if IVSIZE == INTSIZE
1629 COPYVAR(s, strend, utf8, aiv, i);
1630 #elif IVSIZE == LONGSIZE
1631 COPYVAR(s, strend, utf8, aiv, l);
1632 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1633 COPYVAR(s, strend, utf8, aiv, 64);
1635 Perl_croak(aTHX_ "'j' not supported on this platform");
1638 PUSHs(sv_2mortal(newSViv(aiv)));
1639 else if (checksum > bits_in_uv)
1648 #if IVSIZE == INTSIZE
1649 COPYVAR(s, strend, utf8, auv, i);
1650 #elif IVSIZE == LONGSIZE
1651 COPYVAR(s, strend, utf8, auv, l);
1652 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1653 COPYVAR(s, strend, utf8, auv, 64);
1655 Perl_croak(aTHX_ "'J' not supported on this platform");
1658 PUSHs(sv_2mortal(newSVuv(auv)));
1659 else if (checksum > bits_in_uv)
1665 case 'l' | TYPE_IS_SHRIEKING:
1666 #if LONGSIZE != SIZE32
1669 COPYVAR(s, strend, utf8, along, l);
1671 PUSHs(sv_2mortal(newSViv((IV)along)));
1672 else if (checksum > bits_in_uv)
1673 cdouble += (NV)along;
1684 #if U32SIZE > SIZE32
1688 if (!next_uni_bytes(aTHX_ &s, strend,
1689 OFF32(&ai32), SIZE32)) break;
1694 DO_BO_UNPACK(ai32, 32);
1695 #if U32SIZE > SIZE32
1696 if (ai32 > 2147483647) ai32 -= 4294967296;
1699 PUSHs(sv_2mortal(newSViv((IV)ai32)));
1700 else if (checksum > bits_in_uv)
1701 cdouble += (NV)ai32;
1706 case 'L' | TYPE_IS_SHRIEKING:
1707 #if LONGSIZE != SIZE32
1709 unsigned long aulong;
1710 COPYVAR(s, strend, utf8, aulong, l);
1712 PUSHs(sv_2mortal(newSVuv((UV)aulong)));
1713 else if (checksum > bits_in_uv)
1714 cdouble += (NV)aulong;
1727 #if U32SIZE > SIZE32
1731 if (!next_uni_bytes(aTHX_ &s, strend,
1732 OFF32(&au32), SIZE32)) break;
1737 DO_BO_UNPACK(au32, 32);
1739 if (datumtype == 'N')
1740 au32 = PerlSock_ntohl(au32);
1743 if (datumtype == 'V')
1747 PUSHs(sv_2mortal(newSVuv((UV)au32)));
1748 else if (checksum > bits_in_uv)
1749 cdouble += (NV)au32;
1754 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1755 case 'V' | TYPE_IS_SHRIEKING:
1756 case 'N' | TYPE_IS_SHRIEKING:
1759 # if U32SIZE > SIZE32
1763 if (!next_uni_bytes(aTHX_ &s, strend,
1764 OFF32(&ai32), SIZE32)) break;
1770 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1771 ai32 = (I32)PerlSock_ntohl((U32)ai32);
1774 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1775 ai32 = (I32)vtohl((U32)ai32);
1778 PUSHs(sv_2mortal(newSViv((IV)ai32)));
1779 else if (checksum > bits_in_uv)
1780 cdouble += (NV)ai32;
1785 #endif /* PERL_PACK_CAN_SHRIEKSIGN */
1790 if (!next_uni_bytes(aTHX_ &s, strend,
1791 (char *) &aptr, sizeof(aptr))) break;
1793 Copy(s, &aptr, 1, char*);
1796 DO_BO_UNPACK_P(aptr);
1797 /* newSVpv generates undef if aptr is NULL */
1798 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1806 while (len > 0 && s < strend) {
1808 ch = NEXT_BYTE(utf8, s, strend, 'w');
1809 auv = (auv << 7) | (ch & 0x7f);
1810 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1813 PUSHs(sv_2mortal(newSVuv(auv)));
1818 if (++bytes >= sizeof(UV)) { /* promote to string */
1822 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1823 while (s < strend) {
1824 ch = NEXT_BYTE(utf8, s, strend, 'w');
1825 sv = mul128(sv, (U8)(ch & 0x7f));
1835 PUSHs(sv_2mortal(sv));
1840 if ((s >= strend) && bytes)
1841 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1845 if (symptr->howlen == e_star)
1846 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1848 if (sizeof(char*) <= strend - s) {
1851 if (!next_uni_bytes(aTHX_ &s, strend, (char *) &aptr,
1852 sizeof(aptr))) break;
1854 Copy(s, &aptr, 1, char*);
1857 DO_BO_UNPACK_P(aptr);
1858 /* newSVpvn generates undef if aptr is NULL */
1859 PUSHs(sv_2mortal(newSVpvn(aptr, len)));
1866 COPYVAR(s, strend, utf8, aquad, 64);
1868 PUSHs(sv_2mortal(aquad >= IV_MIN && aquad <= IV_MAX ?
1869 newSViv((IV)aquad) : newSVnv((NV)aquad)));
1870 else if (checksum > bits_in_uv)
1871 cdouble += (NV)aquad;
1879 COPYVAR(s, strend, utf8, auquad, 64);
1881 PUSHs(sv_2mortal(auquad <= UV_MAX ?
1882 newSVuv((UV)auquad):newSVnv((NV)auquad)));
1883 else if (checksum > bits_in_uv)
1884 cdouble += (NV)auquad;
1889 #endif /* HAS_QUAD */
1890 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1895 if (!next_uni_bytes(aTHX_ &s, strend, (char *) &afloat,
1896 sizeof(afloat))) break;
1898 Copy(s, &afloat, 1, float);
1901 DO_BO_UNPACK_N(afloat, float);
1903 PUSHs(sv_2mortal(newSVnv((NV)afloat)));
1912 if (!next_uni_bytes(aTHX_ &s, strend, (char *) &adouble,
1913 sizeof(adouble))) break;
1915 Copy(s, &adouble, 1, double);
1916 s += sizeof(double);
1918 DO_BO_UNPACK_N(adouble, double);
1920 PUSHs(sv_2mortal(newSVnv((NV)adouble)));
1929 if (!next_uni_bytes(aTHX_ &s, strend,
1930 (char *) &anv, sizeof(anv))) break;
1932 Copy(s, &anv, 1, NV);
1935 DO_BO_UNPACK_N(anv, NV);
1937 PUSHs(sv_2mortal(newSVnv(anv)));
1942 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1945 long double aldouble;
1947 if (!next_uni_bytes(aTHX_ &s, strend, (char *) &aldouble,
1948 sizeof(aldouble))) break;
1950 Copy(s, &aldouble, 1, long double);
1951 s += LONG_DOUBLESIZE;
1953 DO_BO_UNPACK_N(aldouble, long double);
1955 PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
1957 cdouble += aldouble;
1963 * Initialise the decode mapping. By using a table driven
1964 * algorithm, the code will be character-set independent
1965 * (and just as fast as doing character arithmetic)
1967 if (PL_uudmap['M'] == 0) {
1970 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1971 PL_uudmap[(U8)PL_uuemap[i]] = i;
1973 * Because ' ' and '`' map to the same value,
1974 * we need to decode them both the same.
1979 STRLEN l = (STRLEN) (strend - s) * 3 / 4;
1980 sv = sv_2mortal(NEWSV(42, l));
1981 if (l) SvPOK_on(sv);
1984 while (next_uni_uu(aTHX_ &s, strend, &len)) {
1990 next_uni_uu(aTHX_ &s, strend, &a);
1991 next_uni_uu(aTHX_ &s, strend, &b);
1992 next_uni_uu(aTHX_ &s, strend, &c);
1993 next_uni_uu(aTHX_ &s, strend, &d);
1994 hunk[0] = (char)((a << 2) | (b >> 4));
1995 hunk[1] = (char)((b << 4) | (c >> 2));
1996 hunk[2] = (char)((c << 6) | d);
1997 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
2001 if (*s == '\n') s++;
2003 /* possible checksum byte */
2004 char *skip = s+UTF8SKIP(s);
2005 if (skip < strend && *skip == '\n') s = skip+1;
2010 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
2015 len = PL_uudmap[*(U8*)s++] & 077;
2017 if (s < strend && ISUUCHAR(*s))
2018 a = PL_uudmap[*(U8*)s++] & 077;
2021 if (s < strend && ISUUCHAR(*s))
2022 b = PL_uudmap[*(U8*)s++] & 077;
2025 if (s < strend && ISUUCHAR(*s))
2026 c = PL_uudmap[*(U8*)s++] & 077;
2029 if (s < strend && ISUUCHAR(*s))
2030 d = PL_uudmap[*(U8*)s++] & 077;
2033 hunk[0] = (char)((a << 2) | (b >> 4));
2034 hunk[1] = (char)((b << 4) | (c >> 2));
2035 hunk[2] = (char)((c << 6) | d);
2036 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
2041 else /* possible checksum byte */
2042 if (s + 1 < strend && s[1] == '\n')
2051 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
2052 (checksum > bits_in_uv &&
2053 strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
2056 anv = (NV) (1 << (checksum & 15));
2057 while (checksum >= 16) {
2061 while (cdouble < 0.0)
2063 cdouble = Perl_modf(cdouble / anv, &trouble) * anv;
2064 sv = newSVnv(cdouble);
2067 if (checksum < bits_in_uv) {
2068 UV mask = ((UV)1 << checksum) - 1;
2073 XPUSHs(sv_2mortal(sv));
2077 if (symptr->flags & FLAG_SLASH){
2078 if (SP - PL_stack_base - start_sp_offset <= 0)
2079 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
2080 if( next_symbol(symptr) ){
2081 if( symptr->howlen == e_number )
2082 Perl_croak(aTHX_ "Count after length/code in unpack" );
2084 /* ...end of char buffer then no decent length available */
2085 Perl_croak(aTHX_ "length/code after end of string in unpack" );
2087 /* take top of stack (hope it's numeric) */
2090 Perl_croak(aTHX_ "Negative '/' count in unpack" );
2093 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
2095 datumtype = symptr->code;
2096 explicit_length = FALSE;
2104 return SP - PL_stack_base - start_sp_offset;
2111 I32 gimme = GIMME_V;
2114 char *pat = SvPV(left, llen);
2115 char *s = SvPV(right, rlen);
2116 char *strend = s + rlen;
2117 char *patend = pat + llen;
2121 cnt = unpackstring(pat, patend, s, strend,
2122 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
2123 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
2126 if ( !cnt && gimme == G_SCALAR )
2127 PUSHs(&PL_sv_undef);
2132 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
2136 *hunk = PL_uuemap[len];
2137 sv_catpvn(sv, hunk, 1);
2140 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
2141 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
2142 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
2143 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
2144 sv_catpvn(sv, hunk, 4);
2149 char r = (len > 1 ? s[1] : '\0');
2150 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
2151 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
2152 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
2153 hunk[3] = PL_uuemap[0];
2154 sv_catpvn(sv, hunk, 4);
2156 sv_catpvn(sv, "\n", 1);
2160 S_is_an_int(pTHX_ char *s, STRLEN l)
2163 SV *result = newSVpvn(s, l);
2164 char *result_c = SvPV(result, n_a); /* convenience */
2165 char *out = result_c;
2175 SvREFCNT_dec(result);
2198 SvREFCNT_dec(result);
2204 SvCUR_set(result, out - result_c);
2208 /* pnum must be '\0' terminated */
2210 S_div128(pTHX_ SV *pnum, bool *done)
2213 char *s = SvPV(pnum, len);
2222 i = m * 10 + (*t - '0');
2224 r = (i >> 7); /* r < 10 */
2231 SvCUR_set(pnum, (STRLEN) (t - s));
2238 =for apidoc pack_cat
2240 The engine implementing pack() Perl function. Note: parameters next_in_list and
2241 flags are not used. This call should not be used; use packlist instead.
2247 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
2249 tempsym_t sym = { 0 };
2251 sym.patend = patend;
2252 sym.flags = FLAG_PACK;
2254 (void)pack_rec( cat, &sym, beglist, endlist );
2259 =for apidoc packlist
2261 The engine implementing pack() Perl function.
2267 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
2269 tempsym_t sym = { 0 };
2271 sym.patend = patend;
2272 sym.flags = FLAG_PACK;
2274 (void)pack_rec( cat, &sym, beglist, endlist );
2280 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
2284 register I32 len = 0;
2287 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
2288 static char *space10 = " ";
2291 /* These must not be in registers: */
2301 #if SHORTSIZE != SIZE16
2303 unsigned short aushort;
2307 #if LONGSIZE != SIZE32
2309 unsigned long aulong;
2314 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2315 long double aldouble;
2321 int strrelbeg = SvCUR(cat);
2322 tempsym_t lookahead;
2324 items = endlist - beglist;
2325 found = next_symbol( symptr );
2327 #ifndef PACKED_IS_OCTETS
2328 if (symptr->level == 0 && found && symptr->code == 'U' ){
2334 SV *lengthcode = Nullsv;
2335 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2337 I32 datumtype = symptr->code;
2340 switch( howlen = symptr->howlen ){
2343 len = symptr->length;
2346 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
2350 /* Look ahead for next symbol. Do we have code/code? */
2351 lookahead = *symptr;
2352 found = next_symbol(&lookahead);
2353 if ( symptr->flags & FLAG_SLASH ) {
2355 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2356 e_star != lookahead.howlen )
2357 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2358 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
2359 ? *beglist : &PL_sv_no)
2360 + (lookahead.code == 'Z' ? 1 : 0)));
2362 Perl_croak(aTHX_ "Code missing after '/' in pack");
2366 switch(TYPE_NO_ENDIANNESS(datumtype)) {
2368 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
2370 Perl_croak(aTHX_ "'%%' may not be used in pack");
2372 len += strrelbeg - SvCUR(cat);
2381 tempsym_t savsym = *symptr;
2382 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2383 symptr->flags |= group_modifiers;
2384 symptr->patend = savsym.grpend;
2387 symptr->patptr = savsym.grpbeg;
2388 beglist = pack_rec(cat, symptr, beglist, endlist );
2389 if (savsym.howlen == e_star && beglist == endlist)
2390 break; /* No way to continue */
2392 symptr->flags &= ~group_modifiers;
2393 lookahead.flags = symptr->flags;
2397 case 'X' | TYPE_IS_SHRIEKING:
2398 if (!len) /* Avoid division by 0 */
2400 len = (SvCUR(cat)) % len;
2404 if ((I32)SvCUR(cat) < len)
2405 Perl_croak(aTHX_ "'X' outside of string in pack");
2409 case 'x' | TYPE_IS_SHRIEKING:
2410 if (!len) /* Avoid division by 0 */
2412 aint = (SvCUR(cat)) % len;
2413 if (aint) /* Other portable ways? */
2422 sv_catpvn(cat, null10, 10);
2425 sv_catpvn(cat, null10, len);
2431 aptr = SvPV(fromstr, fromlen);
2432 if (howlen == e_star) {
2434 if (datumtype == 'Z')
2437 if ((I32)fromlen >= len) {
2438 sv_catpvn(cat, aptr, len);
2439 if (datumtype == 'Z' && len > 0)
2440 *(SvEND(cat)-1) = '\0';
2443 sv_catpvn(cat, aptr, fromlen);
2445 if (datumtype == 'A') {
2447 sv_catpvn(cat, space10, 10);
2450 sv_catpvn(cat, space10, len);
2454 sv_catpvn(cat, null10, 10);
2457 sv_catpvn(cat, null10, len);
2469 str = SvPV(fromstr, fromlen);
2470 if (howlen == e_star)
2473 SvCUR(cat) += (len+7)/8;
2474 SvGROW(cat, SvCUR(cat) + 1);
2475 aptr = SvPVX(cat) + aint;
2476 if (len > (I32)fromlen)
2480 if (datumtype == 'B') {
2481 for (len = 0; len++ < aint;) {
2482 items |= *str++ & 1;
2486 *aptr++ = items & 0xff;
2492 for (len = 0; len++ < aint;) {
2498 *aptr++ = items & 0xff;
2504 if (datumtype == 'B')
2505 items <<= 7 - (aint & 7);
2507 items >>= 7 - (aint & 7);
2508 *aptr++ = items & 0xff;
2510 str = SvPVX(cat) + SvCUR(cat);
2525 str = SvPV(fromstr, fromlen);
2526 if (howlen == e_star)
2529 SvCUR(cat) += (len+1)/2;
2530 SvGROW(cat, SvCUR(cat) + 1);
2531 aptr = SvPVX(cat) + aint;
2532 if (len > (I32)fromlen)
2536 if (datumtype == 'H') {
2537 for (len = 0; len++ < aint;) {
2539 items |= ((*str++ & 15) + 9) & 15;
2541 items |= *str++ & 15;
2545 *aptr++ = items & 0xff;
2551 for (len = 0; len++ < aint;) {
2553 items |= (((*str++ & 15) + 9) & 15) << 4;
2555 items |= (*str++ & 15) << 4;
2559 *aptr++ = items & 0xff;
2565 *aptr++ = items & 0xff;
2566 str = SvPVX(cat) + SvCUR(cat);
2577 switch (TYPE_NO_MODIFIERS(datumtype)) {
2579 aint = SvIV(fromstr);
2580 if ((aint < 0 || aint > 255) &&
2582 Perl_warner(aTHX_ packWARN(WARN_PACK),
2583 "Character in 'C' format wrapped in pack");
2585 sv_catpvn(cat, &achar, sizeof(char));
2588 aint = SvIV(fromstr);
2589 if ((aint < -128 || aint > 127) &&
2591 Perl_warner(aTHX_ packWARN(WARN_PACK),
2592 "Character in 'c' format wrapped in pack" );
2594 sv_catpvn(cat, &achar, sizeof(char));
2602 auint = UNI_TO_NATIVE(SvUV(fromstr));
2603 SvGROW(cat, SvCUR(cat) + UTF8_MAXBYTES + 1);
2605 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2608 0 : UNICODE_ALLOW_ANY)
2613 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2618 /* VOS does not automatically map a floating-point overflow
2619 during conversion from double to float into infinity, so we
2620 do it by hand. This code should either be generalized for
2621 any OS that needs it, or removed if and when VOS implements
2622 posix-976 (suggestion to support mapping to infinity).
2623 Paul.Green@stratus.com 02-04-02. */
2624 if (SvNV(fromstr) > FLT_MAX)
2625 afloat = _float_constants[0]; /* single prec. inf. */
2626 else if (SvNV(fromstr) < -FLT_MAX)
2627 afloat = _float_constants[0]; /* single prec. inf. */
2628 else afloat = (float)SvNV(fromstr);
2630 # if defined(VMS) && !defined(__IEEE_FP)
2631 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2632 * on Alpha; fake it if we don't have them.
2634 if (SvNV(fromstr) > FLT_MAX)
2636 else if (SvNV(fromstr) < -FLT_MAX)
2638 else afloat = (float)SvNV(fromstr);
2640 afloat = (float)SvNV(fromstr);
2643 DO_BO_PACK_N(afloat, float);
2644 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2651 /* VOS does not automatically map a floating-point overflow
2652 during conversion from long double to double into infinity,
2653 so we do it by hand. This code should either be generalized
2654 for any OS that needs it, or removed if and when VOS
2655 implements posix-976 (suggestion to support mapping to
2656 infinity). Paul.Green@stratus.com 02-04-02. */
2657 if (SvNV(fromstr) > DBL_MAX)
2658 adouble = _double_constants[0]; /* double prec. inf. */
2659 else if (SvNV(fromstr) < -DBL_MAX)
2660 adouble = _double_constants[0]; /* double prec. inf. */
2661 else adouble = (double)SvNV(fromstr);
2663 # if defined(VMS) && !defined(__IEEE_FP)
2664 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2665 * on Alpha; fake it if we don't have them.
2667 if (SvNV(fromstr) > DBL_MAX)
2669 else if (SvNV(fromstr) < -DBL_MAX)
2671 else adouble = (double)SvNV(fromstr);
2673 adouble = (double)SvNV(fromstr);
2676 DO_BO_PACK_N(adouble, double);
2677 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2681 Zero(&anv, 1, NV); /* can be long double with unused bits */
2684 anv = SvNV(fromstr);
2685 DO_BO_PACK_N(anv, NV);
2686 sv_catpvn(cat, (char *)&anv, NVSIZE);
2689 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2691 /* long doubles can have unused bits, which may be nonzero */
2692 Zero(&aldouble, 1, long double);
2695 aldouble = (long double)SvNV(fromstr);
2696 DO_BO_PACK_N(aldouble, long double);
2697 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2701 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2702 case 'n' | TYPE_IS_SHRIEKING:
2707 ai16 = (I16)SvIV(fromstr);
2709 ai16 = PerlSock_htons(ai16);
2714 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2715 case 'v' | TYPE_IS_SHRIEKING:
2720 ai16 = (I16)SvIV(fromstr);
2727 case 'S' | TYPE_IS_SHRIEKING:
2728 #if SHORTSIZE != SIZE16
2732 aushort = SvUV(fromstr);
2733 DO_BO_PACK(aushort, s);
2734 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2745 au16 = (U16)SvUV(fromstr);
2746 DO_BO_PACK(au16, 16);
2752 case 's' | TYPE_IS_SHRIEKING:
2753 #if SHORTSIZE != SIZE16
2757 ashort = SvIV(fromstr);
2758 DO_BO_PACK(ashort, s);
2759 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2769 ai16 = (I16)SvIV(fromstr);
2770 DO_BO_PACK(ai16, 16);
2775 case 'I' | TYPE_IS_SHRIEKING:
2778 auint = SvUV(fromstr);
2779 DO_BO_PACK(auint, i);
2780 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2786 aiv = SvIV(fromstr);
2787 #if IVSIZE == INTSIZE
2789 #elif IVSIZE == LONGSIZE
2791 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2792 DO_BO_PACK(aiv, 64);
2794 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2800 auv = SvUV(fromstr);
2801 #if UVSIZE == INTSIZE
2803 #elif UVSIZE == LONGSIZE
2805 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2806 DO_BO_PACK(auv, 64);
2808 sv_catpvn(cat, (char*)&auv, UVSIZE);
2814 anv = SvNV(fromstr);
2817 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2819 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2820 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2821 any negative IVs will have already been got by the croak()
2822 above. IOK is untrue for fractions, so we test them
2823 against UV_MAX_P1. */
2824 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2826 char buf[(sizeof(UV)*8)/7+1];
2827 char *in = buf + sizeof(buf);
2828 UV auv = SvUV(fromstr);
2831 *--in = (char)((auv & 0x7f) | 0x80);
2834 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2835 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2837 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2838 char *from, *result, *in;
2843 /* Copy string and check for compliance */
2844 from = SvPV(fromstr, len);
2845 if ((norm = is_an_int(from, len)) == NULL)
2846 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2848 New('w', result, len, char);
2852 *--in = div128(norm, &done) | 0x80;
2853 result[len - 1] &= 0x7F; /* clear continue bit */
2854 sv_catpvn(cat, in, (result + len) - in);
2856 SvREFCNT_dec(norm); /* free norm */
2858 else if (SvNOKp(fromstr)) {
2859 /* 10**NV_MAX_10_EXP is the largest power of 10
2860 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2861 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2862 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2863 And with that many bytes only Inf can overflow.
2864 Some C compilers are strict about integral constant
2865 expressions so we conservatively divide by a slightly
2866 smaller integer instead of multiplying by the exact
2867 floating-point value.
2869 #ifdef NV_MAX_10_EXP
2870 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2871 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2873 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2874 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2876 char *in = buf + sizeof(buf);
2878 anv = Perl_floor(anv);
2880 NV next = Perl_floor(anv / 128);
2881 if (in <= buf) /* this cannot happen ;-) */
2882 Perl_croak(aTHX_ "Cannot compress integer in pack");
2883 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2886 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2887 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2890 char *from, *result, *in;
2895 /* Copy string and check for compliance */
2896 from = SvPV(fromstr, len);
2897 if ((norm = is_an_int(from, len)) == NULL)
2898 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2900 New('w', result, len, char);
2904 *--in = div128(norm, &done) | 0x80;
2905 result[len - 1] &= 0x7F; /* clear continue bit */
2906 sv_catpvn(cat, in, (result + len) - in);
2908 SvREFCNT_dec(norm); /* free norm */
2913 case 'i' | TYPE_IS_SHRIEKING:
2916 aint = SvIV(fromstr);
2917 DO_BO_PACK(aint, i);
2918 sv_catpvn(cat, (char*)&aint, sizeof(int));
2921 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2922 case 'N' | TYPE_IS_SHRIEKING:
2927 au32 = SvUV(fromstr);
2929 au32 = PerlSock_htonl(au32);
2934 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2935 case 'V' | TYPE_IS_SHRIEKING:
2940 au32 = SvUV(fromstr);
2947 case 'L' | TYPE_IS_SHRIEKING:
2948 #if LONGSIZE != SIZE32
2952 aulong = SvUV(fromstr);
2953 DO_BO_PACK(aulong, l);
2954 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2965 au32 = SvUV(fromstr);
2966 DO_BO_PACK(au32, 32);
2971 case 'l' | TYPE_IS_SHRIEKING:
2972 #if LONGSIZE != SIZE32
2976 along = SvIV(fromstr);
2977 DO_BO_PACK(along, l);
2978 sv_catpvn(cat, (char *)&along, sizeof(long));
2988 ai32 = SvIV(fromstr);
2989 DO_BO_PACK(ai32, 32);
2997 auquad = (Uquad_t)SvUV(fromstr);
2998 DO_BO_PACK(auquad, 64);
2999 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
3005 aquad = (Quad_t)SvIV(fromstr);
3006 DO_BO_PACK(aquad, 64);
3007 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
3012 len = 1; /* assume SV is correct length */
3017 SvGETMAGIC(fromstr);
3018 if (!SvOK(fromstr)) aptr = NULL;
3021 /* XXX better yet, could spirit away the string to
3022 * a safe spot and hang on to it until the result
3023 * of pack() (and all copies of the result) are
3026 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
3027 || (SvPADTMP(fromstr)
3028 && !SvREADONLY(fromstr))))
3030 Perl_warner(aTHX_ packWARN(WARN_PACK),
3031 "Attempt to pack pointer to temporary value");
3033 if (SvPOK(fromstr) || SvNIOK(fromstr))
3034 aptr = SvPV_flags(fromstr, n_a, 0);
3036 aptr = SvPV_force_flags(fromstr, n_a, 0);
3039 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
3044 aptr = SvPV(fromstr, fromlen);
3045 SvGROW(cat, fromlen * 4 / 3);
3050 while (fromlen > 0) {
3053 if ((I32)fromlen > len)
3057 doencodes(cat, aptr, todo);
3063 *symptr = lookahead;
3072 dSP; dMARK; dORIGMARK; dTARGET;
3073 register SV *cat = TARG;
3075 register char *pat = SvPVx(*++MARK, fromlen);
3076 register char *patend = pat + fromlen;
3079 sv_setpvn(cat, "", 0);
3081 packlist(cat, pat, patend, MARK, SP + 1);
3091 * c-indentation-style: bsd
3093 * indent-tabs-mode: t
3096 * vim: shiftwidth=4: