3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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,
20 #define PERL_IN_PP_PACK_C
24 * Offset for integer pack/unpack.
26 * On architectures where I16 and I32 aren't really 16 and 32 bits,
27 * which for now are all Crays, pack and unpack have to play games.
31 * These values are required for portability of pack() output.
32 * If they're not right on your machine, then pack() and unpack()
33 * wouldn't work right anyway; you'll need to apply the Cray hack.
34 * (I'd like to check them with #if, but you can't use sizeof() in
35 * the preprocessor.) --???
38 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
39 defines are now in config.h. --Andy Dougherty April 1998
44 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
47 #if U16SIZE > SIZE16 || U32SIZE > SIZE32
48 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
49 # define OFF16(p) (char*)(p)
50 # define OFF32(p) (char*)(p)
52 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
53 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
54 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
56 }}}} bad cray byte order
59 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
60 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
61 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
62 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
63 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
65 # define COPY16(s,p) Copy(s, p, SIZE16, char)
66 # define COPY32(s,p) Copy(s, p, SIZE32, char)
67 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
68 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
69 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
72 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
73 #define MAX_SUB_TEMPLATE_LEVEL 100
75 /* flags (note that type modifiers can also be used as flags!) */
76 #define FLAG_UNPACK_ONLY_ONE 0x10
77 #define FLAG_UNPACK_DO_UTF8 0x08
78 #define FLAG_SLASH 0x04
79 #define FLAG_COMMA 0x02
80 #define FLAG_PACK 0x01
83 S_mul128(pTHX_ SV *sv, U8 m)
86 char *s = SvPV(sv, len);
90 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
91 SV *tmpNew = newSVpvn("0000000000", 10);
94 SvREFCNT_dec(sv); /* free old sv */
99 while (!*t) /* trailing '\0'? */
102 i = ((*t - '0') << 7) + m;
103 *(t--) = '0' + (char)(i % 10);
109 /* Explosives and implosives. */
111 #if 'I' == 73 && 'J' == 74
112 /* On an ASCII/ISO kind of system */
113 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
116 Some other sort of character set - use memchr() so we don't match
119 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
123 #define TYPE_IS_SHRIEKING 0x100
124 #define TYPE_IS_BIG_ENDIAN 0x200
125 #define TYPE_IS_LITTLE_ENDIAN 0x400
126 #define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
127 #define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK)
128 #define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK)
129 #define TYPE_MODIFIERS(t) ((t) & ~0xFF)
130 #define TYPE_NO_MODIFIERS(t) ((t) & 0xFF)
132 #define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP("
134 #define DO_BO_UNPACK(var, type) \
136 switch (TYPE_ENDIANNESS(datumtype)) { \
137 case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \
138 case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \
143 #define DO_BO_PACK(var, type) \
145 switch (TYPE_ENDIANNESS(datumtype)) { \
146 case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \
147 case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \
152 #define DO_BO_UNPACK_PTR(var, type, pre_cast) \
154 switch (TYPE_ENDIANNESS(datumtype)) { \
155 case TYPE_IS_BIG_ENDIAN: \
156 var = (void *) my_betoh ## type ((pre_cast) var); \
158 case TYPE_IS_LITTLE_ENDIAN: \
159 var = (void *) my_letoh ## type ((pre_cast) var); \
166 #define DO_BO_PACK_PTR(var, type, pre_cast) \
168 switch (TYPE_ENDIANNESS(datumtype)) { \
169 case TYPE_IS_BIG_ENDIAN: \
170 var = (void *) my_htobe ## type ((pre_cast) var); \
172 case TYPE_IS_LITTLE_ENDIAN: \
173 var = (void *) my_htole ## type ((pre_cast) var); \
180 #define BO_CANT_DOIT(action, type) \
182 switch (TYPE_ENDIANNESS(datumtype)) { \
183 case TYPE_IS_BIG_ENDIAN: \
184 Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \
185 "platform", #action, #type); \
187 case TYPE_IS_LITTLE_ENDIAN: \
188 Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \
189 "platform", #action, #type); \
196 #if PTRSIZE == INTSIZE
197 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, i, int)
198 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, i, int)
199 #elif PTRSIZE == LONGSIZE
200 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long)
201 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long)
203 # define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer)
204 # define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer)
207 #if defined(my_htolen) && defined(my_letohn) && \
208 defined(my_htoben) && defined(my_betohn)
209 # define DO_BO_UNPACK_N(var, type) \
211 switch (TYPE_ENDIANNESS(datumtype)) { \
212 case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\
213 case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
218 # define DO_BO_PACK_N(var, type) \
220 switch (TYPE_ENDIANNESS(datumtype)) { \
221 case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\
222 case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
227 # define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type)
228 # define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type)
231 /* Returns the sizeof() struct described by pat */
233 S_measure_struct(pTHX_ register tempsym_t* symptr)
235 register I32 len = 0;
236 register I32 total = 0;
241 while (next_symbol(symptr)) {
243 switch( symptr->howlen ){
246 len = symptr->length;
249 Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
250 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
254 /* endianness doesn't influence the size of a type */
255 switch(TYPE_NO_ENDIANNESS(symptr->code)) {
257 Perl_croak(aTHX_ "Invalid type '%c' in %s",
258 (int)TYPE_NO_MODIFIERS(symptr->code),
259 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
262 case 'U': /* XXXX Is it correct? */
265 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
267 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
273 tempsym_t savsym = *symptr;
274 symptr->patptr = savsym.grpbeg;
275 symptr->patend = savsym.grpend;
276 /* XXXX Theoretically, we need to measure many times at different
277 positions, since the subexpression may contain
278 alignment commands, but be not of aligned length.
279 Need to detect this and croak(). */
280 size = measure_struct(symptr);
284 case 'X' | TYPE_IS_SHRIEKING:
285 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */
286 if (!len) /* Avoid division by 0 */
288 len = total % len; /* Assumed: the start is aligned. */
293 Perl_croak(aTHX_ "'X' outside of string in %s",
294 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
296 case 'x' | TYPE_IS_SHRIEKING:
297 if (!len) /* Avoid division by 0 */
299 star = total % len; /* Assumed: the start is aligned. */
300 if (star) /* Other portable ways? */
323 case 's' | TYPE_IS_SHRIEKING:
324 #if SHORTSIZE != SIZE16
325 size = sizeof(short);
333 case 'S' | TYPE_IS_SHRIEKING:
334 #if SHORTSIZE != SIZE16
335 size = sizeof(unsigned short);
340 case 'v' | TYPE_IS_SHRIEKING:
341 case 'n' | TYPE_IS_SHRIEKING:
347 case 'i' | TYPE_IS_SHRIEKING:
351 case 'I' | TYPE_IS_SHRIEKING:
353 size = sizeof(unsigned int);
361 case 'l' | TYPE_IS_SHRIEKING:
362 #if LONGSIZE != SIZE32
371 case 'L' | TYPE_IS_SHRIEKING:
372 #if LONGSIZE != SIZE32
373 size = sizeof(unsigned long);
378 case 'V' | TYPE_IS_SHRIEKING:
379 case 'N' | TYPE_IS_SHRIEKING:
389 size = sizeof(char*);
393 size = sizeof(Quad_t);
396 size = sizeof(Uquad_t);
400 size = sizeof(float);
403 size = sizeof(double);
408 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
410 size = LONG_DOUBLESIZE;
420 /* locate matching closing parenthesis or bracket
421 * returns char pointer to char after match, or NULL
424 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
426 while (patptr < patend) {
434 while (patptr < patend && *patptr != '\n')
438 patptr = group_end(patptr, patend, ')') + 1;
440 patptr = group_end(patptr, patend, ']') + 1;
442 Perl_croak(aTHX_ "No group ending character '%c' found in template",
448 /* Convert unsigned decimal number to binary.
449 * Expects a pointer to the first digit and address of length variable
450 * Advances char pointer to 1st non-digit char and returns number
453 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
455 I32 len = *patptr++ - '0';
456 while (isDIGIT(*patptr)) {
457 if (len >= 0x7FFFFFFF/10)
458 Perl_croak(aTHX_ "pack/unpack repeat count overflow");
459 len = (len * 10) + (*patptr++ - '0');
465 /* The marvellous template parsing routine: Using state stored in *symptr,
466 * locates next template code and count
469 S_next_symbol(pTHX_ register tempsym_t* symptr )
471 register char* patptr = symptr->patptr;
472 register char* patend = symptr->patend;
474 symptr->flags &= ~FLAG_SLASH;
476 while (patptr < patend) {
477 if (isSPACE(*patptr))
479 else if (*patptr == '#') {
481 while (patptr < patend && *patptr != '\n')
486 /* We should have found a template code */
487 I32 code = *patptr++ & 0xFF;
488 U32 inherited_modifiers = 0;
490 if (code == ','){ /* grandfather in commas but with a warning */
491 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
492 symptr->flags |= FLAG_COMMA;
493 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
494 "Invalid type ',' in %s",
495 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
500 /* for '(', skip to ')' */
502 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
503 Perl_croak(aTHX_ "()-group starts with a count in %s",
504 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
505 symptr->grpbeg = patptr;
506 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
507 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
508 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
509 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
512 /* look for group modifiers to inherit */
513 if (TYPE_ENDIANNESS(symptr->flags)) {
514 if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
515 inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
518 /* look for modifiers */
519 while (patptr < patend) {
524 modifier = TYPE_IS_SHRIEKING;
525 allowed = "sSiIlLxXnNvV";
528 modifier = TYPE_IS_BIG_ENDIAN;
529 allowed = ENDIANNESS_ALLOWED_TYPES;
532 modifier = TYPE_IS_LITTLE_ENDIAN;
533 allowed = ENDIANNESS_ALLOWED_TYPES;
542 if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
543 Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
544 allowed, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
546 if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
547 Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
548 (int) TYPE_NO_MODIFIERS(code),
549 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
550 else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
551 TYPE_ENDIANNESS_MASK)
552 Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
553 *patptr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
555 if (ckWARN(WARN_UNPACK)) {
557 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
558 "Duplicate modifier '%c' after '%c' in %s",
559 *patptr, (int) TYPE_NO_MODIFIERS(code),
560 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
567 /* inherit modifiers */
568 code |= inherited_modifiers;
570 /* look for count and/or / */
571 if (patptr < patend) {
572 if (isDIGIT(*patptr)) {
573 patptr = get_num( patptr, &symptr->length );
574 symptr->howlen = e_number;
576 } else if (*patptr == '*') {
578 symptr->howlen = e_star;
580 } else if (*patptr == '[') {
581 char* lenptr = ++patptr;
582 symptr->howlen = e_number;
583 patptr = group_end( patptr, patend, ']' ) + 1;
584 /* what kind of [] is it? */
585 if (isDIGIT(*lenptr)) {
586 lenptr = get_num( lenptr, &symptr->length );
588 Perl_croak(aTHX_ "Malformed integer in [] in %s",
589 symptr->flags & FLAG_PACK ? "pack" : "unpack");
591 tempsym_t savsym = *symptr;
592 symptr->patend = patptr-1;
593 symptr->patptr = lenptr;
594 savsym.length = measure_struct(symptr);
598 symptr->howlen = e_no_len;
603 while (patptr < patend) {
604 if (isSPACE(*patptr))
606 else if (*patptr == '#') {
608 while (patptr < patend && *patptr != '\n')
613 if (*patptr == '/') {
614 symptr->flags |= FLAG_SLASH;
616 if (patptr < patend &&
617 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
618 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
619 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
625 /* at end - no count, no / */
626 symptr->howlen = e_no_len;
631 symptr->patptr = patptr;
635 symptr->patptr = patptr;
640 =for apidoc unpack_str
642 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
643 and ocnt are not used. This call should not be used, use unpackstring instead.
648 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
650 tempsym_t sym = { 0 };
655 return unpack_rec(&sym, s, s, strend, NULL );
659 =for apidoc unpackstring
661 The engine implementing unpack() Perl function. C<unpackstring> puts the
662 extracted list items on the stack and returns the number of elements.
663 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
668 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
670 tempsym_t sym = { 0 };
675 return unpack_rec(&sym, s, s, strend, NULL );
680 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
684 register I32 len = 0;
685 register I32 bits = 0;
688 I32 start_sp_offset = SP - PL_stack_base;
691 /* These must not be in registers: */
700 #if SHORTSIZE != SIZE16
702 unsigned short aushort;
707 #if LONGSIZE != SIZE32
708 unsigned long aulong;
713 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
714 long double aldouble;
723 const int bits_in_uv = 8 * sizeof(cuv);
726 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
728 while (next_symbol(symptr)) {
729 datumtype = symptr->code;
730 /* do first one only unless in list context
731 / is implemented by unpacking the count, then poping it from the
732 stack, so must check that we're not in the middle of a / */
734 && (SP - PL_stack_base == start_sp_offset + 1)
735 && (datumtype != '/') ) /* XXX can this be omitted */
738 switch( howlen = symptr->howlen ){
741 len = symptr->length;
744 len = strend - strbeg; /* long enough */
749 beyond = s >= strend;
750 switch(TYPE_NO_ENDIANNESS(datumtype)) {
752 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
755 if (howlen == e_no_len)
756 len = 16; /* len is not specified */
764 char *ss = s; /* Move from register */
765 tempsym_t savsym = *symptr;
766 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
767 symptr->flags |= group_modifiers;
768 symptr->patend = savsym.grpend;
772 symptr->patptr = savsym.grpbeg;
773 unpack_rec(symptr, ss, strbeg, strend, &ss );
774 if (ss == strend && savsym.howlen == e_star)
775 break; /* No way to continue */
779 symptr->flags &= ~group_modifiers;
780 savsym.flags = symptr->flags;
785 if (len > strend - strrelbeg)
786 Perl_croak(aTHX_ "'@' outside of string in unpack");
789 case 'X' | TYPE_IS_SHRIEKING:
790 if (!len) /* Avoid division by 0 */
792 len = (s - strbeg) % len;
795 if (len > s - strbeg)
796 Perl_croak(aTHX_ "'X' outside of string in unpack" );
799 case 'x' | TYPE_IS_SHRIEKING:
800 if (!len) /* Avoid division by 0 */
802 aint = (s - strbeg) % len;
803 if (aint) /* Other portable ways? */
809 if (len > strend - s)
810 Perl_croak(aTHX_ "'x' outside of string in unpack");
814 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
819 if (len > strend - s)
824 sv_setpvn(sv, s, len);
825 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
826 aptr = s; /* borrow register */
827 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
831 if (howlen == e_star) /* exact for 'Z*' */
832 len = s - SvPVX(sv) + 1;
834 else { /* 'A' strips both nulls and spaces */
835 s = SvPVX(sv) + len - 1;
836 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
840 SvCUR_set(sv, s - SvPVX(sv));
841 s = aptr; /* unborrow register */
844 XPUSHs(sv_2mortal(sv));
848 if (howlen == e_star || len > (strend - s) * 8)
849 len = (strend - s) * 8;
852 Newz(601, PL_bitcount, 256, char);
853 for (bits = 1; bits < 256; bits++) {
854 if (bits & 1) PL_bitcount[bits]++;
855 if (bits & 2) PL_bitcount[bits]++;
856 if (bits & 4) PL_bitcount[bits]++;
857 if (bits & 8) PL_bitcount[bits]++;
858 if (bits & 16) PL_bitcount[bits]++;
859 if (bits & 32) PL_bitcount[bits]++;
860 if (bits & 64) PL_bitcount[bits]++;
861 if (bits & 128) PL_bitcount[bits]++;
865 cuv += PL_bitcount[*(unsigned char*)s++];
870 if (datumtype == 'b') {
878 if (bits & 128) cuv++;
885 sv = NEWSV(35, len + 1);
889 if (datumtype == 'b') {
891 for (len = 0; len < aint; len++) {
892 if (len & 7) /*SUPPRESS 595*/
896 *str++ = '0' + (bits & 1);
901 for (len = 0; len < aint; len++) {
906 *str++ = '0' + ((bits & 128) != 0);
910 XPUSHs(sv_2mortal(sv));
914 if (howlen == e_star || len > (strend - s) * 2)
915 len = (strend - s) * 2;
916 sv = NEWSV(35, len + 1);
920 if (datumtype == 'h') {
922 for (len = 0; len < aint; len++) {
927 *str++ = PL_hexdigit[bits & 15];
932 for (len = 0; len < aint; len++) {
937 *str++ = PL_hexdigit[(bits >> 4) & 15];
941 XPUSHs(sv_2mortal(sv));
944 if (len > strend - s)
949 if (aint >= 128) /* fake up signed chars */
951 if (checksum > bits_in_uv)
958 if (len && unpack_only_one)
964 if (aint >= 128) /* fake up signed chars */
967 sv_setiv(sv, (IV)aint);
968 PUSHs(sv_2mortal(sv));
973 unpack_C: /* unpack U will jump here if not UTF-8 */
975 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
978 if (len > strend - s)
988 if (len && unpack_only_one)
995 sv_setiv(sv, (IV)auint);
996 PUSHs(sv_2mortal(sv));
1002 symptr->flags |= FLAG_UNPACK_DO_UTF8;
1005 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
1007 if (len > strend - s)
1010 while (len-- > 0 && s < strend) {
1012 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1015 if (checksum > bits_in_uv)
1016 cdouble += (NV)auint;
1022 if (len && unpack_only_one)
1026 while (len-- > 0 && s < strend) {
1028 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1032 sv_setuv(sv, (UV)auint);
1033 PUSHs(sv_2mortal(sv));
1037 case 's' | TYPE_IS_SHRIEKING:
1038 #if SHORTSIZE != SIZE16
1039 along = (strend - s) / sizeof(short);
1044 COPYNN(s, &ashort, sizeof(short));
1045 DO_BO_UNPACK(ashort, s);
1047 if (checksum > bits_in_uv)
1048 cdouble += (NV)ashort;
1054 if (len && unpack_only_one)
1059 COPYNN(s, &ashort, sizeof(short));
1060 DO_BO_UNPACK(ashort, s);
1063 sv_setiv(sv, (IV)ashort);
1064 PUSHs(sv_2mortal(sv));
1072 along = (strend - s) / SIZE16;
1078 DO_BO_UNPACK(ai16, 16);
1079 #if U16SIZE > SIZE16
1084 if (checksum > bits_in_uv)
1085 cdouble += (NV)ai16;
1091 if (len && unpack_only_one)
1098 DO_BO_UNPACK(ai16, 16);
1099 #if U16SIZE > SIZE16
1105 sv_setiv(sv, (IV)ai16);
1106 PUSHs(sv_2mortal(sv));
1110 case 'S' | TYPE_IS_SHRIEKING:
1111 #if SHORTSIZE != SIZE16
1112 along = (strend - s) / sizeof(unsigned short);
1117 COPYNN(s, &aushort, sizeof(unsigned short));
1118 DO_BO_UNPACK(aushort, s);
1119 s += sizeof(unsigned short);
1120 if (checksum > bits_in_uv)
1121 cdouble += (NV)aushort;
1127 if (len && unpack_only_one)
1132 COPYNN(s, &aushort, sizeof(unsigned short));
1133 DO_BO_UNPACK(aushort, s);
1134 s += sizeof(unsigned short);
1136 sv_setiv(sv, (UV)aushort);
1137 PUSHs(sv_2mortal(sv));
1147 along = (strend - s) / SIZE16;
1153 DO_BO_UNPACK(au16, 16);
1156 if (datumtype == 'n')
1157 au16 = PerlSock_ntohs(au16);
1160 if (datumtype == 'v')
1163 if (checksum > bits_in_uv)
1164 cdouble += (NV)au16;
1170 if (len && unpack_only_one)
1176 DO_BO_UNPACK(au16, 16);
1180 if (datumtype == 'n')
1181 au16 = PerlSock_ntohs(au16);
1184 if (datumtype == 'v')
1187 sv_setiv(sv, (UV)au16);
1188 PUSHs(sv_2mortal(sv));
1192 case 'v' | TYPE_IS_SHRIEKING:
1193 case 'n' | TYPE_IS_SHRIEKING:
1194 along = (strend - s) / SIZE16;
1202 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1203 ai16 = (I16)PerlSock_ntohs((U16)ai16);
1206 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1207 ai16 = (I16)vtohs((U16)ai16);
1209 if (checksum > bits_in_uv)
1210 cdouble += (NV)ai16;
1216 if (len && unpack_only_one)
1224 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1225 ai16 = (I16)PerlSock_ntohs((U16)ai16);
1228 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1229 ai16 = (I16)vtohs((U16)ai16);
1232 sv_setiv(sv, (IV)ai16);
1233 PUSHs(sv_2mortal(sv));
1238 case 'i' | TYPE_IS_SHRIEKING:
1239 along = (strend - s) / sizeof(int);
1244 Copy(s, &aint, 1, int);
1245 DO_BO_UNPACK(aint, i);
1247 if (checksum > bits_in_uv)
1248 cdouble += (NV)aint;
1254 if (len && unpack_only_one)
1259 Copy(s, &aint, 1, int);
1260 DO_BO_UNPACK(aint, i);
1264 /* Without the dummy below unpack("i", pack("i",-1))
1265 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
1266 * cc with optimization turned on.
1268 * The bug was detected in
1269 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
1270 * with optimization (-O4) turned on.
1271 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
1272 * does not have this problem even with -O4.
1274 * This bug was reported as DECC_BUGS 1431
1275 * and tracked internally as GEM_BUGS 7775.
1277 * The bug is fixed in
1278 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
1279 * UNIX V4.0F support: DEC C V5.9-006 or later
1280 * UNIX V4.0E support: DEC C V5.8-011 or later
1283 * See also few lines later for the same bug.
1286 sv_setiv(sv, (IV)aint) :
1288 sv_setiv(sv, (IV)aint);
1289 PUSHs(sv_2mortal(sv));
1294 case 'I' | TYPE_IS_SHRIEKING:
1295 along = (strend - s) / sizeof(unsigned int);
1300 Copy(s, &auint, 1, unsigned int);
1301 DO_BO_UNPACK(auint, i);
1302 s += sizeof(unsigned int);
1303 if (checksum > bits_in_uv)
1304 cdouble += (NV)auint;
1310 if (len && unpack_only_one)
1315 Copy(s, &auint, 1, unsigned int);
1316 DO_BO_UNPACK(auint, i);
1317 s += sizeof(unsigned int);
1320 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1321 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1322 * See details few lines earlier. */
1324 sv_setuv(sv, (UV)auint) :
1326 sv_setuv(sv, (UV)auint);
1327 PUSHs(sv_2mortal(sv));
1332 along = (strend - s) / IVSIZE;
1337 Copy(s, &aiv, 1, IV);
1338 #if IVSIZE == INTSIZE
1339 DO_BO_UNPACK(aiv, i);
1340 #elif IVSIZE == LONGSIZE
1341 DO_BO_UNPACK(aiv, l);
1342 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1343 DO_BO_UNPACK(aiv, 64);
1346 if (checksum > bits_in_uv)
1353 if (len && unpack_only_one)
1358 Copy(s, &aiv, 1, IV);
1359 #if IVSIZE == INTSIZE
1360 DO_BO_UNPACK(aiv, i);
1361 #elif IVSIZE == LONGSIZE
1362 DO_BO_UNPACK(aiv, l);
1363 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1364 DO_BO_UNPACK(aiv, 64);
1369 PUSHs(sv_2mortal(sv));
1374 along = (strend - s) / UVSIZE;
1379 Copy(s, &auv, 1, UV);
1380 #if UVSIZE == INTSIZE
1381 DO_BO_UNPACK(auv, i);
1382 #elif UVSIZE == LONGSIZE
1383 DO_BO_UNPACK(auv, l);
1384 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1385 DO_BO_UNPACK(auv, 64);
1388 if (checksum > bits_in_uv)
1395 if (len && unpack_only_one)
1400 Copy(s, &auv, 1, UV);
1401 #if UVSIZE == INTSIZE
1402 DO_BO_UNPACK(auv, i);
1403 #elif UVSIZE == LONGSIZE
1404 DO_BO_UNPACK(auv, l);
1405 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1406 DO_BO_UNPACK(auv, 64);
1411 PUSHs(sv_2mortal(sv));
1415 case 'l' | TYPE_IS_SHRIEKING:
1416 #if LONGSIZE != SIZE32
1417 along = (strend - s) / sizeof(long);
1422 COPYNN(s, &along, sizeof(long));
1423 DO_BO_UNPACK(along, l);
1425 if (checksum > bits_in_uv)
1426 cdouble += (NV)along;
1432 if (len && unpack_only_one)
1437 COPYNN(s, &along, sizeof(long));
1438 DO_BO_UNPACK(along, l);
1441 sv_setiv(sv, (IV)along);
1442 PUSHs(sv_2mortal(sv));
1450 along = (strend - s) / SIZE32;
1456 DO_BO_UNPACK(ai32, 32);
1457 #if U32SIZE > SIZE32
1458 if (ai32 > 2147483647)
1462 if (checksum > bits_in_uv)
1463 cdouble += (NV)ai32;
1469 if (len && unpack_only_one)
1475 DO_BO_UNPACK(ai32, 32);
1476 #if U32SIZE > SIZE32
1477 if (ai32 > 2147483647)
1482 sv_setiv(sv, (IV)ai32);
1483 PUSHs(sv_2mortal(sv));
1487 case 'L' | TYPE_IS_SHRIEKING:
1488 #if LONGSIZE != SIZE32
1489 along = (strend - s) / sizeof(unsigned long);
1494 COPYNN(s, &aulong, sizeof(unsigned long));
1495 DO_BO_UNPACK(aulong, l);
1496 s += sizeof(unsigned long);
1497 if (checksum > bits_in_uv)
1498 cdouble += (NV)aulong;
1504 if (len && unpack_only_one)
1509 COPYNN(s, &aulong, sizeof(unsigned long));
1510 DO_BO_UNPACK(aulong, l);
1511 s += sizeof(unsigned long);
1513 sv_setuv(sv, (UV)aulong);
1514 PUSHs(sv_2mortal(sv));
1524 along = (strend - s) / SIZE32;
1530 DO_BO_UNPACK(au32, 32);
1533 if (datumtype == 'N')
1534 au32 = PerlSock_ntohl(au32);
1537 if (datumtype == 'V')
1540 if (checksum > bits_in_uv)
1541 cdouble += (NV)au32;
1547 if (len && unpack_only_one)
1553 DO_BO_UNPACK(au32, 32);
1556 if (datumtype == 'N')
1557 au32 = PerlSock_ntohl(au32);
1560 if (datumtype == 'V')
1564 sv_setuv(sv, (UV)au32);
1565 PUSHs(sv_2mortal(sv));
1569 case 'V' | TYPE_IS_SHRIEKING:
1570 case 'N' | TYPE_IS_SHRIEKING:
1571 along = (strend - s) / SIZE32;
1579 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1580 ai32 = (I32)PerlSock_ntohl((U32)ai32);
1583 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1584 ai32 = (I32)vtohl((U32)ai32);
1586 if (checksum > bits_in_uv)
1587 cdouble += (NV)ai32;
1593 if (len && unpack_only_one)
1601 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1602 ai32 = (I32)PerlSock_ntohl((U32)ai32);
1605 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1606 ai32 = (I32)vtohl((U32)ai32);
1609 sv_setiv(sv, (IV)ai32);
1610 PUSHs(sv_2mortal(sv));
1615 along = (strend - s) / sizeof(char*);
1621 if (sizeof(char*) > strend - s)
1624 Copy(s, &aptr, 1, char*);
1625 DO_BO_UNPACK_P(aptr);
1631 PUSHs(sv_2mortal(sv));
1635 if (len && unpack_only_one)
1643 while ((len > 0) && (s < strend)) {
1644 auv = (auv << 7) | (*s & 0x7f);
1645 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1646 if ((U8)(*s++) < 0x80) {
1650 PUSHs(sv_2mortal(sv));
1654 else if (++bytes >= sizeof(UV)) { /* promote to string */
1658 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1659 while (s < strend) {
1660 sv = mul128(sv, (U8)(*s & 0x7f));
1661 if (!(*s++ & 0x80)) {
1670 PUSHs(sv_2mortal(sv));
1675 if ((s >= strend) && bytes)
1676 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1680 if (symptr->howlen == e_star)
1681 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1683 if (sizeof(char*) > strend - s)
1686 Copy(s, &aptr, 1, char*);
1687 DO_BO_UNPACK_P(aptr);
1692 sv_setpvn(sv, aptr, len);
1693 PUSHs(sv_2mortal(sv));
1697 along = (strend - s) / sizeof(Quad_t);
1702 Copy(s, &aquad, 1, Quad_t);
1703 DO_BO_UNPACK(aquad, 64);
1704 s += sizeof(Quad_t);
1705 if (checksum > bits_in_uv)
1706 cdouble += (NV)aquad;
1712 if (len && unpack_only_one)
1717 if (s + sizeof(Quad_t) > strend)
1720 Copy(s, &aquad, 1, Quad_t);
1721 DO_BO_UNPACK(aquad, 64);
1722 s += sizeof(Quad_t);
1725 if (aquad >= IV_MIN && aquad <= IV_MAX)
1726 sv_setiv(sv, (IV)aquad);
1728 sv_setnv(sv, (NV)aquad);
1729 PUSHs(sv_2mortal(sv));
1734 along = (strend - s) / sizeof(Uquad_t);
1739 Copy(s, &auquad, 1, Uquad_t);
1740 DO_BO_UNPACK(auquad, 64);
1741 s += sizeof(Uquad_t);
1742 if (checksum > bits_in_uv)
1743 cdouble += (NV)auquad;
1749 if (len && unpack_only_one)
1754 if (s + sizeof(Uquad_t) > strend)
1757 Copy(s, &auquad, 1, Uquad_t);
1758 DO_BO_UNPACK(auquad, 64);
1759 s += sizeof(Uquad_t);
1762 if (auquad <= UV_MAX)
1763 sv_setuv(sv, (UV)auquad);
1765 sv_setnv(sv, (NV)auquad);
1766 PUSHs(sv_2mortal(sv));
1771 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1773 along = (strend - s) / sizeof(float);
1778 Copy(s, &afloat, 1, float);
1779 DO_BO_UNPACK_N(afloat, float);
1785 if (len && unpack_only_one)
1790 Copy(s, &afloat, 1, float);
1791 DO_BO_UNPACK_N(afloat, float);
1794 sv_setnv(sv, (NV)afloat);
1795 PUSHs(sv_2mortal(sv));
1800 along = (strend - s) / sizeof(double);
1805 Copy(s, &adouble, 1, double);
1806 DO_BO_UNPACK_N(adouble, double);
1807 s += sizeof(double);
1812 if (len && unpack_only_one)
1817 Copy(s, &adouble, 1, double);
1818 DO_BO_UNPACK_N(adouble, double);
1819 s += sizeof(double);
1821 sv_setnv(sv, (NV)adouble);
1822 PUSHs(sv_2mortal(sv));
1827 along = (strend - s) / NVSIZE;
1832 Copy(s, &anv, 1, NV);
1833 DO_BO_UNPACK_N(anv, NV);
1839 if (len && unpack_only_one)
1844 Copy(s, &anv, 1, NV);
1845 DO_BO_UNPACK_N(anv, NV);
1849 PUSHs(sv_2mortal(sv));
1853 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1855 along = (strend - s) / LONG_DOUBLESIZE;
1860 Copy(s, &aldouble, 1, long double);
1861 DO_BO_UNPACK_N(aldouble, long double);
1862 s += LONG_DOUBLESIZE;
1863 cdouble += aldouble;
1867 if (len && unpack_only_one)
1872 Copy(s, &aldouble, 1, long double);
1873 DO_BO_UNPACK_N(aldouble, long double);
1874 s += LONG_DOUBLESIZE;
1876 sv_setnv(sv, (NV)aldouble);
1877 PUSHs(sv_2mortal(sv));
1884 * Initialise the decode mapping. By using a table driven
1885 * algorithm, the code will be character-set independent
1886 * (and just as fast as doing character arithmetic)
1888 if (PL_uudmap['M'] == 0) {
1891 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1892 PL_uudmap[(U8)PL_uuemap[i]] = i;
1894 * Because ' ' and '`' map to the same value,
1895 * we need to decode them both the same.
1900 along = (strend - s) * 3 / 4;
1901 sv = NEWSV(42, along);
1904 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1909 len = PL_uudmap[*(U8*)s++] & 077;
1911 if (s < strend && ISUUCHAR(*s))
1912 a = PL_uudmap[*(U8*)s++] & 077;
1915 if (s < strend && ISUUCHAR(*s))
1916 b = PL_uudmap[*(U8*)s++] & 077;
1919 if (s < strend && ISUUCHAR(*s))
1920 c = PL_uudmap[*(U8*)s++] & 077;
1923 if (s < strend && ISUUCHAR(*s))
1924 d = PL_uudmap[*(U8*)s++] & 077;
1927 hunk[0] = (char)((a << 2) | (b >> 4));
1928 hunk[1] = (char)((b << 4) | (c >> 2));
1929 hunk[2] = (char)((c << 6) | d);
1930 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1935 else /* possible checksum byte */
1936 if (s + 1 < strend && s[1] == '\n')
1939 XPUSHs(sv_2mortal(sv));
1945 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1946 (checksum > bits_in_uv &&
1947 strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1950 adouble = (NV) (1 << (checksum & 15));
1951 while (checksum >= 16) {
1955 while (cdouble < 0.0)
1957 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1958 sv_setnv(sv, cdouble);
1961 if (checksum < bits_in_uv) {
1962 UV mask = ((UV)1 << checksum) - 1;
1967 XPUSHs(sv_2mortal(sv));
1971 if (symptr->flags & FLAG_SLASH){
1972 if (SP - PL_stack_base - start_sp_offset <= 0)
1973 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1974 if( next_symbol(symptr) ){
1975 if( symptr->howlen == e_number )
1976 Perl_croak(aTHX_ "Count after length/code in unpack" );
1978 /* ...end of char buffer then no decent length available */
1979 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1981 /* take top of stack (hope it's numeric) */
1984 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1987 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1989 datumtype = symptr->code;
1997 return SP - PL_stack_base - start_sp_offset;
2004 I32 gimme = GIMME_V;
2007 register char *pat = SvPV(left, llen);
2008 #ifdef PACKED_IS_OCTETS
2009 /* Packed side is assumed to be octets - so force downgrade if it
2010 has been UTF-8 encoded by accident
2012 register char *s = SvPVbyte(right, rlen);
2014 register char *s = SvPV(right, rlen);
2016 char *strend = s + rlen;
2017 register char *patend = pat + llen;
2021 cnt = unpackstring(pat, patend, s, strend,
2022 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
2023 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
2026 if ( !cnt && gimme == G_SCALAR )
2027 PUSHs(&PL_sv_undef);
2032 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
2036 *hunk = PL_uuemap[len];
2037 sv_catpvn(sv, hunk, 1);
2040 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
2041 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
2042 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
2043 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
2044 sv_catpvn(sv, hunk, 4);
2049 char r = (len > 1 ? s[1] : '\0');
2050 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
2051 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
2052 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
2053 hunk[3] = PL_uuemap[0];
2054 sv_catpvn(sv, hunk, 4);
2056 sv_catpvn(sv, "\n", 1);
2060 S_is_an_int(pTHX_ char *s, STRLEN l)
2063 SV *result = newSVpvn(s, l);
2064 char *result_c = SvPV(result, n_a); /* convenience */
2065 char *out = result_c;
2075 SvREFCNT_dec(result);
2098 SvREFCNT_dec(result);
2104 SvCUR_set(result, out - result_c);
2108 /* pnum must be '\0' terminated */
2110 S_div128(pTHX_ SV *pnum, bool *done)
2113 char *s = SvPV(pnum, len);
2122 i = m * 10 + (*t - '0');
2124 r = (i >> 7); /* r < 10 */
2131 SvCUR_set(pnum, (STRLEN) (t - s));
2138 =for apidoc pack_cat
2140 The engine implementing pack() Perl function. Note: parameters next_in_list and
2141 flags are not used. This call should not be used; use packlist instead.
2147 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
2149 tempsym_t sym = { 0 };
2151 sym.patend = patend;
2152 sym.flags = FLAG_PACK;
2154 (void)pack_rec( cat, &sym, beglist, endlist );
2159 =for apidoc packlist
2161 The engine implementing pack() Perl function.
2167 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
2169 tempsym_t sym = { 0 };
2171 sym.patend = patend;
2172 sym.flags = FLAG_PACK;
2174 (void)pack_rec( cat, &sym, beglist, endlist );
2180 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
2184 register I32 len = 0;
2187 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
2188 static char *space10 = " ";
2191 /* These must not be in registers: */
2201 #if SHORTSIZE != SIZE16
2203 unsigned short aushort;
2207 #if LONGSIZE != SIZE32
2209 unsigned long aulong;
2214 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2215 long double aldouble;
2221 int strrelbeg = SvCUR(cat);
2222 tempsym_t lookahead;
2224 items = endlist - beglist;
2225 found = next_symbol( symptr );
2227 #ifndef PACKED_IS_OCTETS
2228 if (symptr->level == 0 && found && symptr->code == 'U' ){
2234 SV *lengthcode = Nullsv;
2235 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2237 I32 datumtype = symptr->code;
2240 switch( howlen = symptr->howlen ){
2243 len = symptr->length;
2246 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
2250 /* Look ahead for next symbol. Do we have code/code? */
2251 lookahead = *symptr;
2252 found = next_symbol(&lookahead);
2253 if ( symptr->flags & FLAG_SLASH ) {
2255 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2256 e_star != lookahead.howlen )
2257 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2258 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
2259 ? *beglist : &PL_sv_no)
2260 + (lookahead.code == 'Z' ? 1 : 0)));
2262 Perl_croak(aTHX_ "Code missing after '/' in pack");
2266 switch(TYPE_NO_ENDIANNESS(datumtype)) {
2268 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
2270 Perl_croak(aTHX_ "'%%' may not be used in pack");
2272 len += strrelbeg - SvCUR(cat);
2281 tempsym_t savsym = *symptr;
2282 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2283 symptr->flags |= group_modifiers;
2284 symptr->patend = savsym.grpend;
2287 symptr->patptr = savsym.grpbeg;
2288 beglist = pack_rec(cat, symptr, beglist, endlist );
2289 if (savsym.howlen == e_star && beglist == endlist)
2290 break; /* No way to continue */
2292 symptr->flags &= ~group_modifiers;
2293 lookahead.flags = symptr->flags;
2297 case 'X' | TYPE_IS_SHRIEKING:
2298 if (!len) /* Avoid division by 0 */
2300 len = (SvCUR(cat)) % len;
2304 if ((I32)SvCUR(cat) < len)
2305 Perl_croak(aTHX_ "'X' outside of string in pack");
2309 case 'x' | TYPE_IS_SHRIEKING:
2310 if (!len) /* Avoid division by 0 */
2312 aint = (SvCUR(cat)) % len;
2313 if (aint) /* Other portable ways? */
2322 sv_catpvn(cat, null10, 10);
2325 sv_catpvn(cat, null10, len);
2331 aptr = SvPV(fromstr, fromlen);
2332 if (howlen == e_star) {
2334 if (datumtype == 'Z')
2337 if ((I32)fromlen >= len) {
2338 sv_catpvn(cat, aptr, len);
2339 if (datumtype == 'Z')
2340 *(SvEND(cat)-1) = '\0';
2343 sv_catpvn(cat, aptr, fromlen);
2345 if (datumtype == 'A') {
2347 sv_catpvn(cat, space10, 10);
2350 sv_catpvn(cat, space10, len);
2354 sv_catpvn(cat, null10, 10);
2357 sv_catpvn(cat, null10, len);
2369 str = SvPV(fromstr, fromlen);
2370 if (howlen == e_star)
2373 SvCUR(cat) += (len+7)/8;
2374 SvGROW(cat, SvCUR(cat) + 1);
2375 aptr = SvPVX(cat) + aint;
2376 if (len > (I32)fromlen)
2380 if (datumtype == 'B') {
2381 for (len = 0; len++ < aint;) {
2382 items |= *str++ & 1;
2386 *aptr++ = items & 0xff;
2392 for (len = 0; len++ < aint;) {
2398 *aptr++ = items & 0xff;
2404 if (datumtype == 'B')
2405 items <<= 7 - (aint & 7);
2407 items >>= 7 - (aint & 7);
2408 *aptr++ = items & 0xff;
2410 str = SvPVX(cat) + SvCUR(cat);
2425 str = SvPV(fromstr, fromlen);
2426 if (howlen == e_star)
2429 SvCUR(cat) += (len+1)/2;
2430 SvGROW(cat, SvCUR(cat) + 1);
2431 aptr = SvPVX(cat) + aint;
2432 if (len > (I32)fromlen)
2436 if (datumtype == 'H') {
2437 for (len = 0; len++ < aint;) {
2439 items |= ((*str++ & 15) + 9) & 15;
2441 items |= *str++ & 15;
2445 *aptr++ = items & 0xff;
2451 for (len = 0; len++ < aint;) {
2453 items |= (((*str++ & 15) + 9) & 15) << 4;
2455 items |= (*str++ & 15) << 4;
2459 *aptr++ = items & 0xff;
2465 *aptr++ = items & 0xff;
2466 str = SvPVX(cat) + SvCUR(cat);
2477 switch (TYPE_NO_MODIFIERS(datumtype)) {
2479 aint = SvIV(fromstr);
2480 if ((aint < 0 || aint > 255) &&
2482 Perl_warner(aTHX_ packWARN(WARN_PACK),
2483 "Character in 'C' format wrapped in pack");
2485 sv_catpvn(cat, &achar, sizeof(char));
2488 aint = SvIV(fromstr);
2489 if ((aint < -128 || aint > 127) &&
2491 Perl_warner(aTHX_ packWARN(WARN_PACK),
2492 "Character in 'c' format wrapped in pack" );
2494 sv_catpvn(cat, &achar, sizeof(char));
2502 auint = UNI_TO_NATIVE(SvUV(fromstr));
2503 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2505 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2508 0 : UNICODE_ALLOW_ANY)
2513 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2518 /* VOS does not automatically map a floating-point overflow
2519 during conversion from double to float into infinity, so we
2520 do it by hand. This code should either be generalized for
2521 any OS that needs it, or removed if and when VOS implements
2522 posix-976 (suggestion to support mapping to infinity).
2523 Paul.Green@stratus.com 02-04-02. */
2524 if (SvNV(fromstr) > FLT_MAX)
2525 afloat = _float_constants[0]; /* single prec. inf. */
2526 else if (SvNV(fromstr) < -FLT_MAX)
2527 afloat = _float_constants[0]; /* single prec. inf. */
2528 else afloat = (float)SvNV(fromstr);
2530 # if defined(VMS) && !defined(__IEEE_FP)
2531 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2532 * on Alpha; fake it if we don't have them.
2534 if (SvNV(fromstr) > FLT_MAX)
2536 else if (SvNV(fromstr) < -FLT_MAX)
2538 else afloat = (float)SvNV(fromstr);
2540 afloat = (float)SvNV(fromstr);
2543 DO_BO_PACK_N(afloat, float);
2544 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2551 /* VOS does not automatically map a floating-point overflow
2552 during conversion from long double to double into infinity,
2553 so we do it by hand. This code should either be generalized
2554 for any OS that needs it, or removed if and when VOS
2555 implements posix-976 (suggestion to support mapping to
2556 infinity). Paul.Green@stratus.com 02-04-02. */
2557 if (SvNV(fromstr) > DBL_MAX)
2558 adouble = _double_constants[0]; /* double prec. inf. */
2559 else if (SvNV(fromstr) < -DBL_MAX)
2560 adouble = _double_constants[0]; /* double prec. inf. */
2561 else adouble = (double)SvNV(fromstr);
2563 # if defined(VMS) && !defined(__IEEE_FP)
2564 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2565 * on Alpha; fake it if we don't have them.
2567 if (SvNV(fromstr) > DBL_MAX)
2569 else if (SvNV(fromstr) < -DBL_MAX)
2571 else adouble = (double)SvNV(fromstr);
2573 adouble = (double)SvNV(fromstr);
2576 DO_BO_PACK_N(adouble, double);
2577 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2581 Zero(&anv, 1, NV); /* can be long double with unused bits */
2584 anv = SvNV(fromstr);
2585 DO_BO_PACK_N(anv, NV);
2586 sv_catpvn(cat, (char *)&anv, NVSIZE);
2589 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2591 /* long doubles can have unused bits, which may be nonzero */
2592 Zero(&aldouble, 1, long double);
2595 aldouble = (long double)SvNV(fromstr);
2596 DO_BO_PACK_N(aldouble, long double);
2597 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2601 case 'n' | TYPE_IS_SHRIEKING:
2605 ai16 = (I16)SvIV(fromstr);
2607 ai16 = PerlSock_htons(ai16);
2612 case 'v' | TYPE_IS_SHRIEKING:
2616 ai16 = (I16)SvIV(fromstr);
2623 case 'S' | TYPE_IS_SHRIEKING:
2624 #if SHORTSIZE != SIZE16
2628 aushort = SvUV(fromstr);
2629 DO_BO_PACK(aushort, s);
2630 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2641 au16 = (U16)SvUV(fromstr);
2642 DO_BO_PACK(au16, 16);
2648 case 's' | TYPE_IS_SHRIEKING:
2649 #if SHORTSIZE != SIZE16
2653 ashort = SvIV(fromstr);
2654 DO_BO_PACK(ashort, s);
2655 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2665 ai16 = (I16)SvIV(fromstr);
2666 DO_BO_PACK(ai16, 16);
2671 case 'I' | TYPE_IS_SHRIEKING:
2674 auint = SvUV(fromstr);
2675 DO_BO_PACK(auint, i);
2676 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2682 aiv = SvIV(fromstr);
2683 #if IVSIZE == INTSIZE
2685 #elif IVSIZE == LONGSIZE
2687 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2688 DO_BO_PACK(aiv, 64);
2690 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2696 auv = SvUV(fromstr);
2697 #if UVSIZE == INTSIZE
2699 #elif UVSIZE == LONGSIZE
2701 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2702 DO_BO_PACK(auv, 64);
2704 sv_catpvn(cat, (char*)&auv, UVSIZE);
2710 anv = SvNV(fromstr);
2713 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2715 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2716 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2717 any negative IVs will have already been got by the croak()
2718 above. IOK is untrue for fractions, so we test them
2719 against UV_MAX_P1. */
2720 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2722 char buf[(sizeof(UV)*8)/7+1];
2723 char *in = buf + sizeof(buf);
2724 UV auv = SvUV(fromstr);
2727 *--in = (char)((auv & 0x7f) | 0x80);
2730 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2731 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2733 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2734 char *from, *result, *in;
2739 /* Copy string and check for compliance */
2740 from = SvPV(fromstr, len);
2741 if ((norm = is_an_int(from, len)) == NULL)
2742 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2744 New('w', result, len, char);
2748 *--in = div128(norm, &done) | 0x80;
2749 result[len - 1] &= 0x7F; /* clear continue bit */
2750 sv_catpvn(cat, in, (result + len) - in);
2752 SvREFCNT_dec(norm); /* free norm */
2754 else if (SvNOKp(fromstr)) {
2755 /* 10**NV_MAX_10_EXP is the largest power of 10
2756 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2757 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2758 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2759 And with that many bytes only Inf can overflow.
2760 Some C compilers are strict about integral constant
2761 expressions so we conservatively divide by a slightly
2762 smaller integer instead of multiplying by the exact
2763 floating-point value.
2765 #ifdef NV_MAX_10_EXP
2766 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2767 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2769 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2770 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2772 char *in = buf + sizeof(buf);
2774 anv = Perl_floor(anv);
2776 NV next = Perl_floor(anv / 128);
2777 if (in <= buf) /* this cannot happen ;-) */
2778 Perl_croak(aTHX_ "Cannot compress integer in pack");
2779 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2782 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2783 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2786 char *from, *result, *in;
2791 /* Copy string and check for compliance */
2792 from = SvPV(fromstr, len);
2793 if ((norm = is_an_int(from, len)) == NULL)
2794 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2796 New('w', result, len, char);
2800 *--in = div128(norm, &done) | 0x80;
2801 result[len - 1] &= 0x7F; /* clear continue bit */
2802 sv_catpvn(cat, in, (result + len) - in);
2804 SvREFCNT_dec(norm); /* free norm */
2809 case 'i' | TYPE_IS_SHRIEKING:
2812 aint = SvIV(fromstr);
2813 DO_BO_PACK(aint, i);
2814 sv_catpvn(cat, (char*)&aint, sizeof(int));
2817 case 'N' | TYPE_IS_SHRIEKING:
2821 au32 = SvUV(fromstr);
2823 au32 = PerlSock_htonl(au32);
2828 case 'V' | TYPE_IS_SHRIEKING:
2832 au32 = SvUV(fromstr);
2839 case 'L' | TYPE_IS_SHRIEKING:
2840 #if LONGSIZE != SIZE32
2844 aulong = SvUV(fromstr);
2845 DO_BO_PACK(aulong, l);
2846 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2857 au32 = SvUV(fromstr);
2858 DO_BO_PACK(au32, 32);
2863 case 'l' | TYPE_IS_SHRIEKING:
2864 #if LONGSIZE != SIZE32
2868 along = SvIV(fromstr);
2869 DO_BO_PACK(along, l);
2870 sv_catpvn(cat, (char *)&along, sizeof(long));
2880 ai32 = SvIV(fromstr);
2881 DO_BO_PACK(ai32, 32);
2889 auquad = (Uquad_t)SvUV(fromstr);
2890 DO_BO_PACK(auquad, 64);
2891 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2897 aquad = (Quad_t)SvIV(fromstr);
2898 DO_BO_PACK(aquad, 64);
2899 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2904 len = 1; /* assume SV is correct length */
2909 if (fromstr == &PL_sv_undef)
2913 /* XXX better yet, could spirit away the string to
2914 * a safe spot and hang on to it until the result
2915 * of pack() (and all copies of the result) are
2918 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2919 || (SvPADTMP(fromstr)
2920 && !SvREADONLY(fromstr))))
2922 Perl_warner(aTHX_ packWARN(WARN_PACK),
2923 "Attempt to pack pointer to temporary value");
2925 if (SvPOK(fromstr) || SvNIOK(fromstr))
2926 aptr = SvPV(fromstr,n_a);
2928 aptr = SvPV_force(fromstr,n_a);
2931 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2936 aptr = SvPV(fromstr, fromlen);
2937 SvGROW(cat, fromlen * 4 / 3);
2942 while (fromlen > 0) {
2945 if ((I32)fromlen > len)
2949 doencodes(cat, aptr, todo);
2955 *symptr = lookahead;
2964 dSP; dMARK; dORIGMARK; dTARGET;
2965 register SV *cat = TARG;
2967 register char *pat = SvPVx(*++MARK, fromlen);
2968 register char *patend = pat + fromlen;
2971 sv_setpvn(cat, "", 0);
2973 packlist(cat, pat, patend, MARK, SP + 1);