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
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 /* D */ LONG_DOUBLESIZE,
266 /* I */ sizeof(unsigned int),
273 /* Q */ sizeof(Uquad_t),
277 /* U */ sizeof(char),
279 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
280 /* c */ sizeof(char),
281 /* d */ sizeof(double),
283 /* f */ sizeof(float),
292 /* p */ sizeof(char *) | PACK_SIZE_CANNOT_ONLY_ONE | PACK_SIZE_CANNOT_CSUM,
293 /* q */ sizeof(Quad_t),
298 /* w */ sizeof(char) | PACK_SIZE_CANNOT_CSUM
300 unsigned char size_shrieking[46] = {
301 /* I */ sizeof(unsigned int),
303 /* L */ sizeof(unsigned long),
307 /* S */ sizeof(unsigned short),
310 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
313 /* l */ sizeof(long),
317 /* s */ sizeof(short),
321 struct packsize_t packsize[2] = {
322 {size_normal, 67, 53},
323 {size_shrieking, 73, 46}
326 /* EBCDIC (or bust) */
327 unsigned char size_normal[99] = {
328 /* c */ sizeof(char),
329 /* d */ sizeof(double),
331 /* f */ sizeof(float),
341 /* p */ sizeof(char *) | PACK_SIZE_CANNOT_ONLY_ONE | PACK_SIZE_CANNOT_CSUM,
342 /* q */ sizeof(Quad_t),
343 0, 0, 0, 0, 0, 0, 0, 0, 0,
347 /* w */ sizeof(char) | PACK_SIZE_CANNOT_CSUM,
348 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,
350 /* C */ sizeof(unsigned char),
351 /* D */ LONG_DOUBLESIZE,
355 /* I */ sizeof(unsigned int),
363 /* Q */ sizeof(Uquad_t),
364 0, 0, 0, 0, 0, 0, 0, 0, 0,
367 /* U */ sizeof(char),
370 unsigned char size_shrieking[93] = {
372 0, 0, 0, 0, 0, 0, 0, 0, 0,
373 /* l */ sizeof(long),
376 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
377 /* s */ sizeof(short),
380 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,
381 0, 0, 0, 0, 0, 0, 0, 0, 0,
382 /* I */ sizeof(unsigned int),
383 0, 0, 0, 0, 0, 0, 0, 0, 0,
384 /* L */ sizeof(unsigned long),
387 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
388 /* S */ sizeof(unsigned short),
392 struct packsize_t packsize[2] = {
393 {size_normal, 131, 99},
394 {size_shrieking, 137, 93}
399 /* Returns the sizeof() struct described by pat */
401 S_measure_struct(pTHX_ register tempsym_t* symptr)
403 register I32 len = 0;
404 register I32 total = 0;
409 while (next_symbol(symptr)) {
411 switch( symptr->howlen ){
414 len = symptr->length;
417 Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
418 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
422 /* endianness doesn't influence the size of a type */
423 switch(TYPE_NO_ENDIANNESS(symptr->code)) {
425 Perl_croak(aTHX_ "Invalid type '%c' in %s",
426 (int)TYPE_NO_MODIFIERS(symptr->code),
427 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
430 case 'U': /* XXXX Is it correct? */
433 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
435 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
441 tempsym_t savsym = *symptr;
442 symptr->patptr = savsym.grpbeg;
443 symptr->patend = savsym.grpend;
444 /* XXXX Theoretically, we need to measure many times at different
445 positions, since the subexpression may contain
446 alignment commands, but be not of aligned length.
447 Need to detect this and croak(). */
448 size = measure_struct(symptr);
452 case 'X' | TYPE_IS_SHRIEKING:
453 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */
454 if (!len) /* Avoid division by 0 */
456 len = total % len; /* Assumed: the start is aligned. */
461 Perl_croak(aTHX_ "'X' outside of string in %s",
462 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
464 case 'x' | TYPE_IS_SHRIEKING:
465 if (!len) /* Avoid division by 0 */
467 star = total % len; /* Assumed: the start is aligned. */
468 if (star) /* Other portable ways? */
497 size = sizeof(char*);
500 case 's' | TYPE_IS_SHRIEKING:
501 case 'S' | TYPE_IS_SHRIEKING:
502 case 'v' | TYPE_IS_SHRIEKING:
503 case 'n' | TYPE_IS_SHRIEKING:
504 case 'i' | TYPE_IS_SHRIEKING:
505 case 'I' | TYPE_IS_SHRIEKING:
506 case 'l' | TYPE_IS_SHRIEKING:
507 case 'L' | TYPE_IS_SHRIEKING:
508 case 'V' | TYPE_IS_SHRIEKING:
509 case 'N' | TYPE_IS_SHRIEKING:
529 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
533 int which = (symptr->code & TYPE_IS_SHRIEKING)
534 ? PACK_SIZE_SHRIEKING : PACK_SIZE_NORMAL;
536 = TYPE_NO_MODIFIERS(symptr->code) - packsize[which].first;
537 assert (offset >= 0);
538 assert (offset < packsize[which].size);
539 size = packsize[which].array[offset] & PACK_SIZE_MASK;
550 /* locate matching closing parenthesis or bracket
551 * returns char pointer to char after match, or NULL
554 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
556 while (patptr < patend) {
564 while (patptr < patend && *patptr != '\n')
568 patptr = group_end(patptr, patend, ')') + 1;
570 patptr = group_end(patptr, patend, ']') + 1;
572 Perl_croak(aTHX_ "No group ending character '%c' found in template",
578 /* Convert unsigned decimal number to binary.
579 * Expects a pointer to the first digit and address of length variable
580 * Advances char pointer to 1st non-digit char and returns number
583 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
585 I32 len = *patptr++ - '0';
586 while (isDIGIT(*patptr)) {
587 if (len >= 0x7FFFFFFF/10)
588 Perl_croak(aTHX_ "pack/unpack repeat count overflow");
589 len = (len * 10) + (*patptr++ - '0');
595 /* The marvellous template parsing routine: Using state stored in *symptr,
596 * locates next template code and count
599 S_next_symbol(pTHX_ register tempsym_t* symptr )
601 register char* patptr = symptr->patptr;
602 register char* patend = symptr->patend;
604 symptr->flags &= ~FLAG_SLASH;
606 while (patptr < patend) {
607 if (isSPACE(*patptr))
609 else if (*patptr == '#') {
611 while (patptr < patend && *patptr != '\n')
616 /* We should have found a template code */
617 I32 code = *patptr++ & 0xFF;
618 U32 inherited_modifiers = 0;
620 if (code == ','){ /* grandfather in commas but with a warning */
621 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
622 symptr->flags |= FLAG_COMMA;
623 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
624 "Invalid type ',' in %s",
625 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
630 /* for '(', skip to ')' */
632 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
633 Perl_croak(aTHX_ "()-group starts with a count in %s",
634 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
635 symptr->grpbeg = patptr;
636 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
637 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
638 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
639 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
642 /* look for group modifiers to inherit */
643 if (TYPE_ENDIANNESS(symptr->flags)) {
644 if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
645 inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
648 /* look for modifiers */
649 while (patptr < patend) {
654 modifier = TYPE_IS_SHRIEKING;
655 allowed = "sSiIlLxXnNvV";
658 modifier = TYPE_IS_BIG_ENDIAN;
659 allowed = ENDIANNESS_ALLOWED_TYPES;
662 modifier = TYPE_IS_LITTLE_ENDIAN;
663 allowed = ENDIANNESS_ALLOWED_TYPES;
672 if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
673 Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
674 allowed, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
676 if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
677 Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
678 (int) TYPE_NO_MODIFIERS(code),
679 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
680 else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
681 TYPE_ENDIANNESS_MASK)
682 Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
683 *patptr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
685 if (ckWARN(WARN_UNPACK)) {
687 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
688 "Duplicate modifier '%c' after '%c' in %s",
689 *patptr, (int) TYPE_NO_MODIFIERS(code),
690 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
697 /* inherit modifiers */
698 code |= inherited_modifiers;
700 /* look for count and/or / */
701 if (patptr < patend) {
702 if (isDIGIT(*patptr)) {
703 patptr = get_num( patptr, &symptr->length );
704 symptr->howlen = e_number;
706 } else if (*patptr == '*') {
708 symptr->howlen = e_star;
710 } else if (*patptr == '[') {
711 char* lenptr = ++patptr;
712 symptr->howlen = e_number;
713 patptr = group_end( patptr, patend, ']' ) + 1;
714 /* what kind of [] is it? */
715 if (isDIGIT(*lenptr)) {
716 lenptr = get_num( lenptr, &symptr->length );
718 Perl_croak(aTHX_ "Malformed integer in [] in %s",
719 symptr->flags & FLAG_PACK ? "pack" : "unpack");
721 tempsym_t savsym = *symptr;
722 symptr->patend = patptr-1;
723 symptr->patptr = lenptr;
724 savsym.length = measure_struct(symptr);
728 symptr->howlen = e_no_len;
733 while (patptr < patend) {
734 if (isSPACE(*patptr))
736 else if (*patptr == '#') {
738 while (patptr < patend && *patptr != '\n')
743 if (*patptr == '/') {
744 symptr->flags |= FLAG_SLASH;
746 if (patptr < patend &&
747 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
748 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
749 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
755 /* at end - no count, no / */
756 symptr->howlen = e_no_len;
761 symptr->patptr = patptr;
765 symptr->patptr = patptr;
770 =for apidoc unpack_str
772 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
773 and ocnt are not used. This call should not be used, use unpackstring instead.
778 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
780 tempsym_t sym = { 0 };
785 return unpack_rec(&sym, s, s, strend, NULL );
789 =for apidoc unpackstring
791 The engine implementing unpack() Perl function. C<unpackstring> puts the
792 extracted list items on the stack and returns the number of elements.
793 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
798 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
800 tempsym_t sym = { 0 };
805 return unpack_rec(&sym, s, s, strend, NULL );
810 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
814 register I32 len = 0;
815 register I32 bits = 0;
818 I32 start_sp_offset = SP - PL_stack_base;
821 /* These must not be in registers: */
830 #if SHORTSIZE != SIZE16
832 unsigned short aushort;
837 #if LONGSIZE != SIZE32
838 unsigned long aulong;
843 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
844 long double aldouble;
853 const int bits_in_uv = 8 * sizeof(cuv);
856 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
858 while (next_symbol(symptr)) {
859 datumtype = symptr->code;
860 /* do first one only unless in list context
861 / is implemented by unpacking the count, then poping it from the
862 stack, so must check that we're not in the middle of a / */
864 && (SP - PL_stack_base == start_sp_offset + 1)
865 && (datumtype != '/') ) /* XXX can this be omitted */
868 switch( howlen = symptr->howlen ){
871 len = symptr->length;
874 len = strend - strbeg; /* long enough */
879 beyond = s >= strend;
881 int which = (symptr->code & TYPE_IS_SHRIEKING)
882 ? PACK_SIZE_SHRIEKING : PACK_SIZE_NORMAL;
883 int offset = TYPE_NO_MODIFIERS(datumtype) - packsize[which].first;
885 if (offset >= 0 && offset < packsize[which].size) {
886 /* Data about this template letter */
887 unsigned char data = packsize[which].array[offset];
890 /* data nonzero means we can process this letter. */
891 long size = data & PACK_SIZE_MASK;
892 long howmany = (strend - s) / size;
896 if (!checksum || (data & PACK_SIZE_CANNOT_CSUM)) {
897 if (len && unpack_only_one &&
898 !(data & PACK_SIZE_CANNOT_ONLY_ONE))
906 switch(TYPE_NO_ENDIANNESS(datumtype)) {
908 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
911 if (howlen == e_no_len)
912 len = 16; /* len is not specified */
920 char *ss = s; /* Move from register */
921 tempsym_t savsym = *symptr;
922 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
923 symptr->flags |= group_modifiers;
924 symptr->patend = savsym.grpend;
928 symptr->patptr = savsym.grpbeg;
929 unpack_rec(symptr, ss, strbeg, strend, &ss );
930 if (ss == strend && savsym.howlen == e_star)
931 break; /* No way to continue */
935 symptr->flags &= ~group_modifiers;
936 savsym.flags = symptr->flags;
941 if (len > strend - strrelbeg)
942 Perl_croak(aTHX_ "'@' outside of string in unpack");
945 case 'X' | TYPE_IS_SHRIEKING:
946 if (!len) /* Avoid division by 0 */
948 len = (s - strbeg) % len;
951 if (len > s - strbeg)
952 Perl_croak(aTHX_ "'X' outside of string in unpack" );
955 case 'x' | TYPE_IS_SHRIEKING:
956 if (!len) /* Avoid division by 0 */
958 aint = (s - strbeg) % len;
959 if (aint) /* Other portable ways? */
965 if (len > strend - s)
966 Perl_croak(aTHX_ "'x' outside of string in unpack");
970 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
975 if (len > strend - s)
979 sv = newSVpvn(s, len);
980 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
981 aptr = s; /* borrow register */
982 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
986 if (howlen == e_star) /* exact for 'Z*' */
987 len = s - SvPVX(sv) + 1;
989 else { /* 'A' strips both nulls and spaces */
990 s = SvPVX(sv) + len - 1;
991 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
995 SvCUR_set(sv, s - SvPVX(sv));
996 s = aptr; /* unborrow register */
999 XPUSHs(sv_2mortal(sv));
1003 if (howlen == e_star || len > (strend - s) * 8)
1004 len = (strend - s) * 8;
1007 Newz(601, PL_bitcount, 256, char);
1008 for (bits = 1; bits < 256; bits++) {
1009 if (bits & 1) PL_bitcount[bits]++;
1010 if (bits & 2) PL_bitcount[bits]++;
1011 if (bits & 4) PL_bitcount[bits]++;
1012 if (bits & 8) PL_bitcount[bits]++;
1013 if (bits & 16) PL_bitcount[bits]++;
1014 if (bits & 32) PL_bitcount[bits]++;
1015 if (bits & 64) PL_bitcount[bits]++;
1016 if (bits & 128) PL_bitcount[bits]++;
1020 cuv += PL_bitcount[*(unsigned char*)s++];
1025 if (datumtype == 'b') {
1027 if (bits & 1) cuv++;
1033 if (bits & 128) cuv++;
1040 sv = NEWSV(35, len + 1);
1044 if (datumtype == 'b') {
1046 for (len = 0; len < aint; len++) {
1047 if (len & 7) /*SUPPRESS 595*/
1051 *str++ = '0' + (bits & 1);
1056 for (len = 0; len < aint; len++) {
1061 *str++ = '0' + ((bits & 128) != 0);
1065 XPUSHs(sv_2mortal(sv));
1069 if (howlen == e_star || len > (strend - s) * 2)
1070 len = (strend - s) * 2;
1071 sv = NEWSV(35, len + 1);
1075 if (datumtype == 'h') {
1077 for (len = 0; len < aint; len++) {
1082 *str++ = PL_hexdigit[bits & 15];
1087 for (len = 0; len < aint; len++) {
1092 *str++ = PL_hexdigit[(bits >> 4) & 15];
1096 XPUSHs(sv_2mortal(sv));
1101 if (aint >= 128) /* fake up signed chars */
1104 PUSHs(sv_2mortal(newSViv((IV)aint)));
1106 else if (checksum > bits_in_uv)
1107 cdouble += (NV)aint;
1113 unpack_C: /* unpack U will jump here if not UTF-8 */
1115 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
1128 PUSHs(sv_2mortal(newSViv((IV)auint)));
1134 symptr->flags |= FLAG_UNPACK_DO_UTF8;
1137 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
1139 while (len-- > 0 && s < strend) {
1141 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1145 PUSHs(sv_2mortal(newSVuv((UV)auint)));
1147 else if (checksum > bits_in_uv)
1148 cdouble += (NV)auint;
1153 case 's' | TYPE_IS_SHRIEKING:
1154 #if SHORTSIZE != SIZE16
1156 COPYNN(s, &ashort, sizeof(short));
1157 DO_BO_UNPACK(ashort, s);
1160 PUSHs(sv_2mortal(newSViv((IV)ashort)));
1162 else if (checksum > bits_in_uv)
1163 cdouble += (NV)ashort;
1174 DO_BO_UNPACK(ai16, 16);
1175 #if U16SIZE > SIZE16
1181 PUSHs(sv_2mortal(newSViv((IV)ai16)));
1183 else if (checksum > bits_in_uv)
1184 cdouble += (NV)ai16;
1189 case 'S' | TYPE_IS_SHRIEKING:
1190 #if SHORTSIZE != SIZE16
1192 COPYNN(s, &aushort, sizeof(unsigned short));
1193 DO_BO_UNPACK(aushort, s);
1194 s += sizeof(unsigned short);
1196 PUSHs(sv_2mortal(newSViv((UV)aushort)));
1198 else if (checksum > bits_in_uv)
1199 cdouble += (NV)aushort;
1212 DO_BO_UNPACK(au16, 16);
1215 if (datumtype == 'n')
1216 au16 = PerlSock_ntohs(au16);
1219 if (datumtype == 'v')
1223 PUSHs(sv_2mortal(newSViv((UV)au16)));
1225 else if (checksum > bits_in_uv)
1226 cdouble += (NV)au16;
1231 case 'v' | TYPE_IS_SHRIEKING:
1232 case 'n' | TYPE_IS_SHRIEKING:
1237 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1238 ai16 = (I16)PerlSock_ntohs((U16)ai16);
1241 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1242 ai16 = (I16)vtohs((U16)ai16);
1245 PUSHs(sv_2mortal(newSViv((IV)ai16)));
1247 else if (checksum > bits_in_uv)
1248 cdouble += (NV)ai16;
1254 case 'i' | TYPE_IS_SHRIEKING:
1256 Copy(s, &aint, 1, int);
1257 DO_BO_UNPACK(aint, i);
1260 PUSHs(sv_2mortal(newSViv((IV)aint)));
1262 else if (checksum > bits_in_uv)
1263 cdouble += (NV)aint;
1269 case 'I' | TYPE_IS_SHRIEKING:
1271 Copy(s, &auint, 1, unsigned int);
1272 DO_BO_UNPACK(auint, i);
1273 s += sizeof(unsigned int);
1275 PUSHs(sv_2mortal(newSVuv((UV)auint)));
1277 else if (checksum > bits_in_uv)
1278 cdouble += (NV)auint;
1285 Copy(s, &aiv, 1, IV);
1286 #if IVSIZE == INTSIZE
1287 DO_BO_UNPACK(aiv, i);
1288 #elif IVSIZE == LONGSIZE
1289 DO_BO_UNPACK(aiv, l);
1290 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1291 DO_BO_UNPACK(aiv, 64);
1295 PUSHs(sv_2mortal(newSViv(aiv)));
1297 else if (checksum > bits_in_uv)
1305 Copy(s, &auv, 1, UV);
1306 #if UVSIZE == INTSIZE
1307 DO_BO_UNPACK(auv, i);
1308 #elif UVSIZE == LONGSIZE
1309 DO_BO_UNPACK(auv, l);
1310 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1311 DO_BO_UNPACK(auv, 64);
1315 PUSHs(sv_2mortal(newSVuv(auv)));
1317 else if (checksum > bits_in_uv)
1323 case 'l' | TYPE_IS_SHRIEKING:
1324 #if LONGSIZE != SIZE32
1326 COPYNN(s, &along, sizeof(long));
1327 DO_BO_UNPACK(along, l);
1330 PUSHs(sv_2mortal(newSViv((IV)along)));
1332 else if (checksum > bits_in_uv)
1333 cdouble += (NV)along;
1344 DO_BO_UNPACK(ai32, 32);
1345 #if U32SIZE > SIZE32
1346 if (ai32 > 2147483647)
1351 PUSHs(sv_2mortal(newSViv((IV)ai32)));
1353 else if (checksum > bits_in_uv)
1354 cdouble += (NV)ai32;
1359 case 'L' | TYPE_IS_SHRIEKING:
1360 #if LONGSIZE != SIZE32
1362 COPYNN(s, &aulong, sizeof(unsigned long));
1363 DO_BO_UNPACK(aulong, l);
1364 s += sizeof(unsigned long);
1366 PUSHs(sv_2mortal(newSVuv((UV)aulong)));
1368 else if (checksum > bits_in_uv)
1369 cdouble += (NV)aulong;
1382 DO_BO_UNPACK(au32, 32);
1385 if (datumtype == 'N')
1386 au32 = PerlSock_ntohl(au32);
1389 if (datumtype == 'V')
1393 PUSHs(sv_2mortal(newSVuv((UV)au32)));
1395 else if (checksum > bits_in_uv)
1396 cdouble += (NV)au32;
1401 case 'V' | TYPE_IS_SHRIEKING:
1402 case 'N' | TYPE_IS_SHRIEKING:
1407 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1408 ai32 = (I32)PerlSock_ntohl((U32)ai32);
1411 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1412 ai32 = (I32)vtohl((U32)ai32);
1415 PUSHs(sv_2mortal(newSViv((IV)ai32)));
1417 else if (checksum > bits_in_uv)
1418 cdouble += (NV)ai32;
1425 if (sizeof(char*) > strend - s)
1428 Copy(s, &aptr, 1, char*);
1429 DO_BO_UNPACK_P(aptr);
1432 /* newSVpv generates undef if aptr is NULL */
1433 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1441 while ((len > 0) && (s < strend)) {
1442 auv = (auv << 7) | (*s & 0x7f);
1443 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1444 if ((U8)(*s++) < 0x80) {
1446 PUSHs(sv_2mortal(newSVuv(auv)));
1450 else if (++bytes >= sizeof(UV)) { /* promote to string */
1454 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1455 while (s < strend) {
1456 sv = mul128(sv, (U8)(*s & 0x7f));
1457 if (!(*s++ & 0x80)) {
1466 PUSHs(sv_2mortal(sv));
1471 if ((s >= strend) && bytes)
1472 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1476 if (symptr->howlen == e_star)
1477 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1479 if (sizeof(char*) > strend - s)
1482 Copy(s, &aptr, 1, char*);
1483 DO_BO_UNPACK_P(aptr);
1486 /* newSVpvn generates undef if aptr is NULL */
1487 PUSHs(sv_2mortal(newSVpvn(aptr, len)));
1492 assert (s + sizeof(Quad_t) <= strend);
1493 Copy(s, &aquad, 1, Quad_t);
1494 DO_BO_UNPACK(aquad, 64);
1495 s += sizeof(Quad_t);
1497 PUSHs(sv_2mortal((aquad >= IV_MIN && aquad <= IV_MAX) ?
1498 newSViv((IV)aquad) : newSVnv((NV)aquad)));
1500 else if (checksum > bits_in_uv)
1501 cdouble += (NV)aquad;
1508 assert (s + sizeof(Uquad_t) <= strend);
1509 Copy(s, &auquad, 1, Uquad_t);
1510 DO_BO_UNPACK(auquad, 64);
1511 s += sizeof(Uquad_t);
1513 PUSHs(sv_2mortal((auquad <= UV_MAX) ?
1514 newSVuv((UV)auquad) : newSVnv((NV)auquad)));
1516 else if (checksum > bits_in_uv)
1517 cdouble += (NV)auquad;
1523 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1526 Copy(s, &afloat, 1, float);
1527 DO_BO_UNPACK_N(afloat, float);
1530 PUSHs(sv_2mortal(newSVnv((NV)afloat)));
1539 Copy(s, &adouble, 1, double);
1540 DO_BO_UNPACK_N(adouble, double);
1541 s += sizeof(double);
1543 PUSHs(sv_2mortal(newSVnv((NV)adouble)));
1552 Copy(s, &anv, 1, NV);
1553 DO_BO_UNPACK_N(anv, NV);
1556 PUSHs(sv_2mortal(newSVnv(anv)));
1563 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1566 Copy(s, &aldouble, 1, long double);
1567 DO_BO_UNPACK_N(aldouble, long double);
1568 s += LONG_DOUBLESIZE;
1570 PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
1572 else {cdouble += aldouble;
1579 * Initialise the decode mapping. By using a table driven
1580 * algorithm, the code will be character-set independent
1581 * (and just as fast as doing character arithmetic)
1583 if (PL_uudmap['M'] == 0) {
1586 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1587 PL_uudmap[(U8)PL_uuemap[i]] = i;
1589 * Because ' ' and '`' map to the same value,
1590 * we need to decode them both the same.
1595 along = (strend - s) * 3 / 4;
1596 sv = NEWSV(42, along);
1599 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1604 len = PL_uudmap[*(U8*)s++] & 077;
1606 if (s < strend && ISUUCHAR(*s))
1607 a = PL_uudmap[*(U8*)s++] & 077;
1610 if (s < strend && ISUUCHAR(*s))
1611 b = PL_uudmap[*(U8*)s++] & 077;
1614 if (s < strend && ISUUCHAR(*s))
1615 c = PL_uudmap[*(U8*)s++] & 077;
1618 if (s < strend && ISUUCHAR(*s))
1619 d = PL_uudmap[*(U8*)s++] & 077;
1622 hunk[0] = (char)((a << 2) | (b >> 4));
1623 hunk[1] = (char)((b << 4) | (c >> 2));
1624 hunk[2] = (char)((c << 6) | d);
1625 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1630 else /* possible checksum byte */
1631 if (s + 1 < strend && s[1] == '\n')
1634 XPUSHs(sv_2mortal(sv));
1639 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1640 (checksum > bits_in_uv &&
1641 strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1644 adouble = (NV) (1 << (checksum & 15));
1645 while (checksum >= 16) {
1649 while (cdouble < 0.0)
1651 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1652 sv = newSVnv(cdouble);
1655 if (checksum < bits_in_uv) {
1656 UV mask = ((UV)1 << checksum) - 1;
1661 XPUSHs(sv_2mortal(sv));
1665 if (symptr->flags & FLAG_SLASH){
1666 if (SP - PL_stack_base - start_sp_offset <= 0)
1667 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1668 if( next_symbol(symptr) ){
1669 if( symptr->howlen == e_number )
1670 Perl_croak(aTHX_ "Count after length/code in unpack" );
1672 /* ...end of char buffer then no decent length available */
1673 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1675 /* take top of stack (hope it's numeric) */
1678 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1681 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1683 datumtype = symptr->code;
1691 return SP - PL_stack_base - start_sp_offset;
1698 I32 gimme = GIMME_V;
1701 register char *pat = SvPV(left, llen);
1702 #ifdef PACKED_IS_OCTETS
1703 /* Packed side is assumed to be octets - so force downgrade if it
1704 has been UTF-8 encoded by accident
1706 register char *s = SvPVbyte(right, rlen);
1708 register char *s = SvPV(right, rlen);
1710 char *strend = s + rlen;
1711 register char *patend = pat + llen;
1715 cnt = unpackstring(pat, patend, s, strend,
1716 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1717 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1720 if ( !cnt && gimme == G_SCALAR )
1721 PUSHs(&PL_sv_undef);
1726 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1730 *hunk = PL_uuemap[len];
1731 sv_catpvn(sv, hunk, 1);
1734 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1735 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1736 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1737 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1738 sv_catpvn(sv, hunk, 4);
1743 char r = (len > 1 ? s[1] : '\0');
1744 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1745 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1746 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1747 hunk[3] = PL_uuemap[0];
1748 sv_catpvn(sv, hunk, 4);
1750 sv_catpvn(sv, "\n", 1);
1754 S_is_an_int(pTHX_ char *s, STRLEN l)
1757 SV *result = newSVpvn(s, l);
1758 char *result_c = SvPV(result, n_a); /* convenience */
1759 char *out = result_c;
1769 SvREFCNT_dec(result);
1792 SvREFCNT_dec(result);
1798 SvCUR_set(result, out - result_c);
1802 /* pnum must be '\0' terminated */
1804 S_div128(pTHX_ SV *pnum, bool *done)
1807 char *s = SvPV(pnum, len);
1816 i = m * 10 + (*t - '0');
1818 r = (i >> 7); /* r < 10 */
1825 SvCUR_set(pnum, (STRLEN) (t - s));
1832 =for apidoc pack_cat
1834 The engine implementing pack() Perl function. Note: parameters next_in_list and
1835 flags are not used. This call should not be used; use packlist instead.
1841 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1843 tempsym_t sym = { 0 };
1845 sym.patend = patend;
1846 sym.flags = FLAG_PACK;
1848 (void)pack_rec( cat, &sym, beglist, endlist );
1853 =for apidoc packlist
1855 The engine implementing pack() Perl function.
1861 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1863 tempsym_t sym = { 0 };
1865 sym.patend = patend;
1866 sym.flags = FLAG_PACK;
1868 (void)pack_rec( cat, &sym, beglist, endlist );
1874 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1878 register I32 len = 0;
1881 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1882 static char *space10 = " ";
1885 /* These must not be in registers: */
1895 #if SHORTSIZE != SIZE16
1897 unsigned short aushort;
1901 #if LONGSIZE != SIZE32
1903 unsigned long aulong;
1908 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1909 long double aldouble;
1915 int strrelbeg = SvCUR(cat);
1916 tempsym_t lookahead;
1918 items = endlist - beglist;
1919 found = next_symbol( symptr );
1921 #ifndef PACKED_IS_OCTETS
1922 if (symptr->level == 0 && found && symptr->code == 'U' ){
1928 SV *lengthcode = Nullsv;
1929 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1931 I32 datumtype = symptr->code;
1934 switch( howlen = symptr->howlen ){
1937 len = symptr->length;
1940 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
1944 /* Look ahead for next symbol. Do we have code/code? */
1945 lookahead = *symptr;
1946 found = next_symbol(&lookahead);
1947 if ( symptr->flags & FLAG_SLASH ) {
1949 if ( 0 == strchr( "aAZ", lookahead.code ) ||
1950 e_star != lookahead.howlen )
1951 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
1952 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1953 ? *beglist : &PL_sv_no)
1954 + (lookahead.code == 'Z' ? 1 : 0)));
1956 Perl_croak(aTHX_ "Code missing after '/' in pack");
1960 switch(TYPE_NO_ENDIANNESS(datumtype)) {
1962 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
1964 Perl_croak(aTHX_ "'%%' may not be used in pack");
1966 len += strrelbeg - SvCUR(cat);
1975 tempsym_t savsym = *symptr;
1976 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
1977 symptr->flags |= group_modifiers;
1978 symptr->patend = savsym.grpend;
1981 symptr->patptr = savsym.grpbeg;
1982 beglist = pack_rec(cat, symptr, beglist, endlist );
1983 if (savsym.howlen == e_star && beglist == endlist)
1984 break; /* No way to continue */
1986 symptr->flags &= ~group_modifiers;
1987 lookahead.flags = symptr->flags;
1991 case 'X' | TYPE_IS_SHRIEKING:
1992 if (!len) /* Avoid division by 0 */
1994 len = (SvCUR(cat)) % len;
1998 if ((I32)SvCUR(cat) < len)
1999 Perl_croak(aTHX_ "'X' outside of string in pack");
2003 case 'x' | TYPE_IS_SHRIEKING:
2004 if (!len) /* Avoid division by 0 */
2006 aint = (SvCUR(cat)) % len;
2007 if (aint) /* Other portable ways? */
2016 sv_catpvn(cat, null10, 10);
2019 sv_catpvn(cat, null10, len);
2025 aptr = SvPV(fromstr, fromlen);
2026 if (howlen == e_star) {
2028 if (datumtype == 'Z')
2031 if ((I32)fromlen >= len) {
2032 sv_catpvn(cat, aptr, len);
2033 if (datumtype == 'Z')
2034 *(SvEND(cat)-1) = '\0';
2037 sv_catpvn(cat, aptr, fromlen);
2039 if (datumtype == 'A') {
2041 sv_catpvn(cat, space10, 10);
2044 sv_catpvn(cat, space10, len);
2048 sv_catpvn(cat, null10, 10);
2051 sv_catpvn(cat, null10, len);
2063 str = SvPV(fromstr, fromlen);
2064 if (howlen == e_star)
2067 SvCUR(cat) += (len+7)/8;
2068 SvGROW(cat, SvCUR(cat) + 1);
2069 aptr = SvPVX(cat) + aint;
2070 if (len > (I32)fromlen)
2074 if (datumtype == 'B') {
2075 for (len = 0; len++ < aint;) {
2076 items |= *str++ & 1;
2080 *aptr++ = items & 0xff;
2086 for (len = 0; len++ < aint;) {
2092 *aptr++ = items & 0xff;
2098 if (datumtype == 'B')
2099 items <<= 7 - (aint & 7);
2101 items >>= 7 - (aint & 7);
2102 *aptr++ = items & 0xff;
2104 str = SvPVX(cat) + SvCUR(cat);
2119 str = SvPV(fromstr, fromlen);
2120 if (howlen == e_star)
2123 SvCUR(cat) += (len+1)/2;
2124 SvGROW(cat, SvCUR(cat) + 1);
2125 aptr = SvPVX(cat) + aint;
2126 if (len > (I32)fromlen)
2130 if (datumtype == 'H') {
2131 for (len = 0; len++ < aint;) {
2133 items |= ((*str++ & 15) + 9) & 15;
2135 items |= *str++ & 15;
2139 *aptr++ = items & 0xff;
2145 for (len = 0; len++ < aint;) {
2147 items |= (((*str++ & 15) + 9) & 15) << 4;
2149 items |= (*str++ & 15) << 4;
2153 *aptr++ = items & 0xff;
2159 *aptr++ = items & 0xff;
2160 str = SvPVX(cat) + SvCUR(cat);
2171 switch (TYPE_NO_MODIFIERS(datumtype)) {
2173 aint = SvIV(fromstr);
2174 if ((aint < 0 || aint > 255) &&
2176 Perl_warner(aTHX_ packWARN(WARN_PACK),
2177 "Character in 'C' format wrapped in pack");
2179 sv_catpvn(cat, &achar, sizeof(char));
2182 aint = SvIV(fromstr);
2183 if ((aint < -128 || aint > 127) &&
2185 Perl_warner(aTHX_ packWARN(WARN_PACK),
2186 "Character in 'c' format wrapped in pack" );
2188 sv_catpvn(cat, &achar, sizeof(char));
2196 auint = UNI_TO_NATIVE(SvUV(fromstr));
2197 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2199 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2202 0 : UNICODE_ALLOW_ANY)
2207 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2212 /* VOS does not automatically map a floating-point overflow
2213 during conversion from double to float into infinity, so we
2214 do it by hand. This code should either be generalized for
2215 any OS that needs it, or removed if and when VOS implements
2216 posix-976 (suggestion to support mapping to infinity).
2217 Paul.Green@stratus.com 02-04-02. */
2218 if (SvNV(fromstr) > FLT_MAX)
2219 afloat = _float_constants[0]; /* single prec. inf. */
2220 else if (SvNV(fromstr) < -FLT_MAX)
2221 afloat = _float_constants[0]; /* single prec. inf. */
2222 else afloat = (float)SvNV(fromstr);
2224 # if defined(VMS) && !defined(__IEEE_FP)
2225 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2226 * on Alpha; fake it if we don't have them.
2228 if (SvNV(fromstr) > FLT_MAX)
2230 else if (SvNV(fromstr) < -FLT_MAX)
2232 else afloat = (float)SvNV(fromstr);
2234 afloat = (float)SvNV(fromstr);
2237 DO_BO_PACK_N(afloat, float);
2238 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2245 /* VOS does not automatically map a floating-point overflow
2246 during conversion from long double to double into infinity,
2247 so we do it by hand. This code should either be generalized
2248 for any OS that needs it, or removed if and when VOS
2249 implements posix-976 (suggestion to support mapping to
2250 infinity). Paul.Green@stratus.com 02-04-02. */
2251 if (SvNV(fromstr) > DBL_MAX)
2252 adouble = _double_constants[0]; /* double prec. inf. */
2253 else if (SvNV(fromstr) < -DBL_MAX)
2254 adouble = _double_constants[0]; /* double prec. inf. */
2255 else adouble = (double)SvNV(fromstr);
2257 # if defined(VMS) && !defined(__IEEE_FP)
2258 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2259 * on Alpha; fake it if we don't have them.
2261 if (SvNV(fromstr) > DBL_MAX)
2263 else if (SvNV(fromstr) < -DBL_MAX)
2265 else adouble = (double)SvNV(fromstr);
2267 adouble = (double)SvNV(fromstr);
2270 DO_BO_PACK_N(adouble, double);
2271 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2275 Zero(&anv, 1, NV); /* can be long double with unused bits */
2278 anv = SvNV(fromstr);
2279 DO_BO_PACK_N(anv, NV);
2280 sv_catpvn(cat, (char *)&anv, NVSIZE);
2283 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2285 /* long doubles can have unused bits, which may be nonzero */
2286 Zero(&aldouble, 1, long double);
2289 aldouble = (long double)SvNV(fromstr);
2290 DO_BO_PACK_N(aldouble, long double);
2291 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2295 case 'n' | TYPE_IS_SHRIEKING:
2299 ai16 = (I16)SvIV(fromstr);
2301 ai16 = PerlSock_htons(ai16);
2306 case 'v' | TYPE_IS_SHRIEKING:
2310 ai16 = (I16)SvIV(fromstr);
2317 case 'S' | TYPE_IS_SHRIEKING:
2318 #if SHORTSIZE != SIZE16
2322 aushort = SvUV(fromstr);
2323 DO_BO_PACK(aushort, s);
2324 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2335 au16 = (U16)SvUV(fromstr);
2336 DO_BO_PACK(au16, 16);
2342 case 's' | TYPE_IS_SHRIEKING:
2343 #if SHORTSIZE != SIZE16
2347 ashort = SvIV(fromstr);
2348 DO_BO_PACK(ashort, s);
2349 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2359 ai16 = (I16)SvIV(fromstr);
2360 DO_BO_PACK(ai16, 16);
2365 case 'I' | TYPE_IS_SHRIEKING:
2368 auint = SvUV(fromstr);
2369 DO_BO_PACK(auint, i);
2370 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2376 aiv = SvIV(fromstr);
2377 #if IVSIZE == INTSIZE
2379 #elif IVSIZE == LONGSIZE
2381 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2382 DO_BO_PACK(aiv, 64);
2384 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2390 auv = SvUV(fromstr);
2391 #if UVSIZE == INTSIZE
2393 #elif UVSIZE == LONGSIZE
2395 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2396 DO_BO_PACK(auv, 64);
2398 sv_catpvn(cat, (char*)&auv, UVSIZE);
2404 anv = SvNV(fromstr);
2407 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2409 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2410 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2411 any negative IVs will have already been got by the croak()
2412 above. IOK is untrue for fractions, so we test them
2413 against UV_MAX_P1. */
2414 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2416 char buf[(sizeof(UV)*8)/7+1];
2417 char *in = buf + sizeof(buf);
2418 UV auv = SvUV(fromstr);
2421 *--in = (char)((auv & 0x7f) | 0x80);
2424 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2425 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2427 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2428 char *from, *result, *in;
2433 /* Copy string and check for compliance */
2434 from = SvPV(fromstr, len);
2435 if ((norm = is_an_int(from, len)) == NULL)
2436 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2438 New('w', result, len, char);
2442 *--in = div128(norm, &done) | 0x80;
2443 result[len - 1] &= 0x7F; /* clear continue bit */
2444 sv_catpvn(cat, in, (result + len) - in);
2446 SvREFCNT_dec(norm); /* free norm */
2448 else if (SvNOKp(fromstr)) {
2449 /* 10**NV_MAX_10_EXP is the largest power of 10
2450 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2451 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2452 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2453 And with that many bytes only Inf can overflow.
2454 Some C compilers are strict about integral constant
2455 expressions so we conservatively divide by a slightly
2456 smaller integer instead of multiplying by the exact
2457 floating-point value.
2459 #ifdef NV_MAX_10_EXP
2460 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2461 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2463 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2464 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2466 char *in = buf + sizeof(buf);
2468 anv = Perl_floor(anv);
2470 NV next = Perl_floor(anv / 128);
2471 if (in <= buf) /* this cannot happen ;-) */
2472 Perl_croak(aTHX_ "Cannot compress integer in pack");
2473 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2476 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2477 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2480 char *from, *result, *in;
2485 /* Copy string and check for compliance */
2486 from = SvPV(fromstr, len);
2487 if ((norm = is_an_int(from, len)) == NULL)
2488 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2490 New('w', result, len, char);
2494 *--in = div128(norm, &done) | 0x80;
2495 result[len - 1] &= 0x7F; /* clear continue bit */
2496 sv_catpvn(cat, in, (result + len) - in);
2498 SvREFCNT_dec(norm); /* free norm */
2503 case 'i' | TYPE_IS_SHRIEKING:
2506 aint = SvIV(fromstr);
2507 DO_BO_PACK(aint, i);
2508 sv_catpvn(cat, (char*)&aint, sizeof(int));
2511 case 'N' | TYPE_IS_SHRIEKING:
2515 au32 = SvUV(fromstr);
2517 au32 = PerlSock_htonl(au32);
2522 case 'V' | TYPE_IS_SHRIEKING:
2526 au32 = SvUV(fromstr);
2533 case 'L' | TYPE_IS_SHRIEKING:
2534 #if LONGSIZE != SIZE32
2538 aulong = SvUV(fromstr);
2539 DO_BO_PACK(aulong, l);
2540 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2551 au32 = SvUV(fromstr);
2552 DO_BO_PACK(au32, 32);
2557 case 'l' | TYPE_IS_SHRIEKING:
2558 #if LONGSIZE != SIZE32
2562 along = SvIV(fromstr);
2563 DO_BO_PACK(along, l);
2564 sv_catpvn(cat, (char *)&along, sizeof(long));
2574 ai32 = SvIV(fromstr);
2575 DO_BO_PACK(ai32, 32);
2583 auquad = (Uquad_t)SvUV(fromstr);
2584 DO_BO_PACK(auquad, 64);
2585 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2591 aquad = (Quad_t)SvIV(fromstr);
2592 DO_BO_PACK(aquad, 64);
2593 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2598 len = 1; /* assume SV is correct length */
2603 if (fromstr == &PL_sv_undef)
2607 /* XXX better yet, could spirit away the string to
2608 * a safe spot and hang on to it until the result
2609 * of pack() (and all copies of the result) are
2612 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2613 || (SvPADTMP(fromstr)
2614 && !SvREADONLY(fromstr))))
2616 Perl_warner(aTHX_ packWARN(WARN_PACK),
2617 "Attempt to pack pointer to temporary value");
2619 if (SvPOK(fromstr) || SvNIOK(fromstr))
2620 aptr = SvPV(fromstr,n_a);
2622 aptr = SvPV_force(fromstr,n_a);
2625 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2630 aptr = SvPV(fromstr, fromlen);
2631 SvGROW(cat, fromlen * 4 / 3);
2636 while (fromlen > 0) {
2639 if ((I32)fromlen > len)
2643 doencodes(cat, aptr, todo);
2649 *symptr = lookahead;
2658 dSP; dMARK; dORIGMARK; dTARGET;
2659 register SV *cat = TARG;
2661 register char *pat = SvPVx(*++MARK, fromlen);
2662 register char *patend = pat + fromlen;
2665 sv_setpvn(cat, "", 0);
2667 packlist(cat, pat, patend, MARK, SP + 1);
2677 * c-indentation-style: bsd
2679 * indent-tabs-mode: t
2682 * vim: shiftwidth=4: