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 explicit_length;
912 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
914 while (next_symbol(symptr)) {
915 datumtype = symptr->code;
916 /* do first one only unless in list context
917 / is implemented by unpacking the count, then poping it from the
918 stack, so must check that we're not in the middle of a / */
920 && (SP - PL_stack_base == start_sp_offset + 1)
921 && (datumtype != '/') ) /* XXX can this be omitted */
924 switch( howlen = symptr->howlen ){
927 len = symptr->length;
930 len = strend - strbeg; /* long enough */
934 explicit_length = TRUE;
936 beyond = s >= strend;
938 int which = (symptr->code & TYPE_IS_SHRIEKING)
939 ? PACK_SIZE_SHRIEKING : PACK_SIZE_NORMAL;
940 const int rawtype = TYPE_NO_MODIFIERS(datumtype);
941 int offset = rawtype - packsize[which].first;
943 if (offset >= 0 && offset < packsize[which].size) {
944 /* Data about this template letter */
945 unsigned char data = packsize[which].array[offset];
948 /* data nonzero means we can process this letter. */
949 long size = data & PACK_SIZE_MASK;
950 long howmany = (strend - s) / size;
954 /* In the old code, 'p' was the only type without shortcut
955 code to curtail unpacking to only one. As far as I can
956 see the only point of retaining this anomaly is to make
957 code such as $_ = unpack "p2", pack "pI", "Hi", 2
958 continue to segfault. ie, it probably should be
962 if (!checksum || (data & PACK_SIZE_CANNOT_CSUM)) {
963 if (len && unpack_only_one &&
972 switch(TYPE_NO_ENDIANNESS(datumtype)) {
974 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
977 if (howlen == e_no_len)
978 len = 16; /* len is not specified */
986 char *ss = s; /* Move from register */
987 tempsym_t savsym = *symptr;
988 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
989 symptr->flags |= group_modifiers;
990 symptr->patend = savsym.grpend;
994 symptr->patptr = savsym.grpbeg;
995 unpack_rec(symptr, ss, strbeg, strend, &ss );
996 if (savsym.flags & FLAG_UNPACK_DO_UTF8)
997 symptr->flags |= FLAG_UNPACK_DO_UTF8;
999 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
1000 if (ss == strend && savsym.howlen == e_star)
1001 break; /* No way to continue */
1005 symptr->flags &= ~group_modifiers;
1006 savsym.flags = symptr->flags;
1011 if (len > strend - strrelbeg)
1012 Perl_croak(aTHX_ "'@' outside of string in unpack");
1013 s = strrelbeg + len;
1015 case 'X' | TYPE_IS_SHRIEKING:
1016 if (!len) /* Avoid division by 0 */
1018 len = (s - strbeg) % len;
1021 if (len > s - strbeg)
1022 Perl_croak(aTHX_ "'X' outside of string in unpack" );
1025 case 'x' | TYPE_IS_SHRIEKING:
1026 if (!len) /* Avoid division by 0 */
1028 aint = (s - strbeg) % len;
1029 if (aint) /* Other portable ways? */
1035 if (len > strend - s)
1036 Perl_croak(aTHX_ "'x' outside of string in unpack");
1040 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1045 if (len > strend - s)
1048 goto uchar_checksum;
1049 sv = newSVpvn(s, len);
1050 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
1051 aptr = s; /* borrow register */
1052 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
1056 if (howlen == e_star) /* exact for 'Z*' */
1057 len = s - SvPVX(sv) + 1;
1059 else { /* 'A' strips both nulls and spaces */
1060 s = SvPVX(sv) + len - 1;
1061 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
1065 SvCUR_set(sv, s - SvPVX(sv));
1066 s = aptr; /* unborrow register */
1069 XPUSHs(sv_2mortal(sv));
1073 if (howlen == e_star || len > (strend - s) * 8)
1074 len = (strend - s) * 8;
1077 Newz(601, PL_bitcount, 256, char);
1078 for (bits = 1; bits < 256; bits++) {
1079 if (bits & 1) PL_bitcount[bits]++;
1080 if (bits & 2) PL_bitcount[bits]++;
1081 if (bits & 4) PL_bitcount[bits]++;
1082 if (bits & 8) PL_bitcount[bits]++;
1083 if (bits & 16) PL_bitcount[bits]++;
1084 if (bits & 32) PL_bitcount[bits]++;
1085 if (bits & 64) PL_bitcount[bits]++;
1086 if (bits & 128) PL_bitcount[bits]++;
1090 cuv += PL_bitcount[*(unsigned char*)s++];
1095 if (datumtype == 'b') {
1097 if (bits & 1) cuv++;
1103 if (bits & 128) cuv++;
1110 sv = NEWSV(35, len + 1);
1114 if (datumtype == 'b') {
1116 for (len = 0; len < aint; len++) {
1117 if (len & 7) /*SUPPRESS 595*/
1121 *str++ = '0' + (bits & 1);
1126 for (len = 0; len < aint; len++) {
1131 *str++ = '0' + ((bits & 128) != 0);
1135 XPUSHs(sv_2mortal(sv));
1139 if (howlen == e_star || len > (strend - s) * 2)
1140 len = (strend - s) * 2;
1141 sv = NEWSV(35, len + 1);
1145 if (datumtype == 'h') {
1147 for (len = 0; len < aint; len++) {
1152 *str++ = PL_hexdigit[bits & 15];
1157 for (len = 0; len < aint; len++) {
1162 *str++ = PL_hexdigit[(bits >> 4) & 15];
1166 XPUSHs(sv_2mortal(sv));
1171 if (aint >= 128) /* fake up signed chars */
1174 PUSHs(sv_2mortal(newSViv((IV)aint)));
1176 else if (checksum > bits_in_uv)
1177 cdouble += (NV)aint;
1183 unpack_C: /* unpack U will jump here if not UTF-8 */
1185 if (explicit_length)
1186 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
1193 if (checksum > bits_in_uv)
1194 cdouble += (NV)auint;
1202 PUSHs(sv_2mortal(newSViv((IV)auint)));
1208 if (explicit_length)
1209 symptr->flags |= FLAG_UNPACK_DO_UTF8;
1212 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
1214 while (len-- > 0 && s < strend) {
1216 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1220 PUSHs(sv_2mortal(newSVuv((UV)auint)));
1222 else if (checksum > bits_in_uv)
1223 cdouble += (NV)auint;
1228 case 's' | TYPE_IS_SHRIEKING:
1229 #if SHORTSIZE != SIZE16
1231 COPYNN(s, &ashort, sizeof(short));
1232 DO_BO_UNPACK(ashort, s);
1235 PUSHs(sv_2mortal(newSViv((IV)ashort)));
1237 else if (checksum > bits_in_uv)
1238 cdouble += (NV)ashort;
1249 DO_BO_UNPACK(ai16, 16);
1250 #if U16SIZE > SIZE16
1256 PUSHs(sv_2mortal(newSViv((IV)ai16)));
1258 else if (checksum > bits_in_uv)
1259 cdouble += (NV)ai16;
1264 case 'S' | TYPE_IS_SHRIEKING:
1265 #if SHORTSIZE != SIZE16
1267 COPYNN(s, &aushort, sizeof(unsigned short));
1268 DO_BO_UNPACK(aushort, s);
1269 s += sizeof(unsigned short);
1271 PUSHs(sv_2mortal(newSViv((UV)aushort)));
1273 else if (checksum > bits_in_uv)
1274 cdouble += (NV)aushort;
1287 DO_BO_UNPACK(au16, 16);
1290 if (datumtype == 'n')
1291 au16 = PerlSock_ntohs(au16);
1294 if (datumtype == 'v')
1298 PUSHs(sv_2mortal(newSViv((UV)au16)));
1300 else if (checksum > bits_in_uv)
1301 cdouble += (NV)au16;
1306 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1307 case 'v' | TYPE_IS_SHRIEKING:
1308 case 'n' | TYPE_IS_SHRIEKING:
1313 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1314 ai16 = (I16)PerlSock_ntohs((U16)ai16);
1317 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1318 ai16 = (I16)vtohs((U16)ai16);
1321 PUSHs(sv_2mortal(newSViv((IV)ai16)));
1323 else if (checksum > bits_in_uv)
1324 cdouble += (NV)ai16;
1331 case 'i' | TYPE_IS_SHRIEKING:
1333 Copy(s, &aint, 1, int);
1334 DO_BO_UNPACK(aint, i);
1337 PUSHs(sv_2mortal(newSViv((IV)aint)));
1339 else if (checksum > bits_in_uv)
1340 cdouble += (NV)aint;
1346 case 'I' | TYPE_IS_SHRIEKING:
1348 Copy(s, &auint, 1, unsigned int);
1349 DO_BO_UNPACK(auint, i);
1350 s += sizeof(unsigned int);
1352 PUSHs(sv_2mortal(newSVuv((UV)auint)));
1354 else if (checksum > bits_in_uv)
1355 cdouble += (NV)auint;
1362 Copy(s, &aiv, 1, IV);
1363 #if IVSIZE == INTSIZE
1364 DO_BO_UNPACK(aiv, i);
1365 #elif IVSIZE == LONGSIZE
1366 DO_BO_UNPACK(aiv, l);
1367 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1368 DO_BO_UNPACK(aiv, 64);
1372 PUSHs(sv_2mortal(newSViv(aiv)));
1374 else if (checksum > bits_in_uv)
1382 Copy(s, &auv, 1, UV);
1383 #if UVSIZE == INTSIZE
1384 DO_BO_UNPACK(auv, i);
1385 #elif UVSIZE == LONGSIZE
1386 DO_BO_UNPACK(auv, l);
1387 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1388 DO_BO_UNPACK(auv, 64);
1392 PUSHs(sv_2mortal(newSVuv(auv)));
1394 else if (checksum > bits_in_uv)
1400 case 'l' | TYPE_IS_SHRIEKING:
1401 #if LONGSIZE != SIZE32
1403 COPYNN(s, &along, sizeof(long));
1404 DO_BO_UNPACK(along, l);
1407 PUSHs(sv_2mortal(newSViv((IV)along)));
1409 else if (checksum > bits_in_uv)
1410 cdouble += (NV)along;
1421 DO_BO_UNPACK(ai32, 32);
1422 #if U32SIZE > SIZE32
1423 if (ai32 > 2147483647)
1428 PUSHs(sv_2mortal(newSViv((IV)ai32)));
1430 else if (checksum > bits_in_uv)
1431 cdouble += (NV)ai32;
1436 case 'L' | TYPE_IS_SHRIEKING:
1437 #if LONGSIZE != SIZE32
1439 COPYNN(s, &aulong, sizeof(unsigned long));
1440 DO_BO_UNPACK(aulong, l);
1441 s += sizeof(unsigned long);
1443 PUSHs(sv_2mortal(newSVuv((UV)aulong)));
1445 else if (checksum > bits_in_uv)
1446 cdouble += (NV)aulong;
1459 DO_BO_UNPACK(au32, 32);
1462 if (datumtype == 'N')
1463 au32 = PerlSock_ntohl(au32);
1466 if (datumtype == 'V')
1470 PUSHs(sv_2mortal(newSVuv((UV)au32)));
1472 else if (checksum > bits_in_uv)
1473 cdouble += (NV)au32;
1478 #ifdef PERL_PACK_CAN_SHRIEKSIGN
1479 case 'V' | TYPE_IS_SHRIEKING:
1480 case 'N' | TYPE_IS_SHRIEKING:
1485 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1486 ai32 = (I32)PerlSock_ntohl((U32)ai32);
1489 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1490 ai32 = (I32)vtohl((U32)ai32);
1493 PUSHs(sv_2mortal(newSViv((IV)ai32)));
1495 else if (checksum > bits_in_uv)
1496 cdouble += (NV)ai32;
1504 assert (sizeof(char*) <= strend - s);
1505 Copy(s, &aptr, 1, char*);
1506 DO_BO_UNPACK_P(aptr);
1508 /* newSVpv generates undef if aptr is NULL */
1509 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1517 while ((len > 0) && (s < strend)) {
1518 auv = (auv << 7) | (*s & 0x7f);
1519 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1520 if ((U8)(*s++) < 0x80) {
1522 PUSHs(sv_2mortal(newSVuv(auv)));
1526 else if (++bytes >= sizeof(UV)) { /* promote to string */
1530 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1531 while (s < strend) {
1532 sv = mul128(sv, (U8)(*s & 0x7f));
1533 if (!(*s++ & 0x80)) {
1542 PUSHs(sv_2mortal(sv));
1547 if ((s >= strend) && bytes)
1548 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1552 if (symptr->howlen == e_star)
1553 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1555 if (sizeof(char*) > strend - s)
1558 Copy(s, &aptr, 1, char*);
1559 DO_BO_UNPACK_P(aptr);
1562 /* newSVpvn generates undef if aptr is NULL */
1563 PUSHs(sv_2mortal(newSVpvn(aptr, len)));
1568 assert (s + sizeof(Quad_t) <= strend);
1569 Copy(s, &aquad, 1, Quad_t);
1570 DO_BO_UNPACK(aquad, 64);
1571 s += sizeof(Quad_t);
1573 PUSHs(sv_2mortal((aquad >= IV_MIN && aquad <= IV_MAX) ?
1574 newSViv((IV)aquad) : newSVnv((NV)aquad)));
1576 else if (checksum > bits_in_uv)
1577 cdouble += (NV)aquad;
1584 assert (s + sizeof(Uquad_t) <= strend);
1585 Copy(s, &auquad, 1, Uquad_t);
1586 DO_BO_UNPACK(auquad, 64);
1587 s += sizeof(Uquad_t);
1589 PUSHs(sv_2mortal((auquad <= UV_MAX) ?
1590 newSVuv((UV)auquad) : newSVnv((NV)auquad)));
1592 else if (checksum > bits_in_uv)
1593 cdouble += (NV)auquad;
1599 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1602 Copy(s, &afloat, 1, float);
1603 DO_BO_UNPACK_N(afloat, float);
1606 PUSHs(sv_2mortal(newSVnv((NV)afloat)));
1615 Copy(s, &adouble, 1, double);
1616 DO_BO_UNPACK_N(adouble, double);
1617 s += sizeof(double);
1619 PUSHs(sv_2mortal(newSVnv((NV)adouble)));
1628 Copy(s, &anv, 1, NV);
1629 DO_BO_UNPACK_N(anv, NV);
1632 PUSHs(sv_2mortal(newSVnv(anv)));
1639 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1642 Copy(s, &aldouble, 1, long double);
1643 DO_BO_UNPACK_N(aldouble, long double);
1644 s += LONG_DOUBLESIZE;
1646 PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
1648 else {cdouble += aldouble;
1655 * Initialise the decode mapping. By using a table driven
1656 * algorithm, the code will be character-set independent
1657 * (and just as fast as doing character arithmetic)
1659 if (PL_uudmap['M'] == 0) {
1662 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1663 PL_uudmap[(U8)PL_uuemap[i]] = i;
1665 * Because ' ' and '`' map to the same value,
1666 * we need to decode them both the same.
1671 along = (strend - s) * 3 / 4;
1672 sv = NEWSV(42, along);
1675 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1680 len = PL_uudmap[*(U8*)s++] & 077;
1682 if (s < strend && ISUUCHAR(*s))
1683 a = PL_uudmap[*(U8*)s++] & 077;
1686 if (s < strend && ISUUCHAR(*s))
1687 b = PL_uudmap[*(U8*)s++] & 077;
1690 if (s < strend && ISUUCHAR(*s))
1691 c = PL_uudmap[*(U8*)s++] & 077;
1694 if (s < strend && ISUUCHAR(*s))
1695 d = PL_uudmap[*(U8*)s++] & 077;
1698 hunk[0] = (char)((a << 2) | (b >> 4));
1699 hunk[1] = (char)((b << 4) | (c >> 2));
1700 hunk[2] = (char)((c << 6) | d);
1701 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1706 else /* possible checksum byte */
1707 if (s + 1 < strend && s[1] == '\n')
1710 XPUSHs(sv_2mortal(sv));
1715 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1716 (checksum > bits_in_uv &&
1717 strchr("cCsSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1720 adouble = (NV) (1 << (checksum & 15));
1721 while (checksum >= 16) {
1725 while (cdouble < 0.0)
1727 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1728 sv = newSVnv(cdouble);
1731 if (checksum < bits_in_uv) {
1732 UV mask = ((UV)1 << checksum) - 1;
1737 XPUSHs(sv_2mortal(sv));
1741 if (symptr->flags & FLAG_SLASH){
1742 if (SP - PL_stack_base - start_sp_offset <= 0)
1743 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1744 if( next_symbol(symptr) ){
1745 if( symptr->howlen == e_number )
1746 Perl_croak(aTHX_ "Count after length/code in unpack" );
1748 /* ...end of char buffer then no decent length available */
1749 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1751 /* take top of stack (hope it's numeric) */
1754 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1757 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1759 datumtype = symptr->code;
1760 explicit_length = FALSE;
1768 return SP - PL_stack_base - start_sp_offset;
1775 I32 gimme = GIMME_V;
1778 register char *pat = SvPV(left, llen);
1779 #ifdef PACKED_IS_OCTETS
1780 /* Packed side is assumed to be octets - so force downgrade if it
1781 has been UTF-8 encoded by accident
1783 register char *s = SvPVbyte(right, rlen);
1785 register char *s = SvPV(right, rlen);
1787 char *strend = s + rlen;
1788 register char *patend = pat + llen;
1792 cnt = unpackstring(pat, patend, s, strend,
1793 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1794 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1797 if ( !cnt && gimme == G_SCALAR )
1798 PUSHs(&PL_sv_undef);
1803 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1807 *hunk = PL_uuemap[len];
1808 sv_catpvn(sv, hunk, 1);
1811 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1812 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1813 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1814 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1815 sv_catpvn(sv, hunk, 4);
1820 char r = (len > 1 ? s[1] : '\0');
1821 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1822 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1823 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1824 hunk[3] = PL_uuemap[0];
1825 sv_catpvn(sv, hunk, 4);
1827 sv_catpvn(sv, "\n", 1);
1831 S_is_an_int(pTHX_ char *s, STRLEN l)
1834 SV *result = newSVpvn(s, l);
1835 char *result_c = SvPV(result, n_a); /* convenience */
1836 char *out = result_c;
1846 SvREFCNT_dec(result);
1869 SvREFCNT_dec(result);
1875 SvCUR_set(result, out - result_c);
1879 /* pnum must be '\0' terminated */
1881 S_div128(pTHX_ SV *pnum, bool *done)
1884 char *s = SvPV(pnum, len);
1893 i = m * 10 + (*t - '0');
1895 r = (i >> 7); /* r < 10 */
1902 SvCUR_set(pnum, (STRLEN) (t - s));
1909 =for apidoc pack_cat
1911 The engine implementing pack() Perl function. Note: parameters next_in_list and
1912 flags are not used. This call should not be used; use packlist instead.
1918 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1920 tempsym_t sym = { 0 };
1922 sym.patend = patend;
1923 sym.flags = FLAG_PACK;
1925 (void)pack_rec( cat, &sym, beglist, endlist );
1930 =for apidoc packlist
1932 The engine implementing pack() Perl function.
1938 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1940 tempsym_t sym = { 0 };
1942 sym.patend = patend;
1943 sym.flags = FLAG_PACK;
1945 (void)pack_rec( cat, &sym, beglist, endlist );
1951 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1955 register I32 len = 0;
1958 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1959 static char *space10 = " ";
1962 /* These must not be in registers: */
1972 #if SHORTSIZE != SIZE16
1974 unsigned short aushort;
1978 #if LONGSIZE != SIZE32
1980 unsigned long aulong;
1985 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1986 long double aldouble;
1992 int strrelbeg = SvCUR(cat);
1993 tempsym_t lookahead;
1995 items = endlist - beglist;
1996 found = next_symbol( symptr );
1998 #ifndef PACKED_IS_OCTETS
1999 if (symptr->level == 0 && found && symptr->code == 'U' ){
2005 SV *lengthcode = Nullsv;
2006 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2008 I32 datumtype = symptr->code;
2011 switch( howlen = symptr->howlen ){
2014 len = symptr->length;
2017 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
2021 /* Look ahead for next symbol. Do we have code/code? */
2022 lookahead = *symptr;
2023 found = next_symbol(&lookahead);
2024 if ( symptr->flags & FLAG_SLASH ) {
2026 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2027 e_star != lookahead.howlen )
2028 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2029 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
2030 ? *beglist : &PL_sv_no)
2031 + (lookahead.code == 'Z' ? 1 : 0)));
2033 Perl_croak(aTHX_ "Code missing after '/' in pack");
2037 switch(TYPE_NO_ENDIANNESS(datumtype)) {
2039 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
2041 Perl_croak(aTHX_ "'%%' may not be used in pack");
2043 len += strrelbeg - SvCUR(cat);
2052 tempsym_t savsym = *symptr;
2053 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2054 symptr->flags |= group_modifiers;
2055 symptr->patend = savsym.grpend;
2058 symptr->patptr = savsym.grpbeg;
2059 beglist = pack_rec(cat, symptr, beglist, endlist );
2060 if (savsym.howlen == e_star && beglist == endlist)
2061 break; /* No way to continue */
2063 symptr->flags &= ~group_modifiers;
2064 lookahead.flags = symptr->flags;
2068 case 'X' | TYPE_IS_SHRIEKING:
2069 if (!len) /* Avoid division by 0 */
2071 len = (SvCUR(cat)) % len;
2075 if ((I32)SvCUR(cat) < len)
2076 Perl_croak(aTHX_ "'X' outside of string in pack");
2080 case 'x' | TYPE_IS_SHRIEKING:
2081 if (!len) /* Avoid division by 0 */
2083 aint = (SvCUR(cat)) % len;
2084 if (aint) /* Other portable ways? */
2093 sv_catpvn(cat, null10, 10);
2096 sv_catpvn(cat, null10, len);
2102 aptr = SvPV(fromstr, fromlen);
2103 if (howlen == e_star) {
2105 if (datumtype == 'Z')
2108 if ((I32)fromlen >= len) {
2109 sv_catpvn(cat, aptr, len);
2110 if (datumtype == 'Z')
2111 *(SvEND(cat)-1) = '\0';
2114 sv_catpvn(cat, aptr, fromlen);
2116 if (datumtype == 'A') {
2118 sv_catpvn(cat, space10, 10);
2121 sv_catpvn(cat, space10, len);
2125 sv_catpvn(cat, null10, 10);
2128 sv_catpvn(cat, null10, len);
2140 str = SvPV(fromstr, fromlen);
2141 if (howlen == e_star)
2144 SvCUR(cat) += (len+7)/8;
2145 SvGROW(cat, SvCUR(cat) + 1);
2146 aptr = SvPVX(cat) + aint;
2147 if (len > (I32)fromlen)
2151 if (datumtype == 'B') {
2152 for (len = 0; len++ < aint;) {
2153 items |= *str++ & 1;
2157 *aptr++ = items & 0xff;
2163 for (len = 0; len++ < aint;) {
2169 *aptr++ = items & 0xff;
2175 if (datumtype == 'B')
2176 items <<= 7 - (aint & 7);
2178 items >>= 7 - (aint & 7);
2179 *aptr++ = items & 0xff;
2181 str = SvPVX(cat) + SvCUR(cat);
2196 str = SvPV(fromstr, fromlen);
2197 if (howlen == e_star)
2200 SvCUR(cat) += (len+1)/2;
2201 SvGROW(cat, SvCUR(cat) + 1);
2202 aptr = SvPVX(cat) + aint;
2203 if (len > (I32)fromlen)
2207 if (datumtype == 'H') {
2208 for (len = 0; len++ < aint;) {
2210 items |= ((*str++ & 15) + 9) & 15;
2212 items |= *str++ & 15;
2216 *aptr++ = items & 0xff;
2222 for (len = 0; len++ < aint;) {
2224 items |= (((*str++ & 15) + 9) & 15) << 4;
2226 items |= (*str++ & 15) << 4;
2230 *aptr++ = items & 0xff;
2236 *aptr++ = items & 0xff;
2237 str = SvPVX(cat) + SvCUR(cat);
2248 switch (TYPE_NO_MODIFIERS(datumtype)) {
2250 aint = SvIV(fromstr);
2251 if ((aint < 0 || aint > 255) &&
2253 Perl_warner(aTHX_ packWARN(WARN_PACK),
2254 "Character in 'C' format wrapped in pack");
2256 sv_catpvn(cat, &achar, sizeof(char));
2259 aint = SvIV(fromstr);
2260 if ((aint < -128 || aint > 127) &&
2262 Perl_warner(aTHX_ packWARN(WARN_PACK),
2263 "Character in 'c' format wrapped in pack" );
2265 sv_catpvn(cat, &achar, sizeof(char));
2273 auint = UNI_TO_NATIVE(SvUV(fromstr));
2274 SvGROW(cat, SvCUR(cat) + UTF8_MAXBYTES + 1);
2276 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2279 0 : UNICODE_ALLOW_ANY)
2284 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2289 /* VOS does not automatically map a floating-point overflow
2290 during conversion from double to float into infinity, so we
2291 do it by hand. This code should either be generalized for
2292 any OS that needs it, or removed if and when VOS implements
2293 posix-976 (suggestion to support mapping to infinity).
2294 Paul.Green@stratus.com 02-04-02. */
2295 if (SvNV(fromstr) > FLT_MAX)
2296 afloat = _float_constants[0]; /* single prec. inf. */
2297 else if (SvNV(fromstr) < -FLT_MAX)
2298 afloat = _float_constants[0]; /* single prec. inf. */
2299 else afloat = (float)SvNV(fromstr);
2301 # if defined(VMS) && !defined(__IEEE_FP)
2302 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2303 * on Alpha; fake it if we don't have them.
2305 if (SvNV(fromstr) > FLT_MAX)
2307 else if (SvNV(fromstr) < -FLT_MAX)
2309 else afloat = (float)SvNV(fromstr);
2311 afloat = (float)SvNV(fromstr);
2314 DO_BO_PACK_N(afloat, float);
2315 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2322 /* VOS does not automatically map a floating-point overflow
2323 during conversion from long double to double into infinity,
2324 so we do it by hand. This code should either be generalized
2325 for any OS that needs it, or removed if and when VOS
2326 implements posix-976 (suggestion to support mapping to
2327 infinity). Paul.Green@stratus.com 02-04-02. */
2328 if (SvNV(fromstr) > DBL_MAX)
2329 adouble = _double_constants[0]; /* double prec. inf. */
2330 else if (SvNV(fromstr) < -DBL_MAX)
2331 adouble = _double_constants[0]; /* double prec. inf. */
2332 else adouble = (double)SvNV(fromstr);
2334 # if defined(VMS) && !defined(__IEEE_FP)
2335 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2336 * on Alpha; fake it if we don't have them.
2338 if (SvNV(fromstr) > DBL_MAX)
2340 else if (SvNV(fromstr) < -DBL_MAX)
2342 else adouble = (double)SvNV(fromstr);
2344 adouble = (double)SvNV(fromstr);
2347 DO_BO_PACK_N(adouble, double);
2348 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2352 Zero(&anv, 1, NV); /* can be long double with unused bits */
2355 anv = SvNV(fromstr);
2356 DO_BO_PACK_N(anv, NV);
2357 sv_catpvn(cat, (char *)&anv, NVSIZE);
2360 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2362 /* long doubles can have unused bits, which may be nonzero */
2363 Zero(&aldouble, 1, long double);
2366 aldouble = (long double)SvNV(fromstr);
2367 DO_BO_PACK_N(aldouble, long double);
2368 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2372 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2373 case 'n' | TYPE_IS_SHRIEKING:
2378 ai16 = (I16)SvIV(fromstr);
2380 ai16 = PerlSock_htons(ai16);
2385 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2386 case 'v' | TYPE_IS_SHRIEKING:
2391 ai16 = (I16)SvIV(fromstr);
2398 case 'S' | TYPE_IS_SHRIEKING:
2399 #if SHORTSIZE != SIZE16
2403 aushort = SvUV(fromstr);
2404 DO_BO_PACK(aushort, s);
2405 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2416 au16 = (U16)SvUV(fromstr);
2417 DO_BO_PACK(au16, 16);
2423 case 's' | TYPE_IS_SHRIEKING:
2424 #if SHORTSIZE != SIZE16
2428 ashort = SvIV(fromstr);
2429 DO_BO_PACK(ashort, s);
2430 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2440 ai16 = (I16)SvIV(fromstr);
2441 DO_BO_PACK(ai16, 16);
2446 case 'I' | TYPE_IS_SHRIEKING:
2449 auint = SvUV(fromstr);
2450 DO_BO_PACK(auint, i);
2451 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2457 aiv = SvIV(fromstr);
2458 #if IVSIZE == INTSIZE
2460 #elif IVSIZE == LONGSIZE
2462 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2463 DO_BO_PACK(aiv, 64);
2465 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2471 auv = SvUV(fromstr);
2472 #if UVSIZE == INTSIZE
2474 #elif UVSIZE == LONGSIZE
2476 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2477 DO_BO_PACK(auv, 64);
2479 sv_catpvn(cat, (char*)&auv, UVSIZE);
2485 anv = SvNV(fromstr);
2488 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2490 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2491 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2492 any negative IVs will have already been got by the croak()
2493 above. IOK is untrue for fractions, so we test them
2494 against UV_MAX_P1. */
2495 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2497 char buf[(sizeof(UV)*8)/7+1];
2498 char *in = buf + sizeof(buf);
2499 UV auv = SvUV(fromstr);
2502 *--in = (char)((auv & 0x7f) | 0x80);
2505 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2506 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2508 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2509 char *from, *result, *in;
2514 /* Copy string and check for compliance */
2515 from = SvPV(fromstr, len);
2516 if ((norm = is_an_int(from, len)) == NULL)
2517 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2519 New('w', result, len, char);
2523 *--in = div128(norm, &done) | 0x80;
2524 result[len - 1] &= 0x7F; /* clear continue bit */
2525 sv_catpvn(cat, in, (result + len) - in);
2527 SvREFCNT_dec(norm); /* free norm */
2529 else if (SvNOKp(fromstr)) {
2530 /* 10**NV_MAX_10_EXP is the largest power of 10
2531 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2532 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2533 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2534 And with that many bytes only Inf can overflow.
2535 Some C compilers are strict about integral constant
2536 expressions so we conservatively divide by a slightly
2537 smaller integer instead of multiplying by the exact
2538 floating-point value.
2540 #ifdef NV_MAX_10_EXP
2541 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2542 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2544 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2545 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2547 char *in = buf + sizeof(buf);
2549 anv = Perl_floor(anv);
2551 NV next = Perl_floor(anv / 128);
2552 if (in <= buf) /* this cannot happen ;-) */
2553 Perl_croak(aTHX_ "Cannot compress integer in pack");
2554 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2557 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2558 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2561 char *from, *result, *in;
2566 /* Copy string and check for compliance */
2567 from = SvPV(fromstr, len);
2568 if ((norm = is_an_int(from, len)) == NULL)
2569 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2571 New('w', result, len, char);
2575 *--in = div128(norm, &done) | 0x80;
2576 result[len - 1] &= 0x7F; /* clear continue bit */
2577 sv_catpvn(cat, in, (result + len) - in);
2579 SvREFCNT_dec(norm); /* free norm */
2584 case 'i' | TYPE_IS_SHRIEKING:
2587 aint = SvIV(fromstr);
2588 DO_BO_PACK(aint, i);
2589 sv_catpvn(cat, (char*)&aint, sizeof(int));
2592 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2593 case 'N' | TYPE_IS_SHRIEKING:
2598 au32 = SvUV(fromstr);
2600 au32 = PerlSock_htonl(au32);
2605 #ifdef PERL_PACK_CAN_SHRIEKSIGN
2606 case 'V' | TYPE_IS_SHRIEKING:
2611 au32 = SvUV(fromstr);
2618 case 'L' | TYPE_IS_SHRIEKING:
2619 #if LONGSIZE != SIZE32
2623 aulong = SvUV(fromstr);
2624 DO_BO_PACK(aulong, l);
2625 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2636 au32 = SvUV(fromstr);
2637 DO_BO_PACK(au32, 32);
2642 case 'l' | TYPE_IS_SHRIEKING:
2643 #if LONGSIZE != SIZE32
2647 along = SvIV(fromstr);
2648 DO_BO_PACK(along, l);
2649 sv_catpvn(cat, (char *)&along, sizeof(long));
2659 ai32 = SvIV(fromstr);
2660 DO_BO_PACK(ai32, 32);
2668 auquad = (Uquad_t)SvUV(fromstr);
2669 DO_BO_PACK(auquad, 64);
2670 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2676 aquad = (Quad_t)SvIV(fromstr);
2677 DO_BO_PACK(aquad, 64);
2678 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2683 len = 1; /* assume SV is correct length */
2688 if (fromstr == &PL_sv_undef)
2692 /* XXX better yet, could spirit away the string to
2693 * a safe spot and hang on to it until the result
2694 * of pack() (and all copies of the result) are
2697 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2698 || (SvPADTMP(fromstr)
2699 && !SvREADONLY(fromstr))))
2701 Perl_warner(aTHX_ packWARN(WARN_PACK),
2702 "Attempt to pack pointer to temporary value");
2704 if (SvPOK(fromstr) || SvNIOK(fromstr))
2705 aptr = SvPV(fromstr,n_a);
2707 aptr = SvPV_force(fromstr,n_a);
2710 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2715 aptr = SvPV(fromstr, fromlen);
2716 SvGROW(cat, fromlen * 4 / 3);
2721 while (fromlen > 0) {
2724 if ((I32)fromlen > len)
2728 doencodes(cat, aptr, todo);
2734 *symptr = lookahead;
2743 dSP; dMARK; dORIGMARK; dTARGET;
2744 register SV *cat = TARG;
2746 register char *pat = SvPVx(*++MARK, fromlen);
2747 register char *patend = pat + fromlen;
2750 sv_setpvn(cat, "", 0);
2752 packlist(cat, pat, patend, MARK, SP + 1);
2762 * c-indentation-style: bsd
2764 * indent-tabs-mode: t
2767 * vim: shiftwidth=4: