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' + (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);
151 #define TYPE_IS_SHRIEKING 0x100
153 /* Returns the sizeof() struct described by pat */
155 S_measure_struct(pTHX_ char *pat, register char *patend)
159 register I32 total = 0;
161 int star; /* 1 if count is *, -1 if no count given, -2 for / */
162 #ifdef PERL_NATINT_PACK
163 int natint; /* native integer */
164 int unatint; /* unsigned native integer */
169 while ((pat = next_symbol(pat, patend)) < patend) {
170 datumtype = *pat++ & 0xFF;
171 #ifdef PERL_NATINT_PACK
175 static const char *natstr = "sSiIlLxX";
177 if (strchr(natstr, datumtype)) {
178 if (datumtype == 'x' || datumtype == 'X') {
179 datumtype |= TYPE_IS_SHRIEKING;
180 } else { /* XXXX Should be redone similarly! */
181 #ifdef PERL_NATINT_PACK
188 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
190 len = find_count(&pat, patend, &star);
192 Perl_croak(aTHX_ "%s not allowed in length fields", "count *");
193 else if (star < 0) /* No explicit len */
194 len = datumtype != '@';
198 Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
201 case 'U': /* XXXX Is it correct? */
206 Perl_croak(aTHX_ "%s not allowed in length fields", buf);
207 case ',': /* grandfather in commas but with a warning */
208 if (commas++ == 0 && ckWARN(WARN_UNPACK))
209 Perl_warner(aTHX_ WARN_UNPACK,
210 "Invalid type in unpack: '%c'", (int)datumtype);
217 char *beg = pat, *end;
220 Perl_croak(aTHX_ "()-group starts with a count");
221 end = group_end(beg, patend, ')');
223 len = find_count(&pat, patend, &star);
224 if (star < 0) /* No count */
226 else if (star > 0) /* Star */
227 Perl_croak(aTHX_ "%s not allowed in length fields", "count *");
228 /* XXXX Theoretically, we need to measure many times at different
229 positions, since the subexpression may contain
230 alignment commands, but be not of aligned length.
231 Need to detect this and croak(). */
232 size = measure_struct(beg, end);
235 case 'X' | TYPE_IS_SHRIEKING:
236 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */
237 if (!len) /* Avoid division by 0 */
239 len = total % len; /* Assumed: the start is aligned. */
244 Perl_croak(aTHX_ "X outside of string");
246 case 'x' | TYPE_IS_SHRIEKING:
247 if (!len) /* Avoid division by 0 */
249 star = total % len; /* Assumed: the start is aligned. */
250 if (star) /* Other portable ways? */
274 #if SHORTSIZE == SIZE16
277 size = (natint ? sizeof(short) : SIZE16);
283 #if SHORTSIZE == SIZE16
286 unatint = natint && datumtype == 'S';
287 size = (unatint ? sizeof(unsigned short) : SIZE16);
294 size = sizeof(unsigned int);
303 #if LONGSIZE == SIZE32
306 size = (natint ? sizeof(long) : SIZE32);
312 #if LONGSIZE == SIZE32
315 unatint = natint && datumtype == 'L';
316 size = (unatint ? sizeof(unsigned long) : SIZE32);
323 size = sizeof(char*);
327 size = sizeof(Quad_t);
330 size = sizeof(Uquad_t);
334 size = sizeof(float);
337 size = sizeof(double);
342 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
344 size = LONG_DOUBLESIZE;
353 /* Returns -1 on no count or on star */
355 S_find_count(pTHX_ char **ppat, register char *patend, int *star)
363 else if (*pat == '*') {
368 else if (isDIGIT(*pat)) {
370 while (isDIGIT(*pat)) {
371 len = (len * 10) + (*pat++ - '0');
372 if (len < 0) /* 50% chance of catching... */
373 Perl_croak(aTHX_ "Repeat count in pack/unpack overflows");
376 else if (*pat == '[') {
377 char *end = group_end(++pat, patend, ']');
382 return find_count(&pat, end, star);
383 return measure_struct(pat, end);
392 S_next_symbol(pTHX_ register char *pat, register char *patend)
394 while (pat < patend) {
397 else if (*pat == '#') {
399 while (pat < patend && *pat != '\n')
411 =for apidoc unpack_str
413 The engine implementing unpack() Perl function.
418 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
423 register I32 bits = 0;
426 I32 start_sp_offset = SP - PL_stack_base;
428 /* These must not be in registers: */
447 const int bits_in_uv = 8 * sizeof(cuv);
449 int star; /* 1 if count is *, -1 if no count given, -2 for / */
450 #ifdef PERL_NATINT_PACK
451 int natint; /* native integer */
452 int unatint; /* unsigned native integer */
457 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
458 long double aldouble;
460 bool do_utf8 = flags & UNPACK_DO_UTF8;
462 while ((pat = next_symbol(pat, patend)) < patend) {
463 datumtype = *pat++ & 0xFF;
464 #ifdef PERL_NATINT_PACK
467 /* do first one only unless in list context
468 / is implemented by unpacking the count, then poping it from the
469 stack, so must check that we're not in the middle of a / */
470 if ( (flags & UNPACK_ONLY_ONE)
471 && (SP - PL_stack_base == start_sp_offset + 1)
472 && (datumtype != '/') )
475 static const char natstr[] = "sSiIlLxX";
477 if (strchr(natstr, datumtype)) {
478 if (datumtype == 'x' || datumtype == 'X') {
479 datumtype |= TYPE_IS_SHRIEKING;
480 } else { /* XXXX Should be redone similarly! */
481 #ifdef PERL_NATINT_PACK
488 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
490 len = find_count(&pat, patend, &star);
492 len = strend - strbeg; /* long enough */
493 else if (star < 0) /* No explicit len */
494 len = datumtype != '@';
499 Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
500 case ',': /* grandfather in commas but with a warning */
501 if (commas++ == 0 && ckWARN(WARN_UNPACK))
502 Perl_warner(aTHX_ WARN_UNPACK,
503 "Invalid type in unpack: '%c'", (int)datumtype);
506 if (len == 1 && pat[-1] != '1' && pat[-1] != ']')
507 len = 16; /* len is not specified */
516 char *ss = s; /* Move from register */
519 Perl_croak(aTHX_ "()-group starts with a count");
520 aptr = group_end(beg, patend, ')');
523 len = find_count(&pat, patend, &star);
524 if (star < 0) /* No count */
526 else if (star > 0) /* Star */
527 len = strend - strbeg; /* long enough? */
531 unpack_str(beg, aptr, ss, strbeg, strend, &ss,
532 ocnt + SP - PL_stack_base - start_sp_offset, flags);
533 if (star > 0 && ss == strend)
534 break; /* No way to continue */
541 if (len > strend - strbeg)
542 Perl_croak(aTHX_ "@ outside of string");
545 case 'X' | TYPE_IS_SHRIEKING:
546 if (!len) /* Avoid division by 0 */
548 len = (s - strbeg) % len;
551 if (len > s - strbeg)
552 Perl_croak(aTHX_ "X outside of string");
555 case 'x' | TYPE_IS_SHRIEKING:
556 if (!len) /* Avoid division by 0 */
558 aint = (s - strbeg) % len;
559 if (aint) /* Other portable ways? */
565 if (len > strend - s)
566 Perl_croak(aTHX_ "x outside of string");
570 if (ocnt + SP - PL_stack_base - start_sp_offset <= 0)
571 Perl_croak(aTHX_ "/ must follow a numeric type");
574 pat++; /* ignore '*' for compatibility with pack */
576 Perl_croak(aTHX_ "/ cannot take a count" );
583 if (len > strend - s)
588 sv_setpvn(sv, s, len);
589 if (datumtype == 'A' || datumtype == 'Z') {
590 aptr = s; /* borrow register */
591 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
595 if (star > 0) /* exact for 'Z*' */
596 len = s - SvPVX(sv) + 1;
598 else { /* 'A' strips both nulls and spaces */
599 s = SvPVX(sv) + len - 1;
600 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
604 SvCUR_set(sv, s - SvPVX(sv));
605 s = aptr; /* unborrow register */
608 XPUSHs(sv_2mortal(sv));
612 if (star > 0 || len > (strend - s) * 8)
613 len = (strend - s) * 8;
616 Newz(601, PL_bitcount, 256, char);
617 for (bits = 1; bits < 256; bits++) {
618 if (bits & 1) PL_bitcount[bits]++;
619 if (bits & 2) PL_bitcount[bits]++;
620 if (bits & 4) PL_bitcount[bits]++;
621 if (bits & 8) PL_bitcount[bits]++;
622 if (bits & 16) PL_bitcount[bits]++;
623 if (bits & 32) PL_bitcount[bits]++;
624 if (bits & 64) PL_bitcount[bits]++;
625 if (bits & 128) PL_bitcount[bits]++;
629 cuv += PL_bitcount[*(unsigned char*)s++];
634 if (datumtype == 'b') {
642 if (bits & 128) cuv++;
649 sv = NEWSV(35, len + 1);
653 if (datumtype == 'b') {
655 for (len = 0; len < aint; len++) {
656 if (len & 7) /*SUPPRESS 595*/
660 *str++ = '0' + (bits & 1);
665 for (len = 0; len < aint; len++) {
670 *str++ = '0' + ((bits & 128) != 0);
674 XPUSHs(sv_2mortal(sv));
678 if (star > 0 || len > (strend - s) * 2)
679 len = (strend - s) * 2;
680 sv = NEWSV(35, len + 1);
684 if (datumtype == 'h') {
686 for (len = 0; len < aint; len++) {
691 *str++ = PL_hexdigit[bits & 15];
696 for (len = 0; len < aint; len++) {
701 *str++ = PL_hexdigit[(bits >> 4) & 15];
705 XPUSHs(sv_2mortal(sv));
708 if (len > strend - s)
713 if (aint >= 128) /* fake up signed chars */
715 if (checksum > bits_in_uv)
726 if (aint >= 128) /* fake up signed chars */
729 sv_setiv(sv, (IV)aint);
730 PUSHs(sv_2mortal(sv));
735 unpack_C: /* unpack U will jump here if not UTF-8 */
740 if (len > strend - s)
755 sv_setiv(sv, (IV)auint);
756 PUSHs(sv_2mortal(sv));
767 if (len > strend - s)
770 while (len-- > 0 && s < strend) {
772 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, 0));
775 if (checksum > bits_in_uv)
776 cdouble += (NV)auint;
784 while (len-- > 0 && s < strend) {
786 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, 0));
790 sv_setuv(sv, (UV)auint);
791 PUSHs(sv_2mortal(sv));
796 #if SHORTSIZE == SIZE16
797 along = (strend - s) / SIZE16;
799 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
804 #if SHORTSIZE != SIZE16
808 COPYNN(s, &ashort, sizeof(short));
810 if (checksum > bits_in_uv)
811 cdouble += (NV)ashort;
822 #if SHORTSIZE > SIZE16
827 if (checksum > bits_in_uv)
828 cdouble += (NV)ashort;
837 #if SHORTSIZE != SIZE16
841 COPYNN(s, &ashort, sizeof(short));
844 sv_setiv(sv, (IV)ashort);
845 PUSHs(sv_2mortal(sv));
853 #if SHORTSIZE > SIZE16
859 sv_setiv(sv, (IV)ashort);
860 PUSHs(sv_2mortal(sv));
868 #if SHORTSIZE == SIZE16
869 along = (strend - s) / SIZE16;
871 unatint = natint && datumtype == 'S';
872 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
877 #if SHORTSIZE != SIZE16
879 unsigned short aushort;
881 COPYNN(s, &aushort, sizeof(unsigned short));
882 s += sizeof(unsigned short);
883 if (checksum > bits_in_uv)
884 cdouble += (NV)aushort;
896 if (datumtype == 'n')
897 aushort = PerlSock_ntohs(aushort);
900 if (datumtype == 'v')
901 aushort = vtohs(aushort);
903 if (checksum > bits_in_uv)
904 cdouble += (NV)aushort;
913 #if SHORTSIZE != SIZE16
915 unsigned short aushort;
917 COPYNN(s, &aushort, sizeof(unsigned short));
918 s += sizeof(unsigned short);
920 sv_setiv(sv, (UV)aushort);
921 PUSHs(sv_2mortal(sv));
932 if (datumtype == 'n')
933 aushort = PerlSock_ntohs(aushort);
936 if (datumtype == 'v')
937 aushort = vtohs(aushort);
939 sv_setiv(sv, (UV)aushort);
940 PUSHs(sv_2mortal(sv));
946 along = (strend - s) / sizeof(int);
951 Copy(s, &aint, 1, int);
953 if (checksum > bits_in_uv)
963 Copy(s, &aint, 1, int);
967 /* Without the dummy below unpack("i", pack("i",-1))
968 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
969 * cc with optimization turned on.
971 * The bug was detected in
972 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
973 * with optimization (-O4) turned on.
974 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
975 * does not have this problem even with -O4.
977 * This bug was reported as DECC_BUGS 1431
978 * and tracked internally as GEM_BUGS 7775.
980 * The bug is fixed in
981 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
982 * UNIX V4.0F support: DEC C V5.9-006 or later
983 * UNIX V4.0E support: DEC C V5.8-011 or later
986 * See also few lines later for the same bug.
989 sv_setiv(sv, (IV)aint) :
991 sv_setiv(sv, (IV)aint);
992 PUSHs(sv_2mortal(sv));
997 along = (strend - s) / sizeof(unsigned int);
1002 Copy(s, &auint, 1, unsigned int);
1003 s += sizeof(unsigned int);
1004 if (checksum > bits_in_uv)
1005 cdouble += (NV)auint;
1014 Copy(s, &auint, 1, unsigned int);
1015 s += sizeof(unsigned int);
1018 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1019 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1020 * See details few lines earlier. */
1022 sv_setuv(sv, (UV)auint) :
1024 sv_setuv(sv, (UV)auint);
1025 PUSHs(sv_2mortal(sv));
1030 along = (strend - s) / IVSIZE;
1035 Copy(s, &aiv, 1, IV);
1037 if (checksum > bits_in_uv)
1047 Copy(s, &aiv, 1, IV);
1051 PUSHs(sv_2mortal(sv));
1056 along = (strend - s) / UVSIZE;
1061 Copy(s, &auv, 1, UV);
1063 if (checksum > bits_in_uv)
1073 Copy(s, &auv, 1, UV);
1077 PUSHs(sv_2mortal(sv));
1082 #if LONGSIZE == SIZE32
1083 along = (strend - s) / SIZE32;
1085 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
1090 #if LONGSIZE != SIZE32
1093 COPYNN(s, &along, sizeof(long));
1095 if (checksum > bits_in_uv)
1096 cdouble += (NV)along;
1105 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1109 #if LONGSIZE > SIZE32
1110 if (along > 2147483647)
1111 along -= 4294967296;
1114 if (checksum > bits_in_uv)
1115 cdouble += (NV)along;
1124 #if LONGSIZE != SIZE32
1127 COPYNN(s, &along, sizeof(long));
1130 sv_setiv(sv, (IV)along);
1131 PUSHs(sv_2mortal(sv));
1138 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1142 #if LONGSIZE > SIZE32
1143 if (along > 2147483647)
1144 along -= 4294967296;
1148 sv_setiv(sv, (IV)along);
1149 PUSHs(sv_2mortal(sv));
1157 #if LONGSIZE == SIZE32
1158 along = (strend - s) / SIZE32;
1160 unatint = natint && datumtype == 'L';
1161 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
1166 #if LONGSIZE != SIZE32
1168 unsigned long aulong;
1170 COPYNN(s, &aulong, sizeof(unsigned long));
1171 s += sizeof(unsigned long);
1172 if (checksum > bits_in_uv)
1173 cdouble += (NV)aulong;
1185 if (datumtype == 'N')
1186 aulong = PerlSock_ntohl(aulong);
1189 if (datumtype == 'V')
1190 aulong = vtohl(aulong);
1192 if (checksum > bits_in_uv)
1193 cdouble += (NV)aulong;
1202 #if LONGSIZE != SIZE32
1204 unsigned long aulong;
1206 COPYNN(s, &aulong, sizeof(unsigned long));
1207 s += sizeof(unsigned long);
1209 sv_setuv(sv, (UV)aulong);
1210 PUSHs(sv_2mortal(sv));
1220 if (datumtype == 'N')
1221 aulong = PerlSock_ntohl(aulong);
1224 if (datumtype == 'V')
1225 aulong = vtohl(aulong);
1228 sv_setuv(sv, (UV)aulong);
1229 PUSHs(sv_2mortal(sv));
1235 along = (strend - s) / sizeof(char*);
1241 if (sizeof(char*) > strend - s)
1244 Copy(s, &aptr, 1, char*);
1250 PUSHs(sv_2mortal(sv));
1260 while ((len > 0) && (s < strend)) {
1261 auv = (auv << 7) | (*s & 0x7f);
1262 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1263 if ((U8)(*s++) < 0x80) {
1267 PUSHs(sv_2mortal(sv));
1271 else if (++bytes >= sizeof(UV)) { /* promote to string */
1275 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1276 while (s < strend) {
1277 sv = mul128(sv, *s & 0x7f);
1278 if (!(*s++ & 0x80)) {
1287 PUSHs(sv_2mortal(sv));
1292 if ((s >= strend) && bytes)
1293 Perl_croak(aTHX_ "Unterminated compressed integer");
1298 Perl_croak(aTHX_ "P must have an explicit size");
1300 if (sizeof(char*) > strend - s)
1303 Copy(s, &aptr, 1, char*);
1308 sv_setpvn(sv, aptr, len);
1309 PUSHs(sv_2mortal(sv));
1313 along = (strend - s) / sizeof(Quad_t);
1318 Copy(s, &aquad, 1, Quad_t);
1319 s += sizeof(Quad_t);
1320 if (checksum > bits_in_uv)
1321 cdouble += (NV)aquad;
1330 if (s + sizeof(Quad_t) > strend)
1333 Copy(s, &aquad, 1, Quad_t);
1334 s += sizeof(Quad_t);
1337 if (aquad >= IV_MIN && aquad <= IV_MAX)
1338 sv_setiv(sv, (IV)aquad);
1340 sv_setnv(sv, (NV)aquad);
1341 PUSHs(sv_2mortal(sv));
1346 along = (strend - s) / sizeof(Uquad_t);
1351 Copy(s, &auquad, 1, Uquad_t);
1352 s += sizeof(Uquad_t);
1353 if (checksum > bits_in_uv)
1354 cdouble += (NV)auquad;
1363 if (s + sizeof(Uquad_t) > strend)
1366 Copy(s, &auquad, 1, Uquad_t);
1367 s += sizeof(Uquad_t);
1370 if (auquad <= UV_MAX)
1371 sv_setuv(sv, (UV)auquad);
1373 sv_setnv(sv, (NV)auquad);
1374 PUSHs(sv_2mortal(sv));
1379 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1381 along = (strend - s) / sizeof(float);
1386 Copy(s, &afloat, 1, float);
1395 Copy(s, &afloat, 1, float);
1398 sv_setnv(sv, (NV)afloat);
1399 PUSHs(sv_2mortal(sv));
1404 along = (strend - s) / sizeof(double);
1409 Copy(s, &adouble, 1, double);
1410 s += sizeof(double);
1418 Copy(s, &adouble, 1, double);
1419 s += sizeof(double);
1421 sv_setnv(sv, (NV)adouble);
1422 PUSHs(sv_2mortal(sv));
1427 along = (strend - s) / NVSIZE;
1432 Copy(s, &anv, 1, NV);
1441 Copy(s, &anv, 1, NV);
1445 PUSHs(sv_2mortal(sv));
1449 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1451 along = (strend - s) / LONG_DOUBLESIZE;
1456 Copy(s, &aldouble, 1, long double);
1457 s += LONG_DOUBLESIZE;
1458 cdouble += aldouble;
1465 Copy(s, &aldouble, 1, long double);
1466 s += LONG_DOUBLESIZE;
1468 sv_setnv(sv, (NV)aldouble);
1469 PUSHs(sv_2mortal(sv));
1476 * Initialise the decode mapping. By using a table driven
1477 * algorithm, the code will be character-set independent
1478 * (and just as fast as doing character arithmetic)
1480 if (PL_uudmap['M'] == 0) {
1483 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1484 PL_uudmap[(U8)PL_uuemap[i]] = i;
1486 * Because ' ' and '`' map to the same value,
1487 * we need to decode them both the same.
1492 along = (strend - s) * 3 / 4;
1493 sv = NEWSV(42, along);
1496 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1501 len = PL_uudmap[*(U8*)s++] & 077;
1503 if (s < strend && ISUUCHAR(*s))
1504 a = PL_uudmap[*(U8*)s++] & 077;
1507 if (s < strend && ISUUCHAR(*s))
1508 b = PL_uudmap[*(U8*)s++] & 077;
1511 if (s < strend && ISUUCHAR(*s))
1512 c = PL_uudmap[*(U8*)s++] & 077;
1515 if (s < strend && ISUUCHAR(*s))
1516 d = PL_uudmap[*(U8*)s++] & 077;
1519 hunk[0] = (a << 2) | (b >> 4);
1520 hunk[1] = (b << 4) | (c >> 2);
1521 hunk[2] = (c << 6) | d;
1522 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1527 else if (s[1] == '\n') /* possible checksum byte */
1530 XPUSHs(sv_2mortal(sv));
1535 if (strchr("fFdD", datumtype) ||
1536 (checksum > bits_in_uv &&
1537 strchr("csSiIlLnNUvVqQjJ", datumtype)) ) {
1540 adouble = (NV) (1 << (checksum & 15));
1541 while (checksum >= 16) {
1545 while (cdouble < 0.0)
1547 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1548 sv_setnv(sv, cdouble);
1551 if (checksum < bits_in_uv) {
1552 UV mask = ((UV)1 << checksum) - 1;
1558 XPUSHs(sv_2mortal(sv));
1565 return SP - PL_stack_base - start_sp_offset;
1572 I32 gimme = GIMME_V;
1575 register char *pat = SvPV(left, llen);
1576 #ifdef PACKED_IS_OCTETS
1577 /* Packed side is assumed to be octets - so force downgrade if it
1578 has been UTF-8 encoded by accident
1580 register char *s = SvPVbyte(right, rlen);
1582 register char *s = SvPV(right, rlen);
1584 char *strend = s + rlen;
1585 register char *patend = pat + llen;
1589 cnt = unpack_str(pat, patend, s, s, strend, NULL, 0,
1590 ((gimme == G_SCALAR) ? UNPACK_ONLY_ONE : 0)
1591 | (DO_UTF8(right) ? UNPACK_DO_UTF8 : 0));
1593 if ( !cnt && gimme == G_SCALAR )
1594 PUSHs(&PL_sv_undef);
1599 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1603 *hunk = PL_uuemap[len];
1604 sv_catpvn(sv, hunk, 1);
1607 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1608 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1609 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1610 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1611 sv_catpvn(sv, hunk, 4);
1616 char r = (len > 1 ? s[1] : '\0');
1617 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1618 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1619 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1620 hunk[3] = PL_uuemap[0];
1621 sv_catpvn(sv, hunk, 4);
1623 sv_catpvn(sv, "\n", 1);
1627 S_is_an_int(pTHX_ char *s, STRLEN l)
1630 SV *result = newSVpvn(s, l);
1631 char *result_c = SvPV(result, n_a); /* convenience */
1632 char *out = result_c;
1642 SvREFCNT_dec(result);
1665 SvREFCNT_dec(result);
1671 SvCUR_set(result, out - result_c);
1675 /* pnum must be '\0' terminated */
1677 S_div128(pTHX_ SV *pnum, bool *done)
1680 char *s = SvPV(pnum, len);
1689 i = m * 10 + (*t - '0');
1691 r = (i >> 7); /* r < 10 */
1698 SvCUR_set(pnum, (STRLEN) (t - s));
1702 #define PACK_CHILD 0x1
1705 =for apidoc pack_cat
1707 The engine implementing pack() Perl function.
1712 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1720 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1721 static char *space10 = " ";
1724 /* These must not be in registers: */
1734 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1735 long double aldouble;
1745 #ifdef PERL_NATINT_PACK
1746 int natint; /* native integer */
1749 items = endlist - beglist;
1750 #ifndef PACKED_IS_OCTETS
1751 pat = next_symbol(pat, patend);
1752 if (pat < patend && *pat == 'U' && !flags)
1755 while ((pat = next_symbol(pat, patend)) < patend) {
1756 SV *lengthcode = Nullsv;
1757 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1758 datumtype = *pat++ & 0xFF;
1759 #ifdef PERL_NATINT_PACK
1763 static const char natstr[] = "sSiIlLxX";
1765 if (strchr(natstr, datumtype)) {
1766 if (datumtype == 'x' || datumtype == 'X') {
1767 datumtype |= TYPE_IS_SHRIEKING;
1768 } else { /* XXXX Should be redone similarly! */
1769 #ifdef PERL_NATINT_PACK
1776 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
1778 len = find_count(&pat, patend, &star);
1779 if (star > 0) /* Count is '*' */
1780 len = strchr("@Xxu", datumtype) ? 0 : items;
1781 else if (star < 0) /* Default len */
1783 if (*pat == '/') { /* doing lookahead how... */
1785 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
1786 Perl_croak(aTHX_ "/ must be followed by a*, A* or Z*");
1787 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1788 ? *beglist : &PL_sv_no)
1789 + (*pat == 'Z' ? 1 : 0)));
1793 Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
1794 case ',': /* grandfather in commas but with a warning */
1795 if (commas++ == 0 && ckWARN(WARN_PACK))
1796 Perl_warner(aTHX_ WARN_PACK,
1797 "Invalid type in pack: '%c'", (int)datumtype);
1800 Perl_croak(aTHX_ "%% may only be used in unpack");
1812 SV **savebeglist = beglist; /* beglist de-register-ed */
1815 Perl_croak(aTHX_ "()-group starts with a count");
1816 aptr = group_end(beg, patend, ')');
1819 len = find_count(&pat, patend, &star);
1820 if (star < 0) /* No count */
1822 else if (star > 0) /* Star */
1823 len = items; /* long enough? */
1826 pack_cat(cat, beg, aptr, savebeglist, endlist,
1827 &savebeglist, PACK_CHILD);
1828 if (star > 0 && savebeglist == endlist)
1829 break; /* No way to continue */
1831 beglist = savebeglist;
1834 case 'X' | TYPE_IS_SHRIEKING:
1835 if (!len) /* Avoid division by 0 */
1837 len = (SvCUR(cat)) % len;
1841 if (SvCUR(cat) < len)
1842 Perl_croak(aTHX_ "X outside of string");
1846 case 'x' | TYPE_IS_SHRIEKING:
1847 if (!len) /* Avoid division by 0 */
1849 aint = (SvCUR(cat)) % len;
1850 if (aint) /* Other portable ways? */
1858 sv_catpvn(cat, null10, 10);
1861 sv_catpvn(cat, null10, len);
1867 aptr = SvPV(fromstr, fromlen);
1868 if (star > 0) { /* -2 after '/' */
1870 if (datumtype == 'Z')
1873 if (fromlen >= len) {
1874 sv_catpvn(cat, aptr, len);
1875 if (datumtype == 'Z')
1876 *(SvEND(cat)-1) = '\0';
1879 sv_catpvn(cat, aptr, fromlen);
1881 if (datumtype == 'A') {
1883 sv_catpvn(cat, space10, 10);
1886 sv_catpvn(cat, space10, len);
1890 sv_catpvn(cat, null10, 10);
1893 sv_catpvn(cat, null10, len);
1905 str = SvPV(fromstr, fromlen);
1909 SvCUR(cat) += (len+7)/8;
1910 SvGROW(cat, SvCUR(cat) + 1);
1911 aptr = SvPVX(cat) + aint;
1916 if (datumtype == 'B') {
1917 for (len = 0; len++ < aint;) {
1918 items |= *str++ & 1;
1922 *aptr++ = items & 0xff;
1928 for (len = 0; len++ < aint;) {
1934 *aptr++ = items & 0xff;
1940 if (datumtype == 'B')
1941 items <<= 7 - (aint & 7);
1943 items >>= 7 - (aint & 7);
1944 *aptr++ = items & 0xff;
1946 str = SvPVX(cat) + SvCUR(cat);
1961 str = SvPV(fromstr, fromlen);
1965 SvCUR(cat) += (len+1)/2;
1966 SvGROW(cat, SvCUR(cat) + 1);
1967 aptr = SvPVX(cat) + aint;
1972 if (datumtype == 'H') {
1973 for (len = 0; len++ < aint;) {
1975 items |= ((*str++ & 15) + 9) & 15;
1977 items |= *str++ & 15;
1981 *aptr++ = items & 0xff;
1987 for (len = 0; len++ < aint;) {
1989 items |= (((*str++ & 15) + 9) & 15) << 4;
1991 items |= (*str++ & 15) << 4;
1995 *aptr++ = items & 0xff;
2001 *aptr++ = items & 0xff;
2002 str = SvPVX(cat) + SvCUR(cat);
2013 switch (datumtype) {
2015 aint = SvIV(fromstr);
2016 if ((aint < 0 || aint > 255) &&
2018 Perl_warner(aTHX_ WARN_PACK,
2019 "Character in \"C\" format wrapped");
2021 sv_catpvn(cat, &achar, sizeof(char));
2024 aint = SvIV(fromstr);
2025 if ((aint < -128 || aint > 127) &&
2027 Perl_warner(aTHX_ WARN_PACK,
2028 "Character in \"c\" format wrapped");
2030 sv_catpvn(cat, &achar, sizeof(char));
2038 auint = UNI_TO_NATIVE(SvUV(fromstr));
2039 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2040 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
2045 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2049 afloat = (float)SvNV(fromstr);
2050 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2056 adouble = (double)SvNV(fromstr);
2057 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2063 anv = SvNV(fromstr);
2064 sv_catpvn(cat, (char *)&anv, NVSIZE);
2067 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2071 aldouble = (long double)SvNV(fromstr);
2072 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2079 ashort = (I16)SvIV(fromstr);
2081 ashort = PerlSock_htons(ashort);
2083 CAT16(cat, &ashort);
2089 ashort = (I16)SvIV(fromstr);
2091 ashort = htovs(ashort);
2093 CAT16(cat, &ashort);
2097 #if SHORTSIZE != SIZE16
2099 unsigned short aushort;
2103 aushort = SvUV(fromstr);
2104 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2114 aushort = (U16)SvUV(fromstr);
2115 CAT16(cat, &aushort);
2121 #if SHORTSIZE != SIZE16
2127 ashort = SvIV(fromstr);
2128 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2136 ashort = (I16)SvIV(fromstr);
2137 CAT16(cat, &ashort);
2144 auint = SvUV(fromstr);
2145 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2151 aiv = SvIV(fromstr);
2152 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2158 auv = SvUV(fromstr);
2159 sv_catpvn(cat, (char*)&auv, UVSIZE);
2165 adouble = Perl_floor(SvNV(fromstr));
2168 Perl_croak(aTHX_ "Cannot compress negative numbers");
2171 #if UVSIZE > 4 && UVSIZE >= NVSIZE
2172 adouble <= 0xffffffff
2174 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
2175 adouble <= UV_MAX_cxux
2182 char buf[1 + sizeof(UV)];
2183 char *in = buf + sizeof(buf);
2184 UV auv = U_V(adouble);
2187 *--in = (auv & 0x7f) | 0x80;
2190 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2191 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2193 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2194 char *from, *result, *in;
2199 /* Copy string and check for compliance */
2200 from = SvPV(fromstr, len);
2201 if ((norm = is_an_int(from, len)) == NULL)
2202 Perl_croak(aTHX_ "can compress only unsigned integer");
2204 New('w', result, len, char);
2208 *--in = div128(norm, &done) | 0x80;
2209 result[len - 1] &= 0x7F; /* clear continue bit */
2210 sv_catpvn(cat, in, (result + len) - in);
2212 SvREFCNT_dec(norm); /* free norm */
2214 else if (SvNOKp(fromstr)) {
2215 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
2216 char *in = buf + sizeof(buf);
2219 double next = floor(adouble / 128);
2220 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
2221 if (in <= buf) /* this cannot happen ;-) */
2222 Perl_croak(aTHX_ "Cannot compress integer");
2224 } while (adouble > 0);
2225 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2226 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2229 char *from, *result, *in;
2234 /* Copy string and check for compliance */
2235 from = SvPV(fromstr, len);
2236 if ((norm = is_an_int(from, len)) == NULL)
2237 Perl_croak(aTHX_ "can compress only unsigned integer");
2239 New('w', result, len, char);
2243 *--in = div128(norm, &done) | 0x80;
2244 result[len - 1] &= 0x7F; /* clear continue bit */
2245 sv_catpvn(cat, in, (result + len) - in);
2247 SvREFCNT_dec(norm); /* free norm */
2254 aint = SvIV(fromstr);
2255 sv_catpvn(cat, (char*)&aint, sizeof(int));
2261 aulong = SvUV(fromstr);
2263 aulong = PerlSock_htonl(aulong);
2265 CAT32(cat, &aulong);
2271 aulong = SvUV(fromstr);
2273 aulong = htovl(aulong);
2275 CAT32(cat, &aulong);
2279 #if LONGSIZE != SIZE32
2281 unsigned long aulong;
2285 aulong = SvUV(fromstr);
2286 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2294 aulong = SvUV(fromstr);
2295 CAT32(cat, &aulong);
2300 #if LONGSIZE != SIZE32
2306 along = SvIV(fromstr);
2307 sv_catpvn(cat, (char *)&along, sizeof(long));
2315 along = SvIV(fromstr);
2324 auquad = (Uquad_t)SvUV(fromstr);
2325 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2331 aquad = (Quad_t)SvIV(fromstr);
2332 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2337 len = 1; /* assume SV is correct length */
2342 if (fromstr == &PL_sv_undef)
2346 /* XXX better yet, could spirit away the string to
2347 * a safe spot and hang on to it until the result
2348 * of pack() (and all copies of the result) are
2351 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2352 || (SvPADTMP(fromstr)
2353 && !SvREADONLY(fromstr))))
2355 Perl_warner(aTHX_ WARN_PACK,
2356 "Attempt to pack pointer to temporary value");
2358 if (SvPOK(fromstr) || SvNIOK(fromstr))
2359 aptr = SvPV(fromstr,n_a);
2361 aptr = SvPV_force(fromstr,n_a);
2363 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2368 aptr = SvPV(fromstr, fromlen);
2369 SvGROW(cat, fromlen * 4 / 3);
2374 while (fromlen > 0) {
2381 doencodes(cat, aptr, todo);
2389 *next_in_list = beglist;
2396 dSP; dMARK; dORIGMARK; dTARGET;
2397 register SV *cat = TARG;
2399 register char *pat = SvPVx(*++MARK, fromlen);
2400 register char *patend = pat + fromlen;
2403 sv_setpvn(cat, "", 0);
2405 pack_cat(cat, pat, patend, MARK, SP + 1, NULL, 0);