3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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. C<unpackstring> puts the
517 extracted list items on the stack and returns the number of elements.
518 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
523 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
525 tempsym_t sym = { 0 };
530 return unpack_rec(&sym, s, s, strend, NULL );
535 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
539 register I32 len = 0;
540 register I32 bits = 0;
543 I32 start_sp_offset = SP - PL_stack_base;
546 /* These must not be in registers: */
565 const int bits_in_uv = 8 * sizeof(cuv);
568 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
573 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
574 long double aldouble;
577 while (next_symbol(symptr)) {
578 datumtype = symptr->code;
579 /* do first one only unless in list context
580 / is implemented by unpacking the count, then poping it from the
581 stack, so must check that we're not in the middle of a / */
583 && (SP - PL_stack_base == start_sp_offset + 1)
584 && (datumtype != '/') ) /* XXX can this be omitted */
587 switch( howlen = symptr->howlen ){
590 len = symptr->length;
593 len = strend - strbeg; /* long enough */
598 beyond = s >= strend;
601 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)datumtype );
604 if (howlen == e_no_len)
605 len = 16; /* len is not specified */
613 char *ss = s; /* Move from register */
614 tempsym_t savsym = *symptr;
615 symptr->patend = savsym.grpend;
619 symptr->patptr = savsym.grpbeg;
620 unpack_rec(symptr, ss, strbeg, strend, &ss );
621 if (ss == strend && savsym.howlen == e_star)
622 break; /* No way to continue */
626 savsym.flags = symptr->flags;
631 if (len > strend - strrelbeg)
632 Perl_croak(aTHX_ "'@' outside of string in unpack");
635 case 'X' | TYPE_IS_SHRIEKING:
636 if (!len) /* Avoid division by 0 */
638 len = (s - strbeg) % len;
641 if (len > s - strbeg)
642 Perl_croak(aTHX_ "'X' outside of string in unpack" );
645 case 'x' | TYPE_IS_SHRIEKING:
646 if (!len) /* Avoid division by 0 */
648 aint = (s - strbeg) % len;
649 if (aint) /* Other portable ways? */
655 if (len > strend - s)
656 Perl_croak(aTHX_ "'x' outside of string in unpack");
660 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
665 if (len > strend - s)
670 sv_setpvn(sv, s, len);
671 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
672 aptr = s; /* borrow register */
673 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
677 if (howlen == e_star) /* exact for 'Z*' */
678 len = s - SvPVX(sv) + 1;
680 else { /* 'A' strips both nulls and spaces */
681 s = SvPVX(sv) + len - 1;
682 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
686 SvCUR_set(sv, s - SvPVX(sv));
687 s = aptr; /* unborrow register */
690 XPUSHs(sv_2mortal(sv));
694 if (howlen == e_star || len > (strend - s) * 8)
695 len = (strend - s) * 8;
698 Newz(601, PL_bitcount, 256, char);
699 for (bits = 1; bits < 256; bits++) {
700 if (bits & 1) PL_bitcount[bits]++;
701 if (bits & 2) PL_bitcount[bits]++;
702 if (bits & 4) PL_bitcount[bits]++;
703 if (bits & 8) PL_bitcount[bits]++;
704 if (bits & 16) PL_bitcount[bits]++;
705 if (bits & 32) PL_bitcount[bits]++;
706 if (bits & 64) PL_bitcount[bits]++;
707 if (bits & 128) PL_bitcount[bits]++;
711 cuv += PL_bitcount[*(unsigned char*)s++];
716 if (datumtype == 'b') {
724 if (bits & 128) cuv++;
731 sv = NEWSV(35, len + 1);
735 if (datumtype == 'b') {
737 for (len = 0; len < aint; len++) {
738 if (len & 7) /*SUPPRESS 595*/
742 *str++ = '0' + (bits & 1);
747 for (len = 0; len < aint; len++) {
752 *str++ = '0' + ((bits & 128) != 0);
756 XPUSHs(sv_2mortal(sv));
760 if (howlen == e_star || len > (strend - s) * 2)
761 len = (strend - s) * 2;
762 sv = NEWSV(35, len + 1);
766 if (datumtype == 'h') {
768 for (len = 0; len < aint; len++) {
773 *str++ = PL_hexdigit[bits & 15];
778 for (len = 0; len < aint; len++) {
783 *str++ = PL_hexdigit[(bits >> 4) & 15];
787 XPUSHs(sv_2mortal(sv));
790 if (len > strend - s)
795 if (aint >= 128) /* fake up signed chars */
797 if (checksum > bits_in_uv)
804 if (len && unpack_only_one)
810 if (aint >= 128) /* fake up signed chars */
813 sv_setiv(sv, (IV)aint);
814 PUSHs(sv_2mortal(sv));
819 unpack_C: /* unpack U will jump here if not UTF-8 */
821 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
824 if (len > strend - s)
834 if (len && unpack_only_one)
841 sv_setiv(sv, (IV)auint);
842 PUSHs(sv_2mortal(sv));
848 symptr->flags |= FLAG_UNPACK_DO_UTF8;
851 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
853 if (len > strend - s)
856 while (len-- > 0 && s < strend) {
858 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
861 if (checksum > bits_in_uv)
862 cdouble += (NV)auint;
868 if (len && unpack_only_one)
872 while (len-- > 0 && s < strend) {
874 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
878 sv_setuv(sv, (UV)auint);
879 PUSHs(sv_2mortal(sv));
883 case 's' | TYPE_IS_SHRIEKING:
884 #if SHORTSIZE != SIZE16
885 along = (strend - s) / sizeof(short);
891 COPYNN(s, &ashort, sizeof(short));
893 if (checksum > bits_in_uv)
894 cdouble += (NV)ashort;
902 if (len && unpack_only_one)
907 COPYNN(s, &ashort, sizeof(short));
910 sv_setiv(sv, (IV)ashort);
911 PUSHs(sv_2mortal(sv));
919 along = (strend - s) / SIZE16;
925 #if SHORTSIZE > SIZE16
930 if (checksum > bits_in_uv)
931 cdouble += (NV)ashort;
937 if (len && unpack_only_one)
944 #if SHORTSIZE > SIZE16
950 sv_setiv(sv, (IV)ashort);
951 PUSHs(sv_2mortal(sv));
955 case 'S' | TYPE_IS_SHRIEKING:
956 #if SHORTSIZE != SIZE16
957 along = (strend - s) / sizeof(unsigned short);
961 unsigned short aushort;
963 COPYNN(s, &aushort, sizeof(unsigned short));
964 s += sizeof(unsigned short);
965 if (checksum > bits_in_uv)
966 cdouble += (NV)aushort;
972 if (len && unpack_only_one)
977 unsigned short aushort;
978 COPYNN(s, &aushort, sizeof(unsigned short));
979 s += sizeof(unsigned short);
981 sv_setiv(sv, (UV)aushort);
982 PUSHs(sv_2mortal(sv));
992 along = (strend - s) / SIZE16;
1000 if (datumtype == 'n')
1001 aushort = PerlSock_ntohs(aushort);
1004 if (datumtype == 'v')
1005 aushort = vtohs(aushort);
1007 if (checksum > bits_in_uv)
1008 cdouble += (NV)aushort;
1014 if (len && unpack_only_one)
1019 COPY16(s, &aushort);
1023 if (datumtype == 'n')
1024 aushort = PerlSock_ntohs(aushort);
1027 if (datumtype == 'v')
1028 aushort = vtohs(aushort);
1030 sv_setiv(sv, (UV)aushort);
1031 PUSHs(sv_2mortal(sv));
1036 case 'i' | TYPE_IS_SHRIEKING:
1037 along = (strend - s) / sizeof(int);
1042 Copy(s, &aint, 1, int);
1044 if (checksum > bits_in_uv)
1045 cdouble += (NV)aint;
1051 if (len && unpack_only_one)
1056 Copy(s, &aint, 1, int);
1060 /* Without the dummy below unpack("i", pack("i",-1))
1061 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
1062 * cc with optimization turned on.
1064 * The bug was detected in
1065 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
1066 * with optimization (-O4) turned on.
1067 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
1068 * does not have this problem even with -O4.
1070 * This bug was reported as DECC_BUGS 1431
1071 * and tracked internally as GEM_BUGS 7775.
1073 * The bug is fixed in
1074 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
1075 * UNIX V4.0F support: DEC C V5.9-006 or later
1076 * UNIX V4.0E support: DEC C V5.8-011 or later
1079 * See also few lines later for the same bug.
1082 sv_setiv(sv, (IV)aint) :
1084 sv_setiv(sv, (IV)aint);
1085 PUSHs(sv_2mortal(sv));
1090 case 'I' | TYPE_IS_SHRIEKING:
1091 along = (strend - s) / sizeof(unsigned int);
1096 Copy(s, &auint, 1, unsigned int);
1097 s += sizeof(unsigned int);
1098 if (checksum > bits_in_uv)
1099 cdouble += (NV)auint;
1105 if (len && unpack_only_one)
1110 Copy(s, &auint, 1, unsigned int);
1111 s += sizeof(unsigned int);
1114 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1115 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1116 * See details few lines earlier. */
1118 sv_setuv(sv, (UV)auint) :
1120 sv_setuv(sv, (UV)auint);
1121 PUSHs(sv_2mortal(sv));
1126 along = (strend - s) / IVSIZE;
1131 Copy(s, &aiv, 1, IV);
1133 if (checksum > bits_in_uv)
1140 if (len && unpack_only_one)
1145 Copy(s, &aiv, 1, IV);
1149 PUSHs(sv_2mortal(sv));
1154 along = (strend - s) / UVSIZE;
1159 Copy(s, &auv, 1, UV);
1161 if (checksum > bits_in_uv)
1168 if (len && unpack_only_one)
1173 Copy(s, &auv, 1, UV);
1177 PUSHs(sv_2mortal(sv));
1181 case 'l' | TYPE_IS_SHRIEKING:
1182 #if LONGSIZE != SIZE32
1183 along = (strend - s) / sizeof(long);
1188 COPYNN(s, &along, sizeof(long));
1190 if (checksum > bits_in_uv)
1191 cdouble += (NV)along;
1197 if (len && unpack_only_one)
1202 COPYNN(s, &along, sizeof(long));
1205 sv_setiv(sv, (IV)along);
1206 PUSHs(sv_2mortal(sv));
1214 along = (strend - s) / SIZE32;
1219 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1223 #if LONGSIZE > SIZE32
1224 if (along > 2147483647)
1225 along -= 4294967296;
1228 if (checksum > bits_in_uv)
1229 cdouble += (NV)along;
1235 if (len && unpack_only_one)
1240 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1244 #if LONGSIZE > SIZE32
1245 if (along > 2147483647)
1246 along -= 4294967296;
1250 sv_setiv(sv, (IV)along);
1251 PUSHs(sv_2mortal(sv));
1255 case 'L' | TYPE_IS_SHRIEKING:
1256 #if LONGSIZE != SIZE32
1257 along = (strend - s) / sizeof(unsigned long);
1262 unsigned long aulong;
1263 COPYNN(s, &aulong, sizeof(unsigned long));
1264 s += sizeof(unsigned long);
1265 if (checksum > bits_in_uv)
1266 cdouble += (NV)aulong;
1272 if (len && unpack_only_one)
1277 unsigned long aulong;
1278 COPYNN(s, &aulong, sizeof(unsigned long));
1279 s += sizeof(unsigned long);
1281 sv_setuv(sv, (UV)aulong);
1282 PUSHs(sv_2mortal(sv));
1292 along = (strend - s) / SIZE32;
1300 if (datumtype == 'N')
1301 aulong = PerlSock_ntohl(aulong);
1304 if (datumtype == 'V')
1305 aulong = vtohl(aulong);
1307 if (checksum > bits_in_uv)
1308 cdouble += (NV)aulong;
1314 if (len && unpack_only_one)
1322 if (datumtype == 'N')
1323 aulong = PerlSock_ntohl(aulong);
1326 if (datumtype == 'V')
1327 aulong = vtohl(aulong);
1330 sv_setuv(sv, (UV)aulong);
1331 PUSHs(sv_2mortal(sv));
1336 along = (strend - s) / sizeof(char*);
1342 if (sizeof(char*) > strend - s)
1345 Copy(s, &aptr, 1, char*);
1351 PUSHs(sv_2mortal(sv));
1355 if (len && unpack_only_one)
1363 while ((len > 0) && (s < strend)) {
1364 auv = (auv << 7) | (*s & 0x7f);
1365 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1366 if ((U8)(*s++) < 0x80) {
1370 PUSHs(sv_2mortal(sv));
1374 else if (++bytes >= sizeof(UV)) { /* promote to string */
1378 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1379 while (s < strend) {
1380 sv = mul128(sv, (U8)(*s & 0x7f));
1381 if (!(*s++ & 0x80)) {
1390 PUSHs(sv_2mortal(sv));
1395 if ((s >= strend) && bytes)
1396 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1400 if (symptr->howlen == e_star)
1401 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1403 if (sizeof(char*) > strend - s)
1406 Copy(s, &aptr, 1, char*);
1411 sv_setpvn(sv, aptr, len);
1412 PUSHs(sv_2mortal(sv));
1416 along = (strend - s) / sizeof(Quad_t);
1421 Copy(s, &aquad, 1, Quad_t);
1422 s += sizeof(Quad_t);
1423 if (checksum > bits_in_uv)
1424 cdouble += (NV)aquad;
1430 if (len && unpack_only_one)
1435 if (s + sizeof(Quad_t) > strend)
1438 Copy(s, &aquad, 1, Quad_t);
1439 s += sizeof(Quad_t);
1442 if (aquad >= IV_MIN && aquad <= IV_MAX)
1443 sv_setiv(sv, (IV)aquad);
1445 sv_setnv(sv, (NV)aquad);
1446 PUSHs(sv_2mortal(sv));
1451 along = (strend - s) / sizeof(Uquad_t);
1456 Copy(s, &auquad, 1, Uquad_t);
1457 s += sizeof(Uquad_t);
1458 if (checksum > bits_in_uv)
1459 cdouble += (NV)auquad;
1465 if (len && unpack_only_one)
1470 if (s + sizeof(Uquad_t) > strend)
1473 Copy(s, &auquad, 1, Uquad_t);
1474 s += sizeof(Uquad_t);
1477 if (auquad <= UV_MAX)
1478 sv_setuv(sv, (UV)auquad);
1480 sv_setnv(sv, (NV)auquad);
1481 PUSHs(sv_2mortal(sv));
1486 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1488 along = (strend - s) / sizeof(float);
1493 Copy(s, &afloat, 1, float);
1499 if (len && unpack_only_one)
1504 Copy(s, &afloat, 1, float);
1507 sv_setnv(sv, (NV)afloat);
1508 PUSHs(sv_2mortal(sv));
1513 along = (strend - s) / sizeof(double);
1518 Copy(s, &adouble, 1, double);
1519 s += sizeof(double);
1524 if (len && unpack_only_one)
1529 Copy(s, &adouble, 1, double);
1530 s += sizeof(double);
1532 sv_setnv(sv, (NV)adouble);
1533 PUSHs(sv_2mortal(sv));
1538 along = (strend - s) / NVSIZE;
1543 Copy(s, &anv, 1, NV);
1549 if (len && unpack_only_one)
1554 Copy(s, &anv, 1, NV);
1558 PUSHs(sv_2mortal(sv));
1562 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1564 along = (strend - s) / LONG_DOUBLESIZE;
1569 Copy(s, &aldouble, 1, long double);
1570 s += LONG_DOUBLESIZE;
1571 cdouble += aldouble;
1575 if (len && unpack_only_one)
1580 Copy(s, &aldouble, 1, long double);
1581 s += LONG_DOUBLESIZE;
1583 sv_setnv(sv, (NV)aldouble);
1584 PUSHs(sv_2mortal(sv));
1591 * Initialise the decode mapping. By using a table driven
1592 * algorithm, the code will be character-set independent
1593 * (and just as fast as doing character arithmetic)
1595 if (PL_uudmap['M'] == 0) {
1598 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1599 PL_uudmap[(U8)PL_uuemap[i]] = i;
1601 * Because ' ' and '`' map to the same value,
1602 * we need to decode them both the same.
1607 along = (strend - s) * 3 / 4;
1608 sv = NEWSV(42, along);
1611 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1616 len = PL_uudmap[*(U8*)s++] & 077;
1618 if (s < strend && ISUUCHAR(*s))
1619 a = PL_uudmap[*(U8*)s++] & 077;
1622 if (s < strend && ISUUCHAR(*s))
1623 b = PL_uudmap[*(U8*)s++] & 077;
1626 if (s < strend && ISUUCHAR(*s))
1627 c = PL_uudmap[*(U8*)s++] & 077;
1630 if (s < strend && ISUUCHAR(*s))
1631 d = PL_uudmap[*(U8*)s++] & 077;
1634 hunk[0] = (char)((a << 2) | (b >> 4));
1635 hunk[1] = (char)((b << 4) | (c >> 2));
1636 hunk[2] = (char)((c << 6) | d);
1637 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1642 else /* possible checksum byte */
1643 if (s + 1 < strend && s[1] == '\n')
1646 XPUSHs(sv_2mortal(sv));
1652 if (strchr("fFdD", datumtype) ||
1653 (checksum > bits_in_uv &&
1654 strchr("csSiIlLnNUvVqQjJ", datumtype&0xFF)) ) {
1657 adouble = (NV) (1 << (checksum & 15));
1658 while (checksum >= 16) {
1662 while (cdouble < 0.0)
1664 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1665 sv_setnv(sv, cdouble);
1668 if (checksum < bits_in_uv) {
1669 UV mask = ((UV)1 << checksum) - 1;
1674 XPUSHs(sv_2mortal(sv));
1678 if (symptr->flags & FLAG_SLASH){
1679 if (SP - PL_stack_base - start_sp_offset <= 0)
1680 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1681 if( next_symbol(symptr) ){
1682 if( symptr->howlen == e_number )
1683 Perl_croak(aTHX_ "Count after length/code in unpack" );
1685 /* ...end of char buffer then no decent length available */
1686 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1688 /* take top of stack (hope it's numeric) */
1691 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1694 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1696 datumtype = symptr->code;
1704 return SP - PL_stack_base - start_sp_offset;
1711 I32 gimme = GIMME_V;
1714 register char *pat = SvPV(left, llen);
1715 #ifdef PACKED_IS_OCTETS
1716 /* Packed side is assumed to be octets - so force downgrade if it
1717 has been UTF-8 encoded by accident
1719 register char *s = SvPVbyte(right, rlen);
1721 register char *s = SvPV(right, rlen);
1723 char *strend = s + rlen;
1724 register char *patend = pat + llen;
1728 cnt = unpackstring(pat, patend, s, strend,
1729 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1730 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1733 if ( !cnt && gimme == G_SCALAR )
1734 PUSHs(&PL_sv_undef);
1739 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1743 *hunk = PL_uuemap[len];
1744 sv_catpvn(sv, hunk, 1);
1747 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1748 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1749 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1750 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1751 sv_catpvn(sv, hunk, 4);
1756 char r = (len > 1 ? s[1] : '\0');
1757 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1758 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1759 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1760 hunk[3] = PL_uuemap[0];
1761 sv_catpvn(sv, hunk, 4);
1763 sv_catpvn(sv, "\n", 1);
1767 S_is_an_int(pTHX_ char *s, STRLEN l)
1770 SV *result = newSVpvn(s, l);
1771 char *result_c = SvPV(result, n_a); /* convenience */
1772 char *out = result_c;
1782 SvREFCNT_dec(result);
1805 SvREFCNT_dec(result);
1811 SvCUR_set(result, out - result_c);
1815 /* pnum must be '\0' terminated */
1817 S_div128(pTHX_ SV *pnum, bool *done)
1820 char *s = SvPV(pnum, len);
1829 i = m * 10 + (*t - '0');
1831 r = (i >> 7); /* r < 10 */
1838 SvCUR_set(pnum, (STRLEN) (t - s));
1845 =for apidoc pack_cat
1847 The engine implementing pack() Perl function. Note: parameters next_in_list and
1848 flags are not used. This call should not be used; use packlist instead.
1854 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1856 tempsym_t sym = { 0 };
1858 sym.patend = patend;
1859 sym.flags = FLAG_PACK;
1861 (void)pack_rec( cat, &sym, beglist, endlist );
1866 =for apidoc packlist
1868 The engine implementing pack() Perl function.
1874 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1876 tempsym_t sym = { 0 };
1878 sym.patend = patend;
1879 sym.flags = FLAG_PACK;
1881 (void)pack_rec( cat, &sym, beglist, endlist );
1887 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1891 register I32 len = 0;
1894 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1895 static char *space10 = " ";
1898 /* These must not be in registers: */
1908 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1909 long double aldouble;
1918 int strrelbeg = SvCUR(cat);
1919 tempsym_t lookahead;
1921 items = endlist - beglist;
1922 found = next_symbol( symptr );
1924 #ifndef PACKED_IS_OCTETS
1925 if (symptr->level == 0 && found && symptr->code == 'U' ){
1931 SV *lengthcode = Nullsv;
1932 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1934 I32 datumtype = symptr->code;
1937 switch( howlen = symptr->howlen ){
1940 len = symptr->length;
1943 len = strchr("@Xxu", datumtype) ? 0 : items;
1947 /* Look ahead for next symbol. Do we have code/code? */
1948 lookahead = *symptr;
1949 found = next_symbol(&lookahead);
1950 if ( symptr->flags & FLAG_SLASH ) {
1952 if ( 0 == strchr( "aAZ", lookahead.code ) ||
1953 e_star != lookahead.howlen )
1954 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
1955 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1956 ? *beglist : &PL_sv_no)
1957 + (lookahead.code == 'Z' ? 1 : 0)));
1959 Perl_croak(aTHX_ "Code missing after '/' in pack");
1965 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)datumtype);
1967 Perl_croak(aTHX_ "'%%' may not be used in pack");
1969 len += strrelbeg - SvCUR(cat);
1978 tempsym_t savsym = *symptr;
1979 symptr->patend = savsym.grpend;
1982 symptr->patptr = savsym.grpbeg;
1983 beglist = pack_rec(cat, symptr, beglist, endlist );
1984 if (savsym.howlen == e_star && beglist == endlist)
1985 break; /* No way to continue */
1987 lookahead.flags = symptr->flags;
1991 case 'X' | TYPE_IS_SHRIEKING:
1992 if (!len) /* Avoid division by 0 */
1994 len = (SvCUR(cat)) % len;
1998 if ((I32)SvCUR(cat) < len)
1999 Perl_croak(aTHX_ "'X' outside of string in pack");
2003 case 'x' | TYPE_IS_SHRIEKING:
2004 if (!len) /* Avoid division by 0 */
2006 aint = (SvCUR(cat)) % len;
2007 if (aint) /* Other portable ways? */
2016 sv_catpvn(cat, null10, 10);
2019 sv_catpvn(cat, null10, len);
2025 aptr = SvPV(fromstr, fromlen);
2026 if (howlen == e_star) {
2028 if (datumtype == 'Z')
2031 if ((I32)fromlen >= len) {
2032 sv_catpvn(cat, aptr, len);
2033 if (datumtype == 'Z')
2034 *(SvEND(cat)-1) = '\0';
2037 sv_catpvn(cat, aptr, fromlen);
2039 if (datumtype == 'A') {
2041 sv_catpvn(cat, space10, 10);
2044 sv_catpvn(cat, space10, len);
2048 sv_catpvn(cat, null10, 10);
2051 sv_catpvn(cat, null10, len);
2063 str = SvPV(fromstr, fromlen);
2064 if (howlen == e_star)
2067 SvCUR(cat) += (len+7)/8;
2068 SvGROW(cat, SvCUR(cat) + 1);
2069 aptr = SvPVX(cat) + aint;
2070 if (len > (I32)fromlen)
2074 if (datumtype == 'B') {
2075 for (len = 0; len++ < aint;) {
2076 items |= *str++ & 1;
2080 *aptr++ = items & 0xff;
2086 for (len = 0; len++ < aint;) {
2092 *aptr++ = items & 0xff;
2098 if (datumtype == 'B')
2099 items <<= 7 - (aint & 7);
2101 items >>= 7 - (aint & 7);
2102 *aptr++ = items & 0xff;
2104 str = SvPVX(cat) + SvCUR(cat);
2119 str = SvPV(fromstr, fromlen);
2120 if (howlen == e_star)
2123 SvCUR(cat) += (len+1)/2;
2124 SvGROW(cat, SvCUR(cat) + 1);
2125 aptr = SvPVX(cat) + aint;
2126 if (len > (I32)fromlen)
2130 if (datumtype == 'H') {
2131 for (len = 0; len++ < aint;) {
2133 items |= ((*str++ & 15) + 9) & 15;
2135 items |= *str++ & 15;
2139 *aptr++ = items & 0xff;
2145 for (len = 0; len++ < aint;) {
2147 items |= (((*str++ & 15) + 9) & 15) << 4;
2149 items |= (*str++ & 15) << 4;
2153 *aptr++ = items & 0xff;
2159 *aptr++ = items & 0xff;
2160 str = SvPVX(cat) + SvCUR(cat);
2171 switch (datumtype) {
2173 aint = SvIV(fromstr);
2174 if ((aint < 0 || aint > 255) &&
2176 Perl_warner(aTHX_ packWARN(WARN_PACK),
2177 "Character in 'C' format wrapped in pack");
2179 sv_catpvn(cat, &achar, sizeof(char));
2182 aint = SvIV(fromstr);
2183 if ((aint < -128 || aint > 127) &&
2185 Perl_warner(aTHX_ packWARN(WARN_PACK),
2186 "Character in 'c' format wrapped in pack" );
2188 sv_catpvn(cat, &achar, sizeof(char));
2196 auint = UNI_TO_NATIVE(SvUV(fromstr));
2197 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2199 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2202 0 : UNICODE_ALLOW_ANY)
2207 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2212 /* VOS does not automatically map a floating-point overflow
2213 during conversion from double to float into infinity, so we
2214 do it by hand. This code should either be generalized for
2215 any OS that needs it, or removed if and when VOS implements
2216 posix-976 (suggestion to support mapping to infinity).
2217 Paul.Green@stratus.com 02-04-02. */
2218 if (SvNV(fromstr) > FLT_MAX)
2219 afloat = _float_constants[0]; /* single prec. inf. */
2220 else if (SvNV(fromstr) < -FLT_MAX)
2221 afloat = _float_constants[0]; /* single prec. inf. */
2222 else afloat = (float)SvNV(fromstr);
2224 # if defined(VMS) && !defined(__IEEE_FP)
2225 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2226 * on Alpha; fake it if we don't have them.
2228 if (SvNV(fromstr) > FLT_MAX)
2230 else if (SvNV(fromstr) < -FLT_MAX)
2232 else afloat = (float)SvNV(fromstr);
2234 afloat = (float)SvNV(fromstr);
2237 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2244 /* VOS does not automatically map a floating-point overflow
2245 during conversion from long double to double into infinity,
2246 so we do it by hand. This code should either be generalized
2247 for any OS that needs it, or removed if and when VOS
2248 implements posix-976 (suggestion to support mapping to
2249 infinity). Paul.Green@stratus.com 02-04-02. */
2250 if (SvNV(fromstr) > DBL_MAX)
2251 adouble = _double_constants[0]; /* double prec. inf. */
2252 else if (SvNV(fromstr) < -DBL_MAX)
2253 adouble = _double_constants[0]; /* double prec. inf. */
2254 else adouble = (double)SvNV(fromstr);
2256 # if defined(VMS) && !defined(__IEEE_FP)
2257 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2258 * on Alpha; fake it if we don't have them.
2260 if (SvNV(fromstr) > DBL_MAX)
2262 else if (SvNV(fromstr) < -DBL_MAX)
2264 else adouble = (double)SvNV(fromstr);
2266 adouble = (double)SvNV(fromstr);
2269 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2275 anv = SvNV(fromstr);
2276 sv_catpvn(cat, (char *)&anv, NVSIZE);
2279 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2283 aldouble = (long double)SvNV(fromstr);
2284 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2291 ashort = (I16)SvIV(fromstr);
2293 ashort = PerlSock_htons(ashort);
2295 CAT16(cat, &ashort);
2301 ashort = (I16)SvIV(fromstr);
2303 ashort = htovs(ashort);
2305 CAT16(cat, &ashort);
2308 case 'S' | TYPE_IS_SHRIEKING:
2309 #if SHORTSIZE != SIZE16
2311 unsigned short aushort;
2315 aushort = SvUV(fromstr);
2316 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2329 aushort = (U16)SvUV(fromstr);
2330 CAT16(cat, &aushort);
2335 case 's' | TYPE_IS_SHRIEKING:
2336 #if SHORTSIZE != SIZE16
2342 ashort = SvIV(fromstr);
2343 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2353 ashort = (I16)SvIV(fromstr);
2354 CAT16(cat, &ashort);
2358 case 'I' | TYPE_IS_SHRIEKING:
2361 auint = SvUV(fromstr);
2362 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2368 aiv = SvIV(fromstr);
2369 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2375 auv = SvUV(fromstr);
2376 sv_catpvn(cat, (char*)&auv, UVSIZE);
2382 anv = SvNV(fromstr);
2385 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2387 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2388 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2389 any negative IVs will have already been got by the croak()
2390 above. IOK is untrue for fractions, so we test them
2391 against UV_MAX_P1. */
2392 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2394 char buf[(sizeof(UV)*8)/7+1];
2395 char *in = buf + sizeof(buf);
2396 UV auv = SvUV(fromstr);
2399 *--in = (char)((auv & 0x7f) | 0x80);
2402 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2403 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2405 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2406 char *from, *result, *in;
2411 /* Copy string and check for compliance */
2412 from = SvPV(fromstr, len);
2413 if ((norm = is_an_int(from, len)) == NULL)
2414 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2416 New('w', result, len, char);
2420 *--in = div128(norm, &done) | 0x80;
2421 result[len - 1] &= 0x7F; /* clear continue bit */
2422 sv_catpvn(cat, in, (result + len) - in);
2424 SvREFCNT_dec(norm); /* free norm */
2426 else if (SvNOKp(fromstr)) {
2427 /* 10**NV_MAX_10_EXP is the largest power of 10
2428 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2429 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2430 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2431 And with that many bytes only Inf can overflow.
2432 Some C compilers are strict about integral constant
2433 expressions so we conservatively divide by a slightly
2434 smaller integer instead of multiplying by the exact
2435 floating-point value.
2437 #ifdef NV_MAX_10_EXP
2438 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2439 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2441 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2442 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2444 char *in = buf + sizeof(buf);
2446 anv = Perl_floor(anv);
2448 NV next = Perl_floor(anv / 128);
2449 if (in <= buf) /* this cannot happen ;-) */
2450 Perl_croak(aTHX_ "Cannot compress integer in pack");
2451 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2454 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2455 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2458 char *from, *result, *in;
2463 /* Copy string and check for compliance */
2464 from = SvPV(fromstr, len);
2465 if ((norm = is_an_int(from, len)) == NULL)
2466 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2468 New('w', result, len, char);
2472 *--in = div128(norm, &done) | 0x80;
2473 result[len - 1] &= 0x7F; /* clear continue bit */
2474 sv_catpvn(cat, in, (result + len) - in);
2476 SvREFCNT_dec(norm); /* free norm */
2481 case 'i' | TYPE_IS_SHRIEKING:
2484 aint = SvIV(fromstr);
2485 sv_catpvn(cat, (char*)&aint, sizeof(int));
2491 aulong = SvUV(fromstr);
2493 aulong = PerlSock_htonl(aulong);
2495 CAT32(cat, &aulong);
2501 aulong = SvUV(fromstr);
2503 aulong = htovl(aulong);
2505 CAT32(cat, &aulong);
2508 case 'L' | TYPE_IS_SHRIEKING:
2509 #if LONGSIZE != SIZE32
2511 unsigned long aulong;
2515 aulong = SvUV(fromstr);
2516 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2527 aulong = SvUV(fromstr);
2528 CAT32(cat, &aulong);
2532 case 'l' | TYPE_IS_SHRIEKING:
2533 #if LONGSIZE != SIZE32
2539 along = SvIV(fromstr);
2540 sv_catpvn(cat, (char *)&along, sizeof(long));
2550 along = SvIV(fromstr);
2558 auquad = (Uquad_t)SvUV(fromstr);
2559 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2565 aquad = (Quad_t)SvIV(fromstr);
2566 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2571 len = 1; /* assume SV is correct length */
2576 if (fromstr == &PL_sv_undef)
2580 /* XXX better yet, could spirit away the string to
2581 * a safe spot and hang on to it until the result
2582 * of pack() (and all copies of the result) are
2585 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2586 || (SvPADTMP(fromstr)
2587 && !SvREADONLY(fromstr))))
2589 Perl_warner(aTHX_ packWARN(WARN_PACK),
2590 "Attempt to pack pointer to temporary value");
2592 if (SvPOK(fromstr) || SvNIOK(fromstr))
2593 aptr = SvPV(fromstr,n_a);
2595 aptr = SvPV_force(fromstr,n_a);
2597 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2602 aptr = SvPV(fromstr, fromlen);
2603 SvGROW(cat, fromlen * 4 / 3);
2608 while (fromlen > 0) {
2611 if ((I32)fromlen > len)
2615 doencodes(cat, aptr, todo);
2621 *symptr = lookahead;
2630 dSP; dMARK; dORIGMARK; dTARGET;
2631 register SV *cat = TARG;
2633 register char *pat = SvPVx(*++MARK, fromlen);
2634 register char *patend = pat + fromlen;
2637 sv_setpvn(cat, "", 0);
2639 packlist(cat, pat, patend, MARK, SP + 1);