3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * He still hopefully carried some of his gear in his pack: a small tinder-box,
13 * two small shallow pans, the smaller fitting into the larger; inside them a
14 * wooden spoon, a short two-pronged fork and some skewers were stowed; and
15 * hidden at the bottom of the pack in a flat wooden box a dwindling treasure,
19 /* This file contains pp ("push/pop") functions that
20 * execute the opcodes that make up a perl program. A typical pp function
21 * expects to find its arguments on the stack, and usually pushes its
22 * results onto the stack, hence the 'pp' terminology. Each OP structure
23 * contains a pointer to the relevant pp_foo() function.
25 * This particular file just contains pp_pack() and pp_unpack(). See the
26 * other pp*.c files for the rest of the pp_ functions.
31 #define PERL_IN_PP_PACK_C
35 #define PERL_PACK_CAN_BYTEORDER
36 #define PERL_PACK_CAN_SHRIEKSIGN
40 * Offset for integer pack/unpack.
42 * On architectures where I16 and I32 aren't really 16 and 32 bits,
43 * which for now are all Crays, pack and unpack have to play games.
47 * These values are required for portability of pack() output.
48 * If they're not right on your machine, then pack() and unpack()
49 * wouldn't work right anyway; you'll need to apply the Cray hack.
50 * (I'd like to check them with #if, but you can't use sizeof() in
51 * the preprocessor.) --???
54 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
55 defines are now in config.h. --Andy Dougherty April 1998
60 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
63 #if U16SIZE > SIZE16 || U32SIZE > SIZE32
64 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
65 # define OFF16(p) (char*)(p)
66 # define OFF32(p) (char*)(p)
68 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
69 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
70 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
72 }}}} bad cray byte order
75 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
76 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
77 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
78 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
79 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
81 # define COPY16(s,p) Copy(s, p, SIZE16, char)
82 # define COPY32(s,p) Copy(s, p, SIZE32, char)
83 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
84 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
85 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
88 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
89 #define MAX_SUB_TEMPLATE_LEVEL 100
91 /* flags (note that type modifiers can also be used as flags!) */
92 #define FLAG_UNPACK_ONLY_ONE 0x10
93 #define FLAG_UNPACK_DO_UTF8 0x08
94 #define FLAG_SLASH 0x04
95 #define FLAG_COMMA 0x02
96 #define FLAG_PACK 0x01
99 S_mul128(pTHX_ SV *sv, U8 m)
102 char *s = SvPV(sv, len);
106 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
107 SV *tmpNew = newSVpvn("0000000000", 10);
109 sv_catsv(tmpNew, sv);
110 SvREFCNT_dec(sv); /* free old sv */
115 while (!*t) /* trailing '\0'? */
118 i = ((*t - '0') << 7) + m;
119 *(t--) = '0' + (char)(i % 10);
125 /* Explosives and implosives. */
127 #if 'I' == 73 && 'J' == 74
128 /* On an ASCII/ISO kind of system */
129 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
132 Some other sort of character set - use memchr() so we don't match
135 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
139 #define TYPE_IS_SHRIEKING 0x100
140 #define TYPE_IS_BIG_ENDIAN 0x200
141 #define TYPE_IS_LITTLE_ENDIAN 0x400
142 #define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
143 #define TYPE_MODIFIERS(t) ((t) & ~0xFF)
144 #define TYPE_NO_MODIFIERS(t) ((t) & 0xFF)
146 #ifdef PERL_PACK_CAN_SHRIEKSIGN
147 #define SHRIEKING_ALLOWED_TYPES "sSiIlLxXnNvV"
149 #define SHRIEKING_ALLOWED_TYPES "sSiIlLxX"
152 #ifndef PERL_PACK_CAN_BYTEORDER
153 /* Put "can't" first because it is shorter */
154 # define TYPE_ENDIANNESS(t) 0
155 # define TYPE_NO_ENDIANNESS(t) (t)
157 # define ENDIANNESS_ALLOWED_TYPES ""
159 # define DO_BO_UNPACK(var, type)
160 # define DO_BO_PACK(var, type)
161 # define DO_BO_UNPACK_PTR(var, type, pre_cast)
162 # define DO_BO_PACK_PTR(var, type, pre_cast)
163 # define DO_BO_UNPACK_N(var, type)
164 # define DO_BO_PACK_N(var, type)
165 # define DO_BO_UNPACK_P(var)
166 # define DO_BO_PACK_P(var)
170 # define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK)
171 # define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK)
173 # define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP("
175 # define DO_BO_UNPACK(var, type) \
177 switch (TYPE_ENDIANNESS(datumtype)) { \
178 case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \
179 case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \
184 # define DO_BO_PACK(var, type) \
186 switch (TYPE_ENDIANNESS(datumtype)) { \
187 case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \
188 case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \
193 # define DO_BO_UNPACK_PTR(var, type, pre_cast) \
195 switch (TYPE_ENDIANNESS(datumtype)) { \
196 case TYPE_IS_BIG_ENDIAN: \
197 var = (void *) my_betoh ## type ((pre_cast) var); \
199 case TYPE_IS_LITTLE_ENDIAN: \
200 var = (void *) my_letoh ## type ((pre_cast) var); \
207 # define DO_BO_PACK_PTR(var, type, pre_cast) \
209 switch (TYPE_ENDIANNESS(datumtype)) { \
210 case TYPE_IS_BIG_ENDIAN: \
211 var = (void *) my_htobe ## type ((pre_cast) var); \
213 case TYPE_IS_LITTLE_ENDIAN: \
214 var = (void *) my_htole ## type ((pre_cast) var); \
221 # define BO_CANT_DOIT(action, type) \
223 switch (TYPE_ENDIANNESS(datumtype)) { \
224 case TYPE_IS_BIG_ENDIAN: \
225 Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \
226 "platform", #action, #type); \
228 case TYPE_IS_LITTLE_ENDIAN: \
229 Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \
230 "platform", #action, #type); \
237 # if PTRSIZE == INTSIZE
238 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, i, int)
239 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, i, int)
240 # elif PTRSIZE == LONGSIZE
241 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long)
242 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long)
244 # define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer)
245 # define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer)
248 # if defined(my_htolen) && defined(my_letohn) && \
249 defined(my_htoben) && defined(my_betohn)
250 # define DO_BO_UNPACK_N(var, type) \
252 switch (TYPE_ENDIANNESS(datumtype)) { \
253 case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\
254 case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
259 # define DO_BO_PACK_N(var, type) \
261 switch (TYPE_ENDIANNESS(datumtype)) { \
262 case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\
263 case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
268 # define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type)
269 # define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type)
274 #define PACK_SIZE_CANNOT_CSUM 0x80
275 #define PACK_SIZE_SPARE 0x40
276 #define PACK_SIZE_MASK 0x3F
280 const unsigned char *array;
285 #define PACK_SIZE_NORMAL 0
286 #define PACK_SIZE_SHRIEKING 1
288 /* These tables are regenerated by genpacksizetables.pl (and then hand pasted
289 in). You're unlikely ever to need to regenerate them. */
292 unsigned char size_normal[53] = {
293 /* C */ sizeof(unsigned char),
294 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
295 /* D */ LONG_DOUBLESIZE,
302 /* I */ sizeof(unsigned int),
309 #if defined(HAS_QUAD)
310 /* Q */ sizeof(Uquad_t),
317 /* U */ sizeof(char),
319 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
320 /* c */ sizeof(char),
321 /* d */ sizeof(double),
323 /* f */ sizeof(float),
332 /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM,
333 #if defined(HAS_QUAD)
334 /* q */ sizeof(Quad_t),
342 /* w */ sizeof(char) | PACK_SIZE_CANNOT_CSUM,
344 unsigned char size_shrieking[46] = {
345 /* I */ sizeof(unsigned int),
347 /* L */ sizeof(unsigned long),
349 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
355 /* S */ sizeof(unsigned short),
357 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
362 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
365 /* l */ sizeof(long),
367 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
373 /* s */ sizeof(short),
375 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
381 struct packsize_t packsize[2] = {
382 {size_normal, 67, 53},
383 {size_shrieking, 73, 46}
386 /* EBCDIC (or bust) */
387 unsigned char size_normal[99] = {
388 /* c */ sizeof(char),
389 /* d */ sizeof(double),
391 /* f */ sizeof(float),
401 /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM,
402 #if defined(HAS_QUAD)
403 /* q */ sizeof(Quad_t),
407 0, 0, 0, 0, 0, 0, 0, 0, 0,
411 /* w */ sizeof(char) | PACK_SIZE_CANNOT_CSUM,
412 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,
414 /* C */ sizeof(unsigned char),
415 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
416 /* D */ LONG_DOUBLESIZE,
423 /* I */ sizeof(unsigned int),
431 #if defined(HAS_QUAD)
432 /* Q */ sizeof(Uquad_t),
436 0, 0, 0, 0, 0, 0, 0, 0, 0,
439 /* U */ sizeof(char),
442 unsigned char size_shrieking[93] = {
444 0, 0, 0, 0, 0, 0, 0, 0, 0,
445 /* l */ sizeof(long),
447 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
452 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
453 /* s */ sizeof(short),
455 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
460 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,
461 0, 0, 0, 0, 0, 0, 0, 0, 0,
462 /* I */ sizeof(unsigned int),
463 0, 0, 0, 0, 0, 0, 0, 0, 0,
464 /* L */ sizeof(unsigned long),
466 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
471 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
472 /* S */ sizeof(unsigned short),
474 #if defined(PERL_PACK_CAN_SHRIEKSIGN)
480 struct packsize_t packsize[2] = {
481 {size_normal, 131, 99},
482 {size_shrieking, 137, 93}
487 /* Returns the sizeof() struct described by pat */
489 S_measure_struct(pTHX_ register tempsym_t* symptr)
491 register I32 len = 0;
492 register I32 total = 0;
497 while (next_symbol(symptr)) {
498 int which = (symptr->code & TYPE_IS_SHRIEKING)
499 ? PACK_SIZE_SHRIEKING : PACK_SIZE_NORMAL;
501 = TYPE_NO_MODIFIERS(symptr->code) - packsize[which].first;
503 switch( symptr->howlen ){
506 len = symptr->length;
509 Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
510 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
514 if ((offset >= 0) && (offset < packsize[which].size))
515 size = packsize[which].array[offset] & PACK_SIZE_MASK;
520 /* endianness doesn't influence the size of a type */
521 switch(TYPE_NO_ENDIANNESS(symptr->code)) {
523 Perl_croak(aTHX_ "Invalid type '%c' in %s",
524 (int)TYPE_NO_MODIFIERS(symptr->code),
525 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
528 case 'U': /* XXXX Is it correct? */
531 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
533 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
539 tempsym_t savsym = *symptr;
540 symptr->patptr = savsym.grpbeg;
541 symptr->patend = savsym.grpend;
542 /* XXXX Theoretically, we need to measure many times at
543 different positions, since the subexpression may contain
544 alignment commands, but be not of aligned length.
545 Need to detect this and croak(). */
546 size = measure_struct(symptr);
550 case 'X' | TYPE_IS_SHRIEKING:
551 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS.
553 if (!len) /* Avoid division by 0 */
555 len = total % len; /* Assumed: the start is aligned. */
560 Perl_croak(aTHX_ "'X' outside of string in %s",
561 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
563 case 'x' | TYPE_IS_SHRIEKING:
564 if (!len) /* Avoid division by 0 */
566 star = total % len; /* Assumed: the start is aligned. */
567 if (star) /* Other portable ways? */
593 size = sizeof(char*);
603 /* locate matching closing parenthesis or bracket
604 * returns char pointer to char after match, or NULL
607 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
609 while (patptr < patend) {
617 while (patptr < patend && *patptr != '\n')
621 patptr = group_end(patptr, patend, ')') + 1;
623 patptr = group_end(patptr, patend, ']') + 1;
625 Perl_croak(aTHX_ "No group ending character '%c' found in template",
631 /* Convert unsigned decimal number to binary.
632 * Expects a pointer to the first digit and address of length variable
633 * Advances char pointer to 1st non-digit char and returns number
636 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
638 I32 len = *patptr++ - '0';
639 while (isDIGIT(*patptr)) {
640 if (len >= 0x7FFFFFFF/10)
641 Perl_croak(aTHX_ "pack/unpack repeat count overflow");
642 len = (len * 10) + (*patptr++ - '0');
648 /* The marvellous template parsing routine: Using state stored in *symptr,
649 * locates next template code and count
652 S_next_symbol(pTHX_ register tempsym_t* symptr )
654 register char* patptr = symptr->patptr;
655 register char* patend = symptr->patend;
657 symptr->flags &= ~FLAG_SLASH;
659 while (patptr < patend) {
660 if (isSPACE(*patptr))
662 else if (*patptr == '#') {
664 while (patptr < patend && *patptr != '\n')
669 /* We should have found a template code */
670 I32 code = *patptr++ & 0xFF;
671 U32 inherited_modifiers = 0;
673 if (code == ','){ /* grandfather in commas but with a warning */
674 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
675 symptr->flags |= FLAG_COMMA;
676 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
677 "Invalid type ',' in %s",
678 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
683 /* for '(', skip to ')' */
685 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
686 Perl_croak(aTHX_ "()-group starts with a count in %s",
687 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
688 symptr->grpbeg = patptr;
689 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
690 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
691 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
692 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
695 /* look for group modifiers to inherit */
696 if (TYPE_ENDIANNESS(symptr->flags)) {
697 if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
698 inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
701 /* look for modifiers */
702 while (patptr < patend) {
707 modifier = TYPE_IS_SHRIEKING;
708 allowed = SHRIEKING_ALLOWED_TYPES;
710 #ifdef PERL_PACK_CAN_BYTEORDER
712 modifier = TYPE_IS_BIG_ENDIAN;
713 allowed = ENDIANNESS_ALLOWED_TYPES;
716 modifier = TYPE_IS_LITTLE_ENDIAN;
717 allowed = ENDIANNESS_ALLOWED_TYPES;
727 if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
728 Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
729 allowed, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
731 if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
732 Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
733 (int) TYPE_NO_MODIFIERS(code),
734 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
735 else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
736 TYPE_ENDIANNESS_MASK)
737 Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
738 *patptr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
740 if (ckWARN(WARN_UNPACK)) {
742 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
743 "Duplicate modifier '%c' after '%c' in %s",
744 *patptr, (int) TYPE_NO_MODIFIERS(code),
745 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
752 /* inherit modifiers */
753 code |= inherited_modifiers;
755 /* look for count and/or / */
756 if (patptr < patend) {
757 if (isDIGIT(*patptr)) {
758 patptr = get_num( patptr, &symptr->length );
759 symptr->howlen = e_number;
761 } else if (*patptr == '*') {
763 symptr->howlen = e_star;
765 } else if (*patptr == '[') {
766 char* lenptr = ++patptr;
767 symptr->howlen = e_number;
768 patptr = group_end( patptr, patend, ']' ) + 1;
769 /* what kind of [] is it? */
770 if (isDIGIT(*lenptr)) {
771 lenptr = get_num( lenptr, &symptr->length );
773 Perl_croak(aTHX_ "Malformed integer in [] in %s",
774 symptr->flags & FLAG_PACK ? "pack" : "unpack");
776 tempsym_t savsym = *symptr;
777 symptr->patend = patptr-1;
778 symptr->patptr = lenptr;
779 savsym.length = measure_struct(symptr);
783 symptr->howlen = e_no_len;
788 while (patptr < patend) {
789 if (isSPACE(*patptr))
791 else if (*patptr == '#') {
793 while (patptr < patend && *patptr != '\n')
798 if (*patptr == '/') {
799 symptr->flags |= FLAG_SLASH;
801 if (patptr < patend &&
802 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
803 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
804 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
810 /* at end - no count, no / */
811 symptr->howlen = e_no_len;
816 symptr->patptr = patptr;
820 symptr->patptr = patptr;
825 =for apidoc unpack_str
827 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
828 and ocnt are not used. This call should not be used, use unpackstring instead.
833 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
835 tempsym_t sym = { 0 };
840 return unpack_rec(&sym, s, s, strend, NULL );
844 =for apidoc unpackstring
846 The engine implementing unpack() Perl function. C<unpackstring> puts the
847 extracted list items on the stack and returns the number of elements.
848 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
853 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
855 tempsym_t sym = { 0 };
860 return unpack_rec(&sym, s, s, strend, NULL );
865 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
869 register I32 len = 0;
870 register I32 bits = 0;
873 I32 start_sp_offset = SP - PL_stack_base;
876 /* These must not be in registers: */
885 #if SHORTSIZE != SIZE16
887 unsigned short aushort;
892 #if LONGSIZE != SIZE32
893 unsigned long aulong;
898 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
899 long double aldouble;
908 const int bits_in_uv = 8 * sizeof(cuv);
911 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
913 while (next_symbol(symptr)) {
914 datumtype = symptr->code;
915 /* do first one only unless in list context
916 / is implemented by unpacking the count, then poping it from the
917 stack, so must check that we're not in the middle of a / */
919 && (SP - PL_stack_base == start_sp_offset + 1)
920 && (datumtype != '/') ) /* XXX can this be omitted */
923 switch( howlen = symptr->howlen ){
926 len = symptr->length;
929 len = strend - strbeg; /* long enough */
934 beyond = s >= strend;
936 int which = (symptr->code & TYPE_IS_SHRIEKING)
937 ? PACK_SIZE_SHRIEKING : PACK_SIZE_NORMAL;
938 const int rawtype = TYPE_NO_MODIFIERS(datumtype);
939 int offset = rawtype - packsize[which].first;
941 if (offset >= 0 && offset < packsize[which].size) {
942 /* Data about this template letter */
943 unsigned char data = packsize[which].array[offset];
946 /* data nonzero means we can process this letter. */
947 long size = data & PACK_SIZE_MASK;
948 long howmany = (strend - s) / size;
952 /* In the old code, 'p' was the only type without shortcut
953 code to curtail unpacking to only one. As far as I can
954 see the only point of retaining this anomaly is to make
955 code such as $_ = unpack "p2", pack "pI", "Hi", 2
956 continue to segfault. ie, it probably should be
960 if (!checksum || (data & PACK_SIZE_CANNOT_CSUM)) {
961 if (len && unpack_only_one &&
970 switch(TYPE_NO_ENDIANNESS(datumtype)) {
972 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
975 if (howlen == e_no_len)
976 len = 16; /* len is not specified */
984 char *ss = s; /* Move from register */
985 tempsym_t savsym = *symptr;
986 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
987 symptr->flags |= group_modifiers;
988 symptr->patend = savsym.grpend;
992 symptr->patptr = savsym.grpbeg;
993 unpack_rec(symptr, ss, strbeg, strend, &ss );
994 if (ss == strend && savsym.howlen == e_star)
995 break; /* No way to continue */
999 symptr->flags &= ~group_modifiers;
1000 savsym.flags = symptr->flags;
1005 if (len > strend - strrelbeg)
1006 Perl_croak(aTHX_ "'@' outside of string in unpack");
1007 s = strrelbeg + len;
1009 case 'X' | TYPE_IS_SHRIEKING:
1010 if (!len) /* Avoid division by 0 */
1012 len = (s - strbeg) % len;
1015 if (len > s - strbeg)
1016 Perl_croak(aTHX_ "'X' outside of string in unpack" );
1019 case 'x' | TYPE_IS_SHRIEKING:
1020 if (!len) /* Avoid division by 0 */
1022 aint = (s - strbeg) % len;
1023 if (aint) /* Other portable ways? */
1029 if (len > strend - s)
1030 Perl_croak(aTHX_ "'x' outside of string in unpack");
1034 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1039 if (len > strend - s)
1042 goto uchar_checksum;
1043 sv = newSVpvn(s, len);
1044 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
1045 aptr = s; /* borrow register */
1046 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
1050 if (howlen == e_star) /* exact for 'Z*' */
1051 len = s - SvPVX(sv) + 1;
1053 else { /* 'A' strips both nulls and spaces */
1054 s = SvPVX(sv) + len - 1;
1055 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
1059 SvCUR_set(sv, s - SvPVX(sv));
1060 s = aptr; /* unborrow register */
1063 XPUSHs(sv_2mortal(sv));
1067 if (howlen == e_star || len > (strend - s) * 8)
1068 len = (strend - s) * 8;
1071 Newz(601, PL_bitcount, 256, char);
1072 for (bits = 1; bits < 256; bits++) {
1073 if (bits & 1) PL_bitcount[bits]++;
1074 if (bits & 2) PL_bitcount[bits]++;
1075 if (bits & 4) PL_bitcount[bits]++;
1076 if (bits & 8) PL_bitcount[bits]++;
1077 if (bits & 16) PL_bitcount[bits]++;
1078 if (bits & 32) PL_bitcount[bits]++;
1079 if (bits & 64) PL_bitcount[bits]++;
1080 if (bits & 128) PL_bitcount[bits]++;
1084 cuv += PL_bitcount[*(unsigned char*)s++];
1089 if (datumtype == 'b') {
1091 if (bits & 1) cuv++;
1097 if (bits & 128) cuv++;
1104 sv = NEWSV(35, len + 1);
1108 if (datumtype == 'b') {
1110 for (len = 0; len < aint; len++) {
1111 if (len & 7) /*SUPPRESS 595*/
1115 *str++ = '0' + (bits & 1);
1120 for (len = 0; len < aint; len++) {
1125 *str++ = '0' + ((bits & 128) != 0);
1129 XPUSHs(sv_2mortal(sv));
1133 if (howlen == e_star || len > (strend - s) * 2)
1134 len = (strend - s) * 2;
1135 sv = NEWSV(35, len + 1);
1139 if (datumtype == 'h') {
1141 for (len = 0; len < aint; len++) {
1146 *str++ = PL_hexdigit[bits & 15];
1151 for (len = 0; len < aint; len++) {
1156 *str++ = PL_hexdigit[(bits >> 4) & 15];
1160 XPUSHs(sv_2mortal(sv));
1165 if (aint >= 128) /* fake up signed chars */
1168 PUSHs(sv_2mortal(newSViv((IV)aint)));
1170 else if (checksum > bits_in_uv)
1171 cdouble += (NV)aint;
1177 unpack_C: /* unpack U will jump here if not UTF-8 */
1179 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
1192 PUSHs(sv_2mortal(newSViv((IV)auint)));
1198 symptr->flags |= FLAG_UNPACK_DO_UTF8;
1201 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
1203 while (len-- > 0 && s < strend) {
1205 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1209 PUSHs(sv_2mortal(newSVuv((UV)auint)));
1211 else if (checksum > bits_in_uv)
1212 cdouble += (NV)auint;
1217 case 's' | TYPE_IS_SHRIEKING:
1218 #if SHORTSIZE != SIZE16
1220 COPYNN(s, &ashort, sizeof(short));
1221 DO_BO_UNPACK(ashort, s);
1224 PUSHs(sv_2mortal(newSViv((IV)ashort)));
1226 else if (checksum > bits_in_uv)
1227 cdouble += (NV)ashort;
1238 DO_BO_UNPACK(ai16, 16);
1239 #if U16SIZE > SIZE16
1245 PUSHs(sv_2mortal(newSViv((IV)ai16)));
1247 else if (checksum > bits_in_uv)
1248 cdouble += (NV)ai16;
1253 case 'S' | TYPE_IS_SHRIEKING:
1254 #if SHORTSIZE != SIZE16
1256 COPYNN(s, &aushort, sizeof(unsigned short));
1257 DO_BO_UNPACK(aushort, s);
1258 s += sizeof(unsigned short);
1260 PUSHs(sv_2mortal(newSViv((UV)aushort)));
1262 else if (checksum > bits_in_uv)
1263 cdouble += (NV)aushort;
1276 DO_BO_UNPACK(au16, 16);
1279 if (datumtype == 'n')
1280 au16 = PerlSock_ntohs(au16);
1283 if (datumtype == 'v')
1287 PUSHs(sv_2mortal(newSViv((UV)au16)));
1289 else if (checksum > bits_in_uv)
1290 cdouble += (NV)au16;
1295 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1296 case 'v' | TYPE_IS_SHRIEKING:
1297 case 'n' | TYPE_IS_SHRIEKING:
1302 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1303 ai16 = (I16)PerlSock_ntohs((U16)ai16);
1306 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1307 ai16 = (I16)vtohs((U16)ai16);
1310 PUSHs(sv_2mortal(newSViv((IV)ai16)));
1312 else if (checksum > bits_in_uv)
1313 cdouble += (NV)ai16;
1320 case 'i' | TYPE_IS_SHRIEKING:
1322 Copy(s, &aint, 1, int);
1323 DO_BO_UNPACK(aint, i);
1326 PUSHs(sv_2mortal(newSViv((IV)aint)));
1328 else if (checksum > bits_in_uv)
1329 cdouble += (NV)aint;
1335 case 'I' | TYPE_IS_SHRIEKING:
1337 Copy(s, &auint, 1, unsigned int);
1338 DO_BO_UNPACK(auint, i);
1339 s += sizeof(unsigned int);
1341 PUSHs(sv_2mortal(newSVuv((UV)auint)));
1343 else if (checksum > bits_in_uv)
1344 cdouble += (NV)auint;
1351 Copy(s, &aiv, 1, IV);
1352 #if IVSIZE == INTSIZE
1353 DO_BO_UNPACK(aiv, i);
1354 #elif IVSIZE == LONGSIZE
1355 DO_BO_UNPACK(aiv, l);
1356 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1357 DO_BO_UNPACK(aiv, 64);
1361 PUSHs(sv_2mortal(newSViv(aiv)));
1363 else if (checksum > bits_in_uv)
1371 Copy(s, &auv, 1, UV);
1372 #if UVSIZE == INTSIZE
1373 DO_BO_UNPACK(auv, i);
1374 #elif UVSIZE == LONGSIZE
1375 DO_BO_UNPACK(auv, l);
1376 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1377 DO_BO_UNPACK(auv, 64);
1381 PUSHs(sv_2mortal(newSVuv(auv)));
1383 else if (checksum > bits_in_uv)
1389 case 'l' | TYPE_IS_SHRIEKING:
1390 #if LONGSIZE != SIZE32
1392 COPYNN(s, &along, sizeof(long));
1393 DO_BO_UNPACK(along, l);
1396 PUSHs(sv_2mortal(newSViv((IV)along)));
1398 else if (checksum > bits_in_uv)
1399 cdouble += (NV)along;
1410 DO_BO_UNPACK(ai32, 32);
1411 #if U32SIZE > SIZE32
1412 if (ai32 > 2147483647)
1417 PUSHs(sv_2mortal(newSViv((IV)ai32)));
1419 else if (checksum > bits_in_uv)
1420 cdouble += (NV)ai32;
1425 case 'L' | TYPE_IS_SHRIEKING:
1426 #if LONGSIZE != SIZE32
1428 COPYNN(s, &aulong, sizeof(unsigned long));
1429 DO_BO_UNPACK(aulong, l);
1430 s += sizeof(unsigned long);
1432 PUSHs(sv_2mortal(newSVuv((UV)aulong)));
1434 else if (checksum > bits_in_uv)
1435 cdouble += (NV)aulong;
1448 DO_BO_UNPACK(au32, 32);
1451 if (datumtype == 'N')
1452 au32 = PerlSock_ntohl(au32);
1455 if (datumtype == 'V')
1459 PUSHs(sv_2mortal(newSVuv((UV)au32)));
1461 else if (checksum > bits_in_uv)
1462 cdouble += (NV)au32;
1467 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1468 case 'V' | TYPE_IS_SHRIEKING:
1469 case 'N' | TYPE_IS_SHRIEKING:
1474 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1475 ai32 = (I32)PerlSock_ntohl((U32)ai32);
1478 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1479 ai32 = (I32)vtohl((U32)ai32);
1482 PUSHs(sv_2mortal(newSViv((IV)ai32)));
1484 else if (checksum > bits_in_uv)
1485 cdouble += (NV)ai32;
1493 assert (sizeof(char*) <= strend - s);
1494 Copy(s, &aptr, 1, char*);
1495 DO_BO_UNPACK_P(aptr);
1497 /* newSVpv generates undef if aptr is NULL */
1498 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1506 while ((len > 0) && (s < strend)) {
1507 auv = (auv << 7) | (*s & 0x7f);
1508 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1509 if ((U8)(*s++) < 0x80) {
1511 PUSHs(sv_2mortal(newSVuv(auv)));
1515 else if (++bytes >= sizeof(UV)) { /* promote to string */
1519 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1520 while (s < strend) {
1521 sv = mul128(sv, (U8)(*s & 0x7f));
1522 if (!(*s++ & 0x80)) {
1531 PUSHs(sv_2mortal(sv));
1536 if ((s >= strend) && bytes)
1537 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1541 if (symptr->howlen == e_star)
1542 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1544 if (sizeof(char*) > strend - s)
1547 Copy(s, &aptr, 1, char*);
1548 DO_BO_UNPACK_P(aptr);
1551 /* newSVpvn generates undef if aptr is NULL */
1552 PUSHs(sv_2mortal(newSVpvn(aptr, len)));
1557 assert (s + sizeof(Quad_t) <= strend);
1558 Copy(s, &aquad, 1, Quad_t);
1559 DO_BO_UNPACK(aquad, 64);
1560 s += sizeof(Quad_t);
1562 PUSHs(sv_2mortal((aquad >= IV_MIN && aquad <= IV_MAX) ?
1563 newSViv((IV)aquad) : newSVnv((NV)aquad)));
1565 else if (checksum > bits_in_uv)
1566 cdouble += (NV)aquad;
1573 assert (s + sizeof(Uquad_t) <= strend);
1574 Copy(s, &auquad, 1, Uquad_t);
1575 DO_BO_UNPACK(auquad, 64);
1576 s += sizeof(Uquad_t);
1578 PUSHs(sv_2mortal((auquad <= UV_MAX) ?
1579 newSVuv((UV)auquad) : newSVnv((NV)auquad)));
1581 else if (checksum > bits_in_uv)
1582 cdouble += (NV)auquad;
1588 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1591 Copy(s, &afloat, 1, float);
1592 DO_BO_UNPACK_N(afloat, float);
1595 PUSHs(sv_2mortal(newSVnv((NV)afloat)));
1604 Copy(s, &adouble, 1, double);
1605 DO_BO_UNPACK_N(adouble, double);
1606 s += sizeof(double);
1608 PUSHs(sv_2mortal(newSVnv((NV)adouble)));
1617 Copy(s, &anv, 1, NV);
1618 DO_BO_UNPACK_N(anv, NV);
1621 PUSHs(sv_2mortal(newSVnv(anv)));
1628 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1631 Copy(s, &aldouble, 1, long double);
1632 DO_BO_UNPACK_N(aldouble, long double);
1633 s += LONG_DOUBLESIZE;
1635 PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
1637 else {cdouble += aldouble;
1644 * Initialise the decode mapping. By using a table driven
1645 * algorithm, the code will be character-set independent
1646 * (and just as fast as doing character arithmetic)
1648 if (PL_uudmap['M'] == 0) {
1651 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1652 PL_uudmap[(U8)PL_uuemap[i]] = i;
1654 * Because ' ' and '`' map to the same value,
1655 * we need to decode them both the same.
1660 along = (strend - s) * 3 / 4;
1661 sv = NEWSV(42, along);
1664 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1669 len = PL_uudmap[*(U8*)s++] & 077;
1671 if (s < strend && ISUUCHAR(*s))
1672 a = PL_uudmap[*(U8*)s++] & 077;
1675 if (s < strend && ISUUCHAR(*s))
1676 b = PL_uudmap[*(U8*)s++] & 077;
1679 if (s < strend && ISUUCHAR(*s))
1680 c = PL_uudmap[*(U8*)s++] & 077;
1683 if (s < strend && ISUUCHAR(*s))
1684 d = PL_uudmap[*(U8*)s++] & 077;
1687 hunk[0] = (char)((a << 2) | (b >> 4));
1688 hunk[1] = (char)((b << 4) | (c >> 2));
1689 hunk[2] = (char)((c << 6) | d);
1690 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1695 else /* possible checksum byte */
1696 if (s + 1 < strend && s[1] == '\n')
1699 XPUSHs(sv_2mortal(sv));
1704 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1705 (checksum > bits_in_uv &&
1706 strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1709 adouble = (NV) (1 << (checksum & 15));
1710 while (checksum >= 16) {
1714 while (cdouble < 0.0)
1716 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1717 sv = newSVnv(cdouble);
1720 if (checksum < bits_in_uv) {
1721 UV mask = ((UV)1 << checksum) - 1;
1726 XPUSHs(sv_2mortal(sv));
1730 if (symptr->flags & FLAG_SLASH){
1731 if (SP - PL_stack_base - start_sp_offset <= 0)
1732 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1733 if( next_symbol(symptr) ){
1734 if( symptr->howlen == e_number )
1735 Perl_croak(aTHX_ "Count after length/code in unpack" );
1737 /* ...end of char buffer then no decent length available */
1738 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1740 /* take top of stack (hope it's numeric) */
1743 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1746 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1748 datumtype = symptr->code;
1756 return SP - PL_stack_base - start_sp_offset;
1763 I32 gimme = GIMME_V;
1766 register char *pat = SvPV(left, llen);
1767 #ifdef PACKED_IS_OCTETS
1768 /* Packed side is assumed to be octets - so force downgrade if it
1769 has been UTF-8 encoded by accident
1771 register char *s = SvPVbyte(right, rlen);
1773 register char *s = SvPV(right, rlen);
1775 char *strend = s + rlen;
1776 register char *patend = pat + llen;
1780 cnt = unpackstring(pat, patend, s, strend,
1781 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1782 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1785 if ( !cnt && gimme == G_SCALAR )
1786 PUSHs(&PL_sv_undef);
1791 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1795 *hunk = PL_uuemap[len];
1796 sv_catpvn(sv, hunk, 1);
1799 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1800 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1801 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1802 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1803 sv_catpvn(sv, hunk, 4);
1808 char r = (len > 1 ? s[1] : '\0');
1809 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1810 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1811 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1812 hunk[3] = PL_uuemap[0];
1813 sv_catpvn(sv, hunk, 4);
1815 sv_catpvn(sv, "\n", 1);
1819 S_is_an_int(pTHX_ char *s, STRLEN l)
1822 SV *result = newSVpvn(s, l);
1823 char *result_c = SvPV(result, n_a); /* convenience */
1824 char *out = result_c;
1834 SvREFCNT_dec(result);
1857 SvREFCNT_dec(result);
1863 SvCUR_set(result, out - result_c);
1867 /* pnum must be '\0' terminated */
1869 S_div128(pTHX_ SV *pnum, bool *done)
1872 char *s = SvPV(pnum, len);
1881 i = m * 10 + (*t - '0');
1883 r = (i >> 7); /* r < 10 */
1890 SvCUR_set(pnum, (STRLEN) (t - s));
1897 =for apidoc pack_cat
1899 The engine implementing pack() Perl function. Note: parameters next_in_list and
1900 flags are not used. This call should not be used; use packlist instead.
1906 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1908 tempsym_t sym = { 0 };
1910 sym.patend = patend;
1911 sym.flags = FLAG_PACK;
1913 (void)pack_rec( cat, &sym, beglist, endlist );
1918 =for apidoc packlist
1920 The engine implementing pack() Perl function.
1926 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1928 tempsym_t sym = { 0 };
1930 sym.patend = patend;
1931 sym.flags = FLAG_PACK;
1933 (void)pack_rec( cat, &sym, beglist, endlist );
1939 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1943 register I32 len = 0;
1946 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1947 static char *space10 = " ";
1950 /* These must not be in registers: */
1960 #if SHORTSIZE != SIZE16
1962 unsigned short aushort;
1966 #if LONGSIZE != SIZE32
1968 unsigned long aulong;
1973 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1974 long double aldouble;
1980 int strrelbeg = SvCUR(cat);
1981 tempsym_t lookahead;
1983 items = endlist - beglist;
1984 found = next_symbol( symptr );
1986 #ifndef PACKED_IS_OCTETS
1987 if (symptr->level == 0 && found && symptr->code == 'U' ){
1993 SV *lengthcode = Nullsv;
1994 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1996 I32 datumtype = symptr->code;
1999 switch( howlen = symptr->howlen ){
2002 len = symptr->length;
2005 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
2009 /* Look ahead for next symbol. Do we have code/code? */
2010 lookahead = *symptr;
2011 found = next_symbol(&lookahead);
2012 if ( symptr->flags & FLAG_SLASH ) {
2014 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2015 e_star != lookahead.howlen )
2016 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2017 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
2018 ? *beglist : &PL_sv_no)
2019 + (lookahead.code == 'Z' ? 1 : 0)));
2021 Perl_croak(aTHX_ "Code missing after '/' in pack");
2025 switch(TYPE_NO_ENDIANNESS(datumtype)) {
2027 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
2029 Perl_croak(aTHX_ "'%%' may not be used in pack");
2031 len += strrelbeg - SvCUR(cat);
2040 tempsym_t savsym = *symptr;
2041 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2042 symptr->flags |= group_modifiers;
2043 symptr->patend = savsym.grpend;
2046 symptr->patptr = savsym.grpbeg;
2047 beglist = pack_rec(cat, symptr, beglist, endlist );
2048 if (savsym.howlen == e_star && beglist == endlist)
2049 break; /* No way to continue */
2051 symptr->flags &= ~group_modifiers;
2052 lookahead.flags = symptr->flags;
2056 case 'X' | TYPE_IS_SHRIEKING:
2057 if (!len) /* Avoid division by 0 */
2059 len = (SvCUR(cat)) % len;
2063 if ((I32)SvCUR(cat) < len)
2064 Perl_croak(aTHX_ "'X' outside of string in pack");
2068 case 'x' | TYPE_IS_SHRIEKING:
2069 if (!len) /* Avoid division by 0 */
2071 aint = (SvCUR(cat)) % len;
2072 if (aint) /* Other portable ways? */
2081 sv_catpvn(cat, null10, 10);
2084 sv_catpvn(cat, null10, len);
2090 aptr = SvPV(fromstr, fromlen);
2091 if (howlen == e_star) {
2093 if (datumtype == 'Z')
2096 if ((I32)fromlen >= len) {
2097 sv_catpvn(cat, aptr, len);
2098 if (datumtype == 'Z')
2099 *(SvEND(cat)-1) = '\0';
2102 sv_catpvn(cat, aptr, fromlen);
2104 if (datumtype == 'A') {
2106 sv_catpvn(cat, space10, 10);
2109 sv_catpvn(cat, space10, len);
2113 sv_catpvn(cat, null10, 10);
2116 sv_catpvn(cat, null10, len);
2128 str = SvPV(fromstr, fromlen);
2129 if (howlen == e_star)
2132 SvCUR(cat) += (len+7)/8;
2133 SvGROW(cat, SvCUR(cat) + 1);
2134 aptr = SvPVX(cat) + aint;
2135 if (len > (I32)fromlen)
2139 if (datumtype == 'B') {
2140 for (len = 0; len++ < aint;) {
2141 items |= *str++ & 1;
2145 *aptr++ = items & 0xff;
2151 for (len = 0; len++ < aint;) {
2157 *aptr++ = items & 0xff;
2163 if (datumtype == 'B')
2164 items <<= 7 - (aint & 7);
2166 items >>= 7 - (aint & 7);
2167 *aptr++ = items & 0xff;
2169 str = SvPVX(cat) + SvCUR(cat);
2184 str = SvPV(fromstr, fromlen);
2185 if (howlen == e_star)
2188 SvCUR(cat) += (len+1)/2;
2189 SvGROW(cat, SvCUR(cat) + 1);
2190 aptr = SvPVX(cat) + aint;
2191 if (len > (I32)fromlen)
2195 if (datumtype == 'H') {
2196 for (len = 0; len++ < aint;) {
2198 items |= ((*str++ & 15) + 9) & 15;
2200 items |= *str++ & 15;
2204 *aptr++ = items & 0xff;
2210 for (len = 0; len++ < aint;) {
2212 items |= (((*str++ & 15) + 9) & 15) << 4;
2214 items |= (*str++ & 15) << 4;
2218 *aptr++ = items & 0xff;
2224 *aptr++ = items & 0xff;
2225 str = SvPVX(cat) + SvCUR(cat);
2236 switch (TYPE_NO_MODIFIERS(datumtype)) {
2238 aint = SvIV(fromstr);
2239 if ((aint < 0 || aint > 255) &&
2241 Perl_warner(aTHX_ packWARN(WARN_PACK),
2242 "Character in 'C' format wrapped in pack");
2244 sv_catpvn(cat, &achar, sizeof(char));
2247 aint = SvIV(fromstr);
2248 if ((aint < -128 || aint > 127) &&
2250 Perl_warner(aTHX_ packWARN(WARN_PACK),
2251 "Character in 'c' format wrapped in pack" );
2253 sv_catpvn(cat, &achar, sizeof(char));
2261 auint = UNI_TO_NATIVE(SvUV(fromstr));
2262 SvGROW(cat, SvCUR(cat) + UTF8_MAXBYTES + 1);
2264 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2267 0 : UNICODE_ALLOW_ANY)
2272 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2277 /* VOS does not automatically map a floating-point overflow
2278 during conversion from double to float into infinity, so we
2279 do it by hand. This code should either be generalized for
2280 any OS that needs it, or removed if and when VOS implements
2281 posix-976 (suggestion to support mapping to infinity).
2282 Paul.Green@stratus.com 02-04-02. */
2283 if (SvNV(fromstr) > FLT_MAX)
2284 afloat = _float_constants[0]; /* single prec. inf. */
2285 else if (SvNV(fromstr) < -FLT_MAX)
2286 afloat = _float_constants[0]; /* single prec. inf. */
2287 else afloat = (float)SvNV(fromstr);
2289 # if defined(VMS) && !defined(__IEEE_FP)
2290 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2291 * on Alpha; fake it if we don't have them.
2293 if (SvNV(fromstr) > FLT_MAX)
2295 else if (SvNV(fromstr) < -FLT_MAX)
2297 else afloat = (float)SvNV(fromstr);
2299 afloat = (float)SvNV(fromstr);
2302 DO_BO_PACK_N(afloat, float);
2303 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2310 /* VOS does not automatically map a floating-point overflow
2311 during conversion from long double to double into infinity,
2312 so we do it by hand. This code should either be generalized
2313 for any OS that needs it, or removed if and when VOS
2314 implements posix-976 (suggestion to support mapping to
2315 infinity). Paul.Green@stratus.com 02-04-02. */
2316 if (SvNV(fromstr) > DBL_MAX)
2317 adouble = _double_constants[0]; /* double prec. inf. */
2318 else if (SvNV(fromstr) < -DBL_MAX)
2319 adouble = _double_constants[0]; /* double prec. inf. */
2320 else adouble = (double)SvNV(fromstr);
2322 # if defined(VMS) && !defined(__IEEE_FP)
2323 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2324 * on Alpha; fake it if we don't have them.
2326 if (SvNV(fromstr) > DBL_MAX)
2328 else if (SvNV(fromstr) < -DBL_MAX)
2330 else adouble = (double)SvNV(fromstr);
2332 adouble = (double)SvNV(fromstr);
2335 DO_BO_PACK_N(adouble, double);
2336 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2340 Zero(&anv, 1, NV); /* can be long double with unused bits */
2343 anv = SvNV(fromstr);
2344 DO_BO_PACK_N(anv, NV);
2345 sv_catpvn(cat, (char *)&anv, NVSIZE);
2348 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2350 /* long doubles can have unused bits, which may be nonzero */
2351 Zero(&aldouble, 1, long double);
2354 aldouble = (long double)SvNV(fromstr);
2355 DO_BO_PACK_N(aldouble, long double);
2356 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2360 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2361 case 'n' | TYPE_IS_SHRIEKING:
2366 ai16 = (I16)SvIV(fromstr);
2368 ai16 = PerlSock_htons(ai16);
2373 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2374 case 'v' | TYPE_IS_SHRIEKING:
2379 ai16 = (I16)SvIV(fromstr);
2386 case 'S' | TYPE_IS_SHRIEKING:
2387 #if SHORTSIZE != SIZE16
2391 aushort = SvUV(fromstr);
2392 DO_BO_PACK(aushort, s);
2393 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2404 au16 = (U16)SvUV(fromstr);
2405 DO_BO_PACK(au16, 16);
2411 case 's' | TYPE_IS_SHRIEKING:
2412 #if SHORTSIZE != SIZE16
2416 ashort = SvIV(fromstr);
2417 DO_BO_PACK(ashort, s);
2418 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2428 ai16 = (I16)SvIV(fromstr);
2429 DO_BO_PACK(ai16, 16);
2434 case 'I' | TYPE_IS_SHRIEKING:
2437 auint = SvUV(fromstr);
2438 DO_BO_PACK(auint, i);
2439 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2445 aiv = SvIV(fromstr);
2446 #if IVSIZE == INTSIZE
2448 #elif IVSIZE == LONGSIZE
2450 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2451 DO_BO_PACK(aiv, 64);
2453 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2459 auv = SvUV(fromstr);
2460 #if UVSIZE == INTSIZE
2462 #elif UVSIZE == LONGSIZE
2464 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2465 DO_BO_PACK(auv, 64);
2467 sv_catpvn(cat, (char*)&auv, UVSIZE);
2473 anv = SvNV(fromstr);
2476 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2478 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2479 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2480 any negative IVs will have already been got by the croak()
2481 above. IOK is untrue for fractions, so we test them
2482 against UV_MAX_P1. */
2483 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2485 char buf[(sizeof(UV)*8)/7+1];
2486 char *in = buf + sizeof(buf);
2487 UV auv = SvUV(fromstr);
2490 *--in = (char)((auv & 0x7f) | 0x80);
2493 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2494 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2496 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2497 char *from, *result, *in;
2502 /* Copy string and check for compliance */
2503 from = SvPV(fromstr, len);
2504 if ((norm = is_an_int(from, len)) == NULL)
2505 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2507 New('w', result, len, char);
2511 *--in = div128(norm, &done) | 0x80;
2512 result[len - 1] &= 0x7F; /* clear continue bit */
2513 sv_catpvn(cat, in, (result + len) - in);
2515 SvREFCNT_dec(norm); /* free norm */
2517 else if (SvNOKp(fromstr)) {
2518 /* 10**NV_MAX_10_EXP is the largest power of 10
2519 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2520 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2521 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2522 And with that many bytes only Inf can overflow.
2523 Some C compilers are strict about integral constant
2524 expressions so we conservatively divide by a slightly
2525 smaller integer instead of multiplying by the exact
2526 floating-point value.
2528 #ifdef NV_MAX_10_EXP
2529 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2530 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2532 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2533 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2535 char *in = buf + sizeof(buf);
2537 anv = Perl_floor(anv);
2539 NV next = Perl_floor(anv / 128);
2540 if (in <= buf) /* this cannot happen ;-) */
2541 Perl_croak(aTHX_ "Cannot compress integer in pack");
2542 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2545 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2546 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2549 char *from, *result, *in;
2554 /* Copy string and check for compliance */
2555 from = SvPV(fromstr, len);
2556 if ((norm = is_an_int(from, len)) == NULL)
2557 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2559 New('w', result, len, char);
2563 *--in = div128(norm, &done) | 0x80;
2564 result[len - 1] &= 0x7F; /* clear continue bit */
2565 sv_catpvn(cat, in, (result + len) - in);
2567 SvREFCNT_dec(norm); /* free norm */
2572 case 'i' | TYPE_IS_SHRIEKING:
2575 aint = SvIV(fromstr);
2576 DO_BO_PACK(aint, i);
2577 sv_catpvn(cat, (char*)&aint, sizeof(int));
2580 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2581 case 'N' | TYPE_IS_SHRIEKING:
2586 au32 = SvUV(fromstr);
2588 au32 = PerlSock_htonl(au32);
2593 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2594 case 'V' | TYPE_IS_SHRIEKING:
2599 au32 = SvUV(fromstr);
2606 case 'L' | TYPE_IS_SHRIEKING:
2607 #if LONGSIZE != SIZE32
2611 aulong = SvUV(fromstr);
2612 DO_BO_PACK(aulong, l);
2613 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2624 au32 = SvUV(fromstr);
2625 DO_BO_PACK(au32, 32);
2630 case 'l' | TYPE_IS_SHRIEKING:
2631 #if LONGSIZE != SIZE32
2635 along = SvIV(fromstr);
2636 DO_BO_PACK(along, l);
2637 sv_catpvn(cat, (char *)&along, sizeof(long));
2647 ai32 = SvIV(fromstr);
2648 DO_BO_PACK(ai32, 32);
2656 auquad = (Uquad_t)SvUV(fromstr);
2657 DO_BO_PACK(auquad, 64);
2658 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2664 aquad = (Quad_t)SvIV(fromstr);
2665 DO_BO_PACK(aquad, 64);
2666 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2671 len = 1; /* assume SV is correct length */
2676 if (fromstr == &PL_sv_undef)
2680 /* XXX better yet, could spirit away the string to
2681 * a safe spot and hang on to it until the result
2682 * of pack() (and all copies of the result) are
2685 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2686 || (SvPADTMP(fromstr)
2687 && !SvREADONLY(fromstr))))
2689 Perl_warner(aTHX_ packWARN(WARN_PACK),
2690 "Attempt to pack pointer to temporary value");
2692 if (SvPOK(fromstr) || SvNIOK(fromstr))
2693 aptr = SvPV(fromstr,n_a);
2695 aptr = SvPV_force(fromstr,n_a);
2698 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2703 aptr = SvPV(fromstr, fromlen);
2704 SvGROW(cat, fromlen * 4 / 3);
2709 while (fromlen > 0) {
2712 if ((I32)fromlen > len)
2716 doencodes(cat, aptr, todo);
2722 *symptr = lookahead;
2731 dSP; dMARK; dORIGMARK; dTARGET;
2732 register SV *cat = TARG;
2734 register char *pat = SvPVx(*++MARK, fromlen);
2735 register char *patend = pat + fromlen;
2738 sv_setpvn(cat, "", 0);
2740 packlist(cat, pat, patend, MARK, SP + 1);
2750 * c-indentation-style: bsd
2752 * indent-tabs-mode: t
2755 * vim: shiftwidth=4: