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 * Offset for integer pack/unpack.
37 * On architectures where I16 and I32 aren't really 16 and 32 bits,
38 * which for now are all Crays, pack and unpack have to play games.
42 * These values are required for portability of pack() output.
43 * If they're not right on your machine, then pack() and unpack()
44 * wouldn't work right anyway; you'll need to apply the Cray hack.
45 * (I'd like to check them with #if, but you can't use sizeof() in
46 * the preprocessor.) --???
49 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
50 defines are now in config.h. --Andy Dougherty April 1998
55 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
58 #if U16SIZE > SIZE16 || U32SIZE > SIZE32
59 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
76 # define COPY16(s,p) Copy(s, p, SIZE16, char)
77 # define COPY32(s,p) Copy(s, p, SIZE32, char)
78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
83 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
84 #define MAX_SUB_TEMPLATE_LEVEL 100
86 /* flags (note that type modifiers can also be used as flags!) */
87 #define FLAG_UNPACK_ONLY_ONE 0x10
88 #define FLAG_UNPACK_DO_UTF8 0x08
89 #define FLAG_SLASH 0x04
90 #define FLAG_COMMA 0x02
91 #define FLAG_PACK 0x01
94 S_mul128(pTHX_ SV *sv, U8 m)
97 char *s = SvPV(sv, len);
101 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
102 SV *tmpNew = newSVpvn("0000000000", 10);
104 sv_catsv(tmpNew, sv);
105 SvREFCNT_dec(sv); /* free old sv */
110 while (!*t) /* trailing '\0'? */
113 i = ((*t - '0') << 7) + m;
114 *(t--) = '0' + (char)(i % 10);
120 /* Explosives and implosives. */
122 #if 'I' == 73 && 'J' == 74
123 /* On an ASCII/ISO kind of system */
124 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
127 Some other sort of character set - use memchr() so we don't match
130 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
134 #define TYPE_IS_SHRIEKING 0x100
135 #define TYPE_IS_BIG_ENDIAN 0x200
136 #define TYPE_IS_LITTLE_ENDIAN 0x400
137 #define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
138 #define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK)
139 #define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK)
140 #define TYPE_MODIFIERS(t) ((t) & ~0xFF)
141 #define TYPE_NO_MODIFIERS(t) ((t) & 0xFF)
143 #define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP("
145 #define DO_BO_UNPACK(var, type) \
147 switch (TYPE_ENDIANNESS(datumtype)) { \
148 case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \
149 case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \
154 #define DO_BO_PACK(var, type) \
156 switch (TYPE_ENDIANNESS(datumtype)) { \
157 case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \
158 case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \
163 #define DO_BO_UNPACK_PTR(var, type, pre_cast) \
165 switch (TYPE_ENDIANNESS(datumtype)) { \
166 case TYPE_IS_BIG_ENDIAN: \
167 var = (void *) my_betoh ## type ((pre_cast) var); \
169 case TYPE_IS_LITTLE_ENDIAN: \
170 var = (void *) my_letoh ## type ((pre_cast) var); \
177 #define DO_BO_PACK_PTR(var, type, pre_cast) \
179 switch (TYPE_ENDIANNESS(datumtype)) { \
180 case TYPE_IS_BIG_ENDIAN: \
181 var = (void *) my_htobe ## type ((pre_cast) var); \
183 case TYPE_IS_LITTLE_ENDIAN: \
184 var = (void *) my_htole ## type ((pre_cast) var); \
191 #define BO_CANT_DOIT(action, type) \
193 switch (TYPE_ENDIANNESS(datumtype)) { \
194 case TYPE_IS_BIG_ENDIAN: \
195 Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \
196 "platform", #action, #type); \
198 case TYPE_IS_LITTLE_ENDIAN: \
199 Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \
200 "platform", #action, #type); \
207 #if PTRSIZE == INTSIZE
208 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, i, int)
209 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, i, int)
210 #elif PTRSIZE == LONGSIZE
211 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long)
212 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long)
214 # define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer)
215 # define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer)
218 #if defined(my_htolen) && defined(my_letohn) && \
219 defined(my_htoben) && defined(my_betohn)
220 # define DO_BO_UNPACK_N(var, type) \
222 switch (TYPE_ENDIANNESS(datumtype)) { \
223 case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\
224 case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
229 # define DO_BO_PACK_N(var, type) \
231 switch (TYPE_ENDIANNESS(datumtype)) { \
232 case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\
233 case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
238 # define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type)
239 # define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type)
242 #define PACK_SIZE_CANNOT_CSUM 0x80
243 #define PACK_SIZE_CANNOT_ONLY_ONE 0x40
244 #define PACK_SIZE_MASK 0x3F
248 const unsigned char *array;
253 #define PACK_SIZE_NORMAL 0
254 #define PACK_SIZE_SHRIEKING 1
256 /* These tables are regenerated by genpacksizetables.pl (and then hand pasted
257 in). You're unlikely ever to need to regenerate them. */
260 unsigned char size_normal[53] = {
261 /* C */ sizeof(unsigned char),
262 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
263 /* D */ LONG_DOUBLESIZE,
270 /* I */ sizeof(unsigned int),
277 #if defined(HAS_QUAD)
278 /* Q */ sizeof(Uquad_t),
285 /* U */ sizeof(char),
287 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
288 /* c */ sizeof(char),
289 /* d */ sizeof(double),
291 /* f */ sizeof(float),
300 /* p */ sizeof(char *) | PACK_SIZE_CANNOT_ONLY_ONE | PACK_SIZE_CANNOT_CSUM,
301 #if defined(HAS_QUAD)
302 /* q */ sizeof(Quad_t),
310 /* w */ sizeof(char) | PACK_SIZE_CANNOT_CSUM
312 unsigned char size_shrieking[46] = {
313 /* I */ sizeof(unsigned int),
315 /* L */ sizeof(unsigned long),
319 /* S */ sizeof(unsigned short),
322 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
325 /* l */ sizeof(long),
329 /* s */ sizeof(short),
333 struct packsize_t packsize[2] = {
334 {size_normal, 67, 53},
335 {size_shrieking, 73, 46}
338 /* EBCDIC (or bust) */
339 unsigned char size_normal[99] = {
340 /* c */ sizeof(char),
341 /* d */ sizeof(double),
343 /* f */ sizeof(float),
353 /* p */ sizeof(char *) | PACK_SIZE_CANNOT_ONLY_ONE | PACK_SIZE_CANNOT_CSUM,
354 #if defined(HAS_QUAD)
355 /* q */ sizeof(Quad_t),
359 0, 0, 0, 0, 0, 0, 0, 0, 0,
363 /* w */ sizeof(char) | PACK_SIZE_CANNOT_CSUM,
364 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,
366 /* C */ sizeof(unsigned char),
367 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
368 /* D */ LONG_DOUBLESIZE,
375 /* I */ sizeof(unsigned int),
383 #if defined(HAS_QUAD)
384 /* Q */ sizeof(Uquad_t),
388 0, 0, 0, 0, 0, 0, 0, 0, 0,
391 /* U */ sizeof(char),
394 unsigned char size_shrieking[93] = {
396 0, 0, 0, 0, 0, 0, 0, 0, 0,
397 /* l */ sizeof(long),
400 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
401 /* s */ sizeof(short),
404 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,
405 0, 0, 0, 0, 0, 0, 0, 0, 0,
406 /* I */ sizeof(unsigned int),
407 0, 0, 0, 0, 0, 0, 0, 0, 0,
408 /* L */ sizeof(unsigned long),
411 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
412 /* S */ sizeof(unsigned short),
416 struct packsize_t packsize[2] = {
417 {size_normal, 131, 99},
418 {size_shrieking, 137, 93}
423 /* Returns the sizeof() struct described by pat */
425 S_measure_struct(pTHX_ register tempsym_t* symptr)
427 register I32 len = 0;
428 register I32 total = 0;
433 while (next_symbol(symptr)) {
434 int which = (symptr->code & TYPE_IS_SHRIEKING)
435 ? PACK_SIZE_SHRIEKING : PACK_SIZE_NORMAL;
437 = TYPE_NO_MODIFIERS(symptr->code) - packsize[which].first;
439 switch( symptr->howlen ){
442 len = symptr->length;
445 Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
446 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
450 if ((offset >= 0) && (offset < packsize[which].size))
451 size = packsize[which].array[offset] & PACK_SIZE_MASK;
456 /* endianness doesn't influence the size of a type */
457 switch(TYPE_NO_ENDIANNESS(symptr->code)) {
459 Perl_croak(aTHX_ "Invalid type '%c' in %s",
460 (int)TYPE_NO_MODIFIERS(symptr->code),
461 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
464 case 'U': /* XXXX Is it correct? */
467 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
469 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
475 tempsym_t savsym = *symptr;
476 symptr->patptr = savsym.grpbeg;
477 symptr->patend = savsym.grpend;
478 /* XXXX Theoretically, we need to measure many times at
479 different positions, since the subexpression may contain
480 alignment commands, but be not of aligned length.
481 Need to detect this and croak(). */
482 size = measure_struct(symptr);
486 case 'X' | TYPE_IS_SHRIEKING:
487 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS.
489 if (!len) /* Avoid division by 0 */
491 len = total % len; /* Assumed: the start is aligned. */
496 Perl_croak(aTHX_ "'X' outside of string in %s",
497 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
499 case 'x' | TYPE_IS_SHRIEKING:
500 if (!len) /* Avoid division by 0 */
502 star = total % len; /* Assumed: the start is aligned. */
503 if (star) /* Other portable ways? */
529 size = sizeof(char*);
539 /* locate matching closing parenthesis or bracket
540 * returns char pointer to char after match, or NULL
543 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
545 while (patptr < patend) {
553 while (patptr < patend && *patptr != '\n')
557 patptr = group_end(patptr, patend, ')') + 1;
559 patptr = group_end(patptr, patend, ']') + 1;
561 Perl_croak(aTHX_ "No group ending character '%c' found in template",
567 /* Convert unsigned decimal number to binary.
568 * Expects a pointer to the first digit and address of length variable
569 * Advances char pointer to 1st non-digit char and returns number
572 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
574 I32 len = *patptr++ - '0';
575 while (isDIGIT(*patptr)) {
576 if (len >= 0x7FFFFFFF/10)
577 Perl_croak(aTHX_ "pack/unpack repeat count overflow");
578 len = (len * 10) + (*patptr++ - '0');
584 /* The marvellous template parsing routine: Using state stored in *symptr,
585 * locates next template code and count
588 S_next_symbol(pTHX_ register tempsym_t* symptr )
590 register char* patptr = symptr->patptr;
591 register char* patend = symptr->patend;
593 symptr->flags &= ~FLAG_SLASH;
595 while (patptr < patend) {
596 if (isSPACE(*patptr))
598 else if (*patptr == '#') {
600 while (patptr < patend && *patptr != '\n')
605 /* We should have found a template code */
606 I32 code = *patptr++ & 0xFF;
607 U32 inherited_modifiers = 0;
609 if (code == ','){ /* grandfather in commas but with a warning */
610 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
611 symptr->flags |= FLAG_COMMA;
612 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
613 "Invalid type ',' in %s",
614 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
619 /* for '(', skip to ')' */
621 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
622 Perl_croak(aTHX_ "()-group starts with a count in %s",
623 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
624 symptr->grpbeg = patptr;
625 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
626 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
627 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
628 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
631 /* look for group modifiers to inherit */
632 if (TYPE_ENDIANNESS(symptr->flags)) {
633 if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
634 inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
637 /* look for modifiers */
638 while (patptr < patend) {
643 modifier = TYPE_IS_SHRIEKING;
644 allowed = "sSiIlLxXnNvV";
647 modifier = TYPE_IS_BIG_ENDIAN;
648 allowed = ENDIANNESS_ALLOWED_TYPES;
651 modifier = TYPE_IS_LITTLE_ENDIAN;
652 allowed = ENDIANNESS_ALLOWED_TYPES;
661 if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
662 Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
663 allowed, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
665 if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
666 Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
667 (int) TYPE_NO_MODIFIERS(code),
668 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
669 else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
670 TYPE_ENDIANNESS_MASK)
671 Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
672 *patptr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
674 if (ckWARN(WARN_UNPACK)) {
676 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
677 "Duplicate modifier '%c' after '%c' in %s",
678 *patptr, (int) TYPE_NO_MODIFIERS(code),
679 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
686 /* inherit modifiers */
687 code |= inherited_modifiers;
689 /* look for count and/or / */
690 if (patptr < patend) {
691 if (isDIGIT(*patptr)) {
692 patptr = get_num( patptr, &symptr->length );
693 symptr->howlen = e_number;
695 } else if (*patptr == '*') {
697 symptr->howlen = e_star;
699 } else if (*patptr == '[') {
700 char* lenptr = ++patptr;
701 symptr->howlen = e_number;
702 patptr = group_end( patptr, patend, ']' ) + 1;
703 /* what kind of [] is it? */
704 if (isDIGIT(*lenptr)) {
705 lenptr = get_num( lenptr, &symptr->length );
707 Perl_croak(aTHX_ "Malformed integer in [] in %s",
708 symptr->flags & FLAG_PACK ? "pack" : "unpack");
710 tempsym_t savsym = *symptr;
711 symptr->patend = patptr-1;
712 symptr->patptr = lenptr;
713 savsym.length = measure_struct(symptr);
717 symptr->howlen = e_no_len;
722 while (patptr < patend) {
723 if (isSPACE(*patptr))
725 else if (*patptr == '#') {
727 while (patptr < patend && *patptr != '\n')
732 if (*patptr == '/') {
733 symptr->flags |= FLAG_SLASH;
735 if (patptr < patend &&
736 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
737 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
738 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
744 /* at end - no count, no / */
745 symptr->howlen = e_no_len;
750 symptr->patptr = patptr;
754 symptr->patptr = patptr;
759 =for apidoc unpack_str
761 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
762 and ocnt are not used. This call should not be used, use unpackstring instead.
767 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
769 tempsym_t sym = { 0 };
774 return unpack_rec(&sym, s, s, strend, NULL );
778 =for apidoc unpackstring
780 The engine implementing unpack() Perl function. C<unpackstring> puts the
781 extracted list items on the stack and returns the number of elements.
782 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
787 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
789 tempsym_t sym = { 0 };
794 return unpack_rec(&sym, s, s, strend, NULL );
799 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
803 register I32 len = 0;
804 register I32 bits = 0;
807 I32 start_sp_offset = SP - PL_stack_base;
810 /* These must not be in registers: */
819 #if SHORTSIZE != SIZE16
821 unsigned short aushort;
826 #if LONGSIZE != SIZE32
827 unsigned long aulong;
832 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
833 long double aldouble;
842 const int bits_in_uv = 8 * sizeof(cuv);
845 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
847 while (next_symbol(symptr)) {
848 datumtype = symptr->code;
849 /* do first one only unless in list context
850 / is implemented by unpacking the count, then poping it from the
851 stack, so must check that we're not in the middle of a / */
853 && (SP - PL_stack_base == start_sp_offset + 1)
854 && (datumtype != '/') ) /* XXX can this be omitted */
857 switch( howlen = symptr->howlen ){
860 len = symptr->length;
863 len = strend - strbeg; /* long enough */
868 beyond = s >= strend;
870 int which = (symptr->code & TYPE_IS_SHRIEKING)
871 ? PACK_SIZE_SHRIEKING : PACK_SIZE_NORMAL;
872 int offset = TYPE_NO_MODIFIERS(datumtype) - packsize[which].first;
874 if (offset >= 0 && offset < packsize[which].size) {
875 /* Data about this template letter */
876 unsigned char data = packsize[which].array[offset];
879 /* data nonzero means we can process this letter. */
880 long size = data & PACK_SIZE_MASK;
881 long howmany = (strend - s) / size;
885 if (!checksum || (data & PACK_SIZE_CANNOT_CSUM)) {
886 if (len && unpack_only_one &&
887 !(data & PACK_SIZE_CANNOT_ONLY_ONE))
895 switch(TYPE_NO_ENDIANNESS(datumtype)) {
897 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
900 if (howlen == e_no_len)
901 len = 16; /* len is not specified */
909 char *ss = s; /* Move from register */
910 tempsym_t savsym = *symptr;
911 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
912 symptr->flags |= group_modifiers;
913 symptr->patend = savsym.grpend;
917 symptr->patptr = savsym.grpbeg;
918 unpack_rec(symptr, ss, strbeg, strend, &ss );
919 if (ss == strend && savsym.howlen == e_star)
920 break; /* No way to continue */
924 symptr->flags &= ~group_modifiers;
925 savsym.flags = symptr->flags;
930 if (len > strend - strrelbeg)
931 Perl_croak(aTHX_ "'@' outside of string in unpack");
934 case 'X' | TYPE_IS_SHRIEKING:
935 if (!len) /* Avoid division by 0 */
937 len = (s - strbeg) % len;
940 if (len > s - strbeg)
941 Perl_croak(aTHX_ "'X' outside of string in unpack" );
944 case 'x' | TYPE_IS_SHRIEKING:
945 if (!len) /* Avoid division by 0 */
947 aint = (s - strbeg) % len;
948 if (aint) /* Other portable ways? */
954 if (len > strend - s)
955 Perl_croak(aTHX_ "'x' outside of string in unpack");
959 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
964 if (len > strend - s)
968 sv = newSVpvn(s, len);
969 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
970 aptr = s; /* borrow register */
971 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
975 if (howlen == e_star) /* exact for 'Z*' */
976 len = s - SvPVX(sv) + 1;
978 else { /* 'A' strips both nulls and spaces */
979 s = SvPVX(sv) + len - 1;
980 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
984 SvCUR_set(sv, s - SvPVX(sv));
985 s = aptr; /* unborrow register */
988 XPUSHs(sv_2mortal(sv));
992 if (howlen == e_star || len > (strend - s) * 8)
993 len = (strend - s) * 8;
996 Newz(601, PL_bitcount, 256, char);
997 for (bits = 1; bits < 256; bits++) {
998 if (bits & 1) PL_bitcount[bits]++;
999 if (bits & 2) PL_bitcount[bits]++;
1000 if (bits & 4) PL_bitcount[bits]++;
1001 if (bits & 8) PL_bitcount[bits]++;
1002 if (bits & 16) PL_bitcount[bits]++;
1003 if (bits & 32) PL_bitcount[bits]++;
1004 if (bits & 64) PL_bitcount[bits]++;
1005 if (bits & 128) PL_bitcount[bits]++;
1009 cuv += PL_bitcount[*(unsigned char*)s++];
1014 if (datumtype == 'b') {
1016 if (bits & 1) cuv++;
1022 if (bits & 128) cuv++;
1029 sv = NEWSV(35, len + 1);
1033 if (datumtype == 'b') {
1035 for (len = 0; len < aint; len++) {
1036 if (len & 7) /*SUPPRESS 595*/
1040 *str++ = '0' + (bits & 1);
1045 for (len = 0; len < aint; len++) {
1050 *str++ = '0' + ((bits & 128) != 0);
1054 XPUSHs(sv_2mortal(sv));
1058 if (howlen == e_star || len > (strend - s) * 2)
1059 len = (strend - s) * 2;
1060 sv = NEWSV(35, len + 1);
1064 if (datumtype == 'h') {
1066 for (len = 0; len < aint; len++) {
1071 *str++ = PL_hexdigit[bits & 15];
1076 for (len = 0; len < aint; len++) {
1081 *str++ = PL_hexdigit[(bits >> 4) & 15];
1085 XPUSHs(sv_2mortal(sv));
1090 if (aint >= 128) /* fake up signed chars */
1093 PUSHs(sv_2mortal(newSViv((IV)aint)));
1095 else if (checksum > bits_in_uv)
1096 cdouble += (NV)aint;
1102 unpack_C: /* unpack U will jump here if not UTF-8 */
1104 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
1117 PUSHs(sv_2mortal(newSViv((IV)auint)));
1123 symptr->flags |= FLAG_UNPACK_DO_UTF8;
1126 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
1128 while (len-- > 0 && s < strend) {
1130 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1134 PUSHs(sv_2mortal(newSVuv((UV)auint)));
1136 else if (checksum > bits_in_uv)
1137 cdouble += (NV)auint;
1142 case 's' | TYPE_IS_SHRIEKING:
1143 #if SHORTSIZE != SIZE16
1145 COPYNN(s, &ashort, sizeof(short));
1146 DO_BO_UNPACK(ashort, s);
1149 PUSHs(sv_2mortal(newSViv((IV)ashort)));
1151 else if (checksum > bits_in_uv)
1152 cdouble += (NV)ashort;
1163 DO_BO_UNPACK(ai16, 16);
1164 #if U16SIZE > SIZE16
1170 PUSHs(sv_2mortal(newSViv((IV)ai16)));
1172 else if (checksum > bits_in_uv)
1173 cdouble += (NV)ai16;
1178 case 'S' | TYPE_IS_SHRIEKING:
1179 #if SHORTSIZE != SIZE16
1181 COPYNN(s, &aushort, sizeof(unsigned short));
1182 DO_BO_UNPACK(aushort, s);
1183 s += sizeof(unsigned short);
1185 PUSHs(sv_2mortal(newSViv((UV)aushort)));
1187 else if (checksum > bits_in_uv)
1188 cdouble += (NV)aushort;
1201 DO_BO_UNPACK(au16, 16);
1204 if (datumtype == 'n')
1205 au16 = PerlSock_ntohs(au16);
1208 if (datumtype == 'v')
1212 PUSHs(sv_2mortal(newSViv((UV)au16)));
1214 else if (checksum > bits_in_uv)
1215 cdouble += (NV)au16;
1220 case 'v' | TYPE_IS_SHRIEKING:
1221 case 'n' | TYPE_IS_SHRIEKING:
1226 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1227 ai16 = (I16)PerlSock_ntohs((U16)ai16);
1230 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1231 ai16 = (I16)vtohs((U16)ai16);
1234 PUSHs(sv_2mortal(newSViv((IV)ai16)));
1236 else if (checksum > bits_in_uv)
1237 cdouble += (NV)ai16;
1243 case 'i' | TYPE_IS_SHRIEKING:
1245 Copy(s, &aint, 1, int);
1246 DO_BO_UNPACK(aint, i);
1249 PUSHs(sv_2mortal(newSViv((IV)aint)));
1251 else if (checksum > bits_in_uv)
1252 cdouble += (NV)aint;
1258 case 'I' | TYPE_IS_SHRIEKING:
1260 Copy(s, &auint, 1, unsigned int);
1261 DO_BO_UNPACK(auint, i);
1262 s += sizeof(unsigned int);
1264 PUSHs(sv_2mortal(newSVuv((UV)auint)));
1266 else if (checksum > bits_in_uv)
1267 cdouble += (NV)auint;
1274 Copy(s, &aiv, 1, IV);
1275 #if IVSIZE == INTSIZE
1276 DO_BO_UNPACK(aiv, i);
1277 #elif IVSIZE == LONGSIZE
1278 DO_BO_UNPACK(aiv, l);
1279 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1280 DO_BO_UNPACK(aiv, 64);
1284 PUSHs(sv_2mortal(newSViv(aiv)));
1286 else if (checksum > bits_in_uv)
1294 Copy(s, &auv, 1, UV);
1295 #if UVSIZE == INTSIZE
1296 DO_BO_UNPACK(auv, i);
1297 #elif UVSIZE == LONGSIZE
1298 DO_BO_UNPACK(auv, l);
1299 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1300 DO_BO_UNPACK(auv, 64);
1304 PUSHs(sv_2mortal(newSVuv(auv)));
1306 else if (checksum > bits_in_uv)
1312 case 'l' | TYPE_IS_SHRIEKING:
1313 #if LONGSIZE != SIZE32
1315 COPYNN(s, &along, sizeof(long));
1316 DO_BO_UNPACK(along, l);
1319 PUSHs(sv_2mortal(newSViv((IV)along)));
1321 else if (checksum > bits_in_uv)
1322 cdouble += (NV)along;
1333 DO_BO_UNPACK(ai32, 32);
1334 #if U32SIZE > SIZE32
1335 if (ai32 > 2147483647)
1340 PUSHs(sv_2mortal(newSViv((IV)ai32)));
1342 else if (checksum > bits_in_uv)
1343 cdouble += (NV)ai32;
1348 case 'L' | TYPE_IS_SHRIEKING:
1349 #if LONGSIZE != SIZE32
1351 COPYNN(s, &aulong, sizeof(unsigned long));
1352 DO_BO_UNPACK(aulong, l);
1353 s += sizeof(unsigned long);
1355 PUSHs(sv_2mortal(newSVuv((UV)aulong)));
1357 else if (checksum > bits_in_uv)
1358 cdouble += (NV)aulong;
1371 DO_BO_UNPACK(au32, 32);
1374 if (datumtype == 'N')
1375 au32 = PerlSock_ntohl(au32);
1378 if (datumtype == 'V')
1382 PUSHs(sv_2mortal(newSVuv((UV)au32)));
1384 else if (checksum > bits_in_uv)
1385 cdouble += (NV)au32;
1390 case 'V' | TYPE_IS_SHRIEKING:
1391 case 'N' | TYPE_IS_SHRIEKING:
1396 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1397 ai32 = (I32)PerlSock_ntohl((U32)ai32);
1400 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1401 ai32 = (I32)vtohl((U32)ai32);
1404 PUSHs(sv_2mortal(newSViv((IV)ai32)));
1406 else if (checksum > bits_in_uv)
1407 cdouble += (NV)ai32;
1414 assert (sizeof(char*) <= strend - s);
1415 Copy(s, &aptr, 1, char*);
1416 DO_BO_UNPACK_P(aptr);
1418 /* newSVpv generates undef if aptr is NULL */
1419 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1427 while ((len > 0) && (s < strend)) {
1428 auv = (auv << 7) | (*s & 0x7f);
1429 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1430 if ((U8)(*s++) < 0x80) {
1432 PUSHs(sv_2mortal(newSVuv(auv)));
1436 else if (++bytes >= sizeof(UV)) { /* promote to string */
1440 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1441 while (s < strend) {
1442 sv = mul128(sv, (U8)(*s & 0x7f));
1443 if (!(*s++ & 0x80)) {
1452 PUSHs(sv_2mortal(sv));
1457 if ((s >= strend) && bytes)
1458 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1462 if (symptr->howlen == e_star)
1463 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1465 if (sizeof(char*) > strend - s)
1468 Copy(s, &aptr, 1, char*);
1469 DO_BO_UNPACK_P(aptr);
1472 /* newSVpvn generates undef if aptr is NULL */
1473 PUSHs(sv_2mortal(newSVpvn(aptr, len)));
1478 assert (s + sizeof(Quad_t) <= strend);
1479 Copy(s, &aquad, 1, Quad_t);
1480 DO_BO_UNPACK(aquad, 64);
1481 s += sizeof(Quad_t);
1483 PUSHs(sv_2mortal((aquad >= IV_MIN && aquad <= IV_MAX) ?
1484 newSViv((IV)aquad) : newSVnv((NV)aquad)));
1486 else if (checksum > bits_in_uv)
1487 cdouble += (NV)aquad;
1494 assert (s + sizeof(Uquad_t) <= strend);
1495 Copy(s, &auquad, 1, Uquad_t);
1496 DO_BO_UNPACK(auquad, 64);
1497 s += sizeof(Uquad_t);
1499 PUSHs(sv_2mortal((auquad <= UV_MAX) ?
1500 newSVuv((UV)auquad) : newSVnv((NV)auquad)));
1502 else if (checksum > bits_in_uv)
1503 cdouble += (NV)auquad;
1509 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1512 Copy(s, &afloat, 1, float);
1513 DO_BO_UNPACK_N(afloat, float);
1516 PUSHs(sv_2mortal(newSVnv((NV)afloat)));
1525 Copy(s, &adouble, 1, double);
1526 DO_BO_UNPACK_N(adouble, double);
1527 s += sizeof(double);
1529 PUSHs(sv_2mortal(newSVnv((NV)adouble)));
1538 Copy(s, &anv, 1, NV);
1539 DO_BO_UNPACK_N(anv, NV);
1542 PUSHs(sv_2mortal(newSVnv(anv)));
1549 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1552 Copy(s, &aldouble, 1, long double);
1553 DO_BO_UNPACK_N(aldouble, long double);
1554 s += LONG_DOUBLESIZE;
1556 PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
1558 else {cdouble += aldouble;
1565 * Initialise the decode mapping. By using a table driven
1566 * algorithm, the code will be character-set independent
1567 * (and just as fast as doing character arithmetic)
1569 if (PL_uudmap['M'] == 0) {
1572 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1573 PL_uudmap[(U8)PL_uuemap[i]] = i;
1575 * Because ' ' and '`' map to the same value,
1576 * we need to decode them both the same.
1581 along = (strend - s) * 3 / 4;
1582 sv = NEWSV(42, along);
1585 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1590 len = PL_uudmap[*(U8*)s++] & 077;
1592 if (s < strend && ISUUCHAR(*s))
1593 a = PL_uudmap[*(U8*)s++] & 077;
1596 if (s < strend && ISUUCHAR(*s))
1597 b = PL_uudmap[*(U8*)s++] & 077;
1600 if (s < strend && ISUUCHAR(*s))
1601 c = PL_uudmap[*(U8*)s++] & 077;
1604 if (s < strend && ISUUCHAR(*s))
1605 d = PL_uudmap[*(U8*)s++] & 077;
1608 hunk[0] = (char)((a << 2) | (b >> 4));
1609 hunk[1] = (char)((b << 4) | (c >> 2));
1610 hunk[2] = (char)((c << 6) | d);
1611 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1616 else /* possible checksum byte */
1617 if (s + 1 < strend && s[1] == '\n')
1620 XPUSHs(sv_2mortal(sv));
1625 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1626 (checksum > bits_in_uv &&
1627 strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1630 adouble = (NV) (1 << (checksum & 15));
1631 while (checksum >= 16) {
1635 while (cdouble < 0.0)
1637 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1638 sv = newSVnv(cdouble);
1641 if (checksum < bits_in_uv) {
1642 UV mask = ((UV)1 << checksum) - 1;
1647 XPUSHs(sv_2mortal(sv));
1651 if (symptr->flags & FLAG_SLASH){
1652 if (SP - PL_stack_base - start_sp_offset <= 0)
1653 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1654 if( next_symbol(symptr) ){
1655 if( symptr->howlen == e_number )
1656 Perl_croak(aTHX_ "Count after length/code in unpack" );
1658 /* ...end of char buffer then no decent length available */
1659 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1661 /* take top of stack (hope it's numeric) */
1664 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1667 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1669 datumtype = symptr->code;
1677 return SP - PL_stack_base - start_sp_offset;
1684 I32 gimme = GIMME_V;
1687 register char *pat = SvPV(left, llen);
1688 #ifdef PACKED_IS_OCTETS
1689 /* Packed side is assumed to be octets - so force downgrade if it
1690 has been UTF-8 encoded by accident
1692 register char *s = SvPVbyte(right, rlen);
1694 register char *s = SvPV(right, rlen);
1696 char *strend = s + rlen;
1697 register char *patend = pat + llen;
1701 cnt = unpackstring(pat, patend, s, strend,
1702 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1703 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1706 if ( !cnt && gimme == G_SCALAR )
1707 PUSHs(&PL_sv_undef);
1712 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1716 *hunk = PL_uuemap[len];
1717 sv_catpvn(sv, hunk, 1);
1720 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1721 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1722 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1723 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1724 sv_catpvn(sv, hunk, 4);
1729 char r = (len > 1 ? s[1] : '\0');
1730 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1731 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1732 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1733 hunk[3] = PL_uuemap[0];
1734 sv_catpvn(sv, hunk, 4);
1736 sv_catpvn(sv, "\n", 1);
1740 S_is_an_int(pTHX_ char *s, STRLEN l)
1743 SV *result = newSVpvn(s, l);
1744 char *result_c = SvPV(result, n_a); /* convenience */
1745 char *out = result_c;
1755 SvREFCNT_dec(result);
1778 SvREFCNT_dec(result);
1784 SvCUR_set(result, out - result_c);
1788 /* pnum must be '\0' terminated */
1790 S_div128(pTHX_ SV *pnum, bool *done)
1793 char *s = SvPV(pnum, len);
1802 i = m * 10 + (*t - '0');
1804 r = (i >> 7); /* r < 10 */
1811 SvCUR_set(pnum, (STRLEN) (t - s));
1818 =for apidoc pack_cat
1820 The engine implementing pack() Perl function. Note: parameters next_in_list and
1821 flags are not used. This call should not be used; use packlist instead.
1827 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1829 tempsym_t sym = { 0 };
1831 sym.patend = patend;
1832 sym.flags = FLAG_PACK;
1834 (void)pack_rec( cat, &sym, beglist, endlist );
1839 =for apidoc packlist
1841 The engine implementing pack() Perl function.
1847 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1849 tempsym_t sym = { 0 };
1851 sym.patend = patend;
1852 sym.flags = FLAG_PACK;
1854 (void)pack_rec( cat, &sym, beglist, endlist );
1860 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1864 register I32 len = 0;
1867 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1868 static char *space10 = " ";
1871 /* These must not be in registers: */
1881 #if SHORTSIZE != SIZE16
1883 unsigned short aushort;
1887 #if LONGSIZE != SIZE32
1889 unsigned long aulong;
1894 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1895 long double aldouble;
1901 int strrelbeg = SvCUR(cat);
1902 tempsym_t lookahead;
1904 items = endlist - beglist;
1905 found = next_symbol( symptr );
1907 #ifndef PACKED_IS_OCTETS
1908 if (symptr->level == 0 && found && symptr->code == 'U' ){
1914 SV *lengthcode = Nullsv;
1915 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1917 I32 datumtype = symptr->code;
1920 switch( howlen = symptr->howlen ){
1923 len = symptr->length;
1926 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
1930 /* Look ahead for next symbol. Do we have code/code? */
1931 lookahead = *symptr;
1932 found = next_symbol(&lookahead);
1933 if ( symptr->flags & FLAG_SLASH ) {
1935 if ( 0 == strchr( "aAZ", lookahead.code ) ||
1936 e_star != lookahead.howlen )
1937 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
1938 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1939 ? *beglist : &PL_sv_no)
1940 + (lookahead.code == 'Z' ? 1 : 0)));
1942 Perl_croak(aTHX_ "Code missing after '/' in pack");
1946 switch(TYPE_NO_ENDIANNESS(datumtype)) {
1948 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
1950 Perl_croak(aTHX_ "'%%' may not be used in pack");
1952 len += strrelbeg - SvCUR(cat);
1961 tempsym_t savsym = *symptr;
1962 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
1963 symptr->flags |= group_modifiers;
1964 symptr->patend = savsym.grpend;
1967 symptr->patptr = savsym.grpbeg;
1968 beglist = pack_rec(cat, symptr, beglist, endlist );
1969 if (savsym.howlen == e_star && beglist == endlist)
1970 break; /* No way to continue */
1972 symptr->flags &= ~group_modifiers;
1973 lookahead.flags = symptr->flags;
1977 case 'X' | TYPE_IS_SHRIEKING:
1978 if (!len) /* Avoid division by 0 */
1980 len = (SvCUR(cat)) % len;
1984 if ((I32)SvCUR(cat) < len)
1985 Perl_croak(aTHX_ "'X' outside of string in pack");
1989 case 'x' | TYPE_IS_SHRIEKING:
1990 if (!len) /* Avoid division by 0 */
1992 aint = (SvCUR(cat)) % len;
1993 if (aint) /* Other portable ways? */
2002 sv_catpvn(cat, null10, 10);
2005 sv_catpvn(cat, null10, len);
2011 aptr = SvPV(fromstr, fromlen);
2012 if (howlen == e_star) {
2014 if (datumtype == 'Z')
2017 if ((I32)fromlen >= len) {
2018 sv_catpvn(cat, aptr, len);
2019 if (datumtype == 'Z')
2020 *(SvEND(cat)-1) = '\0';
2023 sv_catpvn(cat, aptr, fromlen);
2025 if (datumtype == 'A') {
2027 sv_catpvn(cat, space10, 10);
2030 sv_catpvn(cat, space10, len);
2034 sv_catpvn(cat, null10, 10);
2037 sv_catpvn(cat, null10, len);
2049 str = SvPV(fromstr, fromlen);
2050 if (howlen == e_star)
2053 SvCUR(cat) += (len+7)/8;
2054 SvGROW(cat, SvCUR(cat) + 1);
2055 aptr = SvPVX(cat) + aint;
2056 if (len > (I32)fromlen)
2060 if (datumtype == 'B') {
2061 for (len = 0; len++ < aint;) {
2062 items |= *str++ & 1;
2066 *aptr++ = items & 0xff;
2072 for (len = 0; len++ < aint;) {
2078 *aptr++ = items & 0xff;
2084 if (datumtype == 'B')
2085 items <<= 7 - (aint & 7);
2087 items >>= 7 - (aint & 7);
2088 *aptr++ = items & 0xff;
2090 str = SvPVX(cat) + SvCUR(cat);
2105 str = SvPV(fromstr, fromlen);
2106 if (howlen == e_star)
2109 SvCUR(cat) += (len+1)/2;
2110 SvGROW(cat, SvCUR(cat) + 1);
2111 aptr = SvPVX(cat) + aint;
2112 if (len > (I32)fromlen)
2116 if (datumtype == 'H') {
2117 for (len = 0; len++ < aint;) {
2119 items |= ((*str++ & 15) + 9) & 15;
2121 items |= *str++ & 15;
2125 *aptr++ = items & 0xff;
2131 for (len = 0; len++ < aint;) {
2133 items |= (((*str++ & 15) + 9) & 15) << 4;
2135 items |= (*str++ & 15) << 4;
2139 *aptr++ = items & 0xff;
2145 *aptr++ = items & 0xff;
2146 str = SvPVX(cat) + SvCUR(cat);
2157 switch (TYPE_NO_MODIFIERS(datumtype)) {
2159 aint = SvIV(fromstr);
2160 if ((aint < 0 || aint > 255) &&
2162 Perl_warner(aTHX_ packWARN(WARN_PACK),
2163 "Character in 'C' format wrapped in pack");
2165 sv_catpvn(cat, &achar, sizeof(char));
2168 aint = SvIV(fromstr);
2169 if ((aint < -128 || aint > 127) &&
2171 Perl_warner(aTHX_ packWARN(WARN_PACK),
2172 "Character in 'c' format wrapped in pack" );
2174 sv_catpvn(cat, &achar, sizeof(char));
2182 auint = UNI_TO_NATIVE(SvUV(fromstr));
2183 SvGROW(cat, SvCUR(cat) + UTF8_MAXBYTES + 1);
2185 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2188 0 : UNICODE_ALLOW_ANY)
2193 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2198 /* VOS does not automatically map a floating-point overflow
2199 during conversion from double to float into infinity, so we
2200 do it by hand. This code should either be generalized for
2201 any OS that needs it, or removed if and when VOS implements
2202 posix-976 (suggestion to support mapping to infinity).
2203 Paul.Green@stratus.com 02-04-02. */
2204 if (SvNV(fromstr) > FLT_MAX)
2205 afloat = _float_constants[0]; /* single prec. inf. */
2206 else if (SvNV(fromstr) < -FLT_MAX)
2207 afloat = _float_constants[0]; /* single prec. inf. */
2208 else afloat = (float)SvNV(fromstr);
2210 # if defined(VMS) && !defined(__IEEE_FP)
2211 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2212 * on Alpha; fake it if we don't have them.
2214 if (SvNV(fromstr) > FLT_MAX)
2216 else if (SvNV(fromstr) < -FLT_MAX)
2218 else afloat = (float)SvNV(fromstr);
2220 afloat = (float)SvNV(fromstr);
2223 DO_BO_PACK_N(afloat, float);
2224 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2231 /* VOS does not automatically map a floating-point overflow
2232 during conversion from long double to double into infinity,
2233 so we do it by hand. This code should either be generalized
2234 for any OS that needs it, or removed if and when VOS
2235 implements posix-976 (suggestion to support mapping to
2236 infinity). Paul.Green@stratus.com 02-04-02. */
2237 if (SvNV(fromstr) > DBL_MAX)
2238 adouble = _double_constants[0]; /* double prec. inf. */
2239 else if (SvNV(fromstr) < -DBL_MAX)
2240 adouble = _double_constants[0]; /* double prec. inf. */
2241 else adouble = (double)SvNV(fromstr);
2243 # if defined(VMS) && !defined(__IEEE_FP)
2244 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2245 * on Alpha; fake it if we don't have them.
2247 if (SvNV(fromstr) > DBL_MAX)
2249 else if (SvNV(fromstr) < -DBL_MAX)
2251 else adouble = (double)SvNV(fromstr);
2253 adouble = (double)SvNV(fromstr);
2256 DO_BO_PACK_N(adouble, double);
2257 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2261 Zero(&anv, 1, NV); /* can be long double with unused bits */
2264 anv = SvNV(fromstr);
2265 DO_BO_PACK_N(anv, NV);
2266 sv_catpvn(cat, (char *)&anv, NVSIZE);
2269 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2271 /* long doubles can have unused bits, which may be nonzero */
2272 Zero(&aldouble, 1, long double);
2275 aldouble = (long double)SvNV(fromstr);
2276 DO_BO_PACK_N(aldouble, long double);
2277 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2281 case 'n' | TYPE_IS_SHRIEKING:
2285 ai16 = (I16)SvIV(fromstr);
2287 ai16 = PerlSock_htons(ai16);
2292 case 'v' | TYPE_IS_SHRIEKING:
2296 ai16 = (I16)SvIV(fromstr);
2303 case 'S' | TYPE_IS_SHRIEKING:
2304 #if SHORTSIZE != SIZE16
2308 aushort = SvUV(fromstr);
2309 DO_BO_PACK(aushort, s);
2310 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2321 au16 = (U16)SvUV(fromstr);
2322 DO_BO_PACK(au16, 16);
2328 case 's' | TYPE_IS_SHRIEKING:
2329 #if SHORTSIZE != SIZE16
2333 ashort = SvIV(fromstr);
2334 DO_BO_PACK(ashort, s);
2335 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2345 ai16 = (I16)SvIV(fromstr);
2346 DO_BO_PACK(ai16, 16);
2351 case 'I' | TYPE_IS_SHRIEKING:
2354 auint = SvUV(fromstr);
2355 DO_BO_PACK(auint, i);
2356 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2362 aiv = SvIV(fromstr);
2363 #if IVSIZE == INTSIZE
2365 #elif IVSIZE == LONGSIZE
2367 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2368 DO_BO_PACK(aiv, 64);
2370 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2376 auv = SvUV(fromstr);
2377 #if UVSIZE == INTSIZE
2379 #elif UVSIZE == LONGSIZE
2381 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2382 DO_BO_PACK(auv, 64);
2384 sv_catpvn(cat, (char*)&auv, UVSIZE);
2390 anv = SvNV(fromstr);
2393 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2395 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2396 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2397 any negative IVs will have already been got by the croak()
2398 above. IOK is untrue for fractions, so we test them
2399 against UV_MAX_P1. */
2400 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2402 char buf[(sizeof(UV)*8)/7+1];
2403 char *in = buf + sizeof(buf);
2404 UV auv = SvUV(fromstr);
2407 *--in = (char)((auv & 0x7f) | 0x80);
2410 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2411 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2413 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2414 char *from, *result, *in;
2419 /* Copy string and check for compliance */
2420 from = SvPV(fromstr, len);
2421 if ((norm = is_an_int(from, len)) == NULL)
2422 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2424 New('w', result, len, char);
2428 *--in = div128(norm, &done) | 0x80;
2429 result[len - 1] &= 0x7F; /* clear continue bit */
2430 sv_catpvn(cat, in, (result + len) - in);
2432 SvREFCNT_dec(norm); /* free norm */
2434 else if (SvNOKp(fromstr)) {
2435 /* 10**NV_MAX_10_EXP is the largest power of 10
2436 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2437 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2438 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2439 And with that many bytes only Inf can overflow.
2440 Some C compilers are strict about integral constant
2441 expressions so we conservatively divide by a slightly
2442 smaller integer instead of multiplying by the exact
2443 floating-point value.
2445 #ifdef NV_MAX_10_EXP
2446 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2447 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2449 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2450 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2452 char *in = buf + sizeof(buf);
2454 anv = Perl_floor(anv);
2456 NV next = Perl_floor(anv / 128);
2457 if (in <= buf) /* this cannot happen ;-) */
2458 Perl_croak(aTHX_ "Cannot compress integer in pack");
2459 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2462 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2463 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2466 char *from, *result, *in;
2471 /* Copy string and check for compliance */
2472 from = SvPV(fromstr, len);
2473 if ((norm = is_an_int(from, len)) == NULL)
2474 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2476 New('w', result, len, char);
2480 *--in = div128(norm, &done) | 0x80;
2481 result[len - 1] &= 0x7F; /* clear continue bit */
2482 sv_catpvn(cat, in, (result + len) - in);
2484 SvREFCNT_dec(norm); /* free norm */
2489 case 'i' | TYPE_IS_SHRIEKING:
2492 aint = SvIV(fromstr);
2493 DO_BO_PACK(aint, i);
2494 sv_catpvn(cat, (char*)&aint, sizeof(int));
2497 case 'N' | TYPE_IS_SHRIEKING:
2501 au32 = SvUV(fromstr);
2503 au32 = PerlSock_htonl(au32);
2508 case 'V' | TYPE_IS_SHRIEKING:
2512 au32 = SvUV(fromstr);
2519 case 'L' | TYPE_IS_SHRIEKING:
2520 #if LONGSIZE != SIZE32
2524 aulong = SvUV(fromstr);
2525 DO_BO_PACK(aulong, l);
2526 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2537 au32 = SvUV(fromstr);
2538 DO_BO_PACK(au32, 32);
2543 case 'l' | TYPE_IS_SHRIEKING:
2544 #if LONGSIZE != SIZE32
2548 along = SvIV(fromstr);
2549 DO_BO_PACK(along, l);
2550 sv_catpvn(cat, (char *)&along, sizeof(long));
2560 ai32 = SvIV(fromstr);
2561 DO_BO_PACK(ai32, 32);
2569 auquad = (Uquad_t)SvUV(fromstr);
2570 DO_BO_PACK(auquad, 64);
2571 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2577 aquad = (Quad_t)SvIV(fromstr);
2578 DO_BO_PACK(aquad, 64);
2579 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2584 len = 1; /* assume SV is correct length */
2589 if (fromstr == &PL_sv_undef)
2593 /* XXX better yet, could spirit away the string to
2594 * a safe spot and hang on to it until the result
2595 * of pack() (and all copies of the result) are
2598 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2599 || (SvPADTMP(fromstr)
2600 && !SvREADONLY(fromstr))))
2602 Perl_warner(aTHX_ packWARN(WARN_PACK),
2603 "Attempt to pack pointer to temporary value");
2605 if (SvPOK(fromstr) || SvNIOK(fromstr))
2606 aptr = SvPV(fromstr,n_a);
2608 aptr = SvPV_force(fromstr,n_a);
2611 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2616 aptr = SvPV(fromstr, fromlen);
2617 SvGROW(cat, fromlen * 4 / 3);
2622 while (fromlen > 0) {
2625 if ((I32)fromlen > len)
2629 doencodes(cat, aptr, todo);
2635 *symptr = lookahead;
2644 dSP; dMARK; dORIGMARK; dTARGET;
2645 register SV *cat = TARG;
2647 register char *pat = SvPVx(*++MARK, fromlen);
2648 register char *patend = pat + fromlen;
2651 sv_setpvn(cat, "", 0);
2653 packlist(cat, pat, patend, MARK, SP + 1);
2663 * c-indentation-style: bsd
2665 * indent-tabs-mode: t
2668 * vim: shiftwidth=4: