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);
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? */
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_ 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;
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_ 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)
727 if (aint >= 128) /* fake up signed chars */
730 sv_setiv(sv, (IV)aint);
731 PUSHs(sv_2mortal(sv));
736 unpack_C: /* unpack U will jump here if not UTF-8 */
741 if (len > strend - s)
756 sv_setiv(sv, (IV)auint);
757 PUSHs(sv_2mortal(sv));
768 if (len > strend - s)
771 while (len-- > 0 && s < strend) {
773 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, 0));
776 if (checksum > bits_in_uv)
777 cdouble += (NV)auint;
785 while (len-- > 0 && s < strend) {
787 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, 0));
791 sv_setuv(sv, (UV)auint);
792 PUSHs(sv_2mortal(sv));
797 #if SHORTSIZE == SIZE16
798 along = (strend - s) / SIZE16;
800 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
805 #if SHORTSIZE != SIZE16
809 COPYNN(s, &ashort, sizeof(short));
811 if (checksum > bits_in_uv)
812 cdouble += (NV)ashort;
823 #if SHORTSIZE > SIZE16
828 if (checksum > bits_in_uv)
829 cdouble += (NV)ashort;
838 #if SHORTSIZE != SIZE16
842 COPYNN(s, &ashort, sizeof(short));
845 sv_setiv(sv, (IV)ashort);
846 PUSHs(sv_2mortal(sv));
854 #if SHORTSIZE > SIZE16
860 sv_setiv(sv, (IV)ashort);
861 PUSHs(sv_2mortal(sv));
869 #if SHORTSIZE == SIZE16
870 along = (strend - s) / SIZE16;
872 unatint = natint && datumtype == 'S';
873 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
878 #if SHORTSIZE != SIZE16
880 unsigned short aushort;
882 COPYNN(s, &aushort, sizeof(unsigned short));
883 s += sizeof(unsigned short);
884 if (checksum > bits_in_uv)
885 cdouble += (NV)aushort;
897 if (datumtype == 'n')
898 aushort = PerlSock_ntohs(aushort);
901 if (datumtype == 'v')
902 aushort = vtohs(aushort);
904 if (checksum > bits_in_uv)
905 cdouble += (NV)aushort;
914 #if SHORTSIZE != SIZE16
916 unsigned short aushort;
918 COPYNN(s, &aushort, sizeof(unsigned short));
919 s += sizeof(unsigned short);
921 sv_setiv(sv, (UV)aushort);
922 PUSHs(sv_2mortal(sv));
933 if (datumtype == 'n')
934 aushort = PerlSock_ntohs(aushort);
937 if (datumtype == 'v')
938 aushort = vtohs(aushort);
940 sv_setiv(sv, (UV)aushort);
941 PUSHs(sv_2mortal(sv));
947 along = (strend - s) / sizeof(int);
952 Copy(s, &aint, 1, int);
954 if (checksum > bits_in_uv)
964 Copy(s, &aint, 1, int);
968 /* Without the dummy below unpack("i", pack("i",-1))
969 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
970 * cc with optimization turned on.
972 * The bug was detected in
973 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
974 * with optimization (-O4) turned on.
975 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
976 * does not have this problem even with -O4.
978 * This bug was reported as DECC_BUGS 1431
979 * and tracked internally as GEM_BUGS 7775.
981 * The bug is fixed in
982 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
983 * UNIX V4.0F support: DEC C V5.9-006 or later
984 * UNIX V4.0E support: DEC C V5.8-011 or later
987 * See also few lines later for the same bug.
990 sv_setiv(sv, (IV)aint) :
992 sv_setiv(sv, (IV)aint);
993 PUSHs(sv_2mortal(sv));
998 along = (strend - s) / sizeof(unsigned int);
1003 Copy(s, &auint, 1, unsigned int);
1004 s += sizeof(unsigned int);
1005 if (checksum > bits_in_uv)
1006 cdouble += (NV)auint;
1015 Copy(s, &auint, 1, unsigned int);
1016 s += sizeof(unsigned int);
1019 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1020 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1021 * See details few lines earlier. */
1023 sv_setuv(sv, (UV)auint) :
1025 sv_setuv(sv, (UV)auint);
1026 PUSHs(sv_2mortal(sv));
1031 along = (strend - s) / IVSIZE;
1036 Copy(s, &aiv, 1, IV);
1038 if (checksum > bits_in_uv)
1048 Copy(s, &aiv, 1, IV);
1052 PUSHs(sv_2mortal(sv));
1057 along = (strend - s) / UVSIZE;
1062 Copy(s, &auv, 1, UV);
1064 if (checksum > bits_in_uv)
1074 Copy(s, &auv, 1, UV);
1078 PUSHs(sv_2mortal(sv));
1083 #if LONGSIZE == SIZE32
1084 along = (strend - s) / SIZE32;
1086 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
1091 #if LONGSIZE != SIZE32
1094 COPYNN(s, &along, sizeof(long));
1096 if (checksum > bits_in_uv)
1097 cdouble += (NV)along;
1106 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1110 #if LONGSIZE > SIZE32
1111 if (along > 2147483647)
1112 along -= 4294967296;
1115 if (checksum > bits_in_uv)
1116 cdouble += (NV)along;
1125 #if LONGSIZE != SIZE32
1128 COPYNN(s, &along, sizeof(long));
1131 sv_setiv(sv, (IV)along);
1132 PUSHs(sv_2mortal(sv));
1139 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1143 #if LONGSIZE > SIZE32
1144 if (along > 2147483647)
1145 along -= 4294967296;
1149 sv_setiv(sv, (IV)along);
1150 PUSHs(sv_2mortal(sv));
1158 #if LONGSIZE == SIZE32
1159 along = (strend - s) / SIZE32;
1161 unatint = natint && datumtype == 'L';
1162 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
1167 #if LONGSIZE != SIZE32
1169 unsigned long aulong;
1171 COPYNN(s, &aulong, sizeof(unsigned long));
1172 s += sizeof(unsigned long);
1173 if (checksum > bits_in_uv)
1174 cdouble += (NV)aulong;
1186 if (datumtype == 'N')
1187 aulong = PerlSock_ntohl(aulong);
1190 if (datumtype == 'V')
1191 aulong = vtohl(aulong);
1193 if (checksum > bits_in_uv)
1194 cdouble += (NV)aulong;
1203 #if LONGSIZE != SIZE32
1205 unsigned long aulong;
1207 COPYNN(s, &aulong, sizeof(unsigned long));
1208 s += sizeof(unsigned long);
1210 sv_setuv(sv, (UV)aulong);
1211 PUSHs(sv_2mortal(sv));
1221 if (datumtype == 'N')
1222 aulong = PerlSock_ntohl(aulong);
1225 if (datumtype == 'V')
1226 aulong = vtohl(aulong);
1229 sv_setuv(sv, (UV)aulong);
1230 PUSHs(sv_2mortal(sv));
1236 along = (strend - s) / sizeof(char*);
1242 if (sizeof(char*) > strend - s)
1245 Copy(s, &aptr, 1, char*);
1251 PUSHs(sv_2mortal(sv));
1261 while ((len > 0) && (s < strend)) {
1262 auv = (auv << 7) | (*s & 0x7f);
1263 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1264 if ((U8)(*s++) < 0x80) {
1268 PUSHs(sv_2mortal(sv));
1272 else if (++bytes >= sizeof(UV)) { /* promote to string */
1276 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1277 while (s < strend) {
1278 sv = mul128(sv, *s & 0x7f);
1279 if (!(*s++ & 0x80)) {
1288 PUSHs(sv_2mortal(sv));
1293 if ((s >= strend) && bytes)
1294 Perl_croak(aTHX_ "Unterminated compressed integer");
1299 Perl_croak(aTHX_ "P must have an explicit size");
1301 if (sizeof(char*) > strend - s)
1304 Copy(s, &aptr, 1, char*);
1309 sv_setpvn(sv, aptr, len);
1310 PUSHs(sv_2mortal(sv));
1314 along = (strend - s) / sizeof(Quad_t);
1319 Copy(s, &aquad, 1, Quad_t);
1320 s += sizeof(Quad_t);
1321 if (checksum > bits_in_uv)
1322 cdouble += (NV)aquad;
1331 if (s + sizeof(Quad_t) > strend)
1334 Copy(s, &aquad, 1, Quad_t);
1335 s += sizeof(Quad_t);
1338 if (aquad >= IV_MIN && aquad <= IV_MAX)
1339 sv_setiv(sv, (IV)aquad);
1341 sv_setnv(sv, (NV)aquad);
1342 PUSHs(sv_2mortal(sv));
1347 along = (strend - s) / sizeof(Uquad_t);
1352 Copy(s, &auquad, 1, Uquad_t);
1353 s += sizeof(Uquad_t);
1354 if (checksum > bits_in_uv)
1355 cdouble += (NV)auquad;
1364 if (s + sizeof(Uquad_t) > strend)
1367 Copy(s, &auquad, 1, Uquad_t);
1368 s += sizeof(Uquad_t);
1371 if (auquad <= UV_MAX)
1372 sv_setuv(sv, (UV)auquad);
1374 sv_setnv(sv, (NV)auquad);
1375 PUSHs(sv_2mortal(sv));
1380 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1382 along = (strend - s) / sizeof(float);
1387 Copy(s, &afloat, 1, float);
1396 Copy(s, &afloat, 1, float);
1399 sv_setnv(sv, (NV)afloat);
1400 PUSHs(sv_2mortal(sv));
1405 along = (strend - s) / sizeof(double);
1410 Copy(s, &adouble, 1, double);
1411 s += sizeof(double);
1419 Copy(s, &adouble, 1, double);
1420 s += sizeof(double);
1422 sv_setnv(sv, (NV)adouble);
1423 PUSHs(sv_2mortal(sv));
1428 along = (strend - s) / NVSIZE;
1433 Copy(s, &anv, 1, NV);
1442 Copy(s, &anv, 1, NV);
1446 PUSHs(sv_2mortal(sv));
1450 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1452 along = (strend - s) / LONG_DOUBLESIZE;
1457 Copy(s, &aldouble, 1, long double);
1458 s += LONG_DOUBLESIZE;
1459 cdouble += aldouble;
1466 Copy(s, &aldouble, 1, long double);
1467 s += LONG_DOUBLESIZE;
1469 sv_setnv(sv, (NV)aldouble);
1470 PUSHs(sv_2mortal(sv));
1477 * Initialise the decode mapping. By using a table driven
1478 * algorithm, the code will be character-set independent
1479 * (and just as fast as doing character arithmetic)
1481 if (PL_uudmap['M'] == 0) {
1484 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1485 PL_uudmap[(U8)PL_uuemap[i]] = i;
1487 * Because ' ' and '`' map to the same value,
1488 * we need to decode them both the same.
1493 along = (strend - s) * 3 / 4;
1494 sv = NEWSV(42, along);
1497 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1502 len = PL_uudmap[*(U8*)s++] & 077;
1504 if (s < strend && ISUUCHAR(*s))
1505 a = PL_uudmap[*(U8*)s++] & 077;
1508 if (s < strend && ISUUCHAR(*s))
1509 b = PL_uudmap[*(U8*)s++] & 077;
1512 if (s < strend && ISUUCHAR(*s))
1513 c = PL_uudmap[*(U8*)s++] & 077;
1516 if (s < strend && ISUUCHAR(*s))
1517 d = PL_uudmap[*(U8*)s++] & 077;
1520 hunk[0] = (a << 2) | (b >> 4);
1521 hunk[1] = (b << 4) | (c >> 2);
1522 hunk[2] = (c << 6) | d;
1523 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1528 else if (s[1] == '\n') /* possible checksum byte */
1531 XPUSHs(sv_2mortal(sv));
1536 if (strchr("fFdD", datumtype) ||
1537 (checksum > bits_in_uv &&
1538 strchr("csSiIlLnNUvVqQjJ", datumtype)) ) {
1541 adouble = (NV) (1 << (checksum & 15));
1542 while (checksum >= 16) {
1546 while (cdouble < 0.0)
1548 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1549 sv_setnv(sv, cdouble);
1552 if (checksum < bits_in_uv) {
1553 UV mask = ((UV)1 << checksum) - 1;
1559 XPUSHs(sv_2mortal(sv));
1566 return SP - PL_stack_base - start_sp_offset;
1573 I32 gimme = GIMME_V;
1576 register char *pat = SvPV(left, llen);
1577 #ifdef PACKED_IS_OCTETS
1578 /* Packed side is assumed to be octets - so force downgrade if it
1579 has been UTF-8 encoded by accident
1581 register char *s = SvPVbyte(right, rlen);
1583 register char *s = SvPV(right, rlen);
1585 char *strend = s + rlen;
1586 register char *patend = pat + llen;
1590 cnt = unpack_str(pat, patend, s, s, strend, NULL, 0,
1591 ((gimme == G_SCALAR) ? UNPACK_ONLY_ONE : 0)
1592 | (DO_UTF8(right) ? UNPACK_DO_UTF8 : 0));
1594 if ( !cnt && gimme == G_SCALAR )
1595 PUSHs(&PL_sv_undef);
1600 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1604 *hunk = PL_uuemap[len];
1605 sv_catpvn(sv, hunk, 1);
1608 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1609 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1610 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1611 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1612 sv_catpvn(sv, hunk, 4);
1617 char r = (len > 1 ? s[1] : '\0');
1618 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1619 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1620 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1621 hunk[3] = PL_uuemap[0];
1622 sv_catpvn(sv, hunk, 4);
1624 sv_catpvn(sv, "\n", 1);
1628 S_is_an_int(pTHX_ char *s, STRLEN l)
1631 SV *result = newSVpvn(s, l);
1632 char *result_c = SvPV(result, n_a); /* convenience */
1633 char *out = result_c;
1643 SvREFCNT_dec(result);
1666 SvREFCNT_dec(result);
1672 SvCUR_set(result, out - result_c);
1676 /* pnum must be '\0' terminated */
1678 S_div128(pTHX_ SV *pnum, bool *done)
1681 char *s = SvPV(pnum, len);
1690 i = m * 10 + (*t - '0');
1692 r = (i >> 7); /* r < 10 */
1699 SvCUR_set(pnum, (STRLEN) (t - s));
1703 #define PACK_CHILD 0x1
1706 =for apidoc pack_cat
1708 The engine implementing pack() Perl function.
1713 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1721 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1722 static char *space10 = " ";
1725 /* These must not be in registers: */
1735 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1736 long double aldouble;
1746 #ifdef PERL_NATINT_PACK
1747 int natint; /* native integer */
1750 items = endlist - beglist;
1751 #ifndef PACKED_IS_OCTETS
1752 pat = next_symbol(pat, patend);
1753 if (pat < patend && *pat == 'U' && !flags)
1756 while ((pat = next_symbol(pat, patend)) < patend) {
1757 SV *lengthcode = Nullsv;
1758 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1759 datumtype = *pat++ & 0xFF;
1760 #ifdef PERL_NATINT_PACK
1764 static const char natstr[] = "sSiIlLxX";
1766 if (strchr(natstr, datumtype)) {
1767 if (datumtype == 'x' || datumtype == 'X') {
1768 datumtype |= TYPE_IS_SHRIEKING;
1769 } else { /* XXXX Should be redone similarly! */
1770 #ifdef PERL_NATINT_PACK
1777 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
1779 len = find_count(&pat, patend, &star);
1780 if (star > 0) /* Count is '*' */
1781 len = strchr("@Xxu", datumtype) ? 0 : items;
1782 else if (star < 0) /* Default len */
1784 if (*pat == '/') { /* doing lookahead how... */
1786 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
1787 Perl_croak(aTHX_ "/ must be followed by a*, A* or Z*");
1788 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1789 ? *beglist : &PL_sv_no)
1790 + (*pat == 'Z' ? 1 : 0)));
1794 Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
1795 case ',': /* grandfather in commas but with a warning */
1796 if (commas++ == 0 && ckWARN(WARN_PACK))
1797 Perl_warner(aTHX_ WARN_PACK,
1798 "Invalid type in pack: '%c'", (int)datumtype);
1801 Perl_croak(aTHX_ "%% may only be used in unpack");
1813 SV **savebeglist = beglist; /* beglist de-register-ed */
1816 Perl_croak(aTHX_ "()-group starts with a count");
1817 aptr = group_end(beg, patend, ')');
1820 len = find_count(&pat, patend, &star);
1821 if (star < 0) /* No count */
1823 else if (star > 0) /* Star */
1824 len = items; /* long enough? */
1827 pack_cat(cat, beg, aptr, savebeglist, endlist,
1828 &savebeglist, PACK_CHILD);
1829 if (star > 0 && savebeglist == endlist)
1830 break; /* No way to continue */
1832 beglist = savebeglist;
1835 case 'X' | TYPE_IS_SHRIEKING:
1836 if (!len) /* Avoid division by 0 */
1838 len = (SvCUR(cat)) % len;
1842 if (SvCUR(cat) < len)
1843 Perl_croak(aTHX_ "X outside of string");
1847 case 'x' | TYPE_IS_SHRIEKING:
1848 if (!len) /* Avoid division by 0 */
1850 aint = (SvCUR(cat)) % len;
1851 if (aint) /* Other portable ways? */
1859 sv_catpvn(cat, null10, 10);
1862 sv_catpvn(cat, null10, len);
1868 aptr = SvPV(fromstr, fromlen);
1869 if (star > 0) { /* -2 after '/' */
1871 if (datumtype == 'Z')
1874 if (fromlen >= len) {
1875 sv_catpvn(cat, aptr, len);
1876 if (datumtype == 'Z')
1877 *(SvEND(cat)-1) = '\0';
1880 sv_catpvn(cat, aptr, fromlen);
1882 if (datumtype == 'A') {
1884 sv_catpvn(cat, space10, 10);
1887 sv_catpvn(cat, space10, len);
1891 sv_catpvn(cat, null10, 10);
1894 sv_catpvn(cat, null10, len);
1906 str = SvPV(fromstr, fromlen);
1910 SvCUR(cat) += (len+7)/8;
1911 SvGROW(cat, SvCUR(cat) + 1);
1912 aptr = SvPVX(cat) + aint;
1917 if (datumtype == 'B') {
1918 for (len = 0; len++ < aint;) {
1919 items |= *str++ & 1;
1923 *aptr++ = items & 0xff;
1929 for (len = 0; len++ < aint;) {
1935 *aptr++ = items & 0xff;
1941 if (datumtype == 'B')
1942 items <<= 7 - (aint & 7);
1944 items >>= 7 - (aint & 7);
1945 *aptr++ = items & 0xff;
1947 str = SvPVX(cat) + SvCUR(cat);
1962 str = SvPV(fromstr, fromlen);
1966 SvCUR(cat) += (len+1)/2;
1967 SvGROW(cat, SvCUR(cat) + 1);
1968 aptr = SvPVX(cat) + aint;
1973 if (datumtype == 'H') {
1974 for (len = 0; len++ < aint;) {
1976 items |= ((*str++ & 15) + 9) & 15;
1978 items |= *str++ & 15;
1982 *aptr++ = items & 0xff;
1988 for (len = 0; len++ < aint;) {
1990 items |= (((*str++ & 15) + 9) & 15) << 4;
1992 items |= (*str++ & 15) << 4;
1996 *aptr++ = items & 0xff;
2002 *aptr++ = items & 0xff;
2003 str = SvPVX(cat) + SvCUR(cat);
2014 switch (datumtype) {
2016 aint = SvIV(fromstr);
2017 if ((aint < 0 || aint > 255) &&
2019 Perl_warner(aTHX_ WARN_PACK,
2020 "Character in \"C\" format wrapped");
2022 sv_catpvn(cat, &achar, sizeof(char));
2025 aint = SvIV(fromstr);
2026 if ((aint < -128 || aint > 127) &&
2028 Perl_warner(aTHX_ WARN_PACK,
2029 "Character in \"c\" format wrapped");
2031 sv_catpvn(cat, &achar, sizeof(char));
2039 auint = UNI_TO_NATIVE(SvUV(fromstr));
2040 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2041 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
2046 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2050 afloat = (float)SvNV(fromstr);
2051 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2057 adouble = (double)SvNV(fromstr);
2058 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2064 anv = SvNV(fromstr);
2065 sv_catpvn(cat, (char *)&anv, NVSIZE);
2068 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2072 aldouble = (long double)SvNV(fromstr);
2073 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2080 ashort = (I16)SvIV(fromstr);
2082 ashort = PerlSock_htons(ashort);
2084 CAT16(cat, &ashort);
2090 ashort = (I16)SvIV(fromstr);
2092 ashort = htovs(ashort);
2094 CAT16(cat, &ashort);
2098 #if SHORTSIZE != SIZE16
2100 unsigned short aushort;
2104 aushort = SvUV(fromstr);
2105 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2115 aushort = (U16)SvUV(fromstr);
2116 CAT16(cat, &aushort);
2122 #if SHORTSIZE != SIZE16
2128 ashort = SvIV(fromstr);
2129 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2137 ashort = (I16)SvIV(fromstr);
2138 CAT16(cat, &ashort);
2145 auint = SvUV(fromstr);
2146 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2152 aiv = SvIV(fromstr);
2153 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2159 auv = SvUV(fromstr);
2160 sv_catpvn(cat, (char*)&auv, UVSIZE);
2166 adouble = Perl_floor(SvNV(fromstr));
2169 Perl_croak(aTHX_ "Cannot compress negative numbers");
2172 #if UVSIZE > 4 && UVSIZE >= NVSIZE
2173 adouble <= 0xffffffff
2175 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
2176 adouble <= UV_MAX_cxux
2183 char buf[1 + sizeof(UV)];
2184 char *in = buf + sizeof(buf);
2185 UV auv = U_V(adouble);
2188 *--in = (auv & 0x7f) | 0x80;
2191 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2192 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2194 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2195 char *from, *result, *in;
2200 /* Copy string and check for compliance */
2201 from = SvPV(fromstr, len);
2202 if ((norm = is_an_int(from, len)) == NULL)
2203 Perl_croak(aTHX_ "can compress only unsigned integer");
2205 New('w', result, len, char);
2209 *--in = div128(norm, &done) | 0x80;
2210 result[len - 1] &= 0x7F; /* clear continue bit */
2211 sv_catpvn(cat, in, (result + len) - in);
2213 SvREFCNT_dec(norm); /* free norm */
2215 else if (SvNOKp(fromstr)) {
2216 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
2217 char *in = buf + sizeof(buf);
2220 double next = floor(adouble / 128);
2221 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
2222 if (in <= buf) /* this cannot happen ;-) */
2223 Perl_croak(aTHX_ "Cannot compress integer");
2225 } while (adouble > 0);
2226 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2227 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2230 char *from, *result, *in;
2235 /* Copy string and check for compliance */
2236 from = SvPV(fromstr, len);
2237 if ((norm = is_an_int(from, len)) == NULL)
2238 Perl_croak(aTHX_ "can compress only unsigned integer");
2240 New('w', result, len, char);
2244 *--in = div128(norm, &done) | 0x80;
2245 result[len - 1] &= 0x7F; /* clear continue bit */
2246 sv_catpvn(cat, in, (result + len) - in);
2248 SvREFCNT_dec(norm); /* free norm */
2255 aint = SvIV(fromstr);
2256 sv_catpvn(cat, (char*)&aint, sizeof(int));
2262 aulong = SvUV(fromstr);
2264 aulong = PerlSock_htonl(aulong);
2266 CAT32(cat, &aulong);
2272 aulong = SvUV(fromstr);
2274 aulong = htovl(aulong);
2276 CAT32(cat, &aulong);
2280 #if LONGSIZE != SIZE32
2282 unsigned long aulong;
2286 aulong = SvUV(fromstr);
2287 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2295 aulong = SvUV(fromstr);
2296 CAT32(cat, &aulong);
2301 #if LONGSIZE != SIZE32
2307 along = SvIV(fromstr);
2308 sv_catpvn(cat, (char *)&along, sizeof(long));
2316 along = SvIV(fromstr);
2325 auquad = (Uquad_t)SvUV(fromstr);
2326 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2332 aquad = (Quad_t)SvIV(fromstr);
2333 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2338 len = 1; /* assume SV is correct length */
2343 if (fromstr == &PL_sv_undef)
2347 /* XXX better yet, could spirit away the string to
2348 * a safe spot and hang on to it until the result
2349 * of pack() (and all copies of the result) are
2352 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2353 || (SvPADTMP(fromstr)
2354 && !SvREADONLY(fromstr))))
2356 Perl_warner(aTHX_ WARN_PACK,
2357 "Attempt to pack pointer to temporary value");
2359 if (SvPOK(fromstr) || SvNIOK(fromstr))
2360 aptr = SvPV(fromstr,n_a);
2362 aptr = SvPV_force(fromstr,n_a);
2364 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2369 aptr = SvPV(fromstr, fromlen);
2370 SvGROW(cat, fromlen * 4 / 3);
2375 while (fromlen > 0) {
2382 doencodes(cat, aptr, todo);
2390 *next_in_list = beglist;
2397 dSP; dMARK; dORIGMARK; dTARGET;
2398 register SV *cat = TARG;
2400 register char *pat = SvPVx(*++MARK, fromlen);
2401 register char *patend = pat + fromlen;
2404 sv_setpvn(cat, "", 0);
2406 pack_cat(cat, pat, patend, MARK, SP + 1, NULL, 0);