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 pack/unpack",
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.
502 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
504 tempsym_t sym = { 0 };
509 return unpack_rec(&sym, s, s, strend, NULL );
514 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
518 register I32 len = 0;
519 register I32 bits = 0;
522 I32 start_sp_offset = SP - PL_stack_base;
525 /* These must not be in registers: */
544 const int bits_in_uv = 8 * sizeof(cuv);
547 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
552 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
553 long double aldouble;
556 while (next_symbol(symptr)) {
557 datumtype = symptr->code;
558 /* do first one only unless in list context
559 / is implemented by unpacking the count, then poping it from the
560 stack, so must check that we're not in the middle of a / */
562 && (SP - PL_stack_base == start_sp_offset + 1)
563 && (datumtype != '/') ) /* XXX can this be omitted */
566 switch( howlen = symptr->howlen ){
569 len = symptr->length;
572 len = strend - strbeg; /* long enough */
577 beyond = s >= strend;
580 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)datumtype );
583 if (howlen == e_no_len)
584 len = 16; /* len is not specified */
592 char *ss = s; /* Move from register */
593 tempsym_t savsym = *symptr;
594 symptr->patend = savsym.grpend;
598 symptr->patptr = savsym.grpbeg;
599 unpack_rec(symptr, ss, strbeg, strend, &ss );
600 if (ss == strend && savsym.howlen == e_star)
601 break; /* No way to continue */
605 savsym.flags = symptr->flags;
610 if (len > strend - strrelbeg)
611 Perl_croak(aTHX_ "'@' outside of string in unpack");
614 case 'X' | TYPE_IS_SHRIEKING:
615 if (!len) /* Avoid division by 0 */
617 len = (s - strbeg) % len;
620 if (len > s - strbeg)
621 Perl_croak(aTHX_ "'X' outside of string in unpack" );
624 case 'x' | TYPE_IS_SHRIEKING:
625 if (!len) /* Avoid division by 0 */
627 aint = (s - strbeg) % len;
628 if (aint) /* Other portable ways? */
634 if (len > strend - s)
635 Perl_croak(aTHX_ "'x' outside of string in unpack");
639 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
644 if (len > strend - s)
649 sv_setpvn(sv, s, len);
650 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
651 aptr = s; /* borrow register */
652 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
656 if (howlen == e_star) /* exact for 'Z*' */
657 len = s - SvPVX(sv) + 1;
659 else { /* 'A' strips both nulls and spaces */
660 s = SvPVX(sv) + len - 1;
661 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
665 SvCUR_set(sv, s - SvPVX(sv));
666 s = aptr; /* unborrow register */
669 XPUSHs(sv_2mortal(sv));
673 if (howlen == e_star || len > (strend - s) * 8)
674 len = (strend - s) * 8;
677 Newz(601, PL_bitcount, 256, char);
678 for (bits = 1; bits < 256; bits++) {
679 if (bits & 1) PL_bitcount[bits]++;
680 if (bits & 2) PL_bitcount[bits]++;
681 if (bits & 4) PL_bitcount[bits]++;
682 if (bits & 8) PL_bitcount[bits]++;
683 if (bits & 16) PL_bitcount[bits]++;
684 if (bits & 32) PL_bitcount[bits]++;
685 if (bits & 64) PL_bitcount[bits]++;
686 if (bits & 128) PL_bitcount[bits]++;
690 cuv += PL_bitcount[*(unsigned char*)s++];
695 if (datumtype == 'b') {
703 if (bits & 128) cuv++;
710 sv = NEWSV(35, len + 1);
714 if (datumtype == 'b') {
716 for (len = 0; len < aint; len++) {
717 if (len & 7) /*SUPPRESS 595*/
721 *str++ = '0' + (bits & 1);
726 for (len = 0; len < aint; len++) {
731 *str++ = '0' + ((bits & 128) != 0);
735 XPUSHs(sv_2mortal(sv));
739 if (howlen == e_star || len > (strend - s) * 2)
740 len = (strend - s) * 2;
741 sv = NEWSV(35, len + 1);
745 if (datumtype == 'h') {
747 for (len = 0; len < aint; len++) {
752 *str++ = PL_hexdigit[bits & 15];
757 for (len = 0; len < aint; len++) {
762 *str++ = PL_hexdigit[(bits >> 4) & 15];
766 XPUSHs(sv_2mortal(sv));
769 if (len > strend - s)
774 if (aint >= 128) /* fake up signed chars */
776 if (checksum > bits_in_uv)
783 if (len && unpack_only_one)
789 if (aint >= 128) /* fake up signed chars */
792 sv_setiv(sv, (IV)aint);
793 PUSHs(sv_2mortal(sv));
798 unpack_C: /* unpack U will jump here if not UTF-8 */
800 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
803 if (len > strend - s)
813 if (len && unpack_only_one)
820 sv_setiv(sv, (IV)auint);
821 PUSHs(sv_2mortal(sv));
827 symptr->flags |= FLAG_UNPACK_DO_UTF8;
830 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
832 if (len > strend - s)
835 while (len-- > 0 && s < strend) {
837 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
840 if (checksum > bits_in_uv)
841 cdouble += (NV)auint;
847 if (len && unpack_only_one)
851 while (len-- > 0 && s < strend) {
853 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
857 sv_setuv(sv, (UV)auint);
858 PUSHs(sv_2mortal(sv));
862 case 's' | TYPE_IS_SHRIEKING:
863 #if SHORTSIZE != SIZE16
864 along = (strend - s) / sizeof(short);
870 COPYNN(s, &ashort, sizeof(short));
872 if (checksum > bits_in_uv)
873 cdouble += (NV)ashort;
880 if (len && unpack_only_one)
886 COPYNN(s, &ashort, sizeof(short));
889 sv_setiv(sv, (IV)ashort);
890 PUSHs(sv_2mortal(sv));
898 along = (strend - s) / SIZE16;
904 #if SHORTSIZE > SIZE16
909 if (checksum > bits_in_uv)
910 cdouble += (NV)ashort;
916 if (len && unpack_only_one)
923 #if SHORTSIZE > SIZE16
929 sv_setiv(sv, (IV)ashort);
930 PUSHs(sv_2mortal(sv));
934 case 'S' | TYPE_IS_SHRIEKING:
935 #if SHORTSIZE != SIZE16
936 along = (strend - s) / SIZE16;
940 unsigned short aushort;
942 COPYNN(s, &aushort, sizeof(unsigned short));
943 s += sizeof(unsigned short);
944 if (checksum > bits_in_uv)
945 cdouble += (NV)aushort;
951 if (len && unpack_only_one)
956 unsigned short aushort;
957 COPYNN(s, &aushort, sizeof(unsigned short));
958 s += sizeof(unsigned short);
960 sv_setiv(sv, (UV)aushort);
961 PUSHs(sv_2mortal(sv));
971 along = (strend - s) / SIZE16;
979 if (datumtype == 'n')
980 aushort = PerlSock_ntohs(aushort);
983 if (datumtype == 'v')
984 aushort = vtohs(aushort);
986 if (checksum > bits_in_uv)
987 cdouble += (NV)aushort;
993 if (len && unpack_only_one)
1002 if (datumtype == 'n')
1003 aushort = PerlSock_ntohs(aushort);
1006 if (datumtype == 'v')
1007 aushort = vtohs(aushort);
1009 sv_setiv(sv, (UV)aushort);
1010 PUSHs(sv_2mortal(sv));
1015 case 'i' | TYPE_IS_SHRIEKING:
1016 along = (strend - s) / sizeof(int);
1021 Copy(s, &aint, 1, int);
1023 if (checksum > bits_in_uv)
1024 cdouble += (NV)aint;
1030 if (len && unpack_only_one)
1035 Copy(s, &aint, 1, int);
1039 /* Without the dummy below unpack("i", pack("i",-1))
1040 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
1041 * cc with optimization turned on.
1043 * The bug was detected in
1044 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
1045 * with optimization (-O4) turned on.
1046 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
1047 * does not have this problem even with -O4.
1049 * This bug was reported as DECC_BUGS 1431
1050 * and tracked internally as GEM_BUGS 7775.
1052 * The bug is fixed in
1053 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
1054 * UNIX V4.0F support: DEC C V5.9-006 or later
1055 * UNIX V4.0E support: DEC C V5.8-011 or later
1058 * See also few lines later for the same bug.
1061 sv_setiv(sv, (IV)aint) :
1063 sv_setiv(sv, (IV)aint);
1064 PUSHs(sv_2mortal(sv));
1069 case 'I' | TYPE_IS_SHRIEKING:
1070 along = (strend - s) / sizeof(unsigned int);
1075 Copy(s, &auint, 1, unsigned int);
1076 s += sizeof(unsigned int);
1077 if (checksum > bits_in_uv)
1078 cdouble += (NV)auint;
1084 if (len && unpack_only_one)
1089 Copy(s, &auint, 1, unsigned int);
1090 s += sizeof(unsigned int);
1093 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1094 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1095 * See details few lines earlier. */
1097 sv_setuv(sv, (UV)auint) :
1099 sv_setuv(sv, (UV)auint);
1100 PUSHs(sv_2mortal(sv));
1105 along = (strend - s) / IVSIZE;
1110 Copy(s, &aiv, 1, IV);
1112 if (checksum > bits_in_uv)
1119 if (len && unpack_only_one)
1124 Copy(s, &aiv, 1, IV);
1128 PUSHs(sv_2mortal(sv));
1133 along = (strend - s) / UVSIZE;
1138 Copy(s, &auv, 1, UV);
1140 if (checksum > bits_in_uv)
1147 if (len && unpack_only_one)
1152 Copy(s, &auv, 1, UV);
1156 PUSHs(sv_2mortal(sv));
1160 case 'l' | TYPE_IS_SHRIEKING:
1161 #if LONGSIZE != SIZE32
1162 along = (strend - s) / sizeof(long);
1167 COPYNN(s, &along, sizeof(long));
1169 if (checksum > bits_in_uv)
1170 cdouble += (NV)along;
1176 if (len && unpack_only_one)
1181 COPYNN(s, &along, sizeof(long));
1184 sv_setiv(sv, (IV)along);
1185 PUSHs(sv_2mortal(sv));
1193 along = (strend - s) / SIZE32;
1198 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1202 #if LONGSIZE > SIZE32
1203 if (along > 2147483647)
1204 along -= 4294967296;
1207 if (checksum > bits_in_uv)
1208 cdouble += (NV)along;
1214 if (len && unpack_only_one)
1219 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1223 #if LONGSIZE > SIZE32
1224 if (along > 2147483647)
1225 along -= 4294967296;
1229 sv_setiv(sv, (IV)along);
1230 PUSHs(sv_2mortal(sv));
1234 case 'L' | TYPE_IS_SHRIEKING:
1235 #if LONGSIZE != SIZE32
1236 along = (strend - s) / sizeof(unsigned long);
1241 unsigned long aulong;
1242 COPYNN(s, &aulong, sizeof(unsigned long));
1243 s += sizeof(unsigned long);
1244 if (checksum > bits_in_uv)
1245 cdouble += (NV)aulong;
1251 if (len && unpack_only_one)
1256 unsigned long aulong;
1257 COPYNN(s, &aulong, sizeof(unsigned long));
1258 s += sizeof(unsigned long);
1260 sv_setuv(sv, (UV)aulong);
1261 PUSHs(sv_2mortal(sv));
1271 along = (strend - s) / SIZE32;
1279 if (datumtype == 'N')
1280 aulong = PerlSock_ntohl(aulong);
1283 if (datumtype == 'V')
1284 aulong = vtohl(aulong);
1286 if (checksum > bits_in_uv)
1287 cdouble += (NV)aulong;
1293 if (len && unpack_only_one)
1301 if (datumtype == 'N')
1302 aulong = PerlSock_ntohl(aulong);
1305 if (datumtype == 'V')
1306 aulong = vtohl(aulong);
1309 sv_setuv(sv, (UV)aulong);
1310 PUSHs(sv_2mortal(sv));
1315 along = (strend - s) / sizeof(char*);
1321 if (sizeof(char*) > strend - s)
1324 Copy(s, &aptr, 1, char*);
1330 PUSHs(sv_2mortal(sv));
1334 if (len && unpack_only_one)
1342 while ((len > 0) && (s < strend)) {
1343 auv = (auv << 7) | (*s & 0x7f);
1344 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1345 if ((U8)(*s++) < 0x80) {
1349 PUSHs(sv_2mortal(sv));
1353 else if (++bytes >= sizeof(UV)) { /* promote to string */
1357 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1358 while (s < strend) {
1359 sv = mul128(sv, (U8)(*s & 0x7f));
1360 if (!(*s++ & 0x80)) {
1369 PUSHs(sv_2mortal(sv));
1374 if ((s >= strend) && bytes)
1375 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1379 if (symptr->howlen == e_star)
1380 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1382 if (sizeof(char*) > strend - s)
1385 Copy(s, &aptr, 1, char*);
1390 sv_setpvn(sv, aptr, len);
1391 PUSHs(sv_2mortal(sv));
1395 along = (strend - s) / sizeof(Quad_t);
1400 Copy(s, &aquad, 1, Quad_t);
1401 s += sizeof(Quad_t);
1402 if (checksum > bits_in_uv)
1403 cdouble += (NV)aquad;
1409 if (len && unpack_only_one)
1414 if (s + sizeof(Quad_t) > strend)
1417 Copy(s, &aquad, 1, Quad_t);
1418 s += sizeof(Quad_t);
1421 if (aquad >= IV_MIN && aquad <= IV_MAX)
1422 sv_setiv(sv, (IV)aquad);
1424 sv_setnv(sv, (NV)aquad);
1425 PUSHs(sv_2mortal(sv));
1430 along = (strend - s) / sizeof(Uquad_t);
1435 Copy(s, &auquad, 1, Uquad_t);
1436 s += sizeof(Uquad_t);
1437 if (checksum > bits_in_uv)
1438 cdouble += (NV)auquad;
1444 if (len && unpack_only_one)
1449 if (s + sizeof(Uquad_t) > strend)
1452 Copy(s, &auquad, 1, Uquad_t);
1453 s += sizeof(Uquad_t);
1456 if (auquad <= UV_MAX)
1457 sv_setuv(sv, (UV)auquad);
1459 sv_setnv(sv, (NV)auquad);
1460 PUSHs(sv_2mortal(sv));
1465 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1467 along = (strend - s) / sizeof(float);
1472 Copy(s, &afloat, 1, float);
1478 if (len && unpack_only_one)
1483 Copy(s, &afloat, 1, float);
1486 sv_setnv(sv, (NV)afloat);
1487 PUSHs(sv_2mortal(sv));
1492 along = (strend - s) / sizeof(double);
1497 Copy(s, &adouble, 1, double);
1498 s += sizeof(double);
1503 if (len && unpack_only_one)
1508 Copy(s, &adouble, 1, double);
1509 s += sizeof(double);
1511 sv_setnv(sv, (NV)adouble);
1512 PUSHs(sv_2mortal(sv));
1517 along = (strend - s) / NVSIZE;
1522 Copy(s, &anv, 1, NV);
1528 if (len && unpack_only_one)
1533 Copy(s, &anv, 1, NV);
1537 PUSHs(sv_2mortal(sv));
1541 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1543 along = (strend - s) / LONG_DOUBLESIZE;
1548 Copy(s, &aldouble, 1, long double);
1549 s += LONG_DOUBLESIZE;
1550 cdouble += aldouble;
1554 if (len && unpack_only_one)
1559 Copy(s, &aldouble, 1, long double);
1560 s += LONG_DOUBLESIZE;
1562 sv_setnv(sv, (NV)aldouble);
1563 PUSHs(sv_2mortal(sv));
1570 * Initialise the decode mapping. By using a table driven
1571 * algorithm, the code will be character-set independent
1572 * (and just as fast as doing character arithmetic)
1574 if (PL_uudmap['M'] == 0) {
1577 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1578 PL_uudmap[(U8)PL_uuemap[i]] = i;
1580 * Because ' ' and '`' map to the same value,
1581 * we need to decode them both the same.
1586 along = (strend - s) * 3 / 4;
1587 sv = NEWSV(42, along);
1590 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1595 len = PL_uudmap[*(U8*)s++] & 077;
1597 if (s < strend && ISUUCHAR(*s))
1598 a = PL_uudmap[*(U8*)s++] & 077;
1601 if (s < strend && ISUUCHAR(*s))
1602 b = PL_uudmap[*(U8*)s++] & 077;
1605 if (s < strend && ISUUCHAR(*s))
1606 c = PL_uudmap[*(U8*)s++] & 077;
1609 if (s < strend && ISUUCHAR(*s))
1610 d = PL_uudmap[*(U8*)s++] & 077;
1613 hunk[0] = (char)((a << 2) | (b >> 4));
1614 hunk[1] = (char)((b << 4) | (c >> 2));
1615 hunk[2] = (char)((c << 6) | d);
1616 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1621 else /* possible checksum byte */
1622 if (s + 1 < strend && s[1] == '\n')
1625 XPUSHs(sv_2mortal(sv));
1631 if (strchr("fFdD", datumtype) ||
1632 (checksum > bits_in_uv &&
1633 strchr("csSiIlLnNUvVqQjJ", datumtype&0xFF)) ) {
1636 adouble = (NV) (1 << (checksum & 15));
1637 while (checksum >= 16) {
1641 while (cdouble < 0.0)
1643 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1644 sv_setnv(sv, cdouble);
1647 if (checksum < bits_in_uv) {
1648 UV mask = ((UV)1 << checksum) - 1;
1653 XPUSHs(sv_2mortal(sv));
1657 if (symptr->flags & FLAG_SLASH){
1658 if (SP - PL_stack_base - start_sp_offset <= 0)
1659 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1660 if( next_symbol(symptr) ){
1661 if( symptr->howlen == e_number )
1662 Perl_croak(aTHX_ "Count after length/code in unpack" );
1664 /* ...end of char buffer then no decent length available */
1665 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1667 /* take top of stack (hope it's numeric) */
1670 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1673 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1675 datumtype = symptr->code;
1683 return SP - PL_stack_base - start_sp_offset;
1689 SV *right = (MAXARG > 1) ? POPs : GvSV(PL_defgv);
1691 I32 gimme = GIMME_V;
1694 register char *pat = SvPV(left, llen);
1695 #ifdef PACKED_IS_OCTETS
1696 /* Packed side is assumed to be octets - so force downgrade if it
1697 has been UTF-8 encoded by accident
1699 register char *s = SvPVbyte(right, rlen);
1701 register char *s = SvPV(right, rlen);
1703 char *strend = s + rlen;
1704 register char *patend = pat + llen;
1708 cnt = unpack_str(pat, patend, s, s, strend, NULL, 0,
1709 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1710 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1713 if ( !cnt && gimme == G_SCALAR )
1714 PUSHs(&PL_sv_undef);
1719 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1723 *hunk = PL_uuemap[len];
1724 sv_catpvn(sv, hunk, 1);
1727 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1728 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1729 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1730 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1731 sv_catpvn(sv, hunk, 4);
1736 char r = (len > 1 ? s[1] : '\0');
1737 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1738 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1739 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1740 hunk[3] = PL_uuemap[0];
1741 sv_catpvn(sv, hunk, 4);
1743 sv_catpvn(sv, "\n", 1);
1747 S_is_an_int(pTHX_ char *s, STRLEN l)
1750 SV *result = newSVpvn(s, l);
1751 char *result_c = SvPV(result, n_a); /* convenience */
1752 char *out = result_c;
1762 SvREFCNT_dec(result);
1785 SvREFCNT_dec(result);
1791 SvCUR_set(result, out - result_c);
1795 /* pnum must be '\0' terminated */
1797 S_div128(pTHX_ SV *pnum, bool *done)
1800 char *s = SvPV(pnum, len);
1809 i = m * 10 + (*t - '0');
1811 r = (i >> 7); /* r < 10 */
1818 SvCUR_set(pnum, (STRLEN) (t - s));
1825 =for apidoc pack_cat
1827 The engine implementing pack() Perl function.
1833 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1835 tempsym_t sym = { 0 };
1837 sym.patend = patend;
1840 (void)pack_rec( cat, &sym, beglist, endlist );
1846 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1850 register I32 len = 0;
1853 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1854 static char *space10 = " ";
1857 /* These must not be in registers: */
1867 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1868 long double aldouble;
1877 int strrelbeg = SvCUR(cat);
1878 tempsym_t lookahead;
1880 items = endlist - beglist;
1881 found = next_symbol( symptr );
1883 #ifndef PACKED_IS_OCTETS
1884 if (symptr->level == 0 && found && symptr->code == 'U' ){
1890 SV *lengthcode = Nullsv;
1891 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1893 I32 datumtype = symptr->code;
1896 switch( howlen = symptr->howlen ){
1899 len = symptr->length;
1902 len = strchr("@Xxu", datumtype) ? 0 : items;
1906 /* Look ahead for next symbol. Do we have code/code? */
1907 lookahead = *symptr;
1908 found = next_symbol(&lookahead);
1909 if ( symptr->flags & FLAG_SLASH ) {
1911 if ( 0 == strchr( "aAZ", lookahead.code ) ||
1912 e_star != lookahead.howlen )
1913 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
1914 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1915 ? *beglist : &PL_sv_no)
1916 + (lookahead.code == 'Z' ? 1 : 0)));
1918 Perl_croak(aTHX_ "Code missing after '/' in pack");
1924 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)datumtype);
1926 Perl_croak(aTHX_ "'%%' may not be used in pack");
1928 len += strrelbeg - SvCUR(cat);
1937 tempsym_t savsym = *symptr;
1938 symptr->patend = savsym.grpend;
1941 symptr->patptr = savsym.grpbeg;
1942 beglist = pack_rec(cat, symptr, beglist, endlist );
1943 if (savsym.howlen == e_star && beglist == endlist)
1944 break; /* No way to continue */
1946 lookahead.flags = symptr->flags;
1950 case 'X' | TYPE_IS_SHRIEKING:
1951 if (!len) /* Avoid division by 0 */
1953 len = (SvCUR(cat)) % len;
1957 if ((I32)SvCUR(cat) < len)
1958 Perl_croak(aTHX_ "'X' outside of string in pack");
1962 case 'x' | TYPE_IS_SHRIEKING:
1963 if (!len) /* Avoid division by 0 */
1965 aint = (SvCUR(cat)) % len;
1966 if (aint) /* Other portable ways? */
1975 sv_catpvn(cat, null10, 10);
1978 sv_catpvn(cat, null10, len);
1984 aptr = SvPV(fromstr, fromlen);
1985 if (howlen == e_star) {
1987 if (datumtype == 'Z')
1990 if ((I32)fromlen >= len) {
1991 sv_catpvn(cat, aptr, len);
1992 if (datumtype == 'Z')
1993 *(SvEND(cat)-1) = '\0';
1996 sv_catpvn(cat, aptr, fromlen);
1998 if (datumtype == 'A') {
2000 sv_catpvn(cat, space10, 10);
2003 sv_catpvn(cat, space10, len);
2007 sv_catpvn(cat, null10, 10);
2010 sv_catpvn(cat, null10, len);
2022 str = SvPV(fromstr, fromlen);
2023 if (howlen == e_star)
2026 SvCUR(cat) += (len+7)/8;
2027 SvGROW(cat, SvCUR(cat) + 1);
2028 aptr = SvPVX(cat) + aint;
2029 if (len > (I32)fromlen)
2033 if (datumtype == 'B') {
2034 for (len = 0; len++ < aint;) {
2035 items |= *str++ & 1;
2039 *aptr++ = items & 0xff;
2045 for (len = 0; len++ < aint;) {
2051 *aptr++ = items & 0xff;
2057 if (datumtype == 'B')
2058 items <<= 7 - (aint & 7);
2060 items >>= 7 - (aint & 7);
2061 *aptr++ = items & 0xff;
2063 str = SvPVX(cat) + SvCUR(cat);
2078 str = SvPV(fromstr, fromlen);
2079 if (howlen == e_star)
2082 SvCUR(cat) += (len+1)/2;
2083 SvGROW(cat, SvCUR(cat) + 1);
2084 aptr = SvPVX(cat) + aint;
2085 if (len > (I32)fromlen)
2089 if (datumtype == 'H') {
2090 for (len = 0; len++ < aint;) {
2092 items |= ((*str++ & 15) + 9) & 15;
2094 items |= *str++ & 15;
2098 *aptr++ = items & 0xff;
2104 for (len = 0; len++ < aint;) {
2106 items |= (((*str++ & 15) + 9) & 15) << 4;
2108 items |= (*str++ & 15) << 4;
2112 *aptr++ = items & 0xff;
2118 *aptr++ = items & 0xff;
2119 str = SvPVX(cat) + SvCUR(cat);
2130 switch (datumtype) {
2132 aint = SvIV(fromstr);
2133 if ((aint < 0 || aint > 255) &&
2135 Perl_warner(aTHX_ packWARN(WARN_PACK),
2136 "Character in 'C' format wrapped in pack");
2138 sv_catpvn(cat, &achar, sizeof(char));
2141 aint = SvIV(fromstr);
2142 if ((aint < -128 || aint > 127) &&
2144 Perl_warner(aTHX_ packWARN(WARN_PACK),
2145 "Character in 'c' format wrapped in pack" );
2147 sv_catpvn(cat, &achar, sizeof(char));
2155 auint = UNI_TO_NATIVE(SvUV(fromstr));
2156 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2158 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2161 0 : UNICODE_ALLOW_ANY)
2166 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2171 /* VOS does not automatically map a floating-point overflow
2172 during conversion from double to float into infinity, so we
2173 do it by hand. This code should either be generalized for
2174 any OS that needs it, or removed if and when VOS implements
2175 posix-976 (suggestion to support mapping to infinity).
2176 Paul.Green@stratus.com 02-04-02. */
2177 if (SvNV(fromstr) > FLT_MAX)
2178 afloat = _float_constants[0]; /* single prec. inf. */
2179 else if (SvNV(fromstr) < -FLT_MAX)
2180 afloat = _float_constants[0]; /* single prec. inf. */
2181 else afloat = (float)SvNV(fromstr);
2183 # if defined(VMS) && !defined(__IEEE_FP)
2184 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2185 * on Alpha; fake it if we don't have them.
2187 if (SvNV(fromstr) > FLT_MAX)
2189 else if (SvNV(fromstr) < -FLT_MAX)
2191 else afloat = (float)SvNV(fromstr);
2193 afloat = (float)SvNV(fromstr);
2196 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2203 /* VOS does not automatically map a floating-point overflow
2204 during conversion from long double to double into infinity,
2205 so we do it by hand. This code should either be generalized
2206 for any OS that needs it, or removed if and when VOS
2207 implements posix-976 (suggestion to support mapping to
2208 infinity). Paul.Green@stratus.com 02-04-02. */
2209 if (SvNV(fromstr) > DBL_MAX)
2210 adouble = _double_constants[0]; /* double prec. inf. */
2211 else if (SvNV(fromstr) < -DBL_MAX)
2212 adouble = _double_constants[0]; /* double prec. inf. */
2213 else adouble = (double)SvNV(fromstr);
2215 # if defined(VMS) && !defined(__IEEE_FP)
2216 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2217 * on Alpha; fake it if we don't have them.
2219 if (SvNV(fromstr) > DBL_MAX)
2221 else if (SvNV(fromstr) < -DBL_MAX)
2223 else adouble = (double)SvNV(fromstr);
2225 adouble = (double)SvNV(fromstr);
2228 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2234 anv = SvNV(fromstr);
2235 sv_catpvn(cat, (char *)&anv, NVSIZE);
2238 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2242 aldouble = (long double)SvNV(fromstr);
2243 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2250 ashort = (I16)SvIV(fromstr);
2252 ashort = PerlSock_htons(ashort);
2254 CAT16(cat, &ashort);
2260 ashort = (I16)SvIV(fromstr);
2262 ashort = htovs(ashort);
2264 CAT16(cat, &ashort);
2267 case 'S' | TYPE_IS_SHRIEKING:
2268 #if SHORTSIZE != SIZE16
2270 unsigned short aushort;
2274 aushort = SvUV(fromstr);
2275 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2288 aushort = (U16)SvUV(fromstr);
2289 CAT16(cat, &aushort);
2294 case 's' | TYPE_IS_SHRIEKING:
2295 #if SHORTSIZE != SIZE16
2301 ashort = SvIV(fromstr);
2302 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2312 ashort = (I16)SvIV(fromstr);
2313 CAT16(cat, &ashort);
2317 case 'I' | TYPE_IS_SHRIEKING:
2320 auint = SvUV(fromstr);
2321 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2327 aiv = SvIV(fromstr);
2328 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2334 auv = SvUV(fromstr);
2335 sv_catpvn(cat, (char*)&auv, UVSIZE);
2341 anv = SvNV(fromstr);
2344 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2346 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2347 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2348 any negative IVs will have already been got by the croak()
2349 above. IOK is untrue for fractions, so we test them
2350 against UV_MAX_P1. */
2351 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2353 char buf[(sizeof(UV)*8)/7+1];
2354 char *in = buf + sizeof(buf);
2355 UV auv = SvUV(fromstr);
2358 *--in = (char)((auv & 0x7f) | 0x80);
2361 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2362 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2364 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2365 char *from, *result, *in;
2370 /* Copy string and check for compliance */
2371 from = SvPV(fromstr, len);
2372 if ((norm = is_an_int(from, len)) == NULL)
2373 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2375 New('w', result, len, char);
2379 *--in = div128(norm, &done) | 0x80;
2380 result[len - 1] &= 0x7F; /* clear continue bit */
2381 sv_catpvn(cat, in, (result + len) - in);
2383 SvREFCNT_dec(norm); /* free norm */
2385 else if (SvNOKp(fromstr)) {
2386 /* 10**NV_MAX_10_EXP is the largest power of 10
2387 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2388 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2389 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2390 And with that many bytes only Inf can overflow.
2392 #ifdef NV_MAX_10_EXP
2393 char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)];
2395 char buf[1 + (int)((308 + 1) * 0.47456)];
2397 char *in = buf + sizeof(buf);
2399 anv = Perl_floor(anv);
2401 NV next = Perl_floor(anv / 128);
2402 if (in <= buf) /* this cannot happen ;-) */
2403 Perl_croak(aTHX_ "Cannot compress integer in pack");
2404 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2407 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2408 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2411 char *from, *result, *in;
2416 /* Copy string and check for compliance */
2417 from = SvPV(fromstr, len);
2418 if ((norm = is_an_int(from, len)) == NULL)
2419 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2421 New('w', result, len, char);
2425 *--in = div128(norm, &done) | 0x80;
2426 result[len - 1] &= 0x7F; /* clear continue bit */
2427 sv_catpvn(cat, in, (result + len) - in);
2429 SvREFCNT_dec(norm); /* free norm */
2434 case 'i' | TYPE_IS_SHRIEKING:
2437 aint = SvIV(fromstr);
2438 sv_catpvn(cat, (char*)&aint, sizeof(int));
2444 aulong = SvUV(fromstr);
2446 aulong = PerlSock_htonl(aulong);
2448 CAT32(cat, &aulong);
2454 aulong = SvUV(fromstr);
2456 aulong = htovl(aulong);
2458 CAT32(cat, &aulong);
2461 case 'L' | TYPE_IS_SHRIEKING:
2462 #if LONGSIZE != SIZE32
2464 unsigned long aulong;
2468 aulong = SvUV(fromstr);
2469 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2480 aulong = SvUV(fromstr);
2481 CAT32(cat, &aulong);
2485 case 'l' | TYPE_IS_SHRIEKING:
2486 #if LONGSIZE != SIZE32
2492 along = SvIV(fromstr);
2493 sv_catpvn(cat, (char *)&along, sizeof(long));
2503 along = SvIV(fromstr);
2511 auquad = (Uquad_t)SvUV(fromstr);
2512 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2518 aquad = (Quad_t)SvIV(fromstr);
2519 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2524 len = 1; /* assume SV is correct length */
2529 if (fromstr == &PL_sv_undef)
2533 /* XXX better yet, could spirit away the string to
2534 * a safe spot and hang on to it until the result
2535 * of pack() (and all copies of the result) are
2538 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2539 || (SvPADTMP(fromstr)
2540 && !SvREADONLY(fromstr))))
2542 Perl_warner(aTHX_ packWARN(WARN_PACK),
2543 "Attempt to pack pointer to temporary value");
2545 if (SvPOK(fromstr) || SvNIOK(fromstr))
2546 aptr = SvPV(fromstr,n_a);
2548 aptr = SvPV_force(fromstr,n_a);
2550 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2555 aptr = SvPV(fromstr, fromlen);
2556 SvGROW(cat, fromlen * 4 / 3);
2561 while (fromlen > 0) {
2564 if ((I32)fromlen > len)
2568 doencodes(cat, aptr, todo);
2574 *symptr = lookahead;
2583 dSP; dMARK; dORIGMARK; dTARGET;
2584 register SV *cat = TARG;
2586 register char *pat = SvPVx(*++MARK, fromlen);
2587 register char *patend = pat + fromlen;
2590 sv_setpvn(cat, "", 0);
2592 pack_cat(cat, pat, patend, MARK, SP + 1, NULL, FLAG_PACK);