/* pp_pack.c * * Copyright (c) 1991-2002, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * He still hopefully carried some of his gear in his pack: a small tinder-box, * two small shallow pans, the smaller fitting into the larger; inside them a * wooden spoon, a short two-pronged fork and some skewers were stowed; and * hidden at the bottom of the pack in a flat wooden box a dwindling treasure, * some salt. */ #include "EXTERN.h" #define PERL_IN_PP_PACK_C #include "perl.h" /* * The compiler on Concurrent CX/UX systems has a subtle bug which only * seems to show up when compiling pp.c - it generates the wrong double * precision constant value for (double)UV_MAX when used inline in the body * of the code below, so this makes a static variable up front (which the * compiler seems to get correct) and uses it in place of UV_MAX below. */ #ifdef CXUX_BROKEN_CONSTANT_CONVERT static double UV_MAX_cxux = ((double)UV_MAX); #endif /* * Offset for integer pack/unpack. * * On architectures where I16 and I32 aren't really 16 and 32 bits, * which for now are all Crays, pack and unpack have to play games. */ /* * These values are required for portability of pack() output. * If they're not right on your machine, then pack() and unpack() * wouldn't work right anyway; you'll need to apply the Cray hack. * (I'd like to check them with #if, but you can't use sizeof() in * the preprocessor.) --??? */ /* The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE defines are now in config.h. --Andy Dougherty April 1998 */ #define SIZE16 2 #define SIZE32 4 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack(). --jhi Feb 1999 */ #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32 # define PERL_NATINT_PACK #endif #if LONGSIZE > 4 && defined(_CRAY) # if BYTEORDER == 0x12345678 # define OFF16(p) (char*)(p) # define OFF32(p) (char*)(p) # else # if BYTEORDER == 0x87654321 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16)) # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32)) # else }}}} bad cray byte order # endif # endif # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char)) # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char)) # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char)) # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16) # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32) #else # define COPY16(s,p) Copy(s, p, SIZE16, char) # define COPY32(s,p) Copy(s, p, SIZE32, char) # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char) # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16) # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32) #endif STATIC SV * S_mul128(pTHX_ SV *sv, U8 m) { STRLEN len; char *s = SvPV(sv, len); char *t; U32 i = 0; if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ SV *tmpNew = newSVpvn("0000000000", 10); sv_catsv(tmpNew, sv); SvREFCNT_dec(sv); /* free old sv */ sv = tmpNew; s = SvPV(sv, len); } t = s + len - 1; while (!*t) /* trailing '\0'? */ t--; while (t > s) { i = ((*t - '0') << 7) + m; *(t--) = '0' + (i % 10); m = i / 10; } return (sv); } /* Explosives and implosives. */ #if 'I' == 73 && 'J' == 74 /* On an ASCII/ISO kind of system */ #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a') #else /* Some other sort of character set - use memchr() so we don't match the null byte. */ #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ') #endif #define UNPACK_ONLY_ONE 0x1 #define UNPACK_DO_UTF8 0x2 STATIC char * S_group_end(pTHX_ register char *pat, register char *patend, char ender) { while (pat < patend) { char c = *pat++; if (isSPACE(c)) continue; else if (c == ender) return --pat; else if (c == '#') { while (pat < patend && *pat != '\n') pat++; continue; } else if (c == '(') pat = group_end(pat, patend, ')') + 1; else if (c == '[') pat = group_end(pat, patend, ']') + 1; } Perl_croak(aTHX_ "No group ending character `%c' found", ender); } #define TYPE_IS_SHRIEKING 0x100 /* Returns the sizeof() struct described by pat */ STATIC I32 S_measure_struct(pTHX_ char *pat, register char *patend) { I32 datumtype; register I32 len; register I32 total = 0; int commas = 0; int star; /* 1 if count is *, -1 if no count given, -2 for / */ #ifdef PERL_NATINT_PACK int natint; /* native integer */ int unatint; /* unsigned native integer */ #endif char buf[2]; register int size; while ((pat = next_symbol(pat, patend)) < patend) { datumtype = *pat++ & 0xFF; #ifdef PERL_NATINT_PACK natint = 0; #endif if (*pat == '!') { static const char *natstr = "sSiIlLxX"; if (strchr(natstr, datumtype)) { if (datumtype == 'x' || datumtype == 'X') { datumtype |= TYPE_IS_SHRIEKING; } else { /* XXXX Should be redone similarly! */ #ifdef PERL_NATINT_PACK natint = 1; #endif } pat++; } else Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); } len = find_count(&pat, patend, &star); if (star > 0) /* */ Perl_croak(aTHX_ "%s not allowed in length fields", "count *"); else if (star < 0) /* No explicit len */ len = datumtype != '@'; switch(datumtype) { default: Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); case '@': case '/': case 'U': /* XXXX Is it correct? */ case 'w': case 'u': buf[0] = datumtype; buf[1] = 0; Perl_croak(aTHX_ "%s not allowed in length fields", buf); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_UNPACK)) Perl_warner(aTHX_ WARN_UNPACK, "Invalid type in unpack: '%c'", (int)datumtype); /* FALL THROUGH */ case '%': size = 0; break; case '(': { char *beg = pat, *end; if (star >= 0) Perl_croak(aTHX_ "()-group starts with a count"); end = group_end(beg, patend, ')'); pat = end + 1; len = find_count(&pat, patend, &star); if (star < 0) /* No count */ len = 1; else if (star > 0) /* Star */ Perl_croak(aTHX_ "%s not allowed in length fields", "count *"); /* XXXX Theoretically, we need to measure many times at different positions, since the subexpression may contain alignment commands, but be not of aligned length. Need to detect this and croak(). */ size = measure_struct(beg, end); break; } case 'X' | TYPE_IS_SHRIEKING: /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */ if (!len) /* Avoid division by 0 */ len = 1; len = total % len; /* Assumed: the start is aligned. */ /* FALL THROUGH */ case 'X': size = -1; if (total < len) Perl_croak(aTHX_ "X outside of string"); break; case 'x' | TYPE_IS_SHRIEKING: if (!len) /* Avoid division by 0 */ len = 1; star = total % len; /* Assumed: the start is aligned. */ if (star) /* Other portable ways? */ len = len - star; else len = 0; /* FALL THROUGH */ case 'x': case 'A': case 'Z': case 'a': case 'c': case 'C': size = 1; break; case 'B': case 'b': len = (len + 7)/8; size = 1; break; case 'H': case 'h': len = (len + 1)/2; size = 1; break; case 's': #if SHORTSIZE == SIZE16 size = SIZE16; #else size = (natint ? sizeof(short) : SIZE16); #endif break; case 'v': case 'n': case 'S': #if SHORTSIZE == SIZE16 size = SIZE16; #else unatint = natint && datumtype == 'S'; size = (unatint ? sizeof(unsigned short) : SIZE16); #endif break; case 'i': size = sizeof(int); break; case 'I': size = sizeof(unsigned int); break; case 'j': size = IVSIZE; break; case 'J': size = UVSIZE; break; case 'l': #if LONGSIZE == SIZE32 size = SIZE32; #else size = (natint ? sizeof(long) : SIZE32); #endif break; case 'V': case 'N': case 'L': #if LONGSIZE == SIZE32 size = SIZE32; #else unatint = natint && datumtype == 'L'; size = (unatint ? sizeof(unsigned long) : SIZE32); #endif break; case 'P': len = 1; /* FALL THROUGH */ case 'p': size = sizeof(char*); break; #ifdef HAS_QUAD case 'q': size = sizeof(Quad_t); break; case 'Q': size = sizeof(Uquad_t); break; #endif case 'f': size = sizeof(float); break; case 'd': size = sizeof(double); break; case 'F': size = NVSIZE; break; #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) case 'D': size = LONG_DOUBLESIZE; break; #endif } total += len * size; } return total; } /* Returns -1 on no count or on star */ STATIC I32 S_find_count(pTHX_ char **ppat, register char *patend, int *star) { char *pat = *ppat; I32 len; *star = 0; if (pat >= patend) len = 1; else if (*pat == '*') { pat++; *star = 1; len = -1; } else if (isDIGIT(*pat)) { len = *pat++ - '0'; while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); if (len < 0) /* 50% chance of catching... */ Perl_croak(aTHX_ "Repeat count in pack/unpack overflows"); } } else if (*pat == '[') { char *end = group_end(++pat, patend, ']'); len = 0; *ppat = end + 1; if (isDIGIT(*pat)) return find_count(&pat, end, star); return measure_struct(pat, end); } else len = *star = -1; *ppat = pat; return len; } STATIC char * S_next_symbol(pTHX_ register char *pat, register char *patend) { while (pat < patend) { if (isSPACE(*pat)) pat++; else if (*pat == '#') { pat++; while (pat < patend && *pat != '\n') pat++; if (pat < patend) pat++; } else return pat; } return pat; } /* =for apidoc unpack_str The engine implementing unpack() Perl function. =cut */ I32 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags) { dSP; I32 datumtype; register I32 len; register I32 bits = 0; register char *str; SV *sv; I32 start_sp_offset = SP - PL_stack_base; /* These must not be in registers: */ short ashort; int aint; long along; #ifdef HAS_QUAD Quad_t aquad; #endif U16 aushort; unsigned int auint; U32 aulong; #ifdef HAS_QUAD Uquad_t auquad; #endif char *aptr; float afloat; double adouble; I32 checksum = 0; UV cuv = 0; NV cdouble = 0.0; const int bits_in_uv = 8 * sizeof(cuv); int commas = 0; int star; /* 1 if count is *, -1 if no count given, -2 for / */ #ifdef PERL_NATINT_PACK int natint; /* native integer */ int unatint; /* unsigned native integer */ #endif IV aiv; UV auv; NV anv; #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) long double aldouble; #endif bool do_utf8 = flags & UNPACK_DO_UTF8; while ((pat = next_symbol(pat, patend)) < patend) { datumtype = *pat++ & 0xFF; #ifdef PERL_NATINT_PACK natint = 0; #endif /* do first one only unless in list context / is implemented by unpacking the count, then poping it from the stack, so must check that we're not in the middle of a / */ if ( (flags & UNPACK_ONLY_ONE) && (SP - PL_stack_base == start_sp_offset + 1) && (datumtype != '/') ) break; if (*pat == '!') { static const char natstr[] = "sSiIlLxX"; if (strchr(natstr, datumtype)) { if (datumtype == 'x' || datumtype == 'X') { datumtype |= TYPE_IS_SHRIEKING; } else { /* XXXX Should be redone similarly! */ #ifdef PERL_NATINT_PACK natint = 1; #endif } pat++; } else Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); } len = find_count(&pat, patend, &star); if (star > 0) len = strend - strbeg; /* long enough */ else if (star < 0) /* No explicit len */ len = datumtype != '@'; redo_switch: switch(datumtype) { default: Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_UNPACK)) Perl_warner(aTHX_ WARN_UNPACK, "Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1' && pat[-1] != ']') len = 16; /* len is not specified */ checksum = len; cuv = 0; cdouble = 0; continue; break; case '(': { char *beg = pat; char *ss = s; /* Move from register */ if (star >= 0) Perl_croak(aTHX_ "()-group starts with a count"); aptr = group_end(beg, patend, ')'); pat = aptr + 1; if (star != -2) { len = find_count(&pat, patend, &star); if (star < 0) /* No count */ len = 1; else if (star > 0) /* Star */ len = strend - strbeg; /* long enough? */ } PUTBACK; while (len--) { unpack_str(beg, aptr, ss, strbeg, strend, &ss, ocnt + SP - PL_stack_base - start_sp_offset, flags); if (star > 0 && ss == strend) break; /* No way to continue */ } SPAGAIN; s = ss; break; } case '@': if (len > strend - strbeg) Perl_croak(aTHX_ "@ outside of string"); s = strbeg + len; break; case 'X' | TYPE_IS_SHRIEKING: if (!len) /* Avoid division by 0 */ len = 1; len = (s - strbeg) % len; /* FALL THROUGH */ case 'X': if (len > s - strbeg) Perl_croak(aTHX_ "X outside of string"); s -= len; break; case 'x' | TYPE_IS_SHRIEKING: if (!len) /* Avoid division by 0 */ len = 1; aint = (s - strbeg) % len; if (aint) /* Other portable ways? */ len = len - aint; else len = 0; /* FALL THROUGH */ case 'x': if (len > strend - s) Perl_croak(aTHX_ "x outside of string"); s += len; break; case '/': if (ocnt + SP - PL_stack_base - start_sp_offset <= 0) Perl_croak(aTHX_ "/ must follow a numeric type"); datumtype = *pat++; if (*pat == '*') pat++; /* ignore '*' for compatibility with pack */ if (isDIGIT(*pat)) Perl_croak(aTHX_ "/ cannot take a count" ); len = POPi; star = -2; goto redo_switch; case 'A': case 'Z': case 'a': if (len > strend - s) len = strend - s; if (checksum) goto uchar_checksum; sv = NEWSV(35, len); sv_setpvn(sv, s, len); if (datumtype == 'A' || datumtype == 'Z') { aptr = s; /* borrow register */ if (datumtype == 'Z') { /* 'Z' strips stuff after first null */ s = SvPVX(sv); while (*s) s++; if (star > 0) /* exact for 'Z*' */ len = s - SvPVX(sv) + 1; } else { /* 'A' strips both nulls and spaces */ s = SvPVX(sv) + len - 1; while (s >= SvPVX(sv) && (!*s || isSPACE(*s))) s--; *++s = '\0'; } SvCUR_set(sv, s - SvPVX(sv)); s = aptr; /* unborrow register */ } s += len; XPUSHs(sv_2mortal(sv)); break; case 'B': case 'b': if (star > 0 || len > (strend - s) * 8) len = (strend - s) * 8; if (checksum) { if (!PL_bitcount) { Newz(601, PL_bitcount, 256, char); for (bits = 1; bits < 256; bits++) { if (bits & 1) PL_bitcount[bits]++; if (bits & 2) PL_bitcount[bits]++; if (bits & 4) PL_bitcount[bits]++; if (bits & 8) PL_bitcount[bits]++; if (bits & 16) PL_bitcount[bits]++; if (bits & 32) PL_bitcount[bits]++; if (bits & 64) PL_bitcount[bits]++; if (bits & 128) PL_bitcount[bits]++; } } while (len >= 8) { cuv += PL_bitcount[*(unsigned char*)s++]; len -= 8; } if (len) { bits = *s; if (datumtype == 'b') { while (len-- > 0) { if (bits & 1) cuv++; bits >>= 1; } } else { while (len-- > 0) { if (bits & 128) cuv++; bits <<= 1; } } } break; } sv = NEWSV(35, len + 1); SvCUR_set(sv, len); SvPOK_on(sv); str = SvPVX(sv); if (datumtype == 'b') { aint = len; for (len = 0; len < aint; len++) { if (len & 7) /*SUPPRESS 595*/ bits >>= 1; else bits = *s++; *str++ = '0' + (bits & 1); } } else { aint = len; for (len = 0; len < aint; len++) { if (len & 7) bits <<= 1; else bits = *s++; *str++ = '0' + ((bits & 128) != 0); } } *str = '\0'; XPUSHs(sv_2mortal(sv)); break; case 'H': case 'h': if (star > 0 || len > (strend - s) * 2) len = (strend - s) * 2; sv = NEWSV(35, len + 1); SvCUR_set(sv, len); SvPOK_on(sv); str = SvPVX(sv); if (datumtype == 'h') { aint = len; for (len = 0; len < aint; len++) { if (len & 1) bits >>= 4; else bits = *s++; *str++ = PL_hexdigit[bits & 15]; } } else { aint = len; for (len = 0; len < aint; len++) { if (len & 1) bits <<= 4; else bits = *s++; *str++ = PL_hexdigit[(bits >> 4) & 15]; } } *str = '\0'; XPUSHs(sv_2mortal(sv)); break; case 'c': if (len > strend - s) len = strend - s; if (checksum) { while (len-- > 0) { aint = *s++; if (aint >= 128) /* fake up signed chars */ aint -= 256; if (checksum > bits_in_uv) cdouble += (NV)aint; else cuv += aint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { aint = *s++; if (aint >= 128) /* fake up signed chars */ aint -= 256; sv = NEWSV(36, 0); sv_setiv(sv, (IV)aint); PUSHs(sv_2mortal(sv)); } } break; case 'C': unpack_C: /* unpack U will jump here if not UTF-8 */ if (len == 0) { do_utf8 = FALSE; break; } if (len > strend - s) len = strend - s; if (checksum) { uchar_checksum: while (len-- > 0) { auint = *s++ & 255; cuv += auint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { auint = *s++ & 255; sv = NEWSV(37, 0); sv_setiv(sv, (IV)auint); PUSHs(sv_2mortal(sv)); } } break; case 'U': if (len == 0) { do_utf8 = TRUE; break; } if (!do_utf8) goto unpack_C; if (len > strend - s) len = strend - s; if (checksum) { while (len-- > 0 && s < strend) { STRLEN alen; auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, 0)); along = alen; s += along; if (checksum > bits_in_uv) cdouble += (NV)auint; else cuv += auint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0 && s < strend) { STRLEN alen; auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, 0)); along = alen; s += along; sv = NEWSV(37, 0); sv_setuv(sv, (UV)auint); PUSHs(sv_2mortal(sv)); } } break; case 's': #if SHORTSIZE == SIZE16 along = (strend - s) / SIZE16; #else along = (strend - s) / (natint ? sizeof(short) : SIZE16); #endif if (len > along) len = along; if (checksum) { #if SHORTSIZE != SIZE16 if (natint) { short ashort; while (len-- > 0) { COPYNN(s, &ashort, sizeof(short)); s += sizeof(short); if (checksum > bits_in_uv) cdouble += (NV)ashort; else cuv += ashort; } } else #endif { while (len-- > 0) { COPY16(s, &ashort); #if SHORTSIZE > SIZE16 if (ashort > 32767) ashort -= 65536; #endif s += SIZE16; if (checksum > bits_in_uv) cdouble += (NV)ashort; else cuv += ashort; } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); #if SHORTSIZE != SIZE16 if (natint) { short ashort; while (len-- > 0) { COPYNN(s, &ashort, sizeof(short)); s += sizeof(short); sv = NEWSV(38, 0); sv_setiv(sv, (IV)ashort); PUSHs(sv_2mortal(sv)); } } else #endif { while (len-- > 0) { COPY16(s, &ashort); #if SHORTSIZE > SIZE16 if (ashort > 32767) ashort -= 65536; #endif s += SIZE16; sv = NEWSV(38, 0); sv_setiv(sv, (IV)ashort); PUSHs(sv_2mortal(sv)); } } } break; case 'v': case 'n': case 'S': #if SHORTSIZE == SIZE16 along = (strend - s) / SIZE16; #else unatint = natint && datumtype == 'S'; along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16); #endif if (len > along) len = along; if (checksum) { #if SHORTSIZE != SIZE16 if (unatint) { unsigned short aushort; while (len-- > 0) { COPYNN(s, &aushort, sizeof(unsigned short)); s += sizeof(unsigned short); if (checksum > bits_in_uv) cdouble += (NV)aushort; else cuv += aushort; } } else #endif { while (len-- > 0) { COPY16(s, &aushort); s += SIZE16; #ifdef HAS_NTOHS if (datumtype == 'n') aushort = PerlSock_ntohs(aushort); #endif #ifdef HAS_VTOHS if (datumtype == 'v') aushort = vtohs(aushort); #endif if (checksum > bits_in_uv) cdouble += (NV)aushort; else cuv += aushort; } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); #if SHORTSIZE != SIZE16 if (unatint) { unsigned short aushort; while (len-- > 0) { COPYNN(s, &aushort, sizeof(unsigned short)); s += sizeof(unsigned short); sv = NEWSV(39, 0); sv_setiv(sv, (UV)aushort); PUSHs(sv_2mortal(sv)); } } else #endif { while (len-- > 0) { COPY16(s, &aushort); s += SIZE16; sv = NEWSV(39, 0); #ifdef HAS_NTOHS if (datumtype == 'n') aushort = PerlSock_ntohs(aushort); #endif #ifdef HAS_VTOHS if (datumtype == 'v') aushort = vtohs(aushort); #endif sv_setiv(sv, (UV)aushort); PUSHs(sv_2mortal(sv)); } } } break; case 'i': along = (strend - s) / sizeof(int); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &aint, 1, int); s += sizeof(int); if (checksum > bits_in_uv) cdouble += (NV)aint; else cuv += aint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &aint, 1, int); s += sizeof(int); sv = NEWSV(40, 0); #ifdef __osf__ /* Without the dummy below unpack("i", pack("i",-1)) * return 0xFFffFFff instead of -1 for Digital Unix V4.0 * cc with optimization turned on. * * The bug was detected in * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E) * with optimization (-O4) turned on. * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B) * does not have this problem even with -O4. * * This bug was reported as DECC_BUGS 1431 * and tracked internally as GEM_BUGS 7775. * * The bug is fixed in * Tru64 UNIX V5.0: Compaq C V6.1-006 or later * UNIX V4.0F support: DEC C V5.9-006 or later * UNIX V4.0E support: DEC C V5.8-011 or later * and also in DTK. * * See also few lines later for the same bug. */ (aint) ? sv_setiv(sv, (IV)aint) : #endif sv_setiv(sv, (IV)aint); PUSHs(sv_2mortal(sv)); } } break; case 'I': along = (strend - s) / sizeof(unsigned int); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); if (checksum > bits_in_uv) cdouble += (NV)auint; else cuv += auint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); sv = NEWSV(41, 0); #ifdef __osf__ /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF)) * returns 1.84467440737096e+19 instead of 0xFFFFFFFF. * See details few lines earlier. */ (auint) ? sv_setuv(sv, (UV)auint) : #endif sv_setuv(sv, (UV)auint); PUSHs(sv_2mortal(sv)); } } break; case 'j': along = (strend - s) / IVSIZE; if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &aiv, 1, IV); s += IVSIZE; if (checksum > bits_in_uv) cdouble += (NV)aiv; else cuv += aiv; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &aiv, 1, IV); s += IVSIZE; sv = NEWSV(40, 0); sv_setiv(sv, aiv); PUSHs(sv_2mortal(sv)); } } break; case 'J': along = (strend - s) / UVSIZE; if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &auv, 1, UV); s += UVSIZE; if (checksum > bits_in_uv) cdouble += (NV)auv; else cuv += auv; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &auv, 1, UV); s += UVSIZE; sv = NEWSV(41, 0); sv_setuv(sv, auv); PUSHs(sv_2mortal(sv)); } } break; case 'l': #if LONGSIZE == SIZE32 along = (strend - s) / SIZE32; #else along = (strend - s) / (natint ? sizeof(long) : SIZE32); #endif if (len > along) len = along; if (checksum) { #if LONGSIZE != SIZE32 if (natint) { while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); if (checksum > bits_in_uv) cdouble += (NV)along; else cuv += along; } } else #endif { while (len-- > 0) { #if LONGSIZE > SIZE32 && INTSIZE == SIZE32 I32 along; #endif COPY32(s, &along); #if LONGSIZE > SIZE32 if (along > 2147483647) along -= 4294967296; #endif s += SIZE32; if (checksum > bits_in_uv) cdouble += (NV)along; else cuv += along; } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 if (natint) { while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); sv = NEWSV(42, 0); sv_setiv(sv, (IV)along); PUSHs(sv_2mortal(sv)); } } else #endif { while (len-- > 0) { #if LONGSIZE > SIZE32 && INTSIZE == SIZE32 I32 along; #endif COPY32(s, &along); #if LONGSIZE > SIZE32 if (along > 2147483647) along -= 4294967296; #endif s += SIZE32; sv = NEWSV(42, 0); sv_setiv(sv, (IV)along); PUSHs(sv_2mortal(sv)); } } } break; case 'V': case 'N': case 'L': #if LONGSIZE == SIZE32 along = (strend - s) / SIZE32; #else unatint = natint && datumtype == 'L'; along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32); #endif if (len > along) len = along; if (checksum) { #if LONGSIZE != SIZE32 if (unatint) { unsigned long aulong; while (len-- > 0) { COPYNN(s, &aulong, sizeof(unsigned long)); s += sizeof(unsigned long); if (checksum > bits_in_uv) cdouble += (NV)aulong; else cuv += aulong; } } else #endif { while (len-- > 0) { COPY32(s, &aulong); s += SIZE32; #ifdef HAS_NTOHL if (datumtype == 'N') aulong = PerlSock_ntohl(aulong); #endif #ifdef HAS_VTOHL if (datumtype == 'V') aulong = vtohl(aulong); #endif if (checksum > bits_in_uv) cdouble += (NV)aulong; else cuv += aulong; } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 if (unatint) { unsigned long aulong; while (len-- > 0) { COPYNN(s, &aulong, sizeof(unsigned long)); s += sizeof(unsigned long); sv = NEWSV(43, 0); sv_setuv(sv, (UV)aulong); PUSHs(sv_2mortal(sv)); } } else #endif { while (len-- > 0) { COPY32(s, &aulong); s += SIZE32; #ifdef HAS_NTOHL if (datumtype == 'N') aulong = PerlSock_ntohl(aulong); #endif #ifdef HAS_VTOHL if (datumtype == 'V') aulong = vtohl(aulong); #endif sv = NEWSV(43, 0); sv_setuv(sv, (UV)aulong); PUSHs(sv_2mortal(sv)); } } } break; case 'p': along = (strend - s) / sizeof(char*); if (len > along) len = along; EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { if (sizeof(char*) > strend - s) break; else { Copy(s, &aptr, 1, char*); s += sizeof(char*); } sv = NEWSV(44, 0); if (aptr) sv_setpv(sv, aptr); PUSHs(sv_2mortal(sv)); } break; case 'w': EXTEND(SP, len); EXTEND_MORTAL(len); { UV auv = 0; U32 bytes = 0; while ((len > 0) && (s < strend)) { auv = (auv << 7) | (*s & 0x7f); /* UTF8_IS_XXXXX not right here - using constant 0x80 */ if ((U8)(*s++) < 0x80) { bytes = 0; sv = NEWSV(40, 0); sv_setuv(sv, auv); PUSHs(sv_2mortal(sv)); len--; auv = 0; } else if (++bytes >= sizeof(UV)) { /* promote to string */ char *t; STRLEN n_a; sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv); while (s < strend) { sv = mul128(sv, *s & 0x7f); if (!(*s++ & 0x80)) { bytes = 0; break; } } t = SvPV(sv, n_a); while (*t == '0') t++; sv_chop(sv, t); PUSHs(sv_2mortal(sv)); len--; auv = 0; } } if ((s >= strend) && bytes) Perl_croak(aTHX_ "Unterminated compressed integer"); } break; case 'P': if (star > 0) Perl_croak(aTHX_ "P must have an explicit size"); EXTEND(SP, 1); if (sizeof(char*) > strend - s) break; else { Copy(s, &aptr, 1, char*); s += sizeof(char*); } sv = NEWSV(44, 0); if (aptr) sv_setpvn(sv, aptr, len); PUSHs(sv_2mortal(sv)); break; #ifdef HAS_QUAD case 'q': along = (strend - s) / sizeof(Quad_t); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &aquad, 1, Quad_t); s += sizeof(Quad_t); if (checksum > bits_in_uv) cdouble += (NV)aquad; else cuv += aquad; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { if (s + sizeof(Quad_t) > strend) aquad = 0; else { Copy(s, &aquad, 1, Quad_t); s += sizeof(Quad_t); } sv = NEWSV(42, 0); if (aquad >= IV_MIN && aquad <= IV_MAX) sv_setiv(sv, (IV)aquad); else sv_setnv(sv, (NV)aquad); PUSHs(sv_2mortal(sv)); } } break; case 'Q': along = (strend - s) / sizeof(Uquad_t); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &auquad, 1, Uquad_t); s += sizeof(Uquad_t); if (checksum > bits_in_uv) cdouble += (NV)auquad; else cuv += auquad; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { if (s + sizeof(Uquad_t) > strend) auquad = 0; else { Copy(s, &auquad, 1, Uquad_t); s += sizeof(Uquad_t); } sv = NEWSV(43, 0); if (auquad <= UV_MAX) sv_setuv(sv, (UV)auquad); else sv_setnv(sv, (NV)auquad); PUSHs(sv_2mortal(sv)); } } break; #endif /* float and double added gnb@melba.bby.oz.au 22/11/89 */ case 'f': along = (strend - s) / sizeof(float); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &afloat, 1, float); s += sizeof(float); cdouble += afloat; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &afloat, 1, float); s += sizeof(float); sv = NEWSV(47, 0); sv_setnv(sv, (NV)afloat); PUSHs(sv_2mortal(sv)); } } break; case 'd': along = (strend - s) / sizeof(double); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &adouble, 1, double); s += sizeof(double); cdouble += adouble; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &adouble, 1, double); s += sizeof(double); sv = NEWSV(48, 0); sv_setnv(sv, (NV)adouble); PUSHs(sv_2mortal(sv)); } } break; case 'F': along = (strend - s) / NVSIZE; if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &anv, 1, NV); s += NVSIZE; cdouble += anv; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &anv, 1, NV); s += NVSIZE; sv = NEWSV(48, 0); sv_setnv(sv, anv); PUSHs(sv_2mortal(sv)); } } break; #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) case 'D': along = (strend - s) / LONG_DOUBLESIZE; if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &aldouble, 1, long double); s += LONG_DOUBLESIZE; cdouble += aldouble; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &aldouble, 1, long double); s += LONG_DOUBLESIZE; sv = NEWSV(48, 0); sv_setnv(sv, (NV)aldouble); PUSHs(sv_2mortal(sv)); } } break; #endif case 'u': /* MKS: * Initialise the decode mapping. By using a table driven * algorithm, the code will be character-set independent * (and just as fast as doing character arithmetic) */ if (PL_uudmap['M'] == 0) { int i; for (i = 0; i < sizeof(PL_uuemap); i += 1) PL_uudmap[(U8)PL_uuemap[i]] = i; /* * Because ' ' and '`' map to the same value, * we need to decode them both the same. */ PL_uudmap[' '] = 0; } along = (strend - s) * 3 / 4; sv = NEWSV(42, along); if (along) SvPOK_on(sv); while (s < strend && *s > ' ' && ISUUCHAR(*s)) { I32 a, b, c, d; char hunk[4]; hunk[3] = '\0'; len = PL_uudmap[*(U8*)s++] & 077; while (len > 0) { if (s < strend && ISUUCHAR(*s)) a = PL_uudmap[*(U8*)s++] & 077; else a = 0; if (s < strend && ISUUCHAR(*s)) b = PL_uudmap[*(U8*)s++] & 077; else b = 0; if (s < strend && ISUUCHAR(*s)) c = PL_uudmap[*(U8*)s++] & 077; else c = 0; if (s < strend && ISUUCHAR(*s)) d = PL_uudmap[*(U8*)s++] & 077; else d = 0; hunk[0] = (a << 2) | (b >> 4); hunk[1] = (b << 4) | (c >> 2); hunk[2] = (c << 6) | d; sv_catpvn(sv, hunk, (len > 3) ? 3 : len); len -= 3; } if (*s == '\n') s++; else if (s[1] == '\n') /* possible checksum byte */ s += 2; } XPUSHs(sv_2mortal(sv)); break; } if (checksum) { sv = NEWSV(42, 0); if (strchr("fFdD", datumtype) || (checksum > bits_in_uv && strchr("csSiIlLnNUvVqQjJ", datumtype)) ) { NV trouble; adouble = (NV) (1 << (checksum & 15)); while (checksum >= 16) { checksum -= 16; adouble *= 65536.0; } while (cdouble < 0.0) cdouble += adouble; cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; sv_setnv(sv, cdouble); } else { if (checksum < bits_in_uv) { UV mask = ((UV)1 << checksum) - 1; cuv &= mask; } sv_setuv(sv, cuv); } XPUSHs(sv_2mortal(sv)); checksum = 0; } } if (new_s) *new_s = s; PUTBACK; return SP - PL_stack_base - start_sp_offset; } PP(pp_unpack) { dSP; dPOPPOPssrl; I32 gimme = GIMME_V; STRLEN llen; STRLEN rlen; register char *pat = SvPV(left, llen); #ifdef PACKED_IS_OCTETS /* Packed side is assumed to be octets - so force downgrade if it has been UTF-8 encoded by accident */ register char *s = SvPVbyte(right, rlen); #else register char *s = SvPV(right, rlen); #endif char *strend = s + rlen; register char *patend = pat + llen; register I32 cnt; PUTBACK; cnt = unpack_str(pat, patend, s, s, strend, NULL, 0, ((gimme == G_SCALAR) ? UNPACK_ONLY_ONE : 0) | (DO_UTF8(right) ? UNPACK_DO_UTF8 : 0)); SPAGAIN; if ( !cnt && gimme == G_SCALAR ) PUSHs(&PL_sv_undef); RETURN; } STATIC void S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len) { char hunk[5]; *hunk = PL_uuemap[len]; sv_catpvn(sv, hunk, 1); hunk[4] = '\0'; while (len > 2) { hunk[0] = PL_uuemap[(077 & (*s >> 2))]; hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))]; hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))]; hunk[3] = PL_uuemap[(077 & (s[2] & 077))]; sv_catpvn(sv, hunk, 4); s += 3; len -= 3; } if (len > 0) { char r = (len > 1 ? s[1] : '\0'); hunk[0] = PL_uuemap[(077 & (*s >> 2))]; hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))]; hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))]; hunk[3] = PL_uuemap[0]; sv_catpvn(sv, hunk, 4); } sv_catpvn(sv, "\n", 1); } STATIC SV * S_is_an_int(pTHX_ char *s, STRLEN l) { STRLEN n_a; SV *result = newSVpvn(s, l); char *result_c = SvPV(result, n_a); /* convenience */ char *out = result_c; bool skip = 1; bool ignore = 0; while (*s) { switch (*s) { case ' ': break; case '+': if (!skip) { SvREFCNT_dec(result); return (NULL); } break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': skip = 0; if (!ignore) { *(out++) = *s; } break; case '.': ignore = 1; break; default: SvREFCNT_dec(result); return (NULL); } s++; } *(out++) = '\0'; SvCUR_set(result, out - result_c); return (result); } /* pnum must be '\0' terminated */ STATIC int S_div128(pTHX_ SV *pnum, bool *done) { STRLEN len; char *s = SvPV(pnum, len); int m = 0; int r = 0; char *t = s; *done = 1; while (*t) { int i; i = m * 10 + (*t - '0'); m = i & 0x7F; r = (i >> 7); /* r < 10 */ if (r) { *done = 0; } *(t++) = '0' + r; } *(t++) = '\0'; SvCUR_set(pnum, (STRLEN) (t - s)); return (m); } #define PACK_CHILD 0x1 /* =for apidoc pack_cat The engine implementing pack() Perl function. =cut */ void Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags) { register I32 items; STRLEN fromlen; register I32 len; I32 datumtype; SV *fromstr; /*SUPPRESS 442*/ static char null10[] = {0,0,0,0,0,0,0,0,0,0}; static char *space10 = " "; int star; /* These must not be in registers: */ char achar; I16 ashort; int aint; unsigned int auint; I32 along; U32 aulong; IV aiv; UV auv; NV anv; #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) long double aldouble; #endif #ifdef HAS_QUAD Quad_t aquad; Uquad_t auquad; #endif char *aptr; float afloat; double adouble; int commas = 0; #ifdef PERL_NATINT_PACK int natint; /* native integer */ #endif items = endlist - beglist; #ifndef PACKED_IS_OCTETS pat = next_symbol(pat, patend); if (pat < patend && *pat == 'U' && !flags) SvUTF8_on(cat); #endif while ((pat = next_symbol(pat, patend)) < patend) { SV *lengthcode = Nullsv; #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no) datumtype = *pat++ & 0xFF; #ifdef PERL_NATINT_PACK natint = 0; #endif if (*pat == '!') { static const char natstr[] = "sSiIlLxX"; if (strchr(natstr, datumtype)) { if (datumtype == 'x' || datumtype == 'X') { datumtype |= TYPE_IS_SHRIEKING; } else { /* XXXX Should be redone similarly! */ #ifdef PERL_NATINT_PACK natint = 1; #endif } pat++; } else Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); } len = find_count(&pat, patend, &star); if (star > 0) /* Count is '*' */ len = strchr("@Xxu", datumtype) ? 0 : items; else if (star < 0) /* Default len */ len = 1; if (*pat == '/') { /* doing lookahead how... */ ++pat; if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*') Perl_croak(aTHX_ "/ must be followed by a*, A* or Z*"); lengthcode = sv_2mortal(newSViv(sv_len(items > 0 ? *beglist : &PL_sv_no) + (*pat == 'Z' ? 1 : 0))); } switch(datumtype) { default: Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_PACK)) Perl_warner(aTHX_ WARN_PACK, "Invalid type in pack: '%c'", (int)datumtype); break; case '%': Perl_croak(aTHX_ "%% may only be used in unpack"); case '@': len -= SvCUR(cat); if (len > 0) goto grow; len = -len; if (len > 0) goto shrink; break; case '(': { char *beg = pat; SV **savebeglist = beglist; /* beglist de-register-ed */ if (star >= 0) Perl_croak(aTHX_ "()-group starts with a count"); aptr = group_end(beg, patend, ')'); pat = aptr + 1; if (star != -2) { len = find_count(&pat, patend, &star); if (star < 0) /* No count */ len = 1; else if (star > 0) /* Star */ len = items; /* long enough? */ } while (len--) { pack_cat(cat, beg, aptr, savebeglist, endlist, &savebeglist, PACK_CHILD); if (star > 0 && savebeglist == endlist) break; /* No way to continue */ } beglist = savebeglist; break; } case 'X' | TYPE_IS_SHRIEKING: if (!len) /* Avoid division by 0 */ len = 1; len = (SvCUR(cat)) % len; /* FALL THROUGH */ case 'X': shrink: if (SvCUR(cat) < len) Perl_croak(aTHX_ "X outside of string"); SvCUR(cat) -= len; *SvEND(cat) = '\0'; break; case 'x' | TYPE_IS_SHRIEKING: if (!len) /* Avoid division by 0 */ len = 1; aint = (SvCUR(cat)) % len; if (aint) /* Other portable ways? */ len = len - aint; else len = 0; /* FALL THROUGH */ case 'x': grow: while (len >= 10) { sv_catpvn(cat, null10, 10); len -= 10; } sv_catpvn(cat, null10, len); break; case 'A': case 'Z': case 'a': fromstr = NEXTFROM; aptr = SvPV(fromstr, fromlen); if (star > 0) { /* -2 after '/' */ len = fromlen; if (datumtype == 'Z') ++len; } if (fromlen >= len) { sv_catpvn(cat, aptr, len); if (datumtype == 'Z') *(SvEND(cat)-1) = '\0'; } else { sv_catpvn(cat, aptr, fromlen); len -= fromlen; if (datumtype == 'A') { while (len >= 10) { sv_catpvn(cat, space10, 10); len -= 10; } sv_catpvn(cat, space10, len); } else { while (len >= 10) { sv_catpvn(cat, null10, 10); len -= 10; } sv_catpvn(cat, null10, len); } } break; case 'B': case 'b': { register char *str; I32 saveitems; fromstr = NEXTFROM; saveitems = items; str = SvPV(fromstr, fromlen); if (star > 0) len = fromlen; aint = SvCUR(cat); SvCUR(cat) += (len+7)/8; SvGROW(cat, SvCUR(cat) + 1); aptr = SvPVX(cat) + aint; if (len > fromlen) len = fromlen; aint = len; items = 0; if (datumtype == 'B') { for (len = 0; len++ < aint;) { items |= *str++ & 1; if (len & 7) items <<= 1; else { *aptr++ = items & 0xff; items = 0; } } } else { for (len = 0; len++ < aint;) { if (*str++ & 1) items |= 128; if (len & 7) items >>= 1; else { *aptr++ = items & 0xff; items = 0; } } } if (aint & 7) { if (datumtype == 'B') items <<= 7 - (aint & 7); else items >>= 7 - (aint & 7); *aptr++ = items & 0xff; } str = SvPVX(cat) + SvCUR(cat); while (aptr <= str) *aptr++ = '\0'; items = saveitems; } break; case 'H': case 'h': { register char *str; I32 saveitems; fromstr = NEXTFROM; saveitems = items; str = SvPV(fromstr, fromlen); if (star > 0) len = fromlen; aint = SvCUR(cat); SvCUR(cat) += (len+1)/2; SvGROW(cat, SvCUR(cat) + 1); aptr = SvPVX(cat) + aint; if (len > fromlen) len = fromlen; aint = len; items = 0; if (datumtype == 'H') { for (len = 0; len++ < aint;) { if (isALPHA(*str)) items |= ((*str++ & 15) + 9) & 15; else items |= *str++ & 15; if (len & 1) items <<= 4; else { *aptr++ = items & 0xff; items = 0; } } } else { for (len = 0; len++ < aint;) { if (isALPHA(*str)) items |= (((*str++ & 15) + 9) & 15) << 4; else items |= (*str++ & 15) << 4; if (len & 1) items >>= 4; else { *aptr++ = items & 0xff; items = 0; } } } if (aint & 1) *aptr++ = items & 0xff; str = SvPVX(cat) + SvCUR(cat); while (aptr <= str) *aptr++ = '\0'; items = saveitems; } break; case 'C': case 'c': while (len-- > 0) { fromstr = NEXTFROM; switch (datumtype) { case 'C': aint = SvIV(fromstr); if ((aint < 0 || aint > 255) && ckWARN(WARN_PACK)) Perl_warner(aTHX_ WARN_PACK, "Character in \"C\" format wrapped"); achar = aint & 255; sv_catpvn(cat, &achar, sizeof(char)); break; case 'c': aint = SvIV(fromstr); if ((aint < -128 || aint > 127) && ckWARN(WARN_PACK)) Perl_warner(aTHX_ WARN_PACK, "Character in \"c\" format wrapped"); achar = aint & 255; sv_catpvn(cat, &achar, sizeof(char)); break; } } break; case 'U': while (len-- > 0) { fromstr = NEXTFROM; auint = UNI_TO_NATIVE(SvUV(fromstr)); SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1); SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint) - SvPVX(cat)); } *SvEND(cat) = '\0'; break; /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ case 'f': while (len-- > 0) { fromstr = NEXTFROM; afloat = (float)SvNV(fromstr); sv_catpvn(cat, (char *)&afloat, sizeof (float)); } break; case 'd': while (len-- > 0) { fromstr = NEXTFROM; adouble = (double)SvNV(fromstr); sv_catpvn(cat, (char *)&adouble, sizeof (double)); } break; case 'F': while (len-- > 0) { fromstr = NEXTFROM; anv = SvNV(fromstr); sv_catpvn(cat, (char *)&anv, NVSIZE); } break; #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) case 'D': while (len-- > 0) { fromstr = NEXTFROM; aldouble = (long double)SvNV(fromstr); sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE); } break; #endif case 'n': while (len-- > 0) { fromstr = NEXTFROM; ashort = (I16)SvIV(fromstr); #ifdef HAS_HTONS ashort = PerlSock_htons(ashort); #endif CAT16(cat, &ashort); } break; case 'v': while (len-- > 0) { fromstr = NEXTFROM; ashort = (I16)SvIV(fromstr); #ifdef HAS_HTOVS ashort = htovs(ashort); #endif CAT16(cat, &ashort); } break; case 'S': #if SHORTSIZE != SIZE16 if (natint) { unsigned short aushort; while (len-- > 0) { fromstr = NEXTFROM; aushort = SvUV(fromstr); sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short)); } } else #endif { U16 aushort; while (len-- > 0) { fromstr = NEXTFROM; aushort = (U16)SvUV(fromstr); CAT16(cat, &aushort); } } break; case 's': #if SHORTSIZE != SIZE16 if (natint) { short ashort; while (len-- > 0) { fromstr = NEXTFROM; ashort = SvIV(fromstr); sv_catpvn(cat, (char *)&ashort, sizeof(short)); } } else #endif { while (len-- > 0) { fromstr = NEXTFROM; ashort = (I16)SvIV(fromstr); CAT16(cat, &ashort); } } break; case 'I': while (len-- > 0) { fromstr = NEXTFROM; auint = SvUV(fromstr); sv_catpvn(cat, (char*)&auint, sizeof(unsigned int)); } break; case 'j': while (len-- > 0) { fromstr = NEXTFROM; aiv = SvIV(fromstr); sv_catpvn(cat, (char*)&aiv, IVSIZE); } break; case 'J': while (len-- > 0) { fromstr = NEXTFROM; auv = SvUV(fromstr); sv_catpvn(cat, (char*)&auv, UVSIZE); } break; case 'w': while (len-- > 0) { fromstr = NEXTFROM; adouble = Perl_floor(SvNV(fromstr)); if (adouble < 0) Perl_croak(aTHX_ "Cannot compress negative numbers"); if ( #if UVSIZE > 4 && UVSIZE >= NVSIZE adouble <= 0xffffffff #else # ifdef CXUX_BROKEN_CONSTANT_CONVERT adouble <= UV_MAX_cxux # else adouble <= UV_MAX # endif #endif ) { char buf[1 + sizeof(UV)]; char *in = buf + sizeof(buf); UV auv = U_V(adouble); do { *--in = (auv & 0x7f) | 0x80; auv >>= 7; } while (auv); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ sv_catpvn(cat, in, (buf + sizeof(buf)) - in); } else if (SvPOKp(fromstr)) { /* decimal string arithmetics */ char *from, *result, *in; SV *norm; STRLEN len; bool done; /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) Perl_croak(aTHX_ "can compress only unsigned integer"); New('w', result, len, char); in = result + len; done = FALSE; while (!done) *--in = div128(norm, &done) | 0x80; result[len - 1] &= 0x7F; /* clear continue bit */ sv_catpvn(cat, in, (result + len) - in); Safefree(result); SvREFCNT_dec(norm); /* free norm */ } else if (SvNOKp(fromstr)) { char buf[sizeof(double) * 2]; /* 8/7 <= 2 */ char *in = buf + sizeof(buf); do { double next = floor(adouble / 128); *--in = (unsigned char)(adouble - (next * 128)) | 0x80; if (in <= buf) /* this cannot happen ;-) */ Perl_croak(aTHX_ "Cannot compress integer"); adouble = next; } while (adouble > 0); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ sv_catpvn(cat, in, (buf + sizeof(buf)) - in); } else { char *from, *result, *in; SV *norm; STRLEN len; bool done; /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) Perl_croak(aTHX_ "can compress only unsigned integer"); New('w', result, len, char); in = result + len; done = FALSE; while (!done) *--in = div128(norm, &done) | 0x80; result[len - 1] &= 0x7F; /* clear continue bit */ sv_catpvn(cat, in, (result + len) - in); Safefree(result); SvREFCNT_dec(norm); /* free norm */ } } break; case 'i': while (len-- > 0) { fromstr = NEXTFROM; aint = SvIV(fromstr); sv_catpvn(cat, (char*)&aint, sizeof(int)); } break; case 'N': while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); #ifdef HAS_HTONL aulong = PerlSock_htonl(aulong); #endif CAT32(cat, &aulong); } break; case 'V': while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); #ifdef HAS_HTOVL aulong = htovl(aulong); #endif CAT32(cat, &aulong); } break; case 'L': #if LONGSIZE != SIZE32 if (natint) { unsigned long aulong; while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long)); } } else #endif { while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); CAT32(cat, &aulong); } } break; case 'l': #if LONGSIZE != SIZE32 if (natint) { long along; while (len-- > 0) { fromstr = NEXTFROM; along = SvIV(fromstr); sv_catpvn(cat, (char *)&along, sizeof(long)); } } else #endif { while (len-- > 0) { fromstr = NEXTFROM; along = SvIV(fromstr); CAT32(cat, &along); } } break; #ifdef HAS_QUAD case 'Q': while (len-- > 0) { fromstr = NEXTFROM; auquad = (Uquad_t)SvUV(fromstr); sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t)); } break; case 'q': while (len-- > 0) { fromstr = NEXTFROM; aquad = (Quad_t)SvIV(fromstr); sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t)); } break; #endif case 'P': len = 1; /* assume SV is correct length */ /* FALL THROUGH */ case 'p': while (len-- > 0) { fromstr = NEXTFROM; if (fromstr == &PL_sv_undef) aptr = NULL; else { STRLEN n_a; /* XXX better yet, could spirit away the string to * a safe spot and hang on to it until the result * of pack() (and all copies of the result) are * gone. */ if (ckWARN(WARN_PACK) && (SvTEMP(fromstr) || (SvPADTMP(fromstr) && !SvREADONLY(fromstr)))) { Perl_warner(aTHX_ WARN_PACK, "Attempt to pack pointer to temporary value"); } if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV(fromstr,n_a); else aptr = SvPV_force(fromstr,n_a); } sv_catpvn(cat, (char*)&aptr, sizeof(char*)); } break; case 'u': fromstr = NEXTFROM; aptr = SvPV(fromstr, fromlen); SvGROW(cat, fromlen * 4 / 3); if (len <= 2) len = 45; else len = len / 3 * 3; while (fromlen > 0) { I32 todo; if (fromlen > len) todo = len; else todo = fromlen; doencodes(cat, aptr, todo); fromlen -= todo; aptr += todo; } break; } } if (next_in_list) *next_in_list = beglist; } #undef NEXTFROM PP(pp_pack) { dSP; dMARK; dORIGMARK; dTARGET; register SV *cat = TARG; STRLEN fromlen; register char *pat = SvPVx(*++MARK, fromlen); register char *patend = pat + fromlen; MARK++; sv_setpvn(cat, "", 0); pack_cat(cat, pat, patend, MARK, SP + 1, NULL, 0); SvSETMAGIC(cat); SP = ORIGMARK; PUSHs(cat); RETURN; }