3 * Copyright (c) 1991-2003, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * He still hopefully carried some of his gear in his pack: a small tinder-box,
12 * two small shallow pans, the smaller fitting into the larger; inside them a
13 * wooden spoon, a short two-pronged fork and some skewers were stowed; and
14 * hidden at the bottom of the pack in a flat wooden box a dwindling treasure,
19 #define PERL_IN_PP_PACK_C
23 * The compiler on Concurrent CX/UX systems has a subtle bug which only
24 * seems to show up when compiling pp.c - it generates the wrong double
25 * precision constant value for (double)UV_MAX when used inline in the body
26 * of the code below, so this makes a static variable up front (which the
27 * compiler seems to get correct) and uses it in place of UV_MAX below.
29 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
30 static double UV_MAX_cxux = ((double)UV_MAX);
34 * Offset for integer pack/unpack.
36 * On architectures where I16 and I32 aren't really 16 and 32 bits,
37 * which for now are all Crays, pack and unpack have to play games.
41 * These values are required for portability of pack() output.
42 * If they're not right on your machine, then pack() and unpack()
43 * wouldn't work right anyway; you'll need to apply the Cray hack.
44 * (I'd like to check them with #if, but you can't use sizeof() in
45 * the preprocessor.) --???
48 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
49 defines are now in config.h. --Andy Dougherty April 1998
54 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
57 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
58 # define PERL_NATINT_PACK
61 #if LONGSIZE > 4 && defined(_CRAY)
62 # if BYTEORDER == 0x12345678
63 # define OFF16(p) (char*)(p)
64 # define OFF32(p) (char*)(p)
66 # if BYTEORDER == 0x87654321
67 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
68 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
70 }}}} bad cray byte order
73 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
74 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
75 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
76 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
77 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
79 # define COPY16(s,p) Copy(s, p, SIZE16, char)
80 # define COPY32(s,p) Copy(s, p, SIZE32, char)
81 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
82 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
83 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
86 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
87 #define MAX_SUB_TEMPLATE_LEVEL 100
90 #define FLAG_UNPACK_ONLY_ONE 0x10
91 #define FLAG_UNPACK_DO_UTF8 0x08
92 #define FLAG_SLASH 0x04
93 #define FLAG_COMMA 0x02
94 #define FLAG_PACK 0x01
97 S_mul128(pTHX_ SV *sv, U8 m)
100 char *s = SvPV(sv, len);
104 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
105 SV *tmpNew = newSVpvn("0000000000", 10);
107 sv_catsv(tmpNew, sv);
108 SvREFCNT_dec(sv); /* free old sv */
113 while (!*t) /* trailing '\0'? */
116 i = ((*t - '0') << 7) + m;
117 *(t--) = '0' + (char)(i % 10);
123 /* Explosives and implosives. */
125 #if 'I' == 73 && 'J' == 74
126 /* On an ASCII/ISO kind of system */
127 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
130 Some other sort of character set - use memchr() so we don't match
133 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
136 #define TYPE_IS_SHRIEKING 0x100
138 /* Returns the sizeof() struct described by pat */
140 S_measure_struct(pTHX_ register tempsym_t* symptr)
142 register I32 len = 0;
143 register I32 total = 0;
148 while (next_symbol(symptr)) {
150 switch( symptr->howlen ){
153 len = symptr->length;
156 Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
157 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
161 switch(symptr->code) {
163 Perl_croak(aTHX_ "Invalid type '%c' in %s",
165 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
168 case 'U': /* XXXX Is it correct? */
171 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
173 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
179 tempsym_t savsym = *symptr;
180 symptr->patptr = savsym.grpbeg;
181 symptr->patend = savsym.grpend;
182 /* XXXX Theoretically, we need to measure many times at different
183 positions, since the subexpression may contain
184 alignment commands, but be not of aligned length.
185 Need to detect this and croak(). */
186 size = measure_struct(symptr);
190 case 'X' | TYPE_IS_SHRIEKING:
191 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */
192 if (!len) /* Avoid division by 0 */
194 len = total % len; /* Assumed: the start is aligned. */
199 Perl_croak(aTHX_ "'X' outside of string in %s",
200 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
202 case 'x' | TYPE_IS_SHRIEKING:
203 if (!len) /* Avoid division by 0 */
205 star = total % len; /* Assumed: the start is aligned. */
206 if (star) /* Other portable ways? */
229 case 's' | TYPE_IS_SHRIEKING:
230 #if SHORTSIZE != SIZE16
231 size = sizeof(short);
239 case 'S' | TYPE_IS_SHRIEKING:
240 #if SHORTSIZE != SIZE16
241 size = sizeof(unsigned short);
251 case 'i' | TYPE_IS_SHRIEKING:
255 case 'I' | TYPE_IS_SHRIEKING:
257 size = sizeof(unsigned int);
265 case 'l' | TYPE_IS_SHRIEKING:
266 #if LONGSIZE != SIZE32
275 case 'L' | TYPE_IS_SHRIEKING:
276 #if LONGSIZE != SIZE32
277 size = sizeof(unsigned long);
291 size = sizeof(char*);
295 size = sizeof(Quad_t);
298 size = sizeof(Uquad_t);
302 size = sizeof(float);
305 size = sizeof(double);
310 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
312 size = LONG_DOUBLESIZE;
322 /* locate matching closing parenthesis or bracket
323 * returns char pointer to char after match, or NULL
326 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
328 while (patptr < patend) {
336 while (patptr < patend && *patptr != '\n')
340 patptr = group_end(patptr, patend, ')') + 1;
342 patptr = group_end(patptr, patend, ']') + 1;
344 Perl_croak(aTHX_ "No group ending character '%c' found in template",
350 /* Convert unsigned decimal number to binary.
351 * Expects a pointer to the first digit and address of length variable
352 * Advances char pointer to 1st non-digit char and returns number
355 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
357 I32 len = *patptr++ - '0';
358 while (isDIGIT(*patptr)) {
359 if (len >= 0x7FFFFFFF/10)
360 Perl_croak(aTHX_ "pack/unpack repeat count overflow");
361 len = (len * 10) + (*patptr++ - '0');
367 /* The marvellous template parsing routine: Using state stored in *symptr,
368 * locates next template code and count
371 S_next_symbol(pTHX_ register tempsym_t* symptr )
373 register char* patptr = symptr->patptr;
374 register char* patend = symptr->patend;
376 symptr->flags &= ~FLAG_SLASH;
378 while (patptr < patend) {
379 if (isSPACE(*patptr))
381 else if (*patptr == '#') {
383 while (patptr < patend && *patptr != '\n')
388 /* We should have found a template code */
389 I32 code = *patptr++ & 0xFF;
391 if (code == ','){ /* grandfather in commas but with a warning */
392 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
393 symptr->flags |= FLAG_COMMA;
394 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
395 "Invalid type ',' in %s",
396 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
401 /* for '(', skip to ')' */
403 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
404 Perl_croak(aTHX_ "()-group starts with a count in %s",
405 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
406 symptr->grpbeg = patptr;
407 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
408 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
409 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
410 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
413 /* test for '!' modifier */
414 if (patptr < patend && *patptr == '!') {
415 static const char natstr[] = "sSiIlLxX";
417 if (strchr(natstr, code))
418 code |= TYPE_IS_SHRIEKING;
420 Perl_croak(aTHX_ "'!' allowed only after types %s in pack/unpack",
421 natstr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
424 /* look for count and/or / */
425 if (patptr < patend) {
426 if (isDIGIT(*patptr)) {
427 patptr = get_num( patptr, &symptr->length );
428 symptr->howlen = e_number;
430 } else if (*patptr == '*') {
432 symptr->howlen = e_star;
434 } else if (*patptr == '[') {
435 char* lenptr = ++patptr;
436 symptr->howlen = e_number;
437 patptr = group_end( patptr, patend, ']' ) + 1;
438 /* what kind of [] is it? */
439 if (isDIGIT(*lenptr)) {
440 lenptr = get_num( lenptr, &symptr->length );
442 Perl_croak(aTHX_ "Malformed integer in [] in %s",
443 symptr->flags & FLAG_PACK ? "pack" : "unpack");
445 tempsym_t savsym = *symptr;
446 symptr->patend = patptr-1;
447 symptr->patptr = lenptr;
448 savsym.length = measure_struct(symptr);
452 symptr->howlen = e_no_len;
457 while (patptr < patend) {
458 if (isSPACE(*patptr))
460 else if (*patptr == '#') {
462 while (patptr < patend && *patptr != '\n')
467 if( *patptr == '/' ){
468 symptr->flags |= FLAG_SLASH;
470 if( patptr < patend &&
471 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '[') )
472 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
473 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
479 /* at end - no count, no / */
480 symptr->howlen = e_no_len;
485 symptr->patptr = patptr;
489 symptr->patptr = patptr;
494 =for apidoc unpack_str
496 The engine implementing unpack() Perl function.
501 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
503 tempsym_t sym = { 0 };
508 return unpack_rec(&sym, s, s, strend, NULL );
513 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
517 register I32 len = 0;
518 register I32 bits = 0;
521 I32 start_sp_offset = SP - PL_stack_base;
524 /* These must not be in registers: */
543 const int bits_in_uv = 8 * sizeof(cuv);
546 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
551 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
552 long double aldouble;
555 while (next_symbol(symptr)) {
556 datumtype = symptr->code;
557 /* do first one only unless in list context
558 / is implemented by unpacking the count, then poping it from the
559 stack, so must check that we're not in the middle of a / */
561 && (SP - PL_stack_base == start_sp_offset + 1)
562 && (datumtype != '/') ) /* XXX can this be omitted */
565 switch( howlen = symptr->howlen ){
568 len = symptr->length;
571 len = strend - strbeg; /* long enough */
576 beyond = s >= strend;
579 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)datumtype );
582 if (howlen == e_no_len)
583 len = 16; /* len is not specified */
591 char *ss = s; /* Move from register */
592 tempsym_t savsym = *symptr;
593 symptr->patend = savsym.grpend;
597 symptr->patptr = savsym.grpbeg;
598 unpack_rec(symptr, ss, strbeg, strend, &ss );
599 if (ss == strend && savsym.howlen == e_star)
600 break; /* No way to continue */
604 savsym.flags = symptr->flags;
609 if (len > strend - strrelbeg)
610 Perl_croak(aTHX_ "'@' outside of string in unpack");
613 case 'X' | TYPE_IS_SHRIEKING:
614 if (!len) /* Avoid division by 0 */
616 len = (s - strbeg) % len;
619 if (len > s - strbeg)
620 Perl_croak(aTHX_ "'X' outside of string in unpack" );
623 case 'x' | TYPE_IS_SHRIEKING:
624 if (!len) /* Avoid division by 0 */
626 aint = (s - strbeg) % len;
627 if (aint) /* Other portable ways? */
633 if (len > strend - s)
634 Perl_croak(aTHX_ "'x' outside of string in unpack");
638 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
643 if (len > strend - s)
648 sv_setpvn(sv, s, len);
649 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
650 aptr = s; /* borrow register */
651 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
655 if (howlen == e_star) /* exact for 'Z*' */
656 len = s - SvPVX(sv) + 1;
658 else { /* 'A' strips both nulls and spaces */
659 s = SvPVX(sv) + len - 1;
660 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
664 SvCUR_set(sv, s - SvPVX(sv));
665 s = aptr; /* unborrow register */
668 XPUSHs(sv_2mortal(sv));
672 if (howlen == e_star || len > (strend - s) * 8)
673 len = (strend - s) * 8;
676 Newz(601, PL_bitcount, 256, char);
677 for (bits = 1; bits < 256; bits++) {
678 if (bits & 1) PL_bitcount[bits]++;
679 if (bits & 2) PL_bitcount[bits]++;
680 if (bits & 4) PL_bitcount[bits]++;
681 if (bits & 8) PL_bitcount[bits]++;
682 if (bits & 16) PL_bitcount[bits]++;
683 if (bits & 32) PL_bitcount[bits]++;
684 if (bits & 64) PL_bitcount[bits]++;
685 if (bits & 128) PL_bitcount[bits]++;
689 cuv += PL_bitcount[*(unsigned char*)s++];
694 if (datumtype == 'b') {
702 if (bits & 128) cuv++;
709 sv = NEWSV(35, len + 1);
713 if (datumtype == 'b') {
715 for (len = 0; len < aint; len++) {
716 if (len & 7) /*SUPPRESS 595*/
720 *str++ = '0' + (bits & 1);
725 for (len = 0; len < aint; len++) {
730 *str++ = '0' + ((bits & 128) != 0);
734 XPUSHs(sv_2mortal(sv));
738 if (howlen == e_star || len > (strend - s) * 2)
739 len = (strend - s) * 2;
740 sv = NEWSV(35, len + 1);
744 if (datumtype == 'h') {
746 for (len = 0; len < aint; len++) {
751 *str++ = PL_hexdigit[bits & 15];
756 for (len = 0; len < aint; len++) {
761 *str++ = PL_hexdigit[(bits >> 4) & 15];
765 XPUSHs(sv_2mortal(sv));
768 if (len > strend - s)
773 if (aint >= 128) /* fake up signed chars */
775 if (checksum > bits_in_uv)
782 if (len && unpack_only_one)
788 if (aint >= 128) /* fake up signed chars */
791 sv_setiv(sv, (IV)aint);
792 PUSHs(sv_2mortal(sv));
797 unpack_C: /* unpack U will jump here if not UTF-8 */
799 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
802 if (len > strend - s)
812 if (len && unpack_only_one)
819 sv_setiv(sv, (IV)auint);
820 PUSHs(sv_2mortal(sv));
826 symptr->flags |= FLAG_UNPACK_DO_UTF8;
829 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
831 if (len > strend - s)
834 while (len-- > 0 && s < strend) {
836 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
839 if (checksum > bits_in_uv)
840 cdouble += (NV)auint;
846 if (len && unpack_only_one)
850 while (len-- > 0 && s < strend) {
852 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
856 sv_setuv(sv, (UV)auint);
857 PUSHs(sv_2mortal(sv));
861 case 's' | TYPE_IS_SHRIEKING:
862 #if SHORTSIZE != SIZE16
863 along = (strend - s) / sizeof(short);
869 COPYNN(s, &ashort, sizeof(short));
871 if (checksum > bits_in_uv)
872 cdouble += (NV)ashort;
879 if (len && unpack_only_one)
885 COPYNN(s, &ashort, sizeof(short));
888 sv_setiv(sv, (IV)ashort);
889 PUSHs(sv_2mortal(sv));
897 along = (strend - s) / SIZE16;
903 #if SHORTSIZE > SIZE16
908 if (checksum > bits_in_uv)
909 cdouble += (NV)ashort;
915 if (len && unpack_only_one)
922 #if SHORTSIZE > SIZE16
928 sv_setiv(sv, (IV)ashort);
929 PUSHs(sv_2mortal(sv));
933 case 'S' | TYPE_IS_SHRIEKING:
934 #if SHORTSIZE != SIZE16
935 along = (strend - s) / SIZE16;
939 unsigned short aushort;
941 COPYNN(s, &aushort, sizeof(unsigned short));
942 s += sizeof(unsigned short);
943 if (checksum > bits_in_uv)
944 cdouble += (NV)aushort;
950 if (len && unpack_only_one)
955 unsigned short aushort;
956 COPYNN(s, &aushort, sizeof(unsigned short));
957 s += sizeof(unsigned short);
959 sv_setiv(sv, (UV)aushort);
960 PUSHs(sv_2mortal(sv));
970 along = (strend - s) / SIZE16;
978 if (datumtype == 'n')
979 aushort = PerlSock_ntohs(aushort);
982 if (datumtype == 'v')
983 aushort = vtohs(aushort);
985 if (checksum > bits_in_uv)
986 cdouble += (NV)aushort;
992 if (len && unpack_only_one)
1001 if (datumtype == 'n')
1002 aushort = PerlSock_ntohs(aushort);
1005 if (datumtype == 'v')
1006 aushort = vtohs(aushort);
1008 sv_setiv(sv, (UV)aushort);
1009 PUSHs(sv_2mortal(sv));
1014 case 'i' | TYPE_IS_SHRIEKING:
1015 along = (strend - s) / sizeof(int);
1020 Copy(s, &aint, 1, int);
1022 if (checksum > bits_in_uv)
1023 cdouble += (NV)aint;
1029 if (len && unpack_only_one)
1034 Copy(s, &aint, 1, int);
1038 /* Without the dummy below unpack("i", pack("i",-1))
1039 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
1040 * cc with optimization turned on.
1042 * The bug was detected in
1043 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
1044 * with optimization (-O4) turned on.
1045 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
1046 * does not have this problem even with -O4.
1048 * This bug was reported as DECC_BUGS 1431
1049 * and tracked internally as GEM_BUGS 7775.
1051 * The bug is fixed in
1052 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
1053 * UNIX V4.0F support: DEC C V5.9-006 or later
1054 * UNIX V4.0E support: DEC C V5.8-011 or later
1057 * See also few lines later for the same bug.
1060 sv_setiv(sv, (IV)aint) :
1062 sv_setiv(sv, (IV)aint);
1063 PUSHs(sv_2mortal(sv));
1068 case 'I' | TYPE_IS_SHRIEKING:
1069 along = (strend - s) / sizeof(unsigned int);
1074 Copy(s, &auint, 1, unsigned int);
1075 s += sizeof(unsigned int);
1076 if (checksum > bits_in_uv)
1077 cdouble += (NV)auint;
1083 if (len && unpack_only_one)
1088 Copy(s, &auint, 1, unsigned int);
1089 s += sizeof(unsigned int);
1092 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1093 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1094 * See details few lines earlier. */
1096 sv_setuv(sv, (UV)auint) :
1098 sv_setuv(sv, (UV)auint);
1099 PUSHs(sv_2mortal(sv));
1104 along = (strend - s) / IVSIZE;
1109 Copy(s, &aiv, 1, IV);
1111 if (checksum > bits_in_uv)
1118 if (len && unpack_only_one)
1123 Copy(s, &aiv, 1, IV);
1127 PUSHs(sv_2mortal(sv));
1132 along = (strend - s) / UVSIZE;
1137 Copy(s, &auv, 1, UV);
1139 if (checksum > bits_in_uv)
1146 if (len && unpack_only_one)
1151 Copy(s, &auv, 1, UV);
1155 PUSHs(sv_2mortal(sv));
1159 case 'l' | TYPE_IS_SHRIEKING:
1160 #if LONGSIZE != SIZE32
1161 along = (strend - s) / sizeof(long);
1166 COPYNN(s, &along, sizeof(long));
1168 if (checksum > bits_in_uv)
1169 cdouble += (NV)along;
1175 if (len && unpack_only_one)
1180 COPYNN(s, &along, sizeof(long));
1183 sv_setiv(sv, (IV)along);
1184 PUSHs(sv_2mortal(sv));
1192 along = (strend - s) / SIZE32;
1197 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1201 #if LONGSIZE > SIZE32
1202 if (along > 2147483647)
1203 along -= 4294967296;
1206 if (checksum > bits_in_uv)
1207 cdouble += (NV)along;
1213 if (len && unpack_only_one)
1218 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1222 #if LONGSIZE > SIZE32
1223 if (along > 2147483647)
1224 along -= 4294967296;
1228 sv_setiv(sv, (IV)along);
1229 PUSHs(sv_2mortal(sv));
1233 case 'L' | TYPE_IS_SHRIEKING:
1234 #if LONGSIZE != SIZE32
1235 along = (strend - s) / sizeof(unsigned long);
1240 unsigned long aulong;
1241 COPYNN(s, &aulong, sizeof(unsigned long));
1242 s += sizeof(unsigned long);
1243 if (checksum > bits_in_uv)
1244 cdouble += (NV)aulong;
1250 if (len && unpack_only_one)
1255 unsigned long aulong;
1256 COPYNN(s, &aulong, sizeof(unsigned long));
1257 s += sizeof(unsigned long);
1259 sv_setuv(sv, (UV)aulong);
1260 PUSHs(sv_2mortal(sv));
1270 along = (strend - s) / SIZE32;
1278 if (datumtype == 'N')
1279 aulong = PerlSock_ntohl(aulong);
1282 if (datumtype == 'V')
1283 aulong = vtohl(aulong);
1285 if (checksum > bits_in_uv)
1286 cdouble += (NV)aulong;
1292 if (len && unpack_only_one)
1300 if (datumtype == 'N')
1301 aulong = PerlSock_ntohl(aulong);
1304 if (datumtype == 'V')
1305 aulong = vtohl(aulong);
1308 sv_setuv(sv, (UV)aulong);
1309 PUSHs(sv_2mortal(sv));
1314 along = (strend - s) / sizeof(char*);
1320 if (sizeof(char*) > strend - s)
1323 Copy(s, &aptr, 1, char*);
1329 PUSHs(sv_2mortal(sv));
1333 if (len && unpack_only_one)
1341 while ((len > 0) && (s < strend)) {
1342 auv = (auv << 7) | (*s & 0x7f);
1343 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1344 if ((U8)(*s++) < 0x80) {
1348 PUSHs(sv_2mortal(sv));
1352 else if (++bytes >= sizeof(UV)) { /* promote to string */
1356 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1357 while (s < strend) {
1358 sv = mul128(sv, (U8)(*s & 0x7f));
1359 if (!(*s++ & 0x80)) {
1368 PUSHs(sv_2mortal(sv));
1373 if ((s >= strend) && bytes)
1374 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1378 if (symptr->howlen == e_star)
1379 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1381 if (sizeof(char*) > strend - s)
1384 Copy(s, &aptr, 1, char*);
1389 sv_setpvn(sv, aptr, len);
1390 PUSHs(sv_2mortal(sv));
1394 along = (strend - s) / sizeof(Quad_t);
1399 Copy(s, &aquad, 1, Quad_t);
1400 s += sizeof(Quad_t);
1401 if (checksum > bits_in_uv)
1402 cdouble += (NV)aquad;
1408 if (len && unpack_only_one)
1413 if (s + sizeof(Quad_t) > strend)
1416 Copy(s, &aquad, 1, Quad_t);
1417 s += sizeof(Quad_t);
1420 if (aquad >= IV_MIN && aquad <= IV_MAX)
1421 sv_setiv(sv, (IV)aquad);
1423 sv_setnv(sv, (NV)aquad);
1424 PUSHs(sv_2mortal(sv));
1429 along = (strend - s) / sizeof(Uquad_t);
1434 Copy(s, &auquad, 1, Uquad_t);
1435 s += sizeof(Uquad_t);
1436 if (checksum > bits_in_uv)
1437 cdouble += (NV)auquad;
1443 if (len && unpack_only_one)
1448 if (s + sizeof(Uquad_t) > strend)
1451 Copy(s, &auquad, 1, Uquad_t);
1452 s += sizeof(Uquad_t);
1455 if (auquad <= UV_MAX)
1456 sv_setuv(sv, (UV)auquad);
1458 sv_setnv(sv, (NV)auquad);
1459 PUSHs(sv_2mortal(sv));
1464 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1466 along = (strend - s) / sizeof(float);
1471 Copy(s, &afloat, 1, float);
1477 if (len && unpack_only_one)
1482 Copy(s, &afloat, 1, float);
1485 sv_setnv(sv, (NV)afloat);
1486 PUSHs(sv_2mortal(sv));
1491 along = (strend - s) / sizeof(double);
1496 Copy(s, &adouble, 1, double);
1497 s += sizeof(double);
1502 if (len && unpack_only_one)
1507 Copy(s, &adouble, 1, double);
1508 s += sizeof(double);
1510 sv_setnv(sv, (NV)adouble);
1511 PUSHs(sv_2mortal(sv));
1516 along = (strend - s) / NVSIZE;
1521 Copy(s, &anv, 1, NV);
1527 if (len && unpack_only_one)
1532 Copy(s, &anv, 1, NV);
1536 PUSHs(sv_2mortal(sv));
1540 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1542 along = (strend - s) / LONG_DOUBLESIZE;
1547 Copy(s, &aldouble, 1, long double);
1548 s += LONG_DOUBLESIZE;
1549 cdouble += aldouble;
1553 if (len && unpack_only_one)
1558 Copy(s, &aldouble, 1, long double);
1559 s += LONG_DOUBLESIZE;
1561 sv_setnv(sv, (NV)aldouble);
1562 PUSHs(sv_2mortal(sv));
1569 * Initialise the decode mapping. By using a table driven
1570 * algorithm, the code will be character-set independent
1571 * (and just as fast as doing character arithmetic)
1573 if (PL_uudmap['M'] == 0) {
1576 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1577 PL_uudmap[(U8)PL_uuemap[i]] = i;
1579 * Because ' ' and '`' map to the same value,
1580 * we need to decode them both the same.
1585 along = (strend - s) * 3 / 4;
1586 sv = NEWSV(42, along);
1589 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1594 len = PL_uudmap[*(U8*)s++] & 077;
1596 if (s < strend && ISUUCHAR(*s))
1597 a = PL_uudmap[*(U8*)s++] & 077;
1600 if (s < strend && ISUUCHAR(*s))
1601 b = PL_uudmap[*(U8*)s++] & 077;
1604 if (s < strend && ISUUCHAR(*s))
1605 c = PL_uudmap[*(U8*)s++] & 077;
1608 if (s < strend && ISUUCHAR(*s))
1609 d = PL_uudmap[*(U8*)s++] & 077;
1612 hunk[0] = (char)((a << 2) | (b >> 4));
1613 hunk[1] = (char)((b << 4) | (c >> 2));
1614 hunk[2] = (char)((c << 6) | d);
1615 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1620 else /* possible checksum byte */
1621 if (s + 1 < strend && s[1] == '\n')
1624 XPUSHs(sv_2mortal(sv));
1630 if (strchr("fFdD", datumtype) ||
1631 (checksum > bits_in_uv &&
1632 strchr("csSiIlLnNUvVqQjJ", datumtype&0xFF)) ) {
1635 adouble = (NV) (1 << (checksum & 15));
1636 while (checksum >= 16) {
1640 while (cdouble < 0.0)
1642 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1643 sv_setnv(sv, cdouble);
1646 if (checksum < bits_in_uv) {
1647 UV mask = ((UV)1 << checksum) - 1;
1652 XPUSHs(sv_2mortal(sv));
1656 if (symptr->flags & FLAG_SLASH){
1657 if (SP - PL_stack_base - start_sp_offset <= 0)
1658 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1659 if( next_symbol(symptr) ){
1660 if( symptr->howlen == e_number )
1661 Perl_croak(aTHX_ "Count after length/code in unpack" );
1663 /* ...end of char buffer then no decent length available */
1664 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1666 /* take top of stack (hope it's numeric) */
1669 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1672 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1674 datumtype = symptr->code;
1682 return SP - PL_stack_base - start_sp_offset;
1688 SV *right = (MAXARG > 1) ? POPs : GvSV(PL_defgv);
1690 I32 gimme = GIMME_V;
1693 register char *pat = SvPV(left, llen);
1694 #ifdef PACKED_IS_OCTETS
1695 /* Packed side is assumed to be octets - so force downgrade if it
1696 has been UTF-8 encoded by accident
1698 register char *s = SvPVbyte(right, rlen);
1700 register char *s = SvPV(right, rlen);
1702 char *strend = s + rlen;
1703 register char *patend = pat + llen;
1707 cnt = unpack_str(pat, patend, s, s, strend, NULL, 0,
1708 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1709 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1712 if ( !cnt && gimme == G_SCALAR )
1713 PUSHs(&PL_sv_undef);
1718 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1722 *hunk = PL_uuemap[len];
1723 sv_catpvn(sv, hunk, 1);
1726 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1727 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1728 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1729 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1730 sv_catpvn(sv, hunk, 4);
1735 char r = (len > 1 ? s[1] : '\0');
1736 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1737 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1738 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1739 hunk[3] = PL_uuemap[0];
1740 sv_catpvn(sv, hunk, 4);
1742 sv_catpvn(sv, "\n", 1);
1746 S_is_an_int(pTHX_ char *s, STRLEN l)
1749 SV *result = newSVpvn(s, l);
1750 char *result_c = SvPV(result, n_a); /* convenience */
1751 char *out = result_c;
1761 SvREFCNT_dec(result);
1784 SvREFCNT_dec(result);
1790 SvCUR_set(result, out - result_c);
1794 /* pnum must be '\0' terminated */
1796 S_div128(pTHX_ SV *pnum, bool *done)
1799 char *s = SvPV(pnum, len);
1808 i = m * 10 + (*t - '0');
1810 r = (i >> 7); /* r < 10 */
1817 SvCUR_set(pnum, (STRLEN) (t - s));
1824 =for apidoc pack_cat
1826 The engine implementing pack() Perl function.
1832 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1834 tempsym_t sym = { 0 };
1836 sym.patend = patend;
1839 (void)pack_rec( cat, &sym, beglist, endlist );
1845 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1849 register I32 len = 0;
1852 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1853 static char *space10 = " ";
1856 /* These must not be in registers: */
1866 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1867 long double aldouble;
1876 int strrelbeg = SvCUR(cat);
1877 tempsym_t lookahead;
1879 items = endlist - beglist;
1880 found = next_symbol( symptr );
1882 #ifndef PACKED_IS_OCTETS
1883 if (symptr->level == 0 && found && symptr->code == 'U' ){
1889 SV *lengthcode = Nullsv;
1890 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1892 I32 datumtype = symptr->code;
1895 switch( howlen = symptr->howlen ){
1898 len = symptr->length;
1901 len = strchr("@Xxu", datumtype) ? 0 : items;
1905 /* Look ahead for next symbol. Do we have code/code? */
1906 lookahead = *symptr;
1907 found = next_symbol(&lookahead);
1908 if ( symptr->flags & FLAG_SLASH ) {
1910 if ( 0 == strchr( "aAZ", lookahead.code ) ||
1911 e_star != lookahead.howlen )
1912 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
1913 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1914 ? *beglist : &PL_sv_no)
1915 + (lookahead.code == 'Z' ? 1 : 0)));
1917 Perl_croak(aTHX_ "Code missing after '/' in pack");
1923 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)datumtype);
1925 Perl_croak(aTHX_ "'%%' may not be used in pack");
1927 len += strrelbeg - SvCUR(cat);
1936 tempsym_t savsym = *symptr;
1937 symptr->patend = savsym.grpend;
1940 symptr->patptr = savsym.grpbeg;
1941 beglist = pack_rec(cat, symptr, beglist, endlist );
1942 if (savsym.howlen == e_star && beglist == endlist)
1943 break; /* No way to continue */
1945 lookahead.flags = symptr->flags;
1949 case 'X' | TYPE_IS_SHRIEKING:
1950 if (!len) /* Avoid division by 0 */
1952 len = (SvCUR(cat)) % len;
1956 if ((I32)SvCUR(cat) < len)
1957 Perl_croak(aTHX_ "'X' outside of string in pack");
1961 case 'x' | TYPE_IS_SHRIEKING:
1962 if (!len) /* Avoid division by 0 */
1964 aint = (SvCUR(cat)) % len;
1965 if (aint) /* Other portable ways? */
1974 sv_catpvn(cat, null10, 10);
1977 sv_catpvn(cat, null10, len);
1983 aptr = SvPV(fromstr, fromlen);
1984 if (howlen == e_star) {
1986 if (datumtype == 'Z')
1989 if ((I32)fromlen >= len) {
1990 sv_catpvn(cat, aptr, len);
1991 if (datumtype == 'Z')
1992 *(SvEND(cat)-1) = '\0';
1995 sv_catpvn(cat, aptr, fromlen);
1997 if (datumtype == 'A') {
1999 sv_catpvn(cat, space10, 10);
2002 sv_catpvn(cat, space10, len);
2006 sv_catpvn(cat, null10, 10);
2009 sv_catpvn(cat, null10, len);
2021 str = SvPV(fromstr, fromlen);
2022 if (howlen == e_star)
2025 SvCUR(cat) += (len+7)/8;
2026 SvGROW(cat, SvCUR(cat) + 1);
2027 aptr = SvPVX(cat) + aint;
2028 if (len > (I32)fromlen)
2032 if (datumtype == 'B') {
2033 for (len = 0; len++ < aint;) {
2034 items |= *str++ & 1;
2038 *aptr++ = items & 0xff;
2044 for (len = 0; len++ < aint;) {
2050 *aptr++ = items & 0xff;
2056 if (datumtype == 'B')
2057 items <<= 7 - (aint & 7);
2059 items >>= 7 - (aint & 7);
2060 *aptr++ = items & 0xff;
2062 str = SvPVX(cat) + SvCUR(cat);
2077 str = SvPV(fromstr, fromlen);
2078 if (howlen == e_star)
2081 SvCUR(cat) += (len+1)/2;
2082 SvGROW(cat, SvCUR(cat) + 1);
2083 aptr = SvPVX(cat) + aint;
2084 if (len > (I32)fromlen)
2088 if (datumtype == 'H') {
2089 for (len = 0; len++ < aint;) {
2091 items |= ((*str++ & 15) + 9) & 15;
2093 items |= *str++ & 15;
2097 *aptr++ = items & 0xff;
2103 for (len = 0; len++ < aint;) {
2105 items |= (((*str++ & 15) + 9) & 15) << 4;
2107 items |= (*str++ & 15) << 4;
2111 *aptr++ = items & 0xff;
2117 *aptr++ = items & 0xff;
2118 str = SvPVX(cat) + SvCUR(cat);
2129 switch (datumtype) {
2131 aint = SvIV(fromstr);
2132 if ((aint < 0 || aint > 255) &&
2134 Perl_warner(aTHX_ packWARN(WARN_PACK),
2135 "Character in 'C' format wrapped in pack");
2137 sv_catpvn(cat, &achar, sizeof(char));
2140 aint = SvIV(fromstr);
2141 if ((aint < -128 || aint > 127) &&
2143 Perl_warner(aTHX_ packWARN(WARN_PACK),
2144 "Character in 'c' format wrapped in pack" );
2146 sv_catpvn(cat, &achar, sizeof(char));
2154 auint = UNI_TO_NATIVE(SvUV(fromstr));
2155 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2157 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2160 0 : UNICODE_ALLOW_ANY)
2165 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2170 /* VOS does not automatically map a floating-point overflow
2171 during conversion from double to float into infinity, so we
2172 do it by hand. This code should either be generalized for
2173 any OS that needs it, or removed if and when VOS implements
2174 posix-976 (suggestion to support mapping to infinity).
2175 Paul.Green@stratus.com 02-04-02. */
2176 if (SvNV(fromstr) > FLT_MAX)
2177 afloat = _float_constants[0]; /* single prec. inf. */
2178 else if (SvNV(fromstr) < -FLT_MAX)
2179 afloat = _float_constants[0]; /* single prec. inf. */
2180 else afloat = (float)SvNV(fromstr);
2182 # if defined(VMS) && !defined(__IEEE_FP)
2183 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2184 * on Alpha; fake it if we don't have them.
2186 if (SvNV(fromstr) > FLT_MAX)
2188 else if (SvNV(fromstr) < -FLT_MAX)
2190 else afloat = (float)SvNV(fromstr);
2192 afloat = (float)SvNV(fromstr);
2195 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2202 /* VOS does not automatically map a floating-point overflow
2203 during conversion from long double to double into infinity,
2204 so we do it by hand. This code should either be generalized
2205 for any OS that needs it, or removed if and when VOS
2206 implements posix-976 (suggestion to support mapping to
2207 infinity). Paul.Green@stratus.com 02-04-02. */
2208 if (SvNV(fromstr) > DBL_MAX)
2209 adouble = _double_constants[0]; /* double prec. inf. */
2210 else if (SvNV(fromstr) < -DBL_MAX)
2211 adouble = _double_constants[0]; /* double prec. inf. */
2212 else adouble = (double)SvNV(fromstr);
2214 # if defined(VMS) && !defined(__IEEE_FP)
2215 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2216 * on Alpha; fake it if we don't have them.
2218 if (SvNV(fromstr) > DBL_MAX)
2220 else if (SvNV(fromstr) < -DBL_MAX)
2222 else adouble = (double)SvNV(fromstr);
2224 adouble = (double)SvNV(fromstr);
2227 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2233 anv = SvNV(fromstr);
2234 sv_catpvn(cat, (char *)&anv, NVSIZE);
2237 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2241 aldouble = (long double)SvNV(fromstr);
2242 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2249 ashort = (I16)SvIV(fromstr);
2251 ashort = PerlSock_htons(ashort);
2253 CAT16(cat, &ashort);
2259 ashort = (I16)SvIV(fromstr);
2261 ashort = htovs(ashort);
2263 CAT16(cat, &ashort);
2266 case 'S' | TYPE_IS_SHRIEKING:
2267 #if SHORTSIZE != SIZE16
2269 unsigned short aushort;
2273 aushort = SvUV(fromstr);
2274 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2287 aushort = (U16)SvUV(fromstr);
2288 CAT16(cat, &aushort);
2293 case 's' | TYPE_IS_SHRIEKING:
2294 #if SHORTSIZE != SIZE16
2300 ashort = SvIV(fromstr);
2301 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2311 ashort = (I16)SvIV(fromstr);
2312 CAT16(cat, &ashort);
2316 case 'I' | TYPE_IS_SHRIEKING:
2319 auint = SvUV(fromstr);
2320 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2326 aiv = SvIV(fromstr);
2327 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2333 auv = SvUV(fromstr);
2334 sv_catpvn(cat, (char*)&auv, UVSIZE);
2340 anv = SvNV(fromstr);
2343 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2345 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2346 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2347 any negative IVs will have already been got by the croak()
2348 above. IOK is untrue for fractions, so we test them
2349 against UV_MAX_P1. */
2350 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2352 char buf[(sizeof(UV)*8)/7+1];
2353 char *in = buf + sizeof(buf);
2354 UV auv = SvUV(fromstr);
2357 *--in = (char)((auv & 0x7f) | 0x80);
2360 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2361 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2363 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2364 char *from, *result, *in;
2369 /* Copy string and check for compliance */
2370 from = SvPV(fromstr, len);
2371 if ((norm = is_an_int(from, len)) == NULL)
2372 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2374 New('w', result, len, char);
2378 *--in = div128(norm, &done) | 0x80;
2379 result[len - 1] &= 0x7F; /* clear continue bit */
2380 sv_catpvn(cat, in, (result + len) - in);
2382 SvREFCNT_dec(norm); /* free norm */
2384 else if (SvNOKp(fromstr)) {
2385 /* 10**NV_MAX_10_EXP is the largest power of 10
2386 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2387 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2388 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2389 And with that many bytes only Inf can overflow.
2391 #ifdef NV_MAX_10_EXP
2392 char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)];
2394 char buf[1 + (int)((308 + 1) * 0.47456)];
2396 char *in = buf + sizeof(buf);
2398 anv = Perl_floor(anv);
2400 NV next = Perl_floor(anv / 128);
2401 if (in <= buf) /* this cannot happen ;-) */
2402 Perl_croak(aTHX_ "Cannot compress integer in pack");
2403 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2406 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2407 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2410 char *from, *result, *in;
2415 /* Copy string and check for compliance */
2416 from = SvPV(fromstr, len);
2417 if ((norm = is_an_int(from, len)) == NULL)
2418 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2420 New('w', result, len, char);
2424 *--in = div128(norm, &done) | 0x80;
2425 result[len - 1] &= 0x7F; /* clear continue bit */
2426 sv_catpvn(cat, in, (result + len) - in);
2428 SvREFCNT_dec(norm); /* free norm */
2433 case 'i' | TYPE_IS_SHRIEKING:
2436 aint = SvIV(fromstr);
2437 sv_catpvn(cat, (char*)&aint, sizeof(int));
2443 aulong = SvUV(fromstr);
2445 aulong = PerlSock_htonl(aulong);
2447 CAT32(cat, &aulong);
2453 aulong = SvUV(fromstr);
2455 aulong = htovl(aulong);
2457 CAT32(cat, &aulong);
2460 case 'L' | TYPE_IS_SHRIEKING:
2461 #if LONGSIZE != SIZE32
2463 unsigned long aulong;
2467 aulong = SvUV(fromstr);
2468 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2479 aulong = SvUV(fromstr);
2480 CAT32(cat, &aulong);
2484 case 'l' | TYPE_IS_SHRIEKING:
2485 #if LONGSIZE != SIZE32
2491 along = SvIV(fromstr);
2492 sv_catpvn(cat, (char *)&along, sizeof(long));
2502 along = SvIV(fromstr);
2510 auquad = (Uquad_t)SvUV(fromstr);
2511 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2517 aquad = (Quad_t)SvIV(fromstr);
2518 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2523 len = 1; /* assume SV is correct length */
2528 if (fromstr == &PL_sv_undef)
2532 /* XXX better yet, could spirit away the string to
2533 * a safe spot and hang on to it until the result
2534 * of pack() (and all copies of the result) are
2537 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2538 || (SvPADTMP(fromstr)
2539 && !SvREADONLY(fromstr))))
2541 Perl_warner(aTHX_ packWARN(WARN_PACK),
2542 "Attempt to pack pointer to temporary value");
2544 if (SvPOK(fromstr) || SvNIOK(fromstr))
2545 aptr = SvPV(fromstr,n_a);
2547 aptr = SvPV_force(fromstr,n_a);
2549 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2554 aptr = SvPV(fromstr, fromlen);
2555 SvGROW(cat, fromlen * 4 / 3);
2560 while (fromlen > 0) {
2563 if ((I32)fromlen > len)
2567 doencodes(cat, aptr, todo);
2573 *symptr = lookahead;
2582 dSP; dMARK; dORIGMARK; dTARGET;
2583 register SV *cat = TARG;
2585 register char *pat = SvPVx(*++MARK, fromlen);
2586 register char *patend = pat + fromlen;
2589 sv_setpvn(cat, "", 0);
2591 pack_cat(cat, pat, patend, MARK, SP + 1, NULL, FLAG_PACK);