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_ 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;
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)
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 /* possible checksum byte */
1529 if (s + 1 < strend && s[1] == '\n')
1532 XPUSHs(sv_2mortal(sv));
1537 if (strchr("fFdD", datumtype) ||
1538 (checksum > bits_in_uv &&
1539 strchr("csSiIlLnNUvVqQjJ", datumtype)) ) {
1542 adouble = (NV) (1 << (checksum & 15));
1543 while (checksum >= 16) {
1547 while (cdouble < 0.0)
1549 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1550 sv_setnv(sv, cdouble);
1553 if (checksum < bits_in_uv) {
1554 UV mask = ((UV)1 << checksum) - 1;
1560 XPUSHs(sv_2mortal(sv));
1567 return SP - PL_stack_base - start_sp_offset;
1574 I32 gimme = GIMME_V;
1577 register char *pat = SvPV(left, llen);
1578 #ifdef PACKED_IS_OCTETS
1579 /* Packed side is assumed to be octets - so force downgrade if it
1580 has been UTF-8 encoded by accident
1582 register char *s = SvPVbyte(right, rlen);
1584 register char *s = SvPV(right, rlen);
1586 char *strend = s + rlen;
1587 register char *patend = pat + llen;
1591 cnt = unpack_str(pat, patend, s, s, strend, NULL, 0,
1592 ((gimme == G_SCALAR) ? UNPACK_ONLY_ONE : 0)
1593 | (DO_UTF8(right) ? UNPACK_DO_UTF8 : 0));
1595 if ( !cnt && gimme == G_SCALAR )
1596 PUSHs(&PL_sv_undef);
1601 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1605 *hunk = PL_uuemap[len];
1606 sv_catpvn(sv, hunk, 1);
1609 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1610 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1611 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1612 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1613 sv_catpvn(sv, hunk, 4);
1618 char r = (len > 1 ? s[1] : '\0');
1619 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1620 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1621 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1622 hunk[3] = PL_uuemap[0];
1623 sv_catpvn(sv, hunk, 4);
1625 sv_catpvn(sv, "\n", 1);
1629 S_is_an_int(pTHX_ char *s, STRLEN l)
1632 SV *result = newSVpvn(s, l);
1633 char *result_c = SvPV(result, n_a); /* convenience */
1634 char *out = result_c;
1644 SvREFCNT_dec(result);
1667 SvREFCNT_dec(result);
1673 SvCUR_set(result, out - result_c);
1677 /* pnum must be '\0' terminated */
1679 S_div128(pTHX_ SV *pnum, bool *done)
1682 char *s = SvPV(pnum, len);
1691 i = m * 10 + (*t - '0');
1693 r = (i >> 7); /* r < 10 */
1700 SvCUR_set(pnum, (STRLEN) (t - s));
1704 #define PACK_CHILD 0x1
1707 =for apidoc pack_cat
1709 The engine implementing pack() Perl function.
1714 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1722 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1723 static char *space10 = " ";
1726 /* These must not be in registers: */
1736 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1737 long double aldouble;
1747 #ifdef PERL_NATINT_PACK
1748 int natint; /* native integer */
1751 items = endlist - beglist;
1752 #ifndef PACKED_IS_OCTETS
1753 pat = next_symbol(pat, patend);
1754 if (pat < patend && *pat == 'U' && !flags)
1757 while ((pat = next_symbol(pat, patend)) < patend) {
1758 SV *lengthcode = Nullsv;
1759 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1760 datumtype = *pat++ & 0xFF;
1761 #ifdef PERL_NATINT_PACK
1765 static const char natstr[] = "sSiIlLxX";
1767 if (strchr(natstr, datumtype)) {
1768 if (datumtype == 'x' || datumtype == 'X') {
1769 datumtype |= TYPE_IS_SHRIEKING;
1770 } else { /* XXXX Should be redone similarly! */
1771 #ifdef PERL_NATINT_PACK
1778 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
1780 len = find_count(&pat, patend, &star);
1781 if (star > 0) /* Count is '*' */
1782 len = strchr("@Xxu", datumtype) ? 0 : items;
1783 else if (star < 0) /* Default len */
1785 if (*pat == '/') { /* doing lookahead how... */
1787 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
1788 Perl_croak(aTHX_ "/ must be followed by a*, A* or Z*");
1789 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1790 ? *beglist : &PL_sv_no)
1791 + (*pat == 'Z' ? 1 : 0)));
1795 Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
1796 case ',': /* grandfather in commas but with a warning */
1797 if (commas++ == 0 && ckWARN(WARN_PACK))
1798 Perl_warner(aTHX_ packWARN(WARN_PACK),
1799 "Invalid type in pack: '%c'", (int)datumtype);
1802 Perl_croak(aTHX_ "%% may only be used in unpack");
1814 SV **savebeglist = beglist; /* beglist de-register-ed */
1817 Perl_croak(aTHX_ "()-group starts with a count");
1818 aptr = group_end(beg, patend, ')');
1821 len = find_count(&pat, patend, &star);
1822 if (star < 0) /* No count */
1824 else if (star > 0) /* Star */
1825 len = items; /* long enough? */
1828 pack_cat(cat, beg, aptr, savebeglist, endlist,
1829 &savebeglist, PACK_CHILD);
1830 if (star > 0 && savebeglist == endlist)
1831 break; /* No way to continue */
1833 beglist = savebeglist;
1836 case 'X' | TYPE_IS_SHRIEKING:
1837 if (!len) /* Avoid division by 0 */
1839 len = (SvCUR(cat)) % len;
1843 if (SvCUR(cat) < len)
1844 Perl_croak(aTHX_ "X outside of string");
1848 case 'x' | TYPE_IS_SHRIEKING:
1849 if (!len) /* Avoid division by 0 */
1851 aint = (SvCUR(cat)) % len;
1852 if (aint) /* Other portable ways? */
1860 sv_catpvn(cat, null10, 10);
1863 sv_catpvn(cat, null10, len);
1869 aptr = SvPV(fromstr, fromlen);
1870 if (star > 0) { /* -2 after '/' */
1872 if (datumtype == 'Z')
1875 if (fromlen >= len) {
1876 sv_catpvn(cat, aptr, len);
1877 if (datumtype == 'Z')
1878 *(SvEND(cat)-1) = '\0';
1881 sv_catpvn(cat, aptr, fromlen);
1883 if (datumtype == 'A') {
1885 sv_catpvn(cat, space10, 10);
1888 sv_catpvn(cat, space10, len);
1892 sv_catpvn(cat, null10, 10);
1895 sv_catpvn(cat, null10, len);
1907 str = SvPV(fromstr, fromlen);
1911 SvCUR(cat) += (len+7)/8;
1912 SvGROW(cat, SvCUR(cat) + 1);
1913 aptr = SvPVX(cat) + aint;
1918 if (datumtype == 'B') {
1919 for (len = 0; len++ < aint;) {
1920 items |= *str++ & 1;
1924 *aptr++ = items & 0xff;
1930 for (len = 0; len++ < aint;) {
1936 *aptr++ = items & 0xff;
1942 if (datumtype == 'B')
1943 items <<= 7 - (aint & 7);
1945 items >>= 7 - (aint & 7);
1946 *aptr++ = items & 0xff;
1948 str = SvPVX(cat) + SvCUR(cat);
1963 str = SvPV(fromstr, fromlen);
1967 SvCUR(cat) += (len+1)/2;
1968 SvGROW(cat, SvCUR(cat) + 1);
1969 aptr = SvPVX(cat) + aint;
1974 if (datumtype == 'H') {
1975 for (len = 0; len++ < aint;) {
1977 items |= ((*str++ & 15) + 9) & 15;
1979 items |= *str++ & 15;
1983 *aptr++ = items & 0xff;
1989 for (len = 0; len++ < aint;) {
1991 items |= (((*str++ & 15) + 9) & 15) << 4;
1993 items |= (*str++ & 15) << 4;
1997 *aptr++ = items & 0xff;
2003 *aptr++ = items & 0xff;
2004 str = SvPVX(cat) + SvCUR(cat);
2015 switch (datumtype) {
2017 aint = SvIV(fromstr);
2018 if ((aint < 0 || aint > 255) &&
2020 Perl_warner(aTHX_ packWARN(WARN_PACK),
2021 "Character in \"C\" format wrapped");
2023 sv_catpvn(cat, &achar, sizeof(char));
2026 aint = SvIV(fromstr);
2027 if ((aint < -128 || aint > 127) &&
2029 Perl_warner(aTHX_ packWARN(WARN_PACK),
2030 "Character in \"c\" format wrapped");
2032 sv_catpvn(cat, &achar, sizeof(char));
2040 auint = UNI_TO_NATIVE(SvUV(fromstr));
2041 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2042 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
2047 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2051 afloat = (float)SvNV(fromstr);
2052 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2058 adouble = (double)SvNV(fromstr);
2059 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2065 anv = SvNV(fromstr);
2066 sv_catpvn(cat, (char *)&anv, NVSIZE);
2069 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2073 aldouble = (long double)SvNV(fromstr);
2074 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2081 ashort = (I16)SvIV(fromstr);
2083 ashort = PerlSock_htons(ashort);
2085 CAT16(cat, &ashort);
2091 ashort = (I16)SvIV(fromstr);
2093 ashort = htovs(ashort);
2095 CAT16(cat, &ashort);
2099 #if SHORTSIZE != SIZE16
2101 unsigned short aushort;
2105 aushort = SvUV(fromstr);
2106 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2116 aushort = (U16)SvUV(fromstr);
2117 CAT16(cat, &aushort);
2123 #if SHORTSIZE != SIZE16
2129 ashort = SvIV(fromstr);
2130 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2138 ashort = (I16)SvIV(fromstr);
2139 CAT16(cat, &ashort);
2146 auint = SvUV(fromstr);
2147 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2153 aiv = SvIV(fromstr);
2154 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2160 auv = SvUV(fromstr);
2161 sv_catpvn(cat, (char*)&auv, UVSIZE);
2167 adouble = SvNV(fromstr);
2170 Perl_croak(aTHX_ "Cannot compress negative numbers");
2172 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2173 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2174 any negative IVs will have already been got by the croak()
2175 above. IOK is untrue for fractions, so we test them
2176 against UV_MAX_P1. */
2177 if (SvIOK(fromstr) || adouble < UV_MAX_P1)
2179 char buf[(sizeof(UV)*8)/7+1];
2180 char *in = buf + sizeof(buf);
2181 UV auv = SvUV(fromstr);
2184 *--in = (auv & 0x7f) | 0x80;
2187 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2188 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2190 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2191 char *from, *result, *in;
2196 /* Copy string and check for compliance */
2197 from = SvPV(fromstr, len);
2198 if ((norm = is_an_int(from, len)) == NULL)
2199 Perl_croak(aTHX_ "can compress only unsigned integer");
2201 New('w', result, len, char);
2205 *--in = div128(norm, &done) | 0x80;
2206 result[len - 1] &= 0x7F; /* clear continue bit */
2207 sv_catpvn(cat, in, (result + len) - in);
2209 SvREFCNT_dec(norm); /* free norm */
2211 else if (SvNOKp(fromstr)) {
2212 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
2213 char *in = buf + sizeof(buf);
2215 adouble = Perl_floor(adouble);
2217 double next = floor(adouble / 128);
2218 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
2219 if (in <= buf) /* this cannot happen ;-) */
2220 Perl_croak(aTHX_ "Cannot compress integer");
2222 } while (adouble > 0);
2223 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2224 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2227 char *from, *result, *in;
2232 /* Copy string and check for compliance */
2233 from = SvPV(fromstr, len);
2234 if ((norm = is_an_int(from, len)) == NULL)
2235 Perl_croak(aTHX_ "can compress only unsigned integer");
2237 New('w', result, len, char);
2241 *--in = div128(norm, &done) | 0x80;
2242 result[len - 1] &= 0x7F; /* clear continue bit */
2243 sv_catpvn(cat, in, (result + len) - in);
2245 SvREFCNT_dec(norm); /* free norm */
2252 aint = SvIV(fromstr);
2253 sv_catpvn(cat, (char*)&aint, sizeof(int));
2259 aulong = SvUV(fromstr);
2261 aulong = PerlSock_htonl(aulong);
2263 CAT32(cat, &aulong);
2269 aulong = SvUV(fromstr);
2271 aulong = htovl(aulong);
2273 CAT32(cat, &aulong);
2277 #if LONGSIZE != SIZE32
2279 unsigned long aulong;
2283 aulong = SvUV(fromstr);
2284 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2292 aulong = SvUV(fromstr);
2293 CAT32(cat, &aulong);
2298 #if LONGSIZE != SIZE32
2304 along = SvIV(fromstr);
2305 sv_catpvn(cat, (char *)&along, sizeof(long));
2313 along = SvIV(fromstr);
2322 auquad = (Uquad_t)SvUV(fromstr);
2323 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2329 aquad = (Quad_t)SvIV(fromstr);
2330 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2335 len = 1; /* assume SV is correct length */
2340 if (fromstr == &PL_sv_undef)
2344 /* XXX better yet, could spirit away the string to
2345 * a safe spot and hang on to it until the result
2346 * of pack() (and all copies of the result) are
2349 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2350 || (SvPADTMP(fromstr)
2351 && !SvREADONLY(fromstr))))
2353 Perl_warner(aTHX_ packWARN(WARN_PACK),
2354 "Attempt to pack pointer to temporary value");
2356 if (SvPOK(fromstr) || SvNIOK(fromstr))
2357 aptr = SvPV(fromstr,n_a);
2359 aptr = SvPV_force(fromstr,n_a);
2361 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2366 aptr = SvPV(fromstr, fromlen);
2367 SvGROW(cat, fromlen * 4 / 3);
2372 while (fromlen > 0) {
2379 doencodes(cat, aptr, todo);
2387 *next_in_list = beglist;
2394 dSP; dMARK; dORIGMARK; dTARGET;
2395 register SV *cat = TARG;
2397 register char *pat = SvPVx(*++MARK, fromlen);
2398 register char *patend = pat + fromlen;
2401 sv_setpvn(cat, "", 0);
2403 pack_cat(cat, pat, patend, MARK, SP + 1, NULL, 0);