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,
19 /* This file contains pp ("push/pop") functions that
20 * execute the opcodes that make up a perl program. A typical pp function
21 * expects to find its arguments on the stack, and usually pushes its
22 * results onto the stack, hence the 'pp' terminology. Each OP structure
23 * contains a pointer to the relevant pp_foo() function.
25 * This particular file just contains pp_pack() and pp_unpack(). See the
26 * other pp*.c files for the rest of the pp_ functions.
31 #define PERL_IN_PP_PACK_C
35 * Offset for integer pack/unpack.
37 * On architectures where I16 and I32 aren't really 16 and 32 bits,
38 * which for now are all Crays, pack and unpack have to play games.
42 * These values are required for portability of pack() output.
43 * If they're not right on your machine, then pack() and unpack()
44 * wouldn't work right anyway; you'll need to apply the Cray hack.
45 * (I'd like to check them with #if, but you can't use sizeof() in
46 * the preprocessor.) --???
49 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
50 defines are now in config.h. --Andy Dougherty April 1998
55 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
58 #if U16SIZE > SIZE16 || U32SIZE > SIZE32
59 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
76 # define COPY16(s,p) Copy(s, p, SIZE16, char)
77 # define COPY32(s,p) Copy(s, p, SIZE32, char)
78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
83 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
84 #define MAX_SUB_TEMPLATE_LEVEL 100
86 /* flags (note that type modifiers can also be used as flags!) */
87 #define FLAG_UNPACK_ONLY_ONE 0x10
88 #define FLAG_UNPACK_DO_UTF8 0x08
89 #define FLAG_SLASH 0x04
90 #define FLAG_COMMA 0x02
91 #define FLAG_PACK 0x01
94 S_mul128(pTHX_ SV *sv, U8 m)
97 char *s = SvPV(sv, len);
101 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
102 SV *tmpNew = newSVpvn("0000000000", 10);
104 sv_catsv(tmpNew, sv);
105 SvREFCNT_dec(sv); /* free old sv */
110 while (!*t) /* trailing '\0'? */
113 i = ((*t - '0') << 7) + m;
114 *(t--) = '0' + (char)(i % 10);
120 /* Explosives and implosives. */
122 #if 'I' == 73 && 'J' == 74
123 /* On an ASCII/ISO kind of system */
124 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
127 Some other sort of character set - use memchr() so we don't match
130 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
134 #define TYPE_IS_SHRIEKING 0x100
135 #define TYPE_IS_BIG_ENDIAN 0x200
136 #define TYPE_IS_LITTLE_ENDIAN 0x400
137 #define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
138 #define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK)
139 #define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK)
140 #define TYPE_MODIFIERS(t) ((t) & ~0xFF)
141 #define TYPE_NO_MODIFIERS(t) ((t) & 0xFF)
143 #define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP("
145 #define DO_BO_UNPACK(var, type) \
147 switch (TYPE_ENDIANNESS(datumtype)) { \
148 case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \
149 case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \
154 #define DO_BO_PACK(var, type) \
156 switch (TYPE_ENDIANNESS(datumtype)) { \
157 case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \
158 case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \
163 #define DO_BO_UNPACK_PTR(var, type, pre_cast) \
165 switch (TYPE_ENDIANNESS(datumtype)) { \
166 case TYPE_IS_BIG_ENDIAN: \
167 var = (void *) my_betoh ## type ((pre_cast) var); \
169 case TYPE_IS_LITTLE_ENDIAN: \
170 var = (void *) my_letoh ## type ((pre_cast) var); \
177 #define DO_BO_PACK_PTR(var, type, pre_cast) \
179 switch (TYPE_ENDIANNESS(datumtype)) { \
180 case TYPE_IS_BIG_ENDIAN: \
181 var = (void *) my_htobe ## type ((pre_cast) var); \
183 case TYPE_IS_LITTLE_ENDIAN: \
184 var = (void *) my_htole ## type ((pre_cast) var); \
191 #define BO_CANT_DOIT(action, type) \
193 switch (TYPE_ENDIANNESS(datumtype)) { \
194 case TYPE_IS_BIG_ENDIAN: \
195 Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \
196 "platform", #action, #type); \
198 case TYPE_IS_LITTLE_ENDIAN: \
199 Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \
200 "platform", #action, #type); \
207 #if PTRSIZE == INTSIZE
208 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, i, int)
209 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, i, int)
210 #elif PTRSIZE == LONGSIZE
211 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long)
212 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long)
214 # define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer)
215 # define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer)
218 #if defined(my_htolen) && defined(my_letohn) && \
219 defined(my_htoben) && defined(my_betohn)
220 # define DO_BO_UNPACK_N(var, type) \
222 switch (TYPE_ENDIANNESS(datumtype)) { \
223 case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\
224 case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
229 # define DO_BO_PACK_N(var, type) \
231 switch (TYPE_ENDIANNESS(datumtype)) { \
232 case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\
233 case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
238 # define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type)
239 # define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type)
242 /* Returns the sizeof() struct described by pat */
244 S_measure_struct(pTHX_ register tempsym_t* symptr)
246 register I32 len = 0;
247 register I32 total = 0;
252 while (next_symbol(symptr)) {
254 switch( symptr->howlen ){
257 len = symptr->length;
260 Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
261 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
265 /* endianness doesn't influence the size of a type */
266 switch(TYPE_NO_ENDIANNESS(symptr->code)) {
268 Perl_croak(aTHX_ "Invalid type '%c' in %s",
269 (int)TYPE_NO_MODIFIERS(symptr->code),
270 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
273 case 'U': /* XXXX Is it correct? */
276 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
278 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
284 tempsym_t savsym = *symptr;
285 symptr->patptr = savsym.grpbeg;
286 symptr->patend = savsym.grpend;
287 /* XXXX Theoretically, we need to measure many times at different
288 positions, since the subexpression may contain
289 alignment commands, but be not of aligned length.
290 Need to detect this and croak(). */
291 size = measure_struct(symptr);
295 case 'X' | TYPE_IS_SHRIEKING:
296 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */
297 if (!len) /* Avoid division by 0 */
299 len = total % len; /* Assumed: the start is aligned. */
304 Perl_croak(aTHX_ "'X' outside of string in %s",
305 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
307 case 'x' | TYPE_IS_SHRIEKING:
308 if (!len) /* Avoid division by 0 */
310 star = total % len; /* Assumed: the start is aligned. */
311 if (star) /* Other portable ways? */
334 case 's' | TYPE_IS_SHRIEKING:
335 #if SHORTSIZE != SIZE16
336 size = sizeof(short);
344 case 'S' | TYPE_IS_SHRIEKING:
345 #if SHORTSIZE != SIZE16
346 size = sizeof(unsigned short);
351 case 'v' | TYPE_IS_SHRIEKING:
352 case 'n' | TYPE_IS_SHRIEKING:
358 case 'i' | TYPE_IS_SHRIEKING:
362 case 'I' | TYPE_IS_SHRIEKING:
364 size = sizeof(unsigned int);
372 case 'l' | TYPE_IS_SHRIEKING:
373 #if LONGSIZE != SIZE32
382 case 'L' | TYPE_IS_SHRIEKING:
383 #if LONGSIZE != SIZE32
384 size = sizeof(unsigned long);
389 case 'V' | TYPE_IS_SHRIEKING:
390 case 'N' | TYPE_IS_SHRIEKING:
400 size = sizeof(char*);
404 size = sizeof(Quad_t);
407 size = sizeof(Uquad_t);
411 size = sizeof(float);
414 size = sizeof(double);
419 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
421 size = LONG_DOUBLESIZE;
431 /* locate matching closing parenthesis or bracket
432 * returns char pointer to char after match, or NULL
435 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
437 while (patptr < patend) {
445 while (patptr < patend && *patptr != '\n')
449 patptr = group_end(patptr, patend, ')') + 1;
451 patptr = group_end(patptr, patend, ']') + 1;
453 Perl_croak(aTHX_ "No group ending character '%c' found in template",
459 /* Convert unsigned decimal number to binary.
460 * Expects a pointer to the first digit and address of length variable
461 * Advances char pointer to 1st non-digit char and returns number
464 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
466 I32 len = *patptr++ - '0';
467 while (isDIGIT(*patptr)) {
468 if (len >= 0x7FFFFFFF/10)
469 Perl_croak(aTHX_ "pack/unpack repeat count overflow");
470 len = (len * 10) + (*patptr++ - '0');
476 /* The marvellous template parsing routine: Using state stored in *symptr,
477 * locates next template code and count
480 S_next_symbol(pTHX_ register tempsym_t* symptr )
482 register char* patptr = symptr->patptr;
483 register char* patend = symptr->patend;
485 symptr->flags &= ~FLAG_SLASH;
487 while (patptr < patend) {
488 if (isSPACE(*patptr))
490 else if (*patptr == '#') {
492 while (patptr < patend && *patptr != '\n')
497 /* We should have found a template code */
498 I32 code = *patptr++ & 0xFF;
499 U32 inherited_modifiers = 0;
501 if (code == ','){ /* grandfather in commas but with a warning */
502 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
503 symptr->flags |= FLAG_COMMA;
504 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
505 "Invalid type ',' in %s",
506 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
511 /* for '(', skip to ')' */
513 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
514 Perl_croak(aTHX_ "()-group starts with a count in %s",
515 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
516 symptr->grpbeg = patptr;
517 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
518 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
519 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
520 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
523 /* look for group modifiers to inherit */
524 if (TYPE_ENDIANNESS(symptr->flags)) {
525 if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
526 inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
529 /* look for modifiers */
530 while (patptr < patend) {
535 modifier = TYPE_IS_SHRIEKING;
536 allowed = "sSiIlLxXnNvV";
539 modifier = TYPE_IS_BIG_ENDIAN;
540 allowed = ENDIANNESS_ALLOWED_TYPES;
543 modifier = TYPE_IS_LITTLE_ENDIAN;
544 allowed = ENDIANNESS_ALLOWED_TYPES;
553 if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
554 Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
555 allowed, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
557 if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
558 Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
559 (int) TYPE_NO_MODIFIERS(code),
560 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
561 else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
562 TYPE_ENDIANNESS_MASK)
563 Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
564 *patptr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
566 if (ckWARN(WARN_UNPACK)) {
568 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
569 "Duplicate modifier '%c' after '%c' in %s",
570 *patptr, (int) TYPE_NO_MODIFIERS(code),
571 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
578 /* inherit modifiers */
579 code |= inherited_modifiers;
581 /* look for count and/or / */
582 if (patptr < patend) {
583 if (isDIGIT(*patptr)) {
584 patptr = get_num( patptr, &symptr->length );
585 symptr->howlen = e_number;
587 } else if (*patptr == '*') {
589 symptr->howlen = e_star;
591 } else if (*patptr == '[') {
592 char* lenptr = ++patptr;
593 symptr->howlen = e_number;
594 patptr = group_end( patptr, patend, ']' ) + 1;
595 /* what kind of [] is it? */
596 if (isDIGIT(*lenptr)) {
597 lenptr = get_num( lenptr, &symptr->length );
599 Perl_croak(aTHX_ "Malformed integer in [] in %s",
600 symptr->flags & FLAG_PACK ? "pack" : "unpack");
602 tempsym_t savsym = *symptr;
603 symptr->patend = patptr-1;
604 symptr->patptr = lenptr;
605 savsym.length = measure_struct(symptr);
609 symptr->howlen = e_no_len;
614 while (patptr < patend) {
615 if (isSPACE(*patptr))
617 else if (*patptr == '#') {
619 while (patptr < patend && *patptr != '\n')
624 if (*patptr == '/') {
625 symptr->flags |= FLAG_SLASH;
627 if (patptr < patend &&
628 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
629 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
630 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
636 /* at end - no count, no / */
637 symptr->howlen = e_no_len;
642 symptr->patptr = patptr;
646 symptr->patptr = patptr;
651 =for apidoc unpack_str
653 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
654 and ocnt are not used. This call should not be used, use unpackstring instead.
659 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
661 tempsym_t sym = { 0 };
666 return unpack_rec(&sym, s, s, strend, NULL );
670 =for apidoc unpackstring
672 The engine implementing unpack() Perl function. C<unpackstring> puts the
673 extracted list items on the stack and returns the number of elements.
674 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
679 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
681 tempsym_t sym = { 0 };
686 return unpack_rec(&sym, s, s, strend, NULL );
691 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
695 register I32 len = 0;
696 register I32 bits = 0;
699 I32 start_sp_offset = SP - PL_stack_base;
702 /* These must not be in registers: */
711 #if SHORTSIZE != SIZE16
713 unsigned short aushort;
718 #if LONGSIZE != SIZE32
719 unsigned long aulong;
724 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
725 long double aldouble;
734 const int bits_in_uv = 8 * sizeof(cuv);
737 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
739 while (next_symbol(symptr)) {
740 datumtype = symptr->code;
741 /* do first one only unless in list context
742 / is implemented by unpacking the count, then poping it from the
743 stack, so must check that we're not in the middle of a / */
745 && (SP - PL_stack_base == start_sp_offset + 1)
746 && (datumtype != '/') ) /* XXX can this be omitted */
749 switch( howlen = symptr->howlen ){
752 len = symptr->length;
755 len = strend - strbeg; /* long enough */
760 beyond = s >= strend;
761 switch(TYPE_NO_ENDIANNESS(datumtype)) {
763 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
766 if (howlen == e_no_len)
767 len = 16; /* len is not specified */
775 char *ss = s; /* Move from register */
776 tempsym_t savsym = *symptr;
777 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
778 symptr->flags |= group_modifiers;
779 symptr->patend = savsym.grpend;
783 symptr->patptr = savsym.grpbeg;
784 unpack_rec(symptr, ss, strbeg, strend, &ss );
785 if (ss == strend && savsym.howlen == e_star)
786 break; /* No way to continue */
790 symptr->flags &= ~group_modifiers;
791 savsym.flags = symptr->flags;
796 if (len > strend - strrelbeg)
797 Perl_croak(aTHX_ "'@' outside of string in unpack");
800 case 'X' | TYPE_IS_SHRIEKING:
801 if (!len) /* Avoid division by 0 */
803 len = (s - strbeg) % len;
806 if (len > s - strbeg)
807 Perl_croak(aTHX_ "'X' outside of string in unpack" );
810 case 'x' | TYPE_IS_SHRIEKING:
811 if (!len) /* Avoid division by 0 */
813 aint = (s - strbeg) % len;
814 if (aint) /* Other portable ways? */
820 if (len > strend - s)
821 Perl_croak(aTHX_ "'x' outside of string in unpack");
825 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
830 if (len > strend - s)
835 sv_setpvn(sv, s, len);
836 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
837 aptr = s; /* borrow register */
838 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
842 if (howlen == e_star) /* exact for 'Z*' */
843 len = s - SvPVX(sv) + 1;
845 else { /* 'A' strips both nulls and spaces */
846 s = SvPVX(sv) + len - 1;
847 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
851 SvCUR_set(sv, s - SvPVX(sv));
852 s = aptr; /* unborrow register */
855 XPUSHs(sv_2mortal(sv));
859 if (howlen == e_star || len > (strend - s) * 8)
860 len = (strend - s) * 8;
863 Newz(601, PL_bitcount, 256, char);
864 for (bits = 1; bits < 256; bits++) {
865 if (bits & 1) PL_bitcount[bits]++;
866 if (bits & 2) PL_bitcount[bits]++;
867 if (bits & 4) PL_bitcount[bits]++;
868 if (bits & 8) PL_bitcount[bits]++;
869 if (bits & 16) PL_bitcount[bits]++;
870 if (bits & 32) PL_bitcount[bits]++;
871 if (bits & 64) PL_bitcount[bits]++;
872 if (bits & 128) PL_bitcount[bits]++;
876 cuv += PL_bitcount[*(unsigned char*)s++];
881 if (datumtype == 'b') {
889 if (bits & 128) cuv++;
896 sv = NEWSV(35, len + 1);
900 if (datumtype == 'b') {
902 for (len = 0; len < aint; len++) {
903 if (len & 7) /*SUPPRESS 595*/
907 *str++ = '0' + (bits & 1);
912 for (len = 0; len < aint; len++) {
917 *str++ = '0' + ((bits & 128) != 0);
921 XPUSHs(sv_2mortal(sv));
925 if (howlen == e_star || len > (strend - s) * 2)
926 len = (strend - s) * 2;
927 sv = NEWSV(35, len + 1);
931 if (datumtype == 'h') {
933 for (len = 0; len < aint; len++) {
938 *str++ = PL_hexdigit[bits & 15];
943 for (len = 0; len < aint; len++) {
948 *str++ = PL_hexdigit[(bits >> 4) & 15];
952 XPUSHs(sv_2mortal(sv));
955 if (len > strend - s)
960 if (aint >= 128) /* fake up signed chars */
962 if (checksum > bits_in_uv)
969 if (len && unpack_only_one)
975 if (aint >= 128) /* fake up signed chars */
978 sv_setiv(sv, (IV)aint);
979 PUSHs(sv_2mortal(sv));
984 unpack_C: /* unpack U will jump here if not UTF-8 */
986 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
989 if (len > strend - s)
999 if (len && unpack_only_one)
1006 sv_setiv(sv, (IV)auint);
1007 PUSHs(sv_2mortal(sv));
1013 symptr->flags |= FLAG_UNPACK_DO_UTF8;
1016 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
1018 if (len > strend - s)
1021 while (len-- > 0 && s < strend) {
1023 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1026 if (checksum > bits_in_uv)
1027 cdouble += (NV)auint;
1033 if (len && unpack_only_one)
1037 while (len-- > 0 && s < strend) {
1039 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1043 sv_setuv(sv, (UV)auint);
1044 PUSHs(sv_2mortal(sv));
1048 case 's' | TYPE_IS_SHRIEKING:
1049 #if SHORTSIZE != SIZE16
1050 along = (strend - s) / sizeof(short);
1055 COPYNN(s, &ashort, sizeof(short));
1056 DO_BO_UNPACK(ashort, s);
1058 if (checksum > bits_in_uv)
1059 cdouble += (NV)ashort;
1065 if (len && unpack_only_one)
1070 COPYNN(s, &ashort, sizeof(short));
1071 DO_BO_UNPACK(ashort, s);
1074 sv_setiv(sv, (IV)ashort);
1075 PUSHs(sv_2mortal(sv));
1083 along = (strend - s) / SIZE16;
1089 DO_BO_UNPACK(ai16, 16);
1090 #if U16SIZE > SIZE16
1095 if (checksum > bits_in_uv)
1096 cdouble += (NV)ai16;
1102 if (len && unpack_only_one)
1109 DO_BO_UNPACK(ai16, 16);
1110 #if U16SIZE > SIZE16
1116 sv_setiv(sv, (IV)ai16);
1117 PUSHs(sv_2mortal(sv));
1121 case 'S' | TYPE_IS_SHRIEKING:
1122 #if SHORTSIZE != SIZE16
1123 along = (strend - s) / sizeof(unsigned short);
1128 COPYNN(s, &aushort, sizeof(unsigned short));
1129 DO_BO_UNPACK(aushort, s);
1130 s += sizeof(unsigned short);
1131 if (checksum > bits_in_uv)
1132 cdouble += (NV)aushort;
1138 if (len && unpack_only_one)
1143 COPYNN(s, &aushort, sizeof(unsigned short));
1144 DO_BO_UNPACK(aushort, s);
1145 s += sizeof(unsigned short);
1147 sv_setiv(sv, (UV)aushort);
1148 PUSHs(sv_2mortal(sv));
1158 along = (strend - s) / SIZE16;
1164 DO_BO_UNPACK(au16, 16);
1167 if (datumtype == 'n')
1168 au16 = PerlSock_ntohs(au16);
1171 if (datumtype == 'v')
1174 if (checksum > bits_in_uv)
1175 cdouble += (NV)au16;
1181 if (len && unpack_only_one)
1187 DO_BO_UNPACK(au16, 16);
1191 if (datumtype == 'n')
1192 au16 = PerlSock_ntohs(au16);
1195 if (datumtype == 'v')
1198 sv_setiv(sv, (UV)au16);
1199 PUSHs(sv_2mortal(sv));
1203 case 'v' | TYPE_IS_SHRIEKING:
1204 case 'n' | TYPE_IS_SHRIEKING:
1205 along = (strend - s) / SIZE16;
1213 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1214 ai16 = (I16)PerlSock_ntohs((U16)ai16);
1217 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1218 ai16 = (I16)vtohs((U16)ai16);
1220 if (checksum > bits_in_uv)
1221 cdouble += (NV)ai16;
1227 if (len && unpack_only_one)
1235 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1236 ai16 = (I16)PerlSock_ntohs((U16)ai16);
1239 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1240 ai16 = (I16)vtohs((U16)ai16);
1243 sv_setiv(sv, (IV)ai16);
1244 PUSHs(sv_2mortal(sv));
1249 case 'i' | TYPE_IS_SHRIEKING:
1250 along = (strend - s) / sizeof(int);
1255 Copy(s, &aint, 1, int);
1256 DO_BO_UNPACK(aint, i);
1258 if (checksum > bits_in_uv)
1259 cdouble += (NV)aint;
1265 if (len && unpack_only_one)
1270 Copy(s, &aint, 1, int);
1271 DO_BO_UNPACK(aint, i);
1275 /* Without the dummy below unpack("i", pack("i",-1))
1276 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
1277 * cc with optimization turned on.
1279 * The bug was detected in
1280 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
1281 * with optimization (-O4) turned on.
1282 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
1283 * does not have this problem even with -O4.
1285 * This bug was reported as DECC_BUGS 1431
1286 * and tracked internally as GEM_BUGS 7775.
1288 * The bug is fixed in
1289 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
1290 * UNIX V4.0F support: DEC C V5.9-006 or later
1291 * UNIX V4.0E support: DEC C V5.8-011 or later
1294 * See also few lines later for the same bug.
1297 sv_setiv(sv, (IV)aint) :
1299 sv_setiv(sv, (IV)aint);
1300 PUSHs(sv_2mortal(sv));
1305 case 'I' | TYPE_IS_SHRIEKING:
1306 along = (strend - s) / sizeof(unsigned int);
1311 Copy(s, &auint, 1, unsigned int);
1312 DO_BO_UNPACK(auint, i);
1313 s += sizeof(unsigned int);
1314 if (checksum > bits_in_uv)
1315 cdouble += (NV)auint;
1321 if (len && unpack_only_one)
1326 Copy(s, &auint, 1, unsigned int);
1327 DO_BO_UNPACK(auint, i);
1328 s += sizeof(unsigned int);
1331 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1332 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1333 * See details few lines earlier. */
1335 sv_setuv(sv, (UV)auint) :
1337 sv_setuv(sv, (UV)auint);
1338 PUSHs(sv_2mortal(sv));
1343 along = (strend - s) / IVSIZE;
1348 Copy(s, &aiv, 1, IV);
1349 #if IVSIZE == INTSIZE
1350 DO_BO_UNPACK(aiv, i);
1351 #elif IVSIZE == LONGSIZE
1352 DO_BO_UNPACK(aiv, l);
1353 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1354 DO_BO_UNPACK(aiv, 64);
1357 if (checksum > bits_in_uv)
1364 if (len && unpack_only_one)
1369 Copy(s, &aiv, 1, IV);
1370 #if IVSIZE == INTSIZE
1371 DO_BO_UNPACK(aiv, i);
1372 #elif IVSIZE == LONGSIZE
1373 DO_BO_UNPACK(aiv, l);
1374 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1375 DO_BO_UNPACK(aiv, 64);
1380 PUSHs(sv_2mortal(sv));
1385 along = (strend - s) / UVSIZE;
1390 Copy(s, &auv, 1, UV);
1391 #if UVSIZE == INTSIZE
1392 DO_BO_UNPACK(auv, i);
1393 #elif UVSIZE == LONGSIZE
1394 DO_BO_UNPACK(auv, l);
1395 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1396 DO_BO_UNPACK(auv, 64);
1399 if (checksum > bits_in_uv)
1406 if (len && unpack_only_one)
1411 Copy(s, &auv, 1, UV);
1412 #if UVSIZE == INTSIZE
1413 DO_BO_UNPACK(auv, i);
1414 #elif UVSIZE == LONGSIZE
1415 DO_BO_UNPACK(auv, l);
1416 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1417 DO_BO_UNPACK(auv, 64);
1422 PUSHs(sv_2mortal(sv));
1426 case 'l' | TYPE_IS_SHRIEKING:
1427 #if LONGSIZE != SIZE32
1428 along = (strend - s) / sizeof(long);
1433 COPYNN(s, &along, sizeof(long));
1434 DO_BO_UNPACK(along, l);
1436 if (checksum > bits_in_uv)
1437 cdouble += (NV)along;
1443 if (len && unpack_only_one)
1448 COPYNN(s, &along, sizeof(long));
1449 DO_BO_UNPACK(along, l);
1452 sv_setiv(sv, (IV)along);
1453 PUSHs(sv_2mortal(sv));
1461 along = (strend - s) / SIZE32;
1467 DO_BO_UNPACK(ai32, 32);
1468 #if U32SIZE > SIZE32
1469 if (ai32 > 2147483647)
1473 if (checksum > bits_in_uv)
1474 cdouble += (NV)ai32;
1480 if (len && unpack_only_one)
1486 DO_BO_UNPACK(ai32, 32);
1487 #if U32SIZE > SIZE32
1488 if (ai32 > 2147483647)
1493 sv_setiv(sv, (IV)ai32);
1494 PUSHs(sv_2mortal(sv));
1498 case 'L' | TYPE_IS_SHRIEKING:
1499 #if LONGSIZE != SIZE32
1500 along = (strend - s) / sizeof(unsigned long);
1505 COPYNN(s, &aulong, sizeof(unsigned long));
1506 DO_BO_UNPACK(aulong, l);
1507 s += sizeof(unsigned long);
1508 if (checksum > bits_in_uv)
1509 cdouble += (NV)aulong;
1515 if (len && unpack_only_one)
1520 COPYNN(s, &aulong, sizeof(unsigned long));
1521 DO_BO_UNPACK(aulong, l);
1522 s += sizeof(unsigned long);
1524 sv_setuv(sv, (UV)aulong);
1525 PUSHs(sv_2mortal(sv));
1535 along = (strend - s) / SIZE32;
1541 DO_BO_UNPACK(au32, 32);
1544 if (datumtype == 'N')
1545 au32 = PerlSock_ntohl(au32);
1548 if (datumtype == 'V')
1551 if (checksum > bits_in_uv)
1552 cdouble += (NV)au32;
1558 if (len && unpack_only_one)
1564 DO_BO_UNPACK(au32, 32);
1567 if (datumtype == 'N')
1568 au32 = PerlSock_ntohl(au32);
1571 if (datumtype == 'V')
1575 sv_setuv(sv, (UV)au32);
1576 PUSHs(sv_2mortal(sv));
1580 case 'V' | TYPE_IS_SHRIEKING:
1581 case 'N' | TYPE_IS_SHRIEKING:
1582 along = (strend - s) / SIZE32;
1590 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1591 ai32 = (I32)PerlSock_ntohl((U32)ai32);
1594 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1595 ai32 = (I32)vtohl((U32)ai32);
1597 if (checksum > bits_in_uv)
1598 cdouble += (NV)ai32;
1604 if (len && unpack_only_one)
1612 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1613 ai32 = (I32)PerlSock_ntohl((U32)ai32);
1616 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1617 ai32 = (I32)vtohl((U32)ai32);
1620 sv_setiv(sv, (IV)ai32);
1621 PUSHs(sv_2mortal(sv));
1626 along = (strend - s) / sizeof(char*);
1632 if (sizeof(char*) > strend - s)
1635 Copy(s, &aptr, 1, char*);
1636 DO_BO_UNPACK_P(aptr);
1642 PUSHs(sv_2mortal(sv));
1646 if (len && unpack_only_one)
1654 while ((len > 0) && (s < strend)) {
1655 auv = (auv << 7) | (*s & 0x7f);
1656 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1657 if ((U8)(*s++) < 0x80) {
1661 PUSHs(sv_2mortal(sv));
1665 else if (++bytes >= sizeof(UV)) { /* promote to string */
1669 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1670 while (s < strend) {
1671 sv = mul128(sv, (U8)(*s & 0x7f));
1672 if (!(*s++ & 0x80)) {
1681 PUSHs(sv_2mortal(sv));
1686 if ((s >= strend) && bytes)
1687 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1691 if (symptr->howlen == e_star)
1692 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1694 if (sizeof(char*) > strend - s)
1697 Copy(s, &aptr, 1, char*);
1698 DO_BO_UNPACK_P(aptr);
1703 sv_setpvn(sv, aptr, len);
1704 PUSHs(sv_2mortal(sv));
1708 along = (strend - s) / sizeof(Quad_t);
1713 Copy(s, &aquad, 1, Quad_t);
1714 DO_BO_UNPACK(aquad, 64);
1715 s += sizeof(Quad_t);
1716 if (checksum > bits_in_uv)
1717 cdouble += (NV)aquad;
1723 if (len && unpack_only_one)
1728 if (s + sizeof(Quad_t) > strend)
1731 Copy(s, &aquad, 1, Quad_t);
1732 DO_BO_UNPACK(aquad, 64);
1733 s += sizeof(Quad_t);
1736 if (aquad >= IV_MIN && aquad <= IV_MAX)
1737 sv_setiv(sv, (IV)aquad);
1739 sv_setnv(sv, (NV)aquad);
1740 PUSHs(sv_2mortal(sv));
1745 along = (strend - s) / sizeof(Uquad_t);
1750 Copy(s, &auquad, 1, Uquad_t);
1751 DO_BO_UNPACK(auquad, 64);
1752 s += sizeof(Uquad_t);
1753 if (checksum > bits_in_uv)
1754 cdouble += (NV)auquad;
1760 if (len && unpack_only_one)
1765 if (s + sizeof(Uquad_t) > strend)
1768 Copy(s, &auquad, 1, Uquad_t);
1769 DO_BO_UNPACK(auquad, 64);
1770 s += sizeof(Uquad_t);
1773 if (auquad <= UV_MAX)
1774 sv_setuv(sv, (UV)auquad);
1776 sv_setnv(sv, (NV)auquad);
1777 PUSHs(sv_2mortal(sv));
1782 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1784 along = (strend - s) / sizeof(float);
1789 Copy(s, &afloat, 1, float);
1790 DO_BO_UNPACK_N(afloat, float);
1796 if (len && unpack_only_one)
1801 Copy(s, &afloat, 1, float);
1802 DO_BO_UNPACK_N(afloat, float);
1805 sv_setnv(sv, (NV)afloat);
1806 PUSHs(sv_2mortal(sv));
1811 along = (strend - s) / sizeof(double);
1816 Copy(s, &adouble, 1, double);
1817 DO_BO_UNPACK_N(adouble, double);
1818 s += sizeof(double);
1823 if (len && unpack_only_one)
1828 Copy(s, &adouble, 1, double);
1829 DO_BO_UNPACK_N(adouble, double);
1830 s += sizeof(double);
1832 sv_setnv(sv, (NV)adouble);
1833 PUSHs(sv_2mortal(sv));
1838 along = (strend - s) / NVSIZE;
1843 Copy(s, &anv, 1, NV);
1844 DO_BO_UNPACK_N(anv, NV);
1850 if (len && unpack_only_one)
1855 Copy(s, &anv, 1, NV);
1856 DO_BO_UNPACK_N(anv, NV);
1860 PUSHs(sv_2mortal(sv));
1864 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1866 along = (strend - s) / LONG_DOUBLESIZE;
1871 Copy(s, &aldouble, 1, long double);
1872 DO_BO_UNPACK_N(aldouble, long double);
1873 s += LONG_DOUBLESIZE;
1874 cdouble += aldouble;
1878 if (len && unpack_only_one)
1883 Copy(s, &aldouble, 1, long double);
1884 DO_BO_UNPACK_N(aldouble, long double);
1885 s += LONG_DOUBLESIZE;
1887 sv_setnv(sv, (NV)aldouble);
1888 PUSHs(sv_2mortal(sv));
1895 * Initialise the decode mapping. By using a table driven
1896 * algorithm, the code will be character-set independent
1897 * (and just as fast as doing character arithmetic)
1899 if (PL_uudmap['M'] == 0) {
1902 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1903 PL_uudmap[(U8)PL_uuemap[i]] = i;
1905 * Because ' ' and '`' map to the same value,
1906 * we need to decode them both the same.
1911 along = (strend - s) * 3 / 4;
1912 sv = NEWSV(42, along);
1915 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1920 len = PL_uudmap[*(U8*)s++] & 077;
1922 if (s < strend && ISUUCHAR(*s))
1923 a = PL_uudmap[*(U8*)s++] & 077;
1926 if (s < strend && ISUUCHAR(*s))
1927 b = PL_uudmap[*(U8*)s++] & 077;
1930 if (s < strend && ISUUCHAR(*s))
1931 c = PL_uudmap[*(U8*)s++] & 077;
1934 if (s < strend && ISUUCHAR(*s))
1935 d = PL_uudmap[*(U8*)s++] & 077;
1938 hunk[0] = (char)((a << 2) | (b >> 4));
1939 hunk[1] = (char)((b << 4) | (c >> 2));
1940 hunk[2] = (char)((c << 6) | d);
1941 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1946 else /* possible checksum byte */
1947 if (s + 1 < strend && s[1] == '\n')
1950 XPUSHs(sv_2mortal(sv));
1956 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1957 (checksum > bits_in_uv &&
1958 strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1961 adouble = (NV) (1 << (checksum & 15));
1962 while (checksum >= 16) {
1966 while (cdouble < 0.0)
1968 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1969 sv_setnv(sv, cdouble);
1972 if (checksum < bits_in_uv) {
1973 UV mask = ((UV)1 << checksum) - 1;
1978 XPUSHs(sv_2mortal(sv));
1982 if (symptr->flags & FLAG_SLASH){
1983 if (SP - PL_stack_base - start_sp_offset <= 0)
1984 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1985 if( next_symbol(symptr) ){
1986 if( symptr->howlen == e_number )
1987 Perl_croak(aTHX_ "Count after length/code in unpack" );
1989 /* ...end of char buffer then no decent length available */
1990 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1992 /* take top of stack (hope it's numeric) */
1995 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1998 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
2000 datumtype = symptr->code;
2008 return SP - PL_stack_base - start_sp_offset;
2015 I32 gimme = GIMME_V;
2018 register char *pat = SvPV(left, llen);
2019 #ifdef PACKED_IS_OCTETS
2020 /* Packed side is assumed to be octets - so force downgrade if it
2021 has been UTF-8 encoded by accident
2023 register char *s = SvPVbyte(right, rlen);
2025 register char *s = SvPV(right, rlen);
2027 char *strend = s + rlen;
2028 register char *patend = pat + llen;
2032 cnt = unpackstring(pat, patend, s, strend,
2033 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
2034 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
2037 if ( !cnt && gimme == G_SCALAR )
2038 PUSHs(&PL_sv_undef);
2043 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
2047 *hunk = PL_uuemap[len];
2048 sv_catpvn(sv, hunk, 1);
2051 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
2052 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
2053 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
2054 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
2055 sv_catpvn(sv, hunk, 4);
2060 char r = (len > 1 ? s[1] : '\0');
2061 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
2062 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
2063 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
2064 hunk[3] = PL_uuemap[0];
2065 sv_catpvn(sv, hunk, 4);
2067 sv_catpvn(sv, "\n", 1);
2071 S_is_an_int(pTHX_ char *s, STRLEN l)
2074 SV *result = newSVpvn(s, l);
2075 char *result_c = SvPV(result, n_a); /* convenience */
2076 char *out = result_c;
2086 SvREFCNT_dec(result);
2109 SvREFCNT_dec(result);
2115 SvCUR_set(result, out - result_c);
2119 /* pnum must be '\0' terminated */
2121 S_div128(pTHX_ SV *pnum, bool *done)
2124 char *s = SvPV(pnum, len);
2133 i = m * 10 + (*t - '0');
2135 r = (i >> 7); /* r < 10 */
2142 SvCUR_set(pnum, (STRLEN) (t - s));
2149 =for apidoc pack_cat
2151 The engine implementing pack() Perl function. Note: parameters next_in_list and
2152 flags are not used. This call should not be used; use packlist instead.
2158 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
2160 tempsym_t sym = { 0 };
2162 sym.patend = patend;
2163 sym.flags = FLAG_PACK;
2165 (void)pack_rec( cat, &sym, beglist, endlist );
2170 =for apidoc packlist
2172 The engine implementing pack() Perl function.
2178 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
2180 tempsym_t sym = { 0 };
2182 sym.patend = patend;
2183 sym.flags = FLAG_PACK;
2185 (void)pack_rec( cat, &sym, beglist, endlist );
2191 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
2195 register I32 len = 0;
2198 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
2199 static char *space10 = " ";
2202 /* These must not be in registers: */
2212 #if SHORTSIZE != SIZE16
2214 unsigned short aushort;
2218 #if LONGSIZE != SIZE32
2220 unsigned long aulong;
2225 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2226 long double aldouble;
2232 int strrelbeg = SvCUR(cat);
2233 tempsym_t lookahead;
2235 items = endlist - beglist;
2236 found = next_symbol( symptr );
2238 #ifndef PACKED_IS_OCTETS
2239 if (symptr->level == 0 && found && symptr->code == 'U' ){
2245 SV *lengthcode = Nullsv;
2246 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2248 I32 datumtype = symptr->code;
2251 switch( howlen = symptr->howlen ){
2254 len = symptr->length;
2257 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
2261 /* Look ahead for next symbol. Do we have code/code? */
2262 lookahead = *symptr;
2263 found = next_symbol(&lookahead);
2264 if ( symptr->flags & FLAG_SLASH ) {
2266 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2267 e_star != lookahead.howlen )
2268 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2269 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
2270 ? *beglist : &PL_sv_no)
2271 + (lookahead.code == 'Z' ? 1 : 0)));
2273 Perl_croak(aTHX_ "Code missing after '/' in pack");
2277 switch(TYPE_NO_ENDIANNESS(datumtype)) {
2279 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
2281 Perl_croak(aTHX_ "'%%' may not be used in pack");
2283 len += strrelbeg - SvCUR(cat);
2292 tempsym_t savsym = *symptr;
2293 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2294 symptr->flags |= group_modifiers;
2295 symptr->patend = savsym.grpend;
2298 symptr->patptr = savsym.grpbeg;
2299 beglist = pack_rec(cat, symptr, beglist, endlist );
2300 if (savsym.howlen == e_star && beglist == endlist)
2301 break; /* No way to continue */
2303 symptr->flags &= ~group_modifiers;
2304 lookahead.flags = symptr->flags;
2308 case 'X' | TYPE_IS_SHRIEKING:
2309 if (!len) /* Avoid division by 0 */
2311 len = (SvCUR(cat)) % len;
2315 if ((I32)SvCUR(cat) < len)
2316 Perl_croak(aTHX_ "'X' outside of string in pack");
2320 case 'x' | TYPE_IS_SHRIEKING:
2321 if (!len) /* Avoid division by 0 */
2323 aint = (SvCUR(cat)) % len;
2324 if (aint) /* Other portable ways? */
2333 sv_catpvn(cat, null10, 10);
2336 sv_catpvn(cat, null10, len);
2342 aptr = SvPV(fromstr, fromlen);
2343 if (howlen == e_star) {
2345 if (datumtype == 'Z')
2348 if ((I32)fromlen >= len) {
2349 sv_catpvn(cat, aptr, len);
2350 if (datumtype == 'Z')
2351 *(SvEND(cat)-1) = '\0';
2354 sv_catpvn(cat, aptr, fromlen);
2356 if (datumtype == 'A') {
2358 sv_catpvn(cat, space10, 10);
2361 sv_catpvn(cat, space10, len);
2365 sv_catpvn(cat, null10, 10);
2368 sv_catpvn(cat, null10, len);
2380 str = SvPV(fromstr, fromlen);
2381 if (howlen == e_star)
2384 SvCUR(cat) += (len+7)/8;
2385 SvGROW(cat, SvCUR(cat) + 1);
2386 aptr = SvPVX(cat) + aint;
2387 if (len > (I32)fromlen)
2391 if (datumtype == 'B') {
2392 for (len = 0; len++ < aint;) {
2393 items |= *str++ & 1;
2397 *aptr++ = items & 0xff;
2403 for (len = 0; len++ < aint;) {
2409 *aptr++ = items & 0xff;
2415 if (datumtype == 'B')
2416 items <<= 7 - (aint & 7);
2418 items >>= 7 - (aint & 7);
2419 *aptr++ = items & 0xff;
2421 str = SvPVX(cat) + SvCUR(cat);
2436 str = SvPV(fromstr, fromlen);
2437 if (howlen == e_star)
2440 SvCUR(cat) += (len+1)/2;
2441 SvGROW(cat, SvCUR(cat) + 1);
2442 aptr = SvPVX(cat) + aint;
2443 if (len > (I32)fromlen)
2447 if (datumtype == 'H') {
2448 for (len = 0; len++ < aint;) {
2450 items |= ((*str++ & 15) + 9) & 15;
2452 items |= *str++ & 15;
2456 *aptr++ = items & 0xff;
2462 for (len = 0; len++ < aint;) {
2464 items |= (((*str++ & 15) + 9) & 15) << 4;
2466 items |= (*str++ & 15) << 4;
2470 *aptr++ = items & 0xff;
2476 *aptr++ = items & 0xff;
2477 str = SvPVX(cat) + SvCUR(cat);
2488 switch (TYPE_NO_MODIFIERS(datumtype)) {
2490 aint = SvIV(fromstr);
2491 if ((aint < 0 || aint > 255) &&
2493 Perl_warner(aTHX_ packWARN(WARN_PACK),
2494 "Character in 'C' format wrapped in pack");
2496 sv_catpvn(cat, &achar, sizeof(char));
2499 aint = SvIV(fromstr);
2500 if ((aint < -128 || aint > 127) &&
2502 Perl_warner(aTHX_ packWARN(WARN_PACK),
2503 "Character in 'c' format wrapped in pack" );
2505 sv_catpvn(cat, &achar, sizeof(char));
2513 auint = UNI_TO_NATIVE(SvUV(fromstr));
2514 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2516 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2519 0 : UNICODE_ALLOW_ANY)
2524 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2529 /* VOS does not automatically map a floating-point overflow
2530 during conversion from double to float into infinity, so we
2531 do it by hand. This code should either be generalized for
2532 any OS that needs it, or removed if and when VOS implements
2533 posix-976 (suggestion to support mapping to infinity).
2534 Paul.Green@stratus.com 02-04-02. */
2535 if (SvNV(fromstr) > FLT_MAX)
2536 afloat = _float_constants[0]; /* single prec. inf. */
2537 else if (SvNV(fromstr) < -FLT_MAX)
2538 afloat = _float_constants[0]; /* single prec. inf. */
2539 else afloat = (float)SvNV(fromstr);
2541 # if defined(VMS) && !defined(__IEEE_FP)
2542 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2543 * on Alpha; fake it if we don't have them.
2545 if (SvNV(fromstr) > FLT_MAX)
2547 else if (SvNV(fromstr) < -FLT_MAX)
2549 else afloat = (float)SvNV(fromstr);
2551 afloat = (float)SvNV(fromstr);
2554 DO_BO_PACK_N(afloat, float);
2555 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2562 /* VOS does not automatically map a floating-point overflow
2563 during conversion from long double to double into infinity,
2564 so we do it by hand. This code should either be generalized
2565 for any OS that needs it, or removed if and when VOS
2566 implements posix-976 (suggestion to support mapping to
2567 infinity). Paul.Green@stratus.com 02-04-02. */
2568 if (SvNV(fromstr) > DBL_MAX)
2569 adouble = _double_constants[0]; /* double prec. inf. */
2570 else if (SvNV(fromstr) < -DBL_MAX)
2571 adouble = _double_constants[0]; /* double prec. inf. */
2572 else adouble = (double)SvNV(fromstr);
2574 # if defined(VMS) && !defined(__IEEE_FP)
2575 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2576 * on Alpha; fake it if we don't have them.
2578 if (SvNV(fromstr) > DBL_MAX)
2580 else if (SvNV(fromstr) < -DBL_MAX)
2582 else adouble = (double)SvNV(fromstr);
2584 adouble = (double)SvNV(fromstr);
2587 DO_BO_PACK_N(adouble, double);
2588 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2592 Zero(&anv, 1, NV); /* can be long double with unused bits */
2595 anv = SvNV(fromstr);
2596 DO_BO_PACK_N(anv, NV);
2597 sv_catpvn(cat, (char *)&anv, NVSIZE);
2600 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2602 /* long doubles can have unused bits, which may be nonzero */
2603 Zero(&aldouble, 1, long double);
2606 aldouble = (long double)SvNV(fromstr);
2607 DO_BO_PACK_N(aldouble, long double);
2608 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2612 case 'n' | TYPE_IS_SHRIEKING:
2616 ai16 = (I16)SvIV(fromstr);
2618 ai16 = PerlSock_htons(ai16);
2623 case 'v' | TYPE_IS_SHRIEKING:
2627 ai16 = (I16)SvIV(fromstr);
2634 case 'S' | TYPE_IS_SHRIEKING:
2635 #if SHORTSIZE != SIZE16
2639 aushort = SvUV(fromstr);
2640 DO_BO_PACK(aushort, s);
2641 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2652 au16 = (U16)SvUV(fromstr);
2653 DO_BO_PACK(au16, 16);
2659 case 's' | TYPE_IS_SHRIEKING:
2660 #if SHORTSIZE != SIZE16
2664 ashort = SvIV(fromstr);
2665 DO_BO_PACK(ashort, s);
2666 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2676 ai16 = (I16)SvIV(fromstr);
2677 DO_BO_PACK(ai16, 16);
2682 case 'I' | TYPE_IS_SHRIEKING:
2685 auint = SvUV(fromstr);
2686 DO_BO_PACK(auint, i);
2687 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2693 aiv = SvIV(fromstr);
2694 #if IVSIZE == INTSIZE
2696 #elif IVSIZE == LONGSIZE
2698 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2699 DO_BO_PACK(aiv, 64);
2701 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2707 auv = SvUV(fromstr);
2708 #if UVSIZE == INTSIZE
2710 #elif UVSIZE == LONGSIZE
2712 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2713 DO_BO_PACK(auv, 64);
2715 sv_catpvn(cat, (char*)&auv, UVSIZE);
2721 anv = SvNV(fromstr);
2724 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2726 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2727 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2728 any negative IVs will have already been got by the croak()
2729 above. IOK is untrue for fractions, so we test them
2730 against UV_MAX_P1. */
2731 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2733 char buf[(sizeof(UV)*8)/7+1];
2734 char *in = buf + sizeof(buf);
2735 UV auv = SvUV(fromstr);
2738 *--in = (char)((auv & 0x7f) | 0x80);
2741 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2742 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2744 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2745 char *from, *result, *in;
2750 /* Copy string and check for compliance */
2751 from = SvPV(fromstr, len);
2752 if ((norm = is_an_int(from, len)) == NULL)
2753 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2755 New('w', result, len, char);
2759 *--in = div128(norm, &done) | 0x80;
2760 result[len - 1] &= 0x7F; /* clear continue bit */
2761 sv_catpvn(cat, in, (result + len) - in);
2763 SvREFCNT_dec(norm); /* free norm */
2765 else if (SvNOKp(fromstr)) {
2766 /* 10**NV_MAX_10_EXP is the largest power of 10
2767 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2768 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2769 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2770 And with that many bytes only Inf can overflow.
2771 Some C compilers are strict about integral constant
2772 expressions so we conservatively divide by a slightly
2773 smaller integer instead of multiplying by the exact
2774 floating-point value.
2776 #ifdef NV_MAX_10_EXP
2777 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2778 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2780 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2781 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2783 char *in = buf + sizeof(buf);
2785 anv = Perl_floor(anv);
2787 NV next = Perl_floor(anv / 128);
2788 if (in <= buf) /* this cannot happen ;-) */
2789 Perl_croak(aTHX_ "Cannot compress integer in pack");
2790 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2793 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2794 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2797 char *from, *result, *in;
2802 /* Copy string and check for compliance */
2803 from = SvPV(fromstr, len);
2804 if ((norm = is_an_int(from, len)) == NULL)
2805 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2807 New('w', result, len, char);
2811 *--in = div128(norm, &done) | 0x80;
2812 result[len - 1] &= 0x7F; /* clear continue bit */
2813 sv_catpvn(cat, in, (result + len) - in);
2815 SvREFCNT_dec(norm); /* free norm */
2820 case 'i' | TYPE_IS_SHRIEKING:
2823 aint = SvIV(fromstr);
2824 DO_BO_PACK(aint, i);
2825 sv_catpvn(cat, (char*)&aint, sizeof(int));
2828 case 'N' | TYPE_IS_SHRIEKING:
2832 au32 = SvUV(fromstr);
2834 au32 = PerlSock_htonl(au32);
2839 case 'V' | TYPE_IS_SHRIEKING:
2843 au32 = SvUV(fromstr);
2850 case 'L' | TYPE_IS_SHRIEKING:
2851 #if LONGSIZE != SIZE32
2855 aulong = SvUV(fromstr);
2856 DO_BO_PACK(aulong, l);
2857 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2868 au32 = SvUV(fromstr);
2869 DO_BO_PACK(au32, 32);
2874 case 'l' | TYPE_IS_SHRIEKING:
2875 #if LONGSIZE != SIZE32
2879 along = SvIV(fromstr);
2880 DO_BO_PACK(along, l);
2881 sv_catpvn(cat, (char *)&along, sizeof(long));
2891 ai32 = SvIV(fromstr);
2892 DO_BO_PACK(ai32, 32);
2900 auquad = (Uquad_t)SvUV(fromstr);
2901 DO_BO_PACK(auquad, 64);
2902 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2908 aquad = (Quad_t)SvIV(fromstr);
2909 DO_BO_PACK(aquad, 64);
2910 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2915 len = 1; /* assume SV is correct length */
2920 if (fromstr == &PL_sv_undef)
2924 /* XXX better yet, could spirit away the string to
2925 * a safe spot and hang on to it until the result
2926 * of pack() (and all copies of the result) are
2929 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2930 || (SvPADTMP(fromstr)
2931 && !SvREADONLY(fromstr))))
2933 Perl_warner(aTHX_ packWARN(WARN_PACK),
2934 "Attempt to pack pointer to temporary value");
2936 if (SvPOK(fromstr) || SvNIOK(fromstr))
2937 aptr = SvPV(fromstr,n_a);
2939 aptr = SvPV_force(fromstr,n_a);
2942 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2947 aptr = SvPV(fromstr, fromlen);
2948 SvGROW(cat, fromlen * 4 / 3);
2953 while (fromlen > 0) {
2956 if ((I32)fromlen > len)
2960 doencodes(cat, aptr, todo);
2966 *symptr = lookahead;
2975 dSP; dMARK; dORIGMARK; dTARGET;
2976 register SV *cat = TARG;
2978 register char *pat = SvPVx(*++MARK, fromlen);
2979 register char *patend = pat + fromlen;
2982 sv_setpvn(cat, "", 0);
2984 packlist(cat, pat, patend, MARK, SP + 1);