3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * He still hopefully carried some of his gear in his pack: a small tinder-box,
12 * two small shallow pans, the smaller fitting into the larger; inside them a
13 * wooden spoon, a short two-pronged fork and some skewers were stowed; and
14 * hidden at the bottom of the pack in a flat wooden box a dwindling treasure,
19 #define PERL_IN_PP_PACK_C
23 * The compiler on Concurrent CX/UX systems has a subtle bug which only
24 * seems to show up when compiling pp.c - it generates the wrong double
25 * precision constant value for (double)UV_MAX when used inline in the body
26 * of the code below, so this makes a static variable up front (which the
27 * compiler seems to get correct) and uses it in place of UV_MAX below.
29 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
30 static double UV_MAX_cxux = ((double)UV_MAX);
34 * Offset for integer pack/unpack.
36 * On architectures where I16 and I32 aren't really 16 and 32 bits,
37 * which for now are all Crays, pack and unpack have to play games.
41 * These values are required for portability of pack() output.
42 * If they're not right on your machine, then pack() and unpack()
43 * wouldn't work right anyway; you'll need to apply the Cray hack.
44 * (I'd like to check them with #if, but you can't use sizeof() in
45 * the preprocessor.) --???
48 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
49 defines are now in config.h. --Andy Dougherty April 1998
54 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
57 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
58 # define PERL_NATINT_PACK
61 #if LONGSIZE > 4 && defined(_CRAY)
62 # if BYTEORDER == 0x12345678
63 # define OFF16(p) (char*)(p)
64 # define OFF32(p) (char*)(p)
66 # if BYTEORDER == 0x87654321
67 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
68 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
70 }}}} bad cray byte order
73 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
74 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
75 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
76 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
77 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
79 # define COPY16(s,p) Copy(s, p, SIZE16, char)
80 # define COPY32(s,p) Copy(s, p, SIZE32, char)
81 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
82 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
83 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
87 S_mul128(pTHX_ SV *sv, U8 m)
90 char *s = SvPV(sv, len);
94 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
95 SV *tmpNew = newSVpvn("0000000000", 10);
98 SvREFCNT_dec(sv); /* free old sv */
103 while (!*t) /* trailing '\0'? */
106 i = ((*t - '0') << 7) + m;
107 *(t--) = '0' + (char)(i % 10);
113 /* Explosives and implosives. */
115 #if 'I' == 73 && 'J' == 74
116 /* On an ASCII/ISO kind of system */
117 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
120 Some other sort of character set - use memchr() so we don't match
123 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
126 #define UNPACK_ONLY_ONE 0x1
127 #define UNPACK_DO_UTF8 0x2
130 S_group_end(pTHX_ register char *pat, register char *patend, char ender)
132 while (pat < patend) {
140 while (pat < patend && *pat != '\n')
144 pat = group_end(pat, patend, ')') + 1;
146 pat = group_end(pat, patend, ']') + 1;
148 Perl_croak(aTHX_ "No group ending character `%c' found", ender);
152 #define TYPE_IS_SHRIEKING 0x100
154 /* Returns the sizeof() struct described by pat */
156 S_measure_struct(pTHX_ char *pat, register char *patend)
160 register I32 total = 0;
162 int star; /* 1 if count is *, -1 if no count given, -2 for / */
163 #ifdef PERL_NATINT_PACK
164 int natint; /* native integer */
165 int unatint; /* unsigned native integer */
170 while ((pat = next_symbol(pat, patend)) < patend) {
171 datumtype = *pat++ & 0xFF;
172 #ifdef PERL_NATINT_PACK
176 static const char *natstr = "sSiIlLxX";
178 if (strchr(natstr, datumtype)) {
179 if (datumtype == 'x' || datumtype == 'X') {
180 datumtype |= TYPE_IS_SHRIEKING;
181 } else { /* XXXX Should be redone similarly! */
182 #ifdef PERL_NATINT_PACK
189 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
191 len = find_count(&pat, patend, &star);
193 Perl_croak(aTHX_ "%s not allowed in length fields", "count *");
194 else if (star < 0) /* No explicit len */
195 len = datumtype != '@';
199 Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
202 case 'U': /* XXXX Is it correct? */
205 buf[0] = (char)datumtype;
207 Perl_croak(aTHX_ "%s not allowed in length fields", buf);
208 case ',': /* grandfather in commas but with a warning */
209 if (commas++ == 0 && ckWARN(WARN_UNPACK))
210 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
211 "Invalid type in unpack: '%c'", (int)datumtype);
218 char *beg = pat, *end;
221 Perl_croak(aTHX_ "()-group starts with a count");
222 end = group_end(beg, patend, ')');
224 len = find_count(&pat, patend, &star);
225 if (star < 0) /* No count */
227 else if (star > 0) /* Star */
228 Perl_croak(aTHX_ "%s not allowed in length fields", "count *");
229 /* XXXX Theoretically, we need to measure many times at different
230 positions, since the subexpression may contain
231 alignment commands, but be not of aligned length.
232 Need to detect this and croak(). */
233 size = measure_struct(beg, end);
236 case 'X' | TYPE_IS_SHRIEKING:
237 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */
238 if (!len) /* Avoid division by 0 */
240 len = total % len; /* Assumed: the start is aligned. */
245 Perl_croak(aTHX_ "X outside of string");
247 case 'x' | TYPE_IS_SHRIEKING:
248 if (!len) /* Avoid division by 0 */
250 star = total % len; /* Assumed: the start is aligned. */
251 if (star) /* Other portable ways? */
275 #if SHORTSIZE == SIZE16
278 size = (natint ? sizeof(short) : SIZE16);
284 #if SHORTSIZE == SIZE16
287 unatint = natint && datumtype == 'S';
288 size = (unatint ? sizeof(unsigned short) : SIZE16);
295 size = sizeof(unsigned int);
304 #if LONGSIZE == SIZE32
307 size = (natint ? sizeof(long) : SIZE32);
313 #if LONGSIZE == SIZE32
316 unatint = natint && datumtype == 'L';
317 size = (unatint ? sizeof(unsigned long) : SIZE32);
324 size = sizeof(char*);
328 size = sizeof(Quad_t);
331 size = sizeof(Uquad_t);
335 size = sizeof(float);
338 size = sizeof(double);
343 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
345 size = LONG_DOUBLESIZE;
354 /* Returns -1 on no count or on star */
356 S_find_count(pTHX_ char **ppat, register char *patend, int *star)
364 else if (*pat == '*') {
369 else if (isDIGIT(*pat)) {
371 while (isDIGIT(*pat)) {
372 len = (len * 10) + (*pat++ - '0');
373 if (len < 0) /* 50% chance of catching... */
374 Perl_croak(aTHX_ "Repeat count in pack/unpack overflows");
377 else if (*pat == '[') {
378 char *end = group_end(++pat, patend, ']');
383 return find_count(&pat, end, star);
384 return measure_struct(pat, end);
393 S_next_symbol(pTHX_ register char *pat, register char *patend)
395 while (pat < patend) {
398 else if (*pat == '#') {
400 while (pat < patend && *pat != '\n')
412 =for apidoc unpack_str
414 The engine implementing unpack() Perl function.
419 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
424 register I32 bits = 0;
427 I32 start_sp_offset = SP - PL_stack_base;
429 /* These must not be in registers: */
448 const int bits_in_uv = 8 * sizeof(cuv);
450 int star; /* 1 if count is *, -1 if no count given, -2 for / */
451 #ifdef PERL_NATINT_PACK
452 int natint; /* native integer */
453 int unatint; /* unsigned native integer */
458 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
459 long double aldouble;
461 bool do_utf8 = (flags & UNPACK_DO_UTF8) != 0;
463 while ((pat = next_symbol(pat, patend)) < patend) {
464 datumtype = *pat++ & 0xFF;
465 #ifdef PERL_NATINT_PACK
468 /* do first one only unless in list context
469 / is implemented by unpacking the count, then poping it from the
470 stack, so must check that we're not in the middle of a / */
471 if ( (flags & UNPACK_ONLY_ONE)
472 && (SP - PL_stack_base == start_sp_offset + 1)
473 && (datumtype != '/') )
476 static const char natstr[] = "sSiIlLxX";
478 if (strchr(natstr, datumtype)) {
479 if (datumtype == 'x' || datumtype == 'X') {
480 datumtype |= TYPE_IS_SHRIEKING;
481 } else { /* XXXX Should be redone similarly! */
482 #ifdef PERL_NATINT_PACK
489 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
491 len = find_count(&pat, patend, &star);
493 len = strend - strbeg; /* long enough */
494 else if (star < 0) /* No explicit len */
495 len = datumtype != '@';
500 Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
501 case ',': /* grandfather in commas but with a warning */
502 if (commas++ == 0 && ckWARN(WARN_UNPACK))
503 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
504 "Invalid type in unpack: '%c'", (int)datumtype);
507 if (len == 1 && pat[-1] != '1' && pat[-1] != ']')
508 len = 16; /* len is not specified */
517 char *ss = s; /* Move from register */
520 Perl_croak(aTHX_ "()-group starts with a count");
521 aptr = group_end(beg, patend, ')');
524 len = find_count(&pat, patend, &star);
525 if (star < 0) /* No count */
527 else if (star > 0) /* Star */
528 len = strend - strbeg; /* long enough? */
532 unpack_str(beg, aptr, ss, strbeg, strend, &ss,
533 ocnt + SP - PL_stack_base - start_sp_offset, flags);
534 if (star > 0 && ss == strend)
535 break; /* No way to continue */
542 if (len > strend - strbeg)
543 Perl_croak(aTHX_ "@ outside of string");
546 case 'X' | TYPE_IS_SHRIEKING:
547 if (!len) /* Avoid division by 0 */
549 len = (s - strbeg) % len;
552 if (len > s - strbeg)
553 Perl_croak(aTHX_ "X outside of string");
556 case 'x' | TYPE_IS_SHRIEKING:
557 if (!len) /* Avoid division by 0 */
559 aint = (s - strbeg) % len;
560 if (aint) /* Other portable ways? */
566 if (len > strend - s)
567 Perl_croak(aTHX_ "x outside of string");
571 if (ocnt + SP - PL_stack_base - start_sp_offset <= 0)
572 Perl_croak(aTHX_ "/ must follow a numeric type");
575 pat++; /* ignore '*' for compatibility with pack */
577 Perl_croak(aTHX_ "/ cannot take a count" );
584 if (len > strend - s)
589 sv_setpvn(sv, s, len);
590 if (datumtype == 'A' || datumtype == 'Z') {
591 aptr = s; /* borrow register */
592 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
596 if (star > 0) /* exact for 'Z*' */
597 len = s - SvPVX(sv) + 1;
599 else { /* 'A' strips both nulls and spaces */
600 s = SvPVX(sv) + len - 1;
601 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
605 SvCUR_set(sv, s - SvPVX(sv));
606 s = aptr; /* unborrow register */
609 XPUSHs(sv_2mortal(sv));
613 if (star > 0 || len > (strend - s) * 8)
614 len = (strend - s) * 8;
617 Newz(601, PL_bitcount, 256, char);
618 for (bits = 1; bits < 256; bits++) {
619 if (bits & 1) PL_bitcount[bits]++;
620 if (bits & 2) PL_bitcount[bits]++;
621 if (bits & 4) PL_bitcount[bits]++;
622 if (bits & 8) PL_bitcount[bits]++;
623 if (bits & 16) PL_bitcount[bits]++;
624 if (bits & 32) PL_bitcount[bits]++;
625 if (bits & 64) PL_bitcount[bits]++;
626 if (bits & 128) PL_bitcount[bits]++;
630 cuv += PL_bitcount[*(unsigned char*)s++];
635 if (datumtype == 'b') {
643 if (bits & 128) cuv++;
650 sv = NEWSV(35, len + 1);
654 if (datumtype == 'b') {
656 for (len = 0; len < aint; len++) {
657 if (len & 7) /*SUPPRESS 595*/
661 *str++ = '0' + (bits & 1);
666 for (len = 0; len < aint; len++) {
671 *str++ = '0' + ((bits & 128) != 0);
675 XPUSHs(sv_2mortal(sv));
679 if (star > 0 || len > (strend - s) * 2)
680 len = (strend - s) * 2;
681 sv = NEWSV(35, len + 1);
685 if (datumtype == 'h') {
687 for (len = 0; len < aint; len++) {
692 *str++ = PL_hexdigit[bits & 15];
697 for (len = 0; len < aint; len++) {
702 *str++ = PL_hexdigit[(bits >> 4) & 15];
706 XPUSHs(sv_2mortal(sv));
709 if (len > strend - s)
714 if (aint >= 128) /* fake up signed chars */
716 if (checksum > bits_in_uv)
723 if (len && (flags & UNPACK_ONLY_ONE))
729 if (aint >= 128) /* fake up signed chars */
732 sv_setiv(sv, (IV)aint);
733 PUSHs(sv_2mortal(sv));
738 unpack_C: /* unpack U will jump here if not UTF-8 */
743 if (len > strend - s)
753 if (len && (flags & UNPACK_ONLY_ONE))
760 sv_setiv(sv, (IV)auint);
761 PUSHs(sv_2mortal(sv));
772 if (len > strend - s)
775 while (len-- > 0 && s < strend) {
777 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
780 if (checksum > bits_in_uv)
781 cdouble += (NV)auint;
787 if (len && (flags & UNPACK_ONLY_ONE))
791 while (len-- > 0 && s < strend) {
793 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
797 sv_setuv(sv, (UV)auint);
798 PUSHs(sv_2mortal(sv));
803 #if SHORTSIZE == SIZE16
804 along = (strend - s) / SIZE16;
806 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
811 #if SHORTSIZE != SIZE16
815 COPYNN(s, &ashort, sizeof(short));
817 if (checksum > bits_in_uv)
818 cdouble += (NV)ashort;
829 #if SHORTSIZE > SIZE16
834 if (checksum > bits_in_uv)
835 cdouble += (NV)ashort;
842 if (len && (flags & UNPACK_ONLY_ONE))
846 #if SHORTSIZE != SIZE16
850 COPYNN(s, &ashort, sizeof(short));
853 sv_setiv(sv, (IV)ashort);
854 PUSHs(sv_2mortal(sv));
862 #if SHORTSIZE > SIZE16
868 sv_setiv(sv, (IV)ashort);
869 PUSHs(sv_2mortal(sv));
877 #if SHORTSIZE == SIZE16
878 along = (strend - s) / SIZE16;
880 unatint = natint && datumtype == 'S';
881 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
886 #if SHORTSIZE != SIZE16
888 unsigned short aushort;
890 COPYNN(s, &aushort, sizeof(unsigned short));
891 s += sizeof(unsigned short);
892 if (checksum > bits_in_uv)
893 cdouble += (NV)aushort;
905 if (datumtype == 'n')
906 aushort = PerlSock_ntohs(aushort);
909 if (datumtype == 'v')
910 aushort = vtohs(aushort);
912 if (checksum > bits_in_uv)
913 cdouble += (NV)aushort;
920 if (len && (flags & UNPACK_ONLY_ONE))
924 #if SHORTSIZE != SIZE16
926 unsigned short aushort;
928 COPYNN(s, &aushort, sizeof(unsigned short));
929 s += sizeof(unsigned short);
931 sv_setiv(sv, (UV)aushort);
932 PUSHs(sv_2mortal(sv));
943 if (datumtype == 'n')
944 aushort = PerlSock_ntohs(aushort);
947 if (datumtype == 'v')
948 aushort = vtohs(aushort);
950 sv_setiv(sv, (UV)aushort);
951 PUSHs(sv_2mortal(sv));
957 along = (strend - s) / sizeof(int);
962 Copy(s, &aint, 1, int);
964 if (checksum > bits_in_uv)
971 if (len && (flags & UNPACK_ONLY_ONE))
976 Copy(s, &aint, 1, int);
980 /* Without the dummy below unpack("i", pack("i",-1))
981 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
982 * cc with optimization turned on.
984 * The bug was detected in
985 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
986 * with optimization (-O4) turned on.
987 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
988 * does not have this problem even with -O4.
990 * This bug was reported as DECC_BUGS 1431
991 * and tracked internally as GEM_BUGS 7775.
993 * The bug is fixed in
994 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
995 * UNIX V4.0F support: DEC C V5.9-006 or later
996 * UNIX V4.0E support: DEC C V5.8-011 or later
999 * See also few lines later for the same bug.
1002 sv_setiv(sv, (IV)aint) :
1004 sv_setiv(sv, (IV)aint);
1005 PUSHs(sv_2mortal(sv));
1010 along = (strend - s) / sizeof(unsigned int);
1015 Copy(s, &auint, 1, unsigned int);
1016 s += sizeof(unsigned int);
1017 if (checksum > bits_in_uv)
1018 cdouble += (NV)auint;
1024 if (len && (flags & UNPACK_ONLY_ONE))
1029 Copy(s, &auint, 1, unsigned int);
1030 s += sizeof(unsigned int);
1033 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1034 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1035 * See details few lines earlier. */
1037 sv_setuv(sv, (UV)auint) :
1039 sv_setuv(sv, (UV)auint);
1040 PUSHs(sv_2mortal(sv));
1045 along = (strend - s) / IVSIZE;
1050 Copy(s, &aiv, 1, IV);
1052 if (checksum > bits_in_uv)
1059 if (len && (flags & UNPACK_ONLY_ONE))
1064 Copy(s, &aiv, 1, IV);
1068 PUSHs(sv_2mortal(sv));
1073 along = (strend - s) / UVSIZE;
1078 Copy(s, &auv, 1, UV);
1080 if (checksum > bits_in_uv)
1087 if (len && (flags & UNPACK_ONLY_ONE))
1092 Copy(s, &auv, 1, UV);
1096 PUSHs(sv_2mortal(sv));
1101 #if LONGSIZE == SIZE32
1102 along = (strend - s) / SIZE32;
1104 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
1109 #if LONGSIZE != SIZE32
1112 COPYNN(s, &along, sizeof(long));
1114 if (checksum > bits_in_uv)
1115 cdouble += (NV)along;
1124 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1128 #if LONGSIZE > SIZE32
1129 if (along > 2147483647)
1130 along -= 4294967296;
1133 if (checksum > bits_in_uv)
1134 cdouble += (NV)along;
1141 if (len && (flags & UNPACK_ONLY_ONE))
1145 #if LONGSIZE != SIZE32
1148 COPYNN(s, &along, sizeof(long));
1151 sv_setiv(sv, (IV)along);
1152 PUSHs(sv_2mortal(sv));
1159 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1163 #if LONGSIZE > SIZE32
1164 if (along > 2147483647)
1165 along -= 4294967296;
1169 sv_setiv(sv, (IV)along);
1170 PUSHs(sv_2mortal(sv));
1178 #if LONGSIZE == SIZE32
1179 along = (strend - s) / SIZE32;
1181 unatint = natint && datumtype == 'L';
1182 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
1187 #if LONGSIZE != SIZE32
1189 unsigned long aulong;
1191 COPYNN(s, &aulong, sizeof(unsigned long));
1192 s += sizeof(unsigned long);
1193 if (checksum > bits_in_uv)
1194 cdouble += (NV)aulong;
1206 if (datumtype == 'N')
1207 aulong = PerlSock_ntohl(aulong);
1210 if (datumtype == 'V')
1211 aulong = vtohl(aulong);
1213 if (checksum > bits_in_uv)
1214 cdouble += (NV)aulong;
1221 if (len && (flags & UNPACK_ONLY_ONE))
1225 #if LONGSIZE != SIZE32
1227 unsigned long aulong;
1229 COPYNN(s, &aulong, sizeof(unsigned long));
1230 s += sizeof(unsigned long);
1232 sv_setuv(sv, (UV)aulong);
1233 PUSHs(sv_2mortal(sv));
1243 if (datumtype == 'N')
1244 aulong = PerlSock_ntohl(aulong);
1247 if (datumtype == 'V')
1248 aulong = vtohl(aulong);
1251 sv_setuv(sv, (UV)aulong);
1252 PUSHs(sv_2mortal(sv));
1258 along = (strend - s) / sizeof(char*);
1264 if (sizeof(char*) > strend - s)
1267 Copy(s, &aptr, 1, char*);
1273 PUSHs(sv_2mortal(sv));
1277 if (len && (flags & UNPACK_ONLY_ONE))
1285 while ((len > 0) && (s < strend)) {
1286 auv = (auv << 7) | (*s & 0x7f);
1287 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1288 if ((U8)(*s++) < 0x80) {
1292 PUSHs(sv_2mortal(sv));
1296 else if (++bytes >= sizeof(UV)) { /* promote to string */
1300 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1301 while (s < strend) {
1302 sv = mul128(sv, (U8)(*s & 0x7f));
1303 if (!(*s++ & 0x80)) {
1312 PUSHs(sv_2mortal(sv));
1317 if ((s >= strend) && bytes)
1318 Perl_croak(aTHX_ "Unterminated compressed integer");
1323 Perl_croak(aTHX_ "P must have an explicit size");
1325 if (sizeof(char*) > strend - s)
1328 Copy(s, &aptr, 1, char*);
1333 sv_setpvn(sv, aptr, len);
1334 PUSHs(sv_2mortal(sv));
1338 along = (strend - s) / sizeof(Quad_t);
1343 Copy(s, &aquad, 1, Quad_t);
1344 s += sizeof(Quad_t);
1345 if (checksum > bits_in_uv)
1346 cdouble += (NV)aquad;
1352 if (len && (flags & UNPACK_ONLY_ONE))
1357 if (s + sizeof(Quad_t) > strend)
1360 Copy(s, &aquad, 1, Quad_t);
1361 s += sizeof(Quad_t);
1364 if (aquad >= IV_MIN && aquad <= IV_MAX)
1365 sv_setiv(sv, (IV)aquad);
1367 sv_setnv(sv, (NV)aquad);
1368 PUSHs(sv_2mortal(sv));
1373 along = (strend - s) / sizeof(Uquad_t);
1378 Copy(s, &auquad, 1, Uquad_t);
1379 s += sizeof(Uquad_t);
1380 if (checksum > bits_in_uv)
1381 cdouble += (NV)auquad;
1387 if (len && (flags & UNPACK_ONLY_ONE))
1392 if (s + sizeof(Uquad_t) > strend)
1395 Copy(s, &auquad, 1, Uquad_t);
1396 s += sizeof(Uquad_t);
1399 if (auquad <= UV_MAX)
1400 sv_setuv(sv, (UV)auquad);
1402 sv_setnv(sv, (NV)auquad);
1403 PUSHs(sv_2mortal(sv));
1408 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1410 along = (strend - s) / sizeof(float);
1415 Copy(s, &afloat, 1, float);
1421 if (len && (flags & UNPACK_ONLY_ONE))
1426 Copy(s, &afloat, 1, float);
1429 sv_setnv(sv, (NV)afloat);
1430 PUSHs(sv_2mortal(sv));
1435 along = (strend - s) / sizeof(double);
1440 Copy(s, &adouble, 1, double);
1441 s += sizeof(double);
1446 if (len && (flags & UNPACK_ONLY_ONE))
1451 Copy(s, &adouble, 1, double);
1452 s += sizeof(double);
1454 sv_setnv(sv, (NV)adouble);
1455 PUSHs(sv_2mortal(sv));
1460 along = (strend - s) / NVSIZE;
1465 Copy(s, &anv, 1, NV);
1471 if (len && (flags & UNPACK_ONLY_ONE))
1476 Copy(s, &anv, 1, NV);
1480 PUSHs(sv_2mortal(sv));
1484 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1486 along = (strend - s) / LONG_DOUBLESIZE;
1491 Copy(s, &aldouble, 1, long double);
1492 s += LONG_DOUBLESIZE;
1493 cdouble += aldouble;
1497 if (len && (flags & UNPACK_ONLY_ONE))
1502 Copy(s, &aldouble, 1, long double);
1503 s += LONG_DOUBLESIZE;
1505 sv_setnv(sv, (NV)aldouble);
1506 PUSHs(sv_2mortal(sv));
1513 * Initialise the decode mapping. By using a table driven
1514 * algorithm, the code will be character-set independent
1515 * (and just as fast as doing character arithmetic)
1517 if (PL_uudmap['M'] == 0) {
1520 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1521 PL_uudmap[(U8)PL_uuemap[i]] = i;
1523 * Because ' ' and '`' map to the same value,
1524 * we need to decode them both the same.
1529 along = (strend - s) * 3 / 4;
1530 sv = NEWSV(42, along);
1533 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1538 len = PL_uudmap[*(U8*)s++] & 077;
1540 if (s < strend && ISUUCHAR(*s))
1541 a = PL_uudmap[*(U8*)s++] & 077;
1544 if (s < strend && ISUUCHAR(*s))
1545 b = PL_uudmap[*(U8*)s++] & 077;
1548 if (s < strend && ISUUCHAR(*s))
1549 c = PL_uudmap[*(U8*)s++] & 077;
1552 if (s < strend && ISUUCHAR(*s))
1553 d = PL_uudmap[*(U8*)s++] & 077;
1556 hunk[0] = (char)((a << 2) | (b >> 4));
1557 hunk[1] = (char)((b << 4) | (c >> 2));
1558 hunk[2] = (char)((c << 6) | d);
1559 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1564 else /* possible checksum byte */
1565 if (s + 1 < strend && s[1] == '\n')
1568 XPUSHs(sv_2mortal(sv));
1573 if (strchr("fFdD", datumtype) ||
1574 (checksum > bits_in_uv &&
1575 strchr("csSiIlLnNUvVqQjJ", datumtype)) ) {
1578 adouble = (NV) (1 << (checksum & 15));
1579 while (checksum >= 16) {
1583 while (cdouble < 0.0)
1585 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1586 sv_setnv(sv, cdouble);
1589 if (checksum < bits_in_uv) {
1590 UV mask = ((UV)1 << checksum) - 1;
1596 XPUSHs(sv_2mortal(sv));
1603 return SP - PL_stack_base - start_sp_offset;
1610 I32 gimme = GIMME_V;
1613 register char *pat = SvPV(left, llen);
1614 #ifdef PACKED_IS_OCTETS
1615 /* Packed side is assumed to be octets - so force downgrade if it
1616 has been UTF-8 encoded by accident
1618 register char *s = SvPVbyte(right, rlen);
1620 register char *s = SvPV(right, rlen);
1622 char *strend = s + rlen;
1623 register char *patend = pat + llen;
1627 cnt = unpack_str(pat, patend, s, s, strend, NULL, 0,
1628 ((gimme == G_SCALAR) ? UNPACK_ONLY_ONE : 0)
1629 | (DO_UTF8(right) ? UNPACK_DO_UTF8 : 0));
1631 if ( !cnt && gimme == G_SCALAR )
1632 PUSHs(&PL_sv_undef);
1637 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1641 *hunk = PL_uuemap[len];
1642 sv_catpvn(sv, hunk, 1);
1645 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1646 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1647 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1648 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1649 sv_catpvn(sv, hunk, 4);
1654 char r = (len > 1 ? s[1] : '\0');
1655 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1656 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1657 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1658 hunk[3] = PL_uuemap[0];
1659 sv_catpvn(sv, hunk, 4);
1661 sv_catpvn(sv, "\n", 1);
1665 S_is_an_int(pTHX_ char *s, STRLEN l)
1668 SV *result = newSVpvn(s, l);
1669 char *result_c = SvPV(result, n_a); /* convenience */
1670 char *out = result_c;
1680 SvREFCNT_dec(result);
1703 SvREFCNT_dec(result);
1709 SvCUR_set(result, out - result_c);
1713 /* pnum must be '\0' terminated */
1715 S_div128(pTHX_ SV *pnum, bool *done)
1718 char *s = SvPV(pnum, len);
1727 i = m * 10 + (*t - '0');
1729 r = (i >> 7); /* r < 10 */
1736 SvCUR_set(pnum, (STRLEN) (t - s));
1740 #define PACK_CHILD 0x1
1743 =for apidoc pack_cat
1745 The engine implementing pack() Perl function.
1750 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1758 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1759 static char *space10 = " ";
1762 /* These must not be in registers: */
1772 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1773 long double aldouble;
1783 #ifdef PERL_NATINT_PACK
1784 int natint; /* native integer */
1787 items = endlist - beglist;
1788 #ifndef PACKED_IS_OCTETS
1789 pat = next_symbol(pat, patend);
1790 if (pat < patend && *pat == 'U' && !flags)
1793 while ((pat = next_symbol(pat, patend)) < patend) {
1794 SV *lengthcode = Nullsv;
1795 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1796 datumtype = *pat++ & 0xFF;
1797 #ifdef PERL_NATINT_PACK
1801 static const char natstr[] = "sSiIlLxX";
1803 if (strchr(natstr, datumtype)) {
1804 if (datumtype == 'x' || datumtype == 'X') {
1805 datumtype |= TYPE_IS_SHRIEKING;
1806 } else { /* XXXX Should be redone similarly! */
1807 #ifdef PERL_NATINT_PACK
1814 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
1816 len = find_count(&pat, patend, &star);
1817 if (star > 0) /* Count is '*' */
1818 len = strchr("@Xxu", datumtype) ? 0 : items;
1819 else if (star < 0) /* Default len */
1821 if (*pat == '/') { /* doing lookahead how... */
1823 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
1824 Perl_croak(aTHX_ "/ must be followed by a*, A* or Z*");
1825 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1826 ? *beglist : &PL_sv_no)
1827 + (*pat == 'Z' ? 1 : 0)));
1831 Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
1832 case ',': /* grandfather in commas but with a warning */
1833 if (commas++ == 0 && ckWARN(WARN_PACK))
1834 Perl_warner(aTHX_ packWARN(WARN_PACK),
1835 "Invalid type in pack: '%c'", (int)datumtype);
1838 Perl_croak(aTHX_ "%% may only be used in unpack");
1850 SV **savebeglist = beglist; /* beglist de-register-ed */
1853 Perl_croak(aTHX_ "()-group starts with a count");
1854 aptr = group_end(beg, patend, ')');
1857 len = find_count(&pat, patend, &star);
1858 if (star < 0) /* No count */
1860 else if (star > 0) /* Star */
1861 len = items; /* long enough? */
1864 pack_cat(cat, beg, aptr, savebeglist, endlist,
1865 &savebeglist, PACK_CHILD);
1866 if (star > 0 && savebeglist == endlist)
1867 break; /* No way to continue */
1869 beglist = savebeglist;
1872 case 'X' | TYPE_IS_SHRIEKING:
1873 if (!len) /* Avoid division by 0 */
1875 len = (SvCUR(cat)) % len;
1879 if ((I32)SvCUR(cat) < len)
1880 Perl_croak(aTHX_ "X outside of string");
1884 case 'x' | TYPE_IS_SHRIEKING:
1885 if (!len) /* Avoid division by 0 */
1887 aint = (SvCUR(cat)) % len;
1888 if (aint) /* Other portable ways? */
1896 sv_catpvn(cat, null10, 10);
1899 sv_catpvn(cat, null10, len);
1905 aptr = SvPV(fromstr, fromlen);
1906 if (star > 0) { /* -2 after '/' */
1908 if (datumtype == 'Z')
1911 if ((I32)fromlen >= len) {
1912 sv_catpvn(cat, aptr, len);
1913 if (datumtype == 'Z')
1914 *(SvEND(cat)-1) = '\0';
1917 sv_catpvn(cat, aptr, fromlen);
1919 if (datumtype == 'A') {
1921 sv_catpvn(cat, space10, 10);
1924 sv_catpvn(cat, space10, len);
1928 sv_catpvn(cat, null10, 10);
1931 sv_catpvn(cat, null10, len);
1943 str = SvPV(fromstr, fromlen);
1947 SvCUR(cat) += (len+7)/8;
1948 SvGROW(cat, SvCUR(cat) + 1);
1949 aptr = SvPVX(cat) + aint;
1950 if (len > (I32)fromlen)
1954 if (datumtype == 'B') {
1955 for (len = 0; len++ < aint;) {
1956 items |= *str++ & 1;
1960 *aptr++ = items & 0xff;
1966 for (len = 0; len++ < aint;) {
1972 *aptr++ = items & 0xff;
1978 if (datumtype == 'B')
1979 items <<= 7 - (aint & 7);
1981 items >>= 7 - (aint & 7);
1982 *aptr++ = items & 0xff;
1984 str = SvPVX(cat) + SvCUR(cat);
1999 str = SvPV(fromstr, fromlen);
2003 SvCUR(cat) += (len+1)/2;
2004 SvGROW(cat, SvCUR(cat) + 1);
2005 aptr = SvPVX(cat) + aint;
2006 if (len > (I32)fromlen)
2010 if (datumtype == 'H') {
2011 for (len = 0; len++ < aint;) {
2013 items |= ((*str++ & 15) + 9) & 15;
2015 items |= *str++ & 15;
2019 *aptr++ = items & 0xff;
2025 for (len = 0; len++ < aint;) {
2027 items |= (((*str++ & 15) + 9) & 15) << 4;
2029 items |= (*str++ & 15) << 4;
2033 *aptr++ = items & 0xff;
2039 *aptr++ = items & 0xff;
2040 str = SvPVX(cat) + SvCUR(cat);
2051 switch (datumtype) {
2053 aint = SvIV(fromstr);
2054 if ((aint < 0 || aint > 255) &&
2056 Perl_warner(aTHX_ packWARN(WARN_PACK),
2057 "Character in \"C\" format wrapped");
2059 sv_catpvn(cat, &achar, sizeof(char));
2062 aint = SvIV(fromstr);
2063 if ((aint < -128 || aint > 127) &&
2065 Perl_warner(aTHX_ packWARN(WARN_PACK),
2066 "Character in \"c\" format wrapped");
2068 sv_catpvn(cat, &achar, sizeof(char));
2076 auint = UNI_TO_NATIVE(SvUV(fromstr));
2077 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2079 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2082 0 : UNICODE_ALLOW_ANY)
2087 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2092 /* VOS does not automatically map a floating-point overflow
2093 during conversion from double to float into infinity, so we
2094 do it by hand. This code should either be generalized for
2095 any OS that needs it, or removed if and when VOS implements
2096 posix-976 (suggestion to support mapping to infinity).
2097 Paul.Green@stratus.com 02-04-02. */
2098 if (SvNV(fromstr) > FLT_MAX)
2099 afloat = _float_constants[0]; /* single prec. inf. */
2100 else if (SvNV(fromstr) < -FLT_MAX)
2101 afloat = _float_constants[0]; /* single prec. inf. */
2102 else afloat = (float)SvNV(fromstr);
2104 afloat = (float)SvNV(fromstr);
2106 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2113 /* VOS does not automatically map a floating-point overflow
2114 during conversion from long double to double into infinity,
2115 so we do it by hand. This code should either be generalized
2116 for any OS that needs it, or removed if and when VOS
2117 implements posix-976 (suggestion to support mapping to
2118 infinity). Paul.Green@stratus.com 02-04-02. */
2119 if (SvNV(fromstr) > DBL_MAX)
2120 adouble = _double_constants[0]; /* double prec. inf. */
2121 else if (SvNV(fromstr) < -DBL_MAX)
2122 adouble = _double_constants[0]; /* double prec. inf. */
2123 else adouble = (double)SvNV(fromstr);
2125 adouble = (double)SvNV(fromstr);
2127 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2133 anv = SvNV(fromstr);
2134 sv_catpvn(cat, (char *)&anv, NVSIZE);
2137 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2141 aldouble = (long double)SvNV(fromstr);
2142 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2149 ashort = (I16)SvIV(fromstr);
2151 ashort = PerlSock_htons(ashort);
2153 CAT16(cat, &ashort);
2159 ashort = (I16)SvIV(fromstr);
2161 ashort = htovs(ashort);
2163 CAT16(cat, &ashort);
2167 #if SHORTSIZE != SIZE16
2169 unsigned short aushort;
2173 aushort = SvUV(fromstr);
2174 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2184 aushort = (U16)SvUV(fromstr);
2185 CAT16(cat, &aushort);
2191 #if SHORTSIZE != SIZE16
2197 ashort = SvIV(fromstr);
2198 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2206 ashort = (I16)SvIV(fromstr);
2207 CAT16(cat, &ashort);
2214 auint = SvUV(fromstr);
2215 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2221 aiv = SvIV(fromstr);
2222 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2228 auv = SvUV(fromstr);
2229 sv_catpvn(cat, (char*)&auv, UVSIZE);
2235 adouble = SvNV(fromstr);
2238 Perl_croak(aTHX_ "Cannot compress negative numbers");
2240 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2241 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2242 any negative IVs will have already been got by the croak()
2243 above. IOK is untrue for fractions, so we test them
2244 against UV_MAX_P1. */
2245 if (SvIOK(fromstr) || adouble < UV_MAX_P1)
2247 char buf[(sizeof(UV)*8)/7+1];
2248 char *in = buf + sizeof(buf);
2249 UV auv = SvUV(fromstr);
2252 *--in = (char)((auv & 0x7f) | 0x80);
2255 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2256 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2258 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2259 char *from, *result, *in;
2264 /* Copy string and check for compliance */
2265 from = SvPV(fromstr, len);
2266 if ((norm = is_an_int(from, len)) == NULL)
2267 Perl_croak(aTHX_ "can compress only unsigned integer");
2269 New('w', result, len, char);
2273 *--in = div128(norm, &done) | 0x80;
2274 result[len - 1] &= 0x7F; /* clear continue bit */
2275 sv_catpvn(cat, in, (result + len) - in);
2277 SvREFCNT_dec(norm); /* free norm */
2279 else if (SvNOKp(fromstr)) {
2280 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
2281 char *in = buf + sizeof(buf);
2283 adouble = Perl_floor(adouble);
2285 double next = floor(adouble / 128);
2286 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
2287 if (in <= buf) /* this cannot happen ;-) */
2288 Perl_croak(aTHX_ "Cannot compress integer");
2290 } while (adouble > 0);
2291 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2292 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2295 char *from, *result, *in;
2300 /* Copy string and check for compliance */
2301 from = SvPV(fromstr, len);
2302 if ((norm = is_an_int(from, len)) == NULL)
2303 Perl_croak(aTHX_ "can compress only unsigned integer");
2305 New('w', result, len, char);
2309 *--in = div128(norm, &done) | 0x80;
2310 result[len - 1] &= 0x7F; /* clear continue bit */
2311 sv_catpvn(cat, in, (result + len) - in);
2313 SvREFCNT_dec(norm); /* free norm */
2320 aint = SvIV(fromstr);
2321 sv_catpvn(cat, (char*)&aint, sizeof(int));
2327 aulong = SvUV(fromstr);
2329 aulong = PerlSock_htonl(aulong);
2331 CAT32(cat, &aulong);
2337 aulong = SvUV(fromstr);
2339 aulong = htovl(aulong);
2341 CAT32(cat, &aulong);
2345 #if LONGSIZE != SIZE32
2347 unsigned long aulong;
2351 aulong = SvUV(fromstr);
2352 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2360 aulong = SvUV(fromstr);
2361 CAT32(cat, &aulong);
2366 #if LONGSIZE != SIZE32
2372 along = SvIV(fromstr);
2373 sv_catpvn(cat, (char *)&along, sizeof(long));
2381 along = SvIV(fromstr);
2390 auquad = (Uquad_t)SvUV(fromstr);
2391 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2397 aquad = (Quad_t)SvIV(fromstr);
2398 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2403 len = 1; /* assume SV is correct length */
2408 if (fromstr == &PL_sv_undef)
2412 /* XXX better yet, could spirit away the string to
2413 * a safe spot and hang on to it until the result
2414 * of pack() (and all copies of the result) are
2417 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2418 || (SvPADTMP(fromstr)
2419 && !SvREADONLY(fromstr))))
2421 Perl_warner(aTHX_ packWARN(WARN_PACK),
2422 "Attempt to pack pointer to temporary value");
2424 if (SvPOK(fromstr) || SvNIOK(fromstr))
2425 aptr = SvPV(fromstr,n_a);
2427 aptr = SvPV_force(fromstr,n_a);
2429 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2434 aptr = SvPV(fromstr, fromlen);
2435 SvGROW(cat, fromlen * 4 / 3);
2440 while (fromlen > 0) {
2443 if ((I32)fromlen > len)
2447 doencodes(cat, aptr, todo);
2455 *next_in_list = beglist;
2462 dSP; dMARK; dORIGMARK; dTARGET;
2463 register SV *cat = TARG;
2465 register char *pat = SvPVx(*++MARK, fromlen);
2466 register char *patend = pat + fromlen;
2469 sv_setpvn(cat, "", 0);
2471 pack_cat(cat, pat, patend, MARK, SP + 1, NULL, 0);