3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * He still hopefully carried some of his gear in his pack: a small tinder-box,
13 * two small shallow pans, the smaller fitting into the larger; inside them a
14 * wooden spoon, a short two-pronged fork and some skewers were stowed; and
15 * hidden at the bottom of the pack in a flat wooden box a dwindling treasure,
20 #define PERL_IN_PP_PACK_C
24 * The compiler on Concurrent CX/UX systems has a subtle bug which only
25 * seems to show up when compiling pp.c - it generates the wrong double
26 * precision constant value for (double)UV_MAX when used inline in the body
27 * of the code below, so this makes a static variable up front (which the
28 * compiler seems to get correct) and uses it in place of UV_MAX below.
30 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
31 static double UV_MAX_cxux = ((double)UV_MAX);
35 * Offset for integer pack/unpack.
37 * On architectures where I16 and I32 aren't really 16 and 32 bits,
38 * which for now are all Crays, pack and unpack have to play games.
42 * These values are required for portability of pack() output.
43 * If they're not right on your machine, then pack() and unpack()
44 * wouldn't work right anyway; you'll need to apply the Cray hack.
45 * (I'd like to check them with #if, but you can't use sizeof() in
46 * the preprocessor.) --???
49 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
50 defines are now in config.h. --Andy Dougherty April 1998
55 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
58 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
59 # define PERL_NATINT_PACK
62 #if LONGSIZE > 4 && defined(_CRAY)
63 # if BYTEORDER == 0x12345678
64 # define OFF16(p) (char*)(p)
65 # define OFF32(p) (char*)(p)
67 # if BYTEORDER == 0x87654321
68 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
69 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
71 }}}} bad cray byte order
74 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
75 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
76 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
77 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
78 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
80 # define COPY16(s,p) Copy(s, p, SIZE16, char)
81 # define COPY32(s,p) Copy(s, p, SIZE32, char)
82 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
83 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
84 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
87 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
88 #define MAX_SUB_TEMPLATE_LEVEL 100
91 #define FLAG_UNPACK_ONLY_ONE 0x10
92 #define FLAG_UNPACK_DO_UTF8 0x08
93 #define FLAG_SLASH 0x04
94 #define FLAG_COMMA 0x02
95 #define FLAG_PACK 0x01
98 S_mul128(pTHX_ SV *sv, U8 m)
101 char *s = SvPV(sv, len);
105 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
106 SV *tmpNew = newSVpvn("0000000000", 10);
108 sv_catsv(tmpNew, sv);
109 SvREFCNT_dec(sv); /* free old sv */
114 while (!*t) /* trailing '\0'? */
117 i = ((*t - '0') << 7) + m;
118 *(t--) = '0' + (char)(i % 10);
124 /* Explosives and implosives. */
126 #if 'I' == 73 && 'J' == 74
127 /* On an ASCII/ISO kind of system */
128 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
131 Some other sort of character set - use memchr() so we don't match
134 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
137 #define TYPE_IS_SHRIEKING 0x100
139 /* Returns the sizeof() struct described by pat */
141 S_measure_struct(pTHX_ register tempsym_t* symptr)
143 register I32 len = 0;
144 register I32 total = 0;
149 while (next_symbol(symptr)) {
151 switch( symptr->howlen ){
154 len = symptr->length;
157 Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
158 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
162 switch(symptr->code) {
164 Perl_croak(aTHX_ "Invalid type '%c' in %s",
166 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
169 case 'U': /* XXXX Is it correct? */
172 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
174 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
180 tempsym_t savsym = *symptr;
181 symptr->patptr = savsym.grpbeg;
182 symptr->patend = savsym.grpend;
183 /* XXXX Theoretically, we need to measure many times at different
184 positions, since the subexpression may contain
185 alignment commands, but be not of aligned length.
186 Need to detect this and croak(). */
187 size = measure_struct(symptr);
191 case 'X' | TYPE_IS_SHRIEKING:
192 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */
193 if (!len) /* Avoid division by 0 */
195 len = total % len; /* Assumed: the start is aligned. */
200 Perl_croak(aTHX_ "'X' outside of string in %s",
201 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
203 case 'x' | TYPE_IS_SHRIEKING:
204 if (!len) /* Avoid division by 0 */
206 star = total % len; /* Assumed: the start is aligned. */
207 if (star) /* Other portable ways? */
230 case 's' | TYPE_IS_SHRIEKING:
231 #if SHORTSIZE != SIZE16
232 size = sizeof(short);
240 case 'S' | TYPE_IS_SHRIEKING:
241 #if SHORTSIZE != SIZE16
242 size = sizeof(unsigned short);
252 case 'i' | TYPE_IS_SHRIEKING:
256 case 'I' | TYPE_IS_SHRIEKING:
258 size = sizeof(unsigned int);
266 case 'l' | TYPE_IS_SHRIEKING:
267 #if LONGSIZE != SIZE32
276 case 'L' | TYPE_IS_SHRIEKING:
277 #if LONGSIZE != SIZE32
278 size = sizeof(unsigned long);
292 size = sizeof(char*);
296 size = sizeof(Quad_t);
299 size = sizeof(Uquad_t);
303 size = sizeof(float);
306 size = sizeof(double);
311 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
313 size = LONG_DOUBLESIZE;
323 /* locate matching closing parenthesis or bracket
324 * returns char pointer to char after match, or NULL
327 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
329 while (patptr < patend) {
337 while (patptr < patend && *patptr != '\n')
341 patptr = group_end(patptr, patend, ')') + 1;
343 patptr = group_end(patptr, patend, ']') + 1;
345 Perl_croak(aTHX_ "No group ending character '%c' found in template",
351 /* Convert unsigned decimal number to binary.
352 * Expects a pointer to the first digit and address of length variable
353 * Advances char pointer to 1st non-digit char and returns number
356 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
358 I32 len = *patptr++ - '0';
359 while (isDIGIT(*patptr)) {
360 if (len >= 0x7FFFFFFF/10)
361 Perl_croak(aTHX_ "pack/unpack repeat count overflow");
362 len = (len * 10) + (*patptr++ - '0');
368 /* The marvellous template parsing routine: Using state stored in *symptr,
369 * locates next template code and count
372 S_next_symbol(pTHX_ register tempsym_t* symptr )
374 register char* patptr = symptr->patptr;
375 register char* patend = symptr->patend;
377 symptr->flags &= ~FLAG_SLASH;
379 while (patptr < patend) {
380 if (isSPACE(*patptr))
382 else if (*patptr == '#') {
384 while (patptr < patend && *patptr != '\n')
389 /* We should have found a template code */
390 I32 code = *patptr++ & 0xFF;
392 if (code == ','){ /* grandfather in commas but with a warning */
393 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
394 symptr->flags |= FLAG_COMMA;
395 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
396 "Invalid type ',' in %s",
397 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
402 /* for '(', skip to ')' */
404 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
405 Perl_croak(aTHX_ "()-group starts with a count in %s",
406 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
407 symptr->grpbeg = patptr;
408 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
409 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
410 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
411 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
414 /* test for '!' modifier */
415 if (patptr < patend && *patptr == '!') {
416 static const char natstr[] = "sSiIlLxX";
418 if (strchr(natstr, code))
419 code |= TYPE_IS_SHRIEKING;
421 Perl_croak(aTHX_ "'!' allowed only after types %s in %s",
422 natstr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
425 /* look for count and/or / */
426 if (patptr < patend) {
427 if (isDIGIT(*patptr)) {
428 patptr = get_num( patptr, &symptr->length );
429 symptr->howlen = e_number;
431 } else if (*patptr == '*') {
433 symptr->howlen = e_star;
435 } else if (*patptr == '[') {
436 char* lenptr = ++patptr;
437 symptr->howlen = e_number;
438 patptr = group_end( patptr, patend, ']' ) + 1;
439 /* what kind of [] is it? */
440 if (isDIGIT(*lenptr)) {
441 lenptr = get_num( lenptr, &symptr->length );
443 Perl_croak(aTHX_ "Malformed integer in [] in %s",
444 symptr->flags & FLAG_PACK ? "pack" : "unpack");
446 tempsym_t savsym = *symptr;
447 symptr->patend = patptr-1;
448 symptr->patptr = lenptr;
449 savsym.length = measure_struct(symptr);
453 symptr->howlen = e_no_len;
458 while (patptr < patend) {
459 if (isSPACE(*patptr))
461 else if (*patptr == '#') {
463 while (patptr < patend && *patptr != '\n')
468 if( *patptr == '/' ){
469 symptr->flags |= FLAG_SLASH;
471 if( patptr < patend &&
472 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '[') )
473 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
474 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
480 /* at end - no count, no / */
481 symptr->howlen = e_no_len;
486 symptr->patptr = patptr;
490 symptr->patptr = patptr;
495 =for apidoc unpack_str
497 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
498 and ocnt are not used. This call should not be used, use unpackstring instead.
503 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
505 tempsym_t sym = { 0 };
510 return unpack_rec(&sym, s, s, strend, NULL );
514 =for apidoc unpackstring
516 The engine implementing unpack() Perl function.
521 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
523 tempsym_t sym = { 0 };
528 return unpack_rec(&sym, s, s, strend, NULL );
533 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
537 register I32 len = 0;
538 register I32 bits = 0;
541 I32 start_sp_offset = SP - PL_stack_base;
544 /* These must not be in registers: */
563 const int bits_in_uv = 8 * sizeof(cuv);
566 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
571 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
572 long double aldouble;
575 while (next_symbol(symptr)) {
576 datumtype = symptr->code;
577 /* do first one only unless in list context
578 / is implemented by unpacking the count, then poping it from the
579 stack, so must check that we're not in the middle of a / */
581 && (SP - PL_stack_base == start_sp_offset + 1)
582 && (datumtype != '/') ) /* XXX can this be omitted */
585 switch( howlen = symptr->howlen ){
588 len = symptr->length;
591 len = strend - strbeg; /* long enough */
596 beyond = s >= strend;
599 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)datumtype );
602 if (howlen == e_no_len)
603 len = 16; /* len is not specified */
611 char *ss = s; /* Move from register */
612 tempsym_t savsym = *symptr;
613 symptr->patend = savsym.grpend;
617 symptr->patptr = savsym.grpbeg;
618 unpack_rec(symptr, ss, strbeg, strend, &ss );
619 if (ss == strend && savsym.howlen == e_star)
620 break; /* No way to continue */
624 savsym.flags = symptr->flags;
629 if (len > strend - strrelbeg)
630 Perl_croak(aTHX_ "'@' outside of string in unpack");
633 case 'X' | TYPE_IS_SHRIEKING:
634 if (!len) /* Avoid division by 0 */
636 len = (s - strbeg) % len;
639 if (len > s - strbeg)
640 Perl_croak(aTHX_ "'X' outside of string in unpack" );
643 case 'x' | TYPE_IS_SHRIEKING:
644 if (!len) /* Avoid division by 0 */
646 aint = (s - strbeg) % len;
647 if (aint) /* Other portable ways? */
653 if (len > strend - s)
654 Perl_croak(aTHX_ "'x' outside of string in unpack");
658 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
663 if (len > strend - s)
668 sv_setpvn(sv, s, len);
669 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
670 aptr = s; /* borrow register */
671 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
675 if (howlen == e_star) /* exact for 'Z*' */
676 len = s - SvPVX(sv) + 1;
678 else { /* 'A' strips both nulls and spaces */
679 s = SvPVX(sv) + len - 1;
680 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
684 SvCUR_set(sv, s - SvPVX(sv));
685 s = aptr; /* unborrow register */
688 XPUSHs(sv_2mortal(sv));
692 if (howlen == e_star || len > (strend - s) * 8)
693 len = (strend - s) * 8;
696 Newz(601, PL_bitcount, 256, char);
697 for (bits = 1; bits < 256; bits++) {
698 if (bits & 1) PL_bitcount[bits]++;
699 if (bits & 2) PL_bitcount[bits]++;
700 if (bits & 4) PL_bitcount[bits]++;
701 if (bits & 8) PL_bitcount[bits]++;
702 if (bits & 16) PL_bitcount[bits]++;
703 if (bits & 32) PL_bitcount[bits]++;
704 if (bits & 64) PL_bitcount[bits]++;
705 if (bits & 128) PL_bitcount[bits]++;
709 cuv += PL_bitcount[*(unsigned char*)s++];
714 if (datumtype == 'b') {
722 if (bits & 128) cuv++;
729 sv = NEWSV(35, len + 1);
733 if (datumtype == 'b') {
735 for (len = 0; len < aint; len++) {
736 if (len & 7) /*SUPPRESS 595*/
740 *str++ = '0' + (bits & 1);
745 for (len = 0; len < aint; len++) {
750 *str++ = '0' + ((bits & 128) != 0);
754 XPUSHs(sv_2mortal(sv));
758 if (howlen == e_star || len > (strend - s) * 2)
759 len = (strend - s) * 2;
760 sv = NEWSV(35, len + 1);
764 if (datumtype == 'h') {
766 for (len = 0; len < aint; len++) {
771 *str++ = PL_hexdigit[bits & 15];
776 for (len = 0; len < aint; len++) {
781 *str++ = PL_hexdigit[(bits >> 4) & 15];
785 XPUSHs(sv_2mortal(sv));
788 if (len > strend - s)
793 if (aint >= 128) /* fake up signed chars */
795 if (checksum > bits_in_uv)
802 if (len && unpack_only_one)
808 if (aint >= 128) /* fake up signed chars */
811 sv_setiv(sv, (IV)aint);
812 PUSHs(sv_2mortal(sv));
817 unpack_C: /* unpack U will jump here if not UTF-8 */
819 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
822 if (len > strend - s)
832 if (len && unpack_only_one)
839 sv_setiv(sv, (IV)auint);
840 PUSHs(sv_2mortal(sv));
846 symptr->flags |= FLAG_UNPACK_DO_UTF8;
849 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
851 if (len > strend - s)
854 while (len-- > 0 && s < strend) {
856 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
859 if (checksum > bits_in_uv)
860 cdouble += (NV)auint;
866 if (len && unpack_only_one)
870 while (len-- > 0 && s < strend) {
872 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
876 sv_setuv(sv, (UV)auint);
877 PUSHs(sv_2mortal(sv));
881 case 's' | TYPE_IS_SHRIEKING:
882 #if SHORTSIZE != SIZE16
883 along = (strend - s) / sizeof(short);
889 COPYNN(s, &ashort, sizeof(short));
891 if (checksum > bits_in_uv)
892 cdouble += (NV)ashort;
900 if (len && unpack_only_one)
905 COPYNN(s, &ashort, sizeof(short));
908 sv_setiv(sv, (IV)ashort);
909 PUSHs(sv_2mortal(sv));
917 along = (strend - s) / SIZE16;
923 #if SHORTSIZE > SIZE16
928 if (checksum > bits_in_uv)
929 cdouble += (NV)ashort;
935 if (len && unpack_only_one)
942 #if SHORTSIZE > SIZE16
948 sv_setiv(sv, (IV)ashort);
949 PUSHs(sv_2mortal(sv));
953 case 'S' | TYPE_IS_SHRIEKING:
954 #if SHORTSIZE != SIZE16
955 along = (strend - s) / sizeof(unsigned short);
959 unsigned short aushort;
961 COPYNN(s, &aushort, sizeof(unsigned short));
962 s += sizeof(unsigned short);
963 if (checksum > bits_in_uv)
964 cdouble += (NV)aushort;
970 if (len && unpack_only_one)
975 unsigned short aushort;
976 COPYNN(s, &aushort, sizeof(unsigned short));
977 s += sizeof(unsigned short);
979 sv_setiv(sv, (UV)aushort);
980 PUSHs(sv_2mortal(sv));
990 along = (strend - s) / SIZE16;
998 if (datumtype == 'n')
999 aushort = PerlSock_ntohs(aushort);
1002 if (datumtype == 'v')
1003 aushort = vtohs(aushort);
1005 if (checksum > bits_in_uv)
1006 cdouble += (NV)aushort;
1012 if (len && unpack_only_one)
1017 COPY16(s, &aushort);
1021 if (datumtype == 'n')
1022 aushort = PerlSock_ntohs(aushort);
1025 if (datumtype == 'v')
1026 aushort = vtohs(aushort);
1028 sv_setiv(sv, (UV)aushort);
1029 PUSHs(sv_2mortal(sv));
1034 case 'i' | TYPE_IS_SHRIEKING:
1035 along = (strend - s) / sizeof(int);
1040 Copy(s, &aint, 1, int);
1042 if (checksum > bits_in_uv)
1043 cdouble += (NV)aint;
1049 if (len && unpack_only_one)
1054 Copy(s, &aint, 1, int);
1058 /* Without the dummy below unpack("i", pack("i",-1))
1059 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
1060 * cc with optimization turned on.
1062 * The bug was detected in
1063 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
1064 * with optimization (-O4) turned on.
1065 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
1066 * does not have this problem even with -O4.
1068 * This bug was reported as DECC_BUGS 1431
1069 * and tracked internally as GEM_BUGS 7775.
1071 * The bug is fixed in
1072 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
1073 * UNIX V4.0F support: DEC C V5.9-006 or later
1074 * UNIX V4.0E support: DEC C V5.8-011 or later
1077 * See also few lines later for the same bug.
1080 sv_setiv(sv, (IV)aint) :
1082 sv_setiv(sv, (IV)aint);
1083 PUSHs(sv_2mortal(sv));
1088 case 'I' | TYPE_IS_SHRIEKING:
1089 along = (strend - s) / sizeof(unsigned int);
1094 Copy(s, &auint, 1, unsigned int);
1095 s += sizeof(unsigned int);
1096 if (checksum > bits_in_uv)
1097 cdouble += (NV)auint;
1103 if (len && unpack_only_one)
1108 Copy(s, &auint, 1, unsigned int);
1109 s += sizeof(unsigned int);
1112 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1113 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1114 * See details few lines earlier. */
1116 sv_setuv(sv, (UV)auint) :
1118 sv_setuv(sv, (UV)auint);
1119 PUSHs(sv_2mortal(sv));
1124 along = (strend - s) / IVSIZE;
1129 Copy(s, &aiv, 1, IV);
1131 if (checksum > bits_in_uv)
1138 if (len && unpack_only_one)
1143 Copy(s, &aiv, 1, IV);
1147 PUSHs(sv_2mortal(sv));
1152 along = (strend - s) / UVSIZE;
1157 Copy(s, &auv, 1, UV);
1159 if (checksum > bits_in_uv)
1166 if (len && unpack_only_one)
1171 Copy(s, &auv, 1, UV);
1175 PUSHs(sv_2mortal(sv));
1179 case 'l' | TYPE_IS_SHRIEKING:
1180 #if LONGSIZE != SIZE32
1181 along = (strend - s) / sizeof(long);
1186 COPYNN(s, &along, sizeof(long));
1188 if (checksum > bits_in_uv)
1189 cdouble += (NV)along;
1195 if (len && unpack_only_one)
1200 COPYNN(s, &along, sizeof(long));
1203 sv_setiv(sv, (IV)along);
1204 PUSHs(sv_2mortal(sv));
1212 along = (strend - s) / SIZE32;
1217 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1221 #if LONGSIZE > SIZE32
1222 if (along > 2147483647)
1223 along -= 4294967296;
1226 if (checksum > bits_in_uv)
1227 cdouble += (NV)along;
1233 if (len && unpack_only_one)
1238 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1242 #if LONGSIZE > SIZE32
1243 if (along > 2147483647)
1244 along -= 4294967296;
1248 sv_setiv(sv, (IV)along);
1249 PUSHs(sv_2mortal(sv));
1253 case 'L' | TYPE_IS_SHRIEKING:
1254 #if LONGSIZE != SIZE32
1255 along = (strend - s) / sizeof(unsigned long);
1260 unsigned long aulong;
1261 COPYNN(s, &aulong, sizeof(unsigned long));
1262 s += sizeof(unsigned long);
1263 if (checksum > bits_in_uv)
1264 cdouble += (NV)aulong;
1270 if (len && unpack_only_one)
1275 unsigned long aulong;
1276 COPYNN(s, &aulong, sizeof(unsigned long));
1277 s += sizeof(unsigned long);
1279 sv_setuv(sv, (UV)aulong);
1280 PUSHs(sv_2mortal(sv));
1290 along = (strend - s) / SIZE32;
1298 if (datumtype == 'N')
1299 aulong = PerlSock_ntohl(aulong);
1302 if (datumtype == 'V')
1303 aulong = vtohl(aulong);
1305 if (checksum > bits_in_uv)
1306 cdouble += (NV)aulong;
1312 if (len && unpack_only_one)
1320 if (datumtype == 'N')
1321 aulong = PerlSock_ntohl(aulong);
1324 if (datumtype == 'V')
1325 aulong = vtohl(aulong);
1328 sv_setuv(sv, (UV)aulong);
1329 PUSHs(sv_2mortal(sv));
1334 along = (strend - s) / sizeof(char*);
1340 if (sizeof(char*) > strend - s)
1343 Copy(s, &aptr, 1, char*);
1349 PUSHs(sv_2mortal(sv));
1353 if (len && unpack_only_one)
1361 while ((len > 0) && (s < strend)) {
1362 auv = (auv << 7) | (*s & 0x7f);
1363 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1364 if ((U8)(*s++) < 0x80) {
1368 PUSHs(sv_2mortal(sv));
1372 else if (++bytes >= sizeof(UV)) { /* promote to string */
1376 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1377 while (s < strend) {
1378 sv = mul128(sv, (U8)(*s & 0x7f));
1379 if (!(*s++ & 0x80)) {
1388 PUSHs(sv_2mortal(sv));
1393 if ((s >= strend) && bytes)
1394 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1398 if (symptr->howlen == e_star)
1399 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1401 if (sizeof(char*) > strend - s)
1404 Copy(s, &aptr, 1, char*);
1409 sv_setpvn(sv, aptr, len);
1410 PUSHs(sv_2mortal(sv));
1414 along = (strend - s) / sizeof(Quad_t);
1419 Copy(s, &aquad, 1, Quad_t);
1420 s += sizeof(Quad_t);
1421 if (checksum > bits_in_uv)
1422 cdouble += (NV)aquad;
1428 if (len && unpack_only_one)
1433 if (s + sizeof(Quad_t) > strend)
1436 Copy(s, &aquad, 1, Quad_t);
1437 s += sizeof(Quad_t);
1440 if (aquad >= IV_MIN && aquad <= IV_MAX)
1441 sv_setiv(sv, (IV)aquad);
1443 sv_setnv(sv, (NV)aquad);
1444 PUSHs(sv_2mortal(sv));
1449 along = (strend - s) / sizeof(Uquad_t);
1454 Copy(s, &auquad, 1, Uquad_t);
1455 s += sizeof(Uquad_t);
1456 if (checksum > bits_in_uv)
1457 cdouble += (NV)auquad;
1463 if (len && unpack_only_one)
1468 if (s + sizeof(Uquad_t) > strend)
1471 Copy(s, &auquad, 1, Uquad_t);
1472 s += sizeof(Uquad_t);
1475 if (auquad <= UV_MAX)
1476 sv_setuv(sv, (UV)auquad);
1478 sv_setnv(sv, (NV)auquad);
1479 PUSHs(sv_2mortal(sv));
1484 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1486 along = (strend - s) / sizeof(float);
1491 Copy(s, &afloat, 1, float);
1497 if (len && unpack_only_one)
1502 Copy(s, &afloat, 1, float);
1505 sv_setnv(sv, (NV)afloat);
1506 PUSHs(sv_2mortal(sv));
1511 along = (strend - s) / sizeof(double);
1516 Copy(s, &adouble, 1, double);
1517 s += sizeof(double);
1522 if (len && unpack_only_one)
1527 Copy(s, &adouble, 1, double);
1528 s += sizeof(double);
1530 sv_setnv(sv, (NV)adouble);
1531 PUSHs(sv_2mortal(sv));
1536 along = (strend - s) / NVSIZE;
1541 Copy(s, &anv, 1, NV);
1547 if (len && unpack_only_one)
1552 Copy(s, &anv, 1, NV);
1556 PUSHs(sv_2mortal(sv));
1560 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1562 along = (strend - s) / LONG_DOUBLESIZE;
1567 Copy(s, &aldouble, 1, long double);
1568 s += LONG_DOUBLESIZE;
1569 cdouble += aldouble;
1573 if (len && unpack_only_one)
1578 Copy(s, &aldouble, 1, long double);
1579 s += LONG_DOUBLESIZE;
1581 sv_setnv(sv, (NV)aldouble);
1582 PUSHs(sv_2mortal(sv));
1589 * Initialise the decode mapping. By using a table driven
1590 * algorithm, the code will be character-set independent
1591 * (and just as fast as doing character arithmetic)
1593 if (PL_uudmap['M'] == 0) {
1596 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1597 PL_uudmap[(U8)PL_uuemap[i]] = i;
1599 * Because ' ' and '`' map to the same value,
1600 * we need to decode them both the same.
1605 along = (strend - s) * 3 / 4;
1606 sv = NEWSV(42, along);
1609 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1614 len = PL_uudmap[*(U8*)s++] & 077;
1616 if (s < strend && ISUUCHAR(*s))
1617 a = PL_uudmap[*(U8*)s++] & 077;
1620 if (s < strend && ISUUCHAR(*s))
1621 b = PL_uudmap[*(U8*)s++] & 077;
1624 if (s < strend && ISUUCHAR(*s))
1625 c = PL_uudmap[*(U8*)s++] & 077;
1628 if (s < strend && ISUUCHAR(*s))
1629 d = PL_uudmap[*(U8*)s++] & 077;
1632 hunk[0] = (char)((a << 2) | (b >> 4));
1633 hunk[1] = (char)((b << 4) | (c >> 2));
1634 hunk[2] = (char)((c << 6) | d);
1635 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1640 else /* possible checksum byte */
1641 if (s + 1 < strend && s[1] == '\n')
1644 XPUSHs(sv_2mortal(sv));
1650 if (strchr("fFdD", datumtype) ||
1651 (checksum > bits_in_uv &&
1652 strchr("csSiIlLnNUvVqQjJ", datumtype&0xFF)) ) {
1655 adouble = (NV) (1 << (checksum & 15));
1656 while (checksum >= 16) {
1660 while (cdouble < 0.0)
1662 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1663 sv_setnv(sv, cdouble);
1666 if (checksum < bits_in_uv) {
1667 UV mask = ((UV)1 << checksum) - 1;
1672 XPUSHs(sv_2mortal(sv));
1676 if (symptr->flags & FLAG_SLASH){
1677 if (SP - PL_stack_base - start_sp_offset <= 0)
1678 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1679 if( next_symbol(symptr) ){
1680 if( symptr->howlen == e_number )
1681 Perl_croak(aTHX_ "Count after length/code in unpack" );
1683 /* ...end of char buffer then no decent length available */
1684 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1686 /* take top of stack (hope it's numeric) */
1689 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1692 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1694 datumtype = symptr->code;
1702 return SP - PL_stack_base - start_sp_offset;
1708 SV *right = (MAXARG > 1) ? POPs : GvSV(PL_defgv);
1710 I32 gimme = GIMME_V;
1713 register char *pat = SvPV(left, llen);
1714 #ifdef PACKED_IS_OCTETS
1715 /* Packed side is assumed to be octets - so force downgrade if it
1716 has been UTF-8 encoded by accident
1718 register char *s = SvPVbyte(right, rlen);
1720 register char *s = SvPV(right, rlen);
1722 char *strend = s + rlen;
1723 register char *patend = pat + llen;
1727 cnt = unpackstring(pat, patend, s, strend,
1728 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1729 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1732 if ( !cnt && gimme == G_SCALAR )
1733 PUSHs(&PL_sv_undef);
1738 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1742 *hunk = PL_uuemap[len];
1743 sv_catpvn(sv, hunk, 1);
1746 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1747 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1748 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1749 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1750 sv_catpvn(sv, hunk, 4);
1755 char r = (len > 1 ? s[1] : '\0');
1756 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1757 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1758 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1759 hunk[3] = PL_uuemap[0];
1760 sv_catpvn(sv, hunk, 4);
1762 sv_catpvn(sv, "\n", 1);
1766 S_is_an_int(pTHX_ char *s, STRLEN l)
1769 SV *result = newSVpvn(s, l);
1770 char *result_c = SvPV(result, n_a); /* convenience */
1771 char *out = result_c;
1781 SvREFCNT_dec(result);
1804 SvREFCNT_dec(result);
1810 SvCUR_set(result, out - result_c);
1814 /* pnum must be '\0' terminated */
1816 S_div128(pTHX_ SV *pnum, bool *done)
1819 char *s = SvPV(pnum, len);
1828 i = m * 10 + (*t - '0');
1830 r = (i >> 7); /* r < 10 */
1837 SvCUR_set(pnum, (STRLEN) (t - s));
1844 =for apidoc pack_cat
1846 The engine implementing pack() Perl function. Note: parameters next_in_list and
1847 flags are not used. This call should not be used; use packlist instead.
1853 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1855 tempsym_t sym = { 0 };
1857 sym.patend = patend;
1858 sym.flags = FLAG_PACK;
1860 (void)pack_rec( cat, &sym, beglist, endlist );
1865 =for apidoc packlist
1867 The engine implementing pack() Perl function.
1873 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1875 tempsym_t sym = { 0 };
1877 sym.patend = patend;
1878 sym.flags = FLAG_PACK;
1880 (void)pack_rec( cat, &sym, beglist, endlist );
1886 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1890 register I32 len = 0;
1893 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1894 static char *space10 = " ";
1897 /* These must not be in registers: */
1907 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1908 long double aldouble;
1917 int strrelbeg = SvCUR(cat);
1918 tempsym_t lookahead;
1920 items = endlist - beglist;
1921 found = next_symbol( symptr );
1923 #ifndef PACKED_IS_OCTETS
1924 if (symptr->level == 0 && found && symptr->code == 'U' ){
1930 SV *lengthcode = Nullsv;
1931 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1933 I32 datumtype = symptr->code;
1936 switch( howlen = symptr->howlen ){
1939 len = symptr->length;
1942 len = strchr("@Xxu", datumtype) ? 0 : items;
1946 /* Look ahead for next symbol. Do we have code/code? */
1947 lookahead = *symptr;
1948 found = next_symbol(&lookahead);
1949 if ( symptr->flags & FLAG_SLASH ) {
1951 if ( 0 == strchr( "aAZ", lookahead.code ) ||
1952 e_star != lookahead.howlen )
1953 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
1954 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1955 ? *beglist : &PL_sv_no)
1956 + (lookahead.code == 'Z' ? 1 : 0)));
1958 Perl_croak(aTHX_ "Code missing after '/' in pack");
1964 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)datumtype);
1966 Perl_croak(aTHX_ "'%%' may not be used in pack");
1968 len += strrelbeg - SvCUR(cat);
1977 tempsym_t savsym = *symptr;
1978 symptr->patend = savsym.grpend;
1981 symptr->patptr = savsym.grpbeg;
1982 beglist = pack_rec(cat, symptr, beglist, endlist );
1983 if (savsym.howlen == e_star && beglist == endlist)
1984 break; /* No way to continue */
1986 lookahead.flags = symptr->flags;
1990 case 'X' | TYPE_IS_SHRIEKING:
1991 if (!len) /* Avoid division by 0 */
1993 len = (SvCUR(cat)) % len;
1997 if ((I32)SvCUR(cat) < len)
1998 Perl_croak(aTHX_ "'X' outside of string in pack");
2002 case 'x' | TYPE_IS_SHRIEKING:
2003 if (!len) /* Avoid division by 0 */
2005 aint = (SvCUR(cat)) % len;
2006 if (aint) /* Other portable ways? */
2015 sv_catpvn(cat, null10, 10);
2018 sv_catpvn(cat, null10, len);
2024 aptr = SvPV(fromstr, fromlen);
2025 if (howlen == e_star) {
2027 if (datumtype == 'Z')
2030 if ((I32)fromlen >= len) {
2031 sv_catpvn(cat, aptr, len);
2032 if (datumtype == 'Z')
2033 *(SvEND(cat)-1) = '\0';
2036 sv_catpvn(cat, aptr, fromlen);
2038 if (datumtype == 'A') {
2040 sv_catpvn(cat, space10, 10);
2043 sv_catpvn(cat, space10, len);
2047 sv_catpvn(cat, null10, 10);
2050 sv_catpvn(cat, null10, len);
2062 str = SvPV(fromstr, fromlen);
2063 if (howlen == e_star)
2066 SvCUR(cat) += (len+7)/8;
2067 SvGROW(cat, SvCUR(cat) + 1);
2068 aptr = SvPVX(cat) + aint;
2069 if (len > (I32)fromlen)
2073 if (datumtype == 'B') {
2074 for (len = 0; len++ < aint;) {
2075 items |= *str++ & 1;
2079 *aptr++ = items & 0xff;
2085 for (len = 0; len++ < aint;) {
2091 *aptr++ = items & 0xff;
2097 if (datumtype == 'B')
2098 items <<= 7 - (aint & 7);
2100 items >>= 7 - (aint & 7);
2101 *aptr++ = items & 0xff;
2103 str = SvPVX(cat) + SvCUR(cat);
2118 str = SvPV(fromstr, fromlen);
2119 if (howlen == e_star)
2122 SvCUR(cat) += (len+1)/2;
2123 SvGROW(cat, SvCUR(cat) + 1);
2124 aptr = SvPVX(cat) + aint;
2125 if (len > (I32)fromlen)
2129 if (datumtype == 'H') {
2130 for (len = 0; len++ < aint;) {
2132 items |= ((*str++ & 15) + 9) & 15;
2134 items |= *str++ & 15;
2138 *aptr++ = items & 0xff;
2144 for (len = 0; len++ < aint;) {
2146 items |= (((*str++ & 15) + 9) & 15) << 4;
2148 items |= (*str++ & 15) << 4;
2152 *aptr++ = items & 0xff;
2158 *aptr++ = items & 0xff;
2159 str = SvPVX(cat) + SvCUR(cat);
2170 switch (datumtype) {
2172 aint = SvIV(fromstr);
2173 if ((aint < 0 || aint > 255) &&
2175 Perl_warner(aTHX_ packWARN(WARN_PACK),
2176 "Character in 'C' format wrapped in pack");
2178 sv_catpvn(cat, &achar, sizeof(char));
2181 aint = SvIV(fromstr);
2182 if ((aint < -128 || aint > 127) &&
2184 Perl_warner(aTHX_ packWARN(WARN_PACK),
2185 "Character in 'c' format wrapped in pack" );
2187 sv_catpvn(cat, &achar, sizeof(char));
2195 auint = UNI_TO_NATIVE(SvUV(fromstr));
2196 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2198 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2201 0 : UNICODE_ALLOW_ANY)
2206 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2211 /* VOS does not automatically map a floating-point overflow
2212 during conversion from double to float into infinity, so we
2213 do it by hand. This code should either be generalized for
2214 any OS that needs it, or removed if and when VOS implements
2215 posix-976 (suggestion to support mapping to infinity).
2216 Paul.Green@stratus.com 02-04-02. */
2217 if (SvNV(fromstr) > FLT_MAX)
2218 afloat = _float_constants[0]; /* single prec. inf. */
2219 else if (SvNV(fromstr) < -FLT_MAX)
2220 afloat = _float_constants[0]; /* single prec. inf. */
2221 else afloat = (float)SvNV(fromstr);
2223 # if defined(VMS) && !defined(__IEEE_FP)
2224 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2225 * on Alpha; fake it if we don't have them.
2227 if (SvNV(fromstr) > FLT_MAX)
2229 else if (SvNV(fromstr) < -FLT_MAX)
2231 else afloat = (float)SvNV(fromstr);
2233 afloat = (float)SvNV(fromstr);
2236 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2243 /* VOS does not automatically map a floating-point overflow
2244 during conversion from long double to double into infinity,
2245 so we do it by hand. This code should either be generalized
2246 for any OS that needs it, or removed if and when VOS
2247 implements posix-976 (suggestion to support mapping to
2248 infinity). Paul.Green@stratus.com 02-04-02. */
2249 if (SvNV(fromstr) > DBL_MAX)
2250 adouble = _double_constants[0]; /* double prec. inf. */
2251 else if (SvNV(fromstr) < -DBL_MAX)
2252 adouble = _double_constants[0]; /* double prec. inf. */
2253 else adouble = (double)SvNV(fromstr);
2255 # if defined(VMS) && !defined(__IEEE_FP)
2256 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2257 * on Alpha; fake it if we don't have them.
2259 if (SvNV(fromstr) > DBL_MAX)
2261 else if (SvNV(fromstr) < -DBL_MAX)
2263 else adouble = (double)SvNV(fromstr);
2265 adouble = (double)SvNV(fromstr);
2268 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2274 anv = SvNV(fromstr);
2275 sv_catpvn(cat, (char *)&anv, NVSIZE);
2278 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2282 aldouble = (long double)SvNV(fromstr);
2283 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2290 ashort = (I16)SvIV(fromstr);
2292 ashort = PerlSock_htons(ashort);
2294 CAT16(cat, &ashort);
2300 ashort = (I16)SvIV(fromstr);
2302 ashort = htovs(ashort);
2304 CAT16(cat, &ashort);
2307 case 'S' | TYPE_IS_SHRIEKING:
2308 #if SHORTSIZE != SIZE16
2310 unsigned short aushort;
2314 aushort = SvUV(fromstr);
2315 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2328 aushort = (U16)SvUV(fromstr);
2329 CAT16(cat, &aushort);
2334 case 's' | TYPE_IS_SHRIEKING:
2335 #if SHORTSIZE != SIZE16
2341 ashort = SvIV(fromstr);
2342 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2352 ashort = (I16)SvIV(fromstr);
2353 CAT16(cat, &ashort);
2357 case 'I' | TYPE_IS_SHRIEKING:
2360 auint = SvUV(fromstr);
2361 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2367 aiv = SvIV(fromstr);
2368 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2374 auv = SvUV(fromstr);
2375 sv_catpvn(cat, (char*)&auv, UVSIZE);
2381 anv = SvNV(fromstr);
2384 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2386 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2387 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2388 any negative IVs will have already been got by the croak()
2389 above. IOK is untrue for fractions, so we test them
2390 against UV_MAX_P1. */
2391 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2393 char buf[(sizeof(UV)*8)/7+1];
2394 char *in = buf + sizeof(buf);
2395 UV auv = SvUV(fromstr);
2398 *--in = (char)((auv & 0x7f) | 0x80);
2401 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2402 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2404 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2405 char *from, *result, *in;
2410 /* Copy string and check for compliance */
2411 from = SvPV(fromstr, len);
2412 if ((norm = is_an_int(from, len)) == NULL)
2413 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2415 New('w', result, len, char);
2419 *--in = div128(norm, &done) | 0x80;
2420 result[len - 1] &= 0x7F; /* clear continue bit */
2421 sv_catpvn(cat, in, (result + len) - in);
2423 SvREFCNT_dec(norm); /* free norm */
2425 else if (SvNOKp(fromstr)) {
2426 /* 10**NV_MAX_10_EXP is the largest power of 10
2427 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2428 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2429 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2430 And with that many bytes only Inf can overflow.
2432 #ifdef NV_MAX_10_EXP
2433 char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)];
2435 char buf[1 + (int)((308 + 1) * 0.47456)];
2437 char *in = buf + sizeof(buf);
2439 anv = Perl_floor(anv);
2441 NV next = Perl_floor(anv / 128);
2442 if (in <= buf) /* this cannot happen ;-) */
2443 Perl_croak(aTHX_ "Cannot compress integer in pack");
2444 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2447 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2448 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2451 char *from, *result, *in;
2456 /* Copy string and check for compliance */
2457 from = SvPV(fromstr, len);
2458 if ((norm = is_an_int(from, len)) == NULL)
2459 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2461 New('w', result, len, char);
2465 *--in = div128(norm, &done) | 0x80;
2466 result[len - 1] &= 0x7F; /* clear continue bit */
2467 sv_catpvn(cat, in, (result + len) - in);
2469 SvREFCNT_dec(norm); /* free norm */
2474 case 'i' | TYPE_IS_SHRIEKING:
2477 aint = SvIV(fromstr);
2478 sv_catpvn(cat, (char*)&aint, sizeof(int));
2484 aulong = SvUV(fromstr);
2486 aulong = PerlSock_htonl(aulong);
2488 CAT32(cat, &aulong);
2494 aulong = SvUV(fromstr);
2496 aulong = htovl(aulong);
2498 CAT32(cat, &aulong);
2501 case 'L' | TYPE_IS_SHRIEKING:
2502 #if LONGSIZE != SIZE32
2504 unsigned long aulong;
2508 aulong = SvUV(fromstr);
2509 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2520 aulong = SvUV(fromstr);
2521 CAT32(cat, &aulong);
2525 case 'l' | TYPE_IS_SHRIEKING:
2526 #if LONGSIZE != SIZE32
2532 along = SvIV(fromstr);
2533 sv_catpvn(cat, (char *)&along, sizeof(long));
2543 along = SvIV(fromstr);
2551 auquad = (Uquad_t)SvUV(fromstr);
2552 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2558 aquad = (Quad_t)SvIV(fromstr);
2559 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2564 len = 1; /* assume SV is correct length */
2569 if (fromstr == &PL_sv_undef)
2573 /* XXX better yet, could spirit away the string to
2574 * a safe spot and hang on to it until the result
2575 * of pack() (and all copies of the result) are
2578 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2579 || (SvPADTMP(fromstr)
2580 && !SvREADONLY(fromstr))))
2582 Perl_warner(aTHX_ packWARN(WARN_PACK),
2583 "Attempt to pack pointer to temporary value");
2585 if (SvPOK(fromstr) || SvNIOK(fromstr))
2586 aptr = SvPV(fromstr,n_a);
2588 aptr = SvPV_force(fromstr,n_a);
2590 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2595 aptr = SvPV(fromstr, fromlen);
2596 SvGROW(cat, fromlen * 4 / 3);
2601 while (fromlen > 0) {
2604 if ((I32)fromlen > len)
2608 doencodes(cat, aptr, todo);
2614 *symptr = lookahead;
2623 dSP; dMARK; dORIGMARK; dTARGET;
2624 register SV *cat = TARG;
2626 register char *pat = SvPVx(*++MARK, fromlen);
2627 register char *patend = pat + fromlen;
2630 sv_setpvn(cat, "", 0);
2632 packlist(cat, pat, patend, MARK, SP + 1);