From: Jarkko Hietaniemi Date: Mon, 18 Jun 2001 13:11:49 +0000 (+0000) Subject: Split off the pack/unpack code, from Nicholas Clark. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a6ec74c1448e028e8d796742c81e78fb067bf603;p=p5sagit%2Fp5-mst-13.2.git Split off the pack/unpack code, from Nicholas Clark. p4raw-id: //depot/perl@10685 --- diff --git a/MANIFEST b/MANIFEST index 46a9895..403305e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1778,6 +1778,7 @@ pp.h Push/Pop code defs pp.sym Push/Pop code symbols pp_ctl.c Push/Pop code for control flow pp_hot.c Push/Pop code for heavily used opcodes +pp_pack.c Push/Pop code for pack/unpack pp_proto.h C++ definitions for Push/Pop code pp_sys.c Push/Pop code for system interaction proto.h Prototypes diff --git a/Makefile.SH b/Makefile.SH index 5eaef2c..133fd33 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -263,13 +263,13 @@ h = $(h1) $(h2) $(h3) $(h4) $(h5) c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c xsutils.c -c4 = globals.c perlio.c perlapi.c numeric.c locale.c +c4 = globals.c perlio.c perlapi.c numeric.c locale.c pp_pack.c c = $(c1) $(c2) $(c3) $(c4) miniperlmain.c perlmain.c obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT) -obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) locale$(OBJ_EXT) +obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS) diff --git a/Makefile.micro b/Makefile.micro index 118648c..4ed2a1c 100644 --- a/Makefile.micro +++ b/Makefile.micro @@ -12,7 +12,7 @@ O = uav$(_O) udeb$(_O) udoio$(_O) udoop$(_O) udump$(_O) \ uglobals$(_O) ugv$(_O) uhv$(_O) \ umg$(_O) uperlmain$(_O) uop$(_O) \ uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \ - upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) \ + upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) upp_pack$(_O) \ uregcomp$(_O) uregexec$(_O) urun$(_O) \ uscope$(_O) usv$(_O) utaint$(_O) utoke$(_O) \ unumeric$(_O) ulocale$(_O) \ @@ -92,6 +92,9 @@ upp_hot$(_O): $(HE) pp_hot.c upp_sys$(_O): $(HE) pp_sys.c $(CC) -c -o $@ $(CFLAGS) pp_sys.c +upp_pack$(_O): $(HE) pp_pack.c + $(CC) -c -o $@ $(CFLAGS) pp_pack.c + uregcomp$(_O): $(HE) regcomp.c regcomp.h regnodes.h INTERN.h $(CC) -c -o $@ $(CFLAGS) regcomp.c diff --git a/cflags.SH b/cflags.SH index f76d7fb..d2564af 100755 --- a/cflags.SH +++ b/cflags.SH @@ -99,10 +99,12 @@ for file do dump) ;; gv) ;; hv) ;; + locale) ;; main) ;; malloc) ;; mg) ;; miniperlmain) ;; + numeric) ;; op) ;; perl) ;; perlapi) ;; @@ -111,6 +113,7 @@ for file do pp) ;; pp_ctl) ;; pp_hot) ;; + pp_pack) ;; pp_sys) ;; regcomp) ;; regexec) ;; diff --git a/embed.h b/embed.h index 7ce30b9..fe61bc8 100644 --- a/embed.h +++ b/embed.h @@ -967,9 +967,11 @@ # endif #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) -#define doencodes S_doencodes #define refto S_refto #define seed S_seed +#endif +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +#define doencodes S_doencodes #define mul128 S_mul128 #define is_an_int S_is_an_int #define div128 S_div128 @@ -2466,9 +2468,11 @@ # endif #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) -#define doencodes(a,b,c) S_doencodes(aTHX_ a,b,c) #define refto(a) S_refto(aTHX_ a) #define seed() S_seed(aTHX) +#endif +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +#define doencodes(a,b,c) S_doencodes(aTHX_ a,b,c) #define mul128(a,b) S_mul128(aTHX_ a,b) #define is_an_int(a,b) S_is_an_int(aTHX_ a,b) #define div128(a,b) S_div128(aTHX_ a,b) @@ -4825,12 +4829,14 @@ # endif #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) -#define S_doencodes CPerlObj::S_doencodes -#define doencodes S_doencodes #define S_refto CPerlObj::S_refto #define refto S_refto #define S_seed CPerlObj::S_seed #define seed S_seed +#endif +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +#define S_doencodes CPerlObj::S_doencodes +#define doencodes S_doencodes #define S_mul128 CPerlObj::S_mul128 #define mul128 S_mul128 #define S_is_an_int CPerlObj::S_is_an_int diff --git a/embed.pl b/embed.pl index ed617ae..9fe53ba 100755 --- a/embed.pl +++ b/embed.pl @@ -2359,9 +2359,12 @@ s |struct perl_thread * |init_main_thread #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) -s |void |doencodes |SV* sv|char* s|I32 len s |SV* |refto |SV* sv s |U32 |seed +#endif + +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +s |void |doencodes |SV* sv|char* s|I32 len s |SV* |mul128 |SV *sv|U8 m s |SV* |is_an_int |char *s|STRLEN l s |int |div128 |SV *pnum|bool *done diff --git a/objXSUB.h b/objXSUB.h index f02868f..984376c 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -2360,6 +2360,8 @@ #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) #endif +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +#endif #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) #if defined(PERL_FLEXIBLE_EXCEPTIONS) #endif diff --git a/perlapi.c b/perlapi.c index 7140b99..e910818 100644 --- a/perlapi.c +++ b/perlapi.c @@ -4225,6 +4225,8 @@ Perl_sys_intern_init(pTHXo) #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) #endif +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +#endif #if defined(PERL_IN_PP_CTL_C) || defined(PERL_DECL_PROT) #if defined(PERL_FLEXIBLE_EXCEPTIONS) #endif diff --git a/pod/perlhack.pod b/pod/perlhack.pod index 6b67e57..64c69ad 100644 --- a/pod/perlhack.pod +++ b/pod/perlhack.pod @@ -1387,6 +1387,9 @@ the C happens at runtime, so it's going to be in one of the F files. Sure enough, C is in F. Since we're going to be altering this file, let's copy it to F. +[Well, it was in F when this tutorial was written. It has now been +split off with C to its own file, F] + Now let's look over C: we take a pattern into C, and then loop over the pattern, taking each format character in turn into C. Then for each possible format character, we swallow up diff --git a/pp.c b/pp.c index ebdf3fd..6d393bd 100644 --- a/pp.c +++ b/pp.c @@ -16,70 +16,6 @@ #define PERL_IN_PP_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 - /* variations on pp_null */ /* XXX I can't imagine anyone who doesn't have this actually _needs_ @@ -4071,1755 +4007,6 @@ PP(pp_reverse) RETURN; } -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 - - -PP(pp_unpack) -{ - dSP; - dPOPPOPssrl; - I32 start_sp_offset = SP - PL_stack_base; - I32 gimme = GIMME_V; - SV *sv; - 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; - char *strbeg = s; - register char *patend = pat + llen; - I32 datumtype; - register I32 len; - register I32 bits = 0; - register char *str; - - /* 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; - register U32 culong = 0; - NV cdouble = 0.0; - int commas = 0; - int star; -#ifdef PERL_NATINT_PACK - int natint; /* native integer */ - int unatint; /* unsigned native integer */ -#endif - - if (gimme != G_ARRAY) { /* arrange to do first one only */ - /*SUPPRESS 530*/ - for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ; - if (strchr("aAZbBhHP", *patend) || *pat == '%') { - patend++; - while (isDIGIT(*patend) || *patend == '*') - patend++; - } - else - patend++; - } - while (pat < patend) { - reparse: - datumtype = *pat++ & 0xFF; -#ifdef PERL_NATINT_PACK - natint = 0; -#endif - if (isSPACE(datumtype)) - continue; - if (datumtype == '#') { - while (pat < patend && *pat != '\n') - pat++; - continue; - } - if (*pat == '!') { - char *natstr = "sSiIlL"; - - if (strchr(natstr, datumtype)) { -#ifdef PERL_NATINT_PACK - natint = 1; -#endif - pat++; - } - else - DIE(aTHX_ "'!' allowed only after types %s", natstr); - } - star = 0; - if (pat >= patend) - len = 1; - else if (*pat == '*') { - len = strend - strbeg; /* long enough */ - pat++; - star = 1; - } - else if (isDIGIT(*pat)) { - len = *pat++ - '0'; - while (isDIGIT(*pat)) { - len = (len * 10) + (*pat++ - '0'); - if (len < 0) - DIE(aTHX_ "Repeat count in unpack overflows"); - } - } - else - len = (datumtype != '@'); - redo_switch: - switch(datumtype) { - default: - DIE(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') - len = 16; - checksum = len; - culong = 0; - cdouble = 0; - if (pat < patend) - goto reparse; - break; - case '@': - if (len > strend - strbeg) - DIE(aTHX_ "@ outside of string"); - s = strbeg + len; - break; - case 'X': - if (len > s - strbeg) - DIE(aTHX_ "X outside of string"); - s -= len; - break; - case 'x': - if (len > strend - s) - DIE(aTHX_ "x outside of string"); - s += len; - break; - case '/': - if (start_sp_offset >= SP - PL_stack_base) - DIE(aTHX_ "/ must follow a numeric type"); - datumtype = *pat++; - if (*pat == '*') - pat++; /* ignore '*' for compatibility with pack */ - if (isDIGIT(*pat)) - DIE(aTHX_ "/ cannot take a count" ); - len = POPi; - star = 0; - 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); - 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++; - } - 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 */ - } - XPUSHs(sv_2mortal(sv)); - break; - case 'B': - case 'b': - if (star || 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) { - culong += PL_bitcount[*(unsigned char*)s++]; - len -= 8; - } - if (len) { - bits = *s; - if (datumtype == 'b') { - while (len-- > 0) { - if (bits & 1) culong++; - bits >>= 1; - } - } - else { - while (len-- > 0) { - if (bits & 128) culong++; - 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 || 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; - culong += 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': - if (len > strend - s) - len = strend - s; - if (checksum) { - uchar_checksum: - while (len-- > 0) { - auint = *s++ & 255; - culong += 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 > strend - s) - len = strend - s; - if (checksum) { - while (len-- > 0 && s < strend) { - STRLEN alen; - auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0); - along = alen; - s += along; - if (checksum > 32) - cdouble += (NV)auint; - else - culong += auint; - } - } - else { - EXTEND(SP, len); - EXTEND_MORTAL(len); - while (len-- > 0 && s < strend) { - STRLEN alen; - auint = 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); - culong += ashort; - - } - } - else -#endif - { - while (len-- > 0) { - COPY16(s, &ashort); -#if SHORTSIZE > SIZE16 - if (ashort > 32767) - ashort -= 65536; -#endif - s += SIZE16; - culong += 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); - culong += 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 - culong += 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 > 32) - cdouble += (NV)aint; - else - culong += 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 > 32) - cdouble += (NV)auint; - else - culong += 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 '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 > 32) - cdouble += (NV)along; - else - culong += 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 > 32) - cdouble += (NV)along; - else - culong += 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 > 32) - cdouble += (NV)aulong; - else - culong += 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 > 32) - cdouble += (NV)aulong; - else - culong += 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) - DIE(aTHX_ "Unterminated compressed integer"); - } - break; - case 'P': - 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; - 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(Quad_t); - if (len > along) - len = along; - 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': - 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': - 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 '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 > 32 && strchr("iIlLNU", datumtype)) ) { - NV trouble; - - adouble = 1.0; - while (checksum >= 16) { - checksum -= 16; - adouble *= 65536.0; - } - while (checksum >= 4) { - checksum -= 4; - adouble *= 16.0; - } - while (checksum--) - adouble *= 2.0; - along = (1 << checksum) - 1; - while (cdouble < 0.0) - cdouble += adouble; - cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; - sv_setnv(sv, cdouble); - } - else { - if (checksum < 32) { - aulong = (1 << checksum) - 1; - culong &= aulong; - } - sv_setuv(sv, (UV)culong); - } - XPUSHs(sv_2mortal(sv)); - checksum = 0; - } - } - if (SP - PL_stack_base == start_sp_offset && 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); -} - - -PP(pp_pack) -{ - dSP; dMARK; dORIGMARK; dTARGET; - register SV *cat = TARG; - register I32 items; - STRLEN fromlen; - register char *pat = SvPVx(*++MARK, fromlen); - char *patcopy; - register char *patend = pat + 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 = " "; - - /* These must not be in registers: */ - char achar; - I16 ashort; - int aint; - unsigned int auint; - I32 along; - U32 aulong; -#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 = SP - MARK; - MARK++; - sv_setpvn(cat, "", 0); - patcopy = pat; - while (pat < patend) { - SV *lengthcode = Nullsv; -#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no) - datumtype = *pat++ & 0xFF; -#ifdef PERL_NATINT_PACK - natint = 0; -#endif - if (isSPACE(datumtype)) { - patcopy++; - continue; - } -#ifndef PACKED_IS_OCTETS - if (datumtype == 'U' && pat == patcopy+1) - SvUTF8_on(cat); -#endif - if (datumtype == '#') { - while (pat < patend && *pat != '\n') - pat++; - continue; - } - if (*pat == '!') { - char *natstr = "sSiIlL"; - - if (strchr(natstr, datumtype)) { -#ifdef PERL_NATINT_PACK - natint = 1; -#endif - pat++; - } - else - DIE(aTHX_ "'!' allowed only after types %s", natstr); - } - if (*pat == '*') { - len = strchr("@Xxu", datumtype) ? 0 : items; - pat++; - } - else if (isDIGIT(*pat)) { - len = *pat++ - '0'; - while (isDIGIT(*pat)) { - len = (len * 10) + (*pat++ - '0'); - if (len < 0) - DIE(aTHX_ "Repeat count in pack overflows"); - } - } - else - len = 1; - if (*pat == '/') { - ++pat; - if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*') - DIE(aTHX_ "/ must be followed by a*, A* or Z*"); - lengthcode = sv_2mortal(newSViv(sv_len(items > 0 - ? *MARK : &PL_sv_no) - + (*pat == 'Z' ? 1 : 0))); - } - switch(datumtype) { - default: - DIE(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 '%': - DIE(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 'X': - shrink: - if (SvCUR(cat) < len) - DIE(aTHX_ "X outside of string"); - SvCUR(cat) -= len; - *SvEND(cat) = '\0'; - break; - 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 (pat[-1] == '*') { - 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 (pat[-1] == '*') - 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 (pat[-1] == '*') - 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 = 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': - case 'F': - while (len-- > 0) { - fromstr = NEXTFROM; - afloat = (float)SvNV(fromstr); - sv_catpvn(cat, (char *)&afloat, sizeof (float)); - } - break; - case 'd': - case 'D': - while (len-- > 0) { - fromstr = NEXTFROM; - adouble = (double)SvNV(fromstr); - sv_catpvn(cat, (char *)&adouble, sizeof (double)); - } - break; - 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 'w': - while (len-- > 0) { - fromstr = NEXTFROM; - adouble = Perl_floor(SvNV(fromstr)); - - if (adouble < 0) - DIE(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) - DIE(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 ;-) */ - DIE(aTHX_ "Cannot compress integer"); - in--; - adouble = next; - } while (adouble > 0); - buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ - sv_catpvn(cat, in, (buf + sizeof(buf)) - in); - } - else - DIE(aTHX_ "Cannot compress non integer"); - } - 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 <= 1) - 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; - } - } - SvSETMAGIC(cat); - SP = ORIGMARK; - PUSHs(cat); - RETURN; -} -#undef NEXTFROM - - PP(pp_split) { dSP; dTARG; diff --git a/pp_pack.c b/pp_pack.c new file mode 100644 index 0000000..be6ff6f --- /dev/null +++ b/pp_pack.c @@ -0,0 +1,1825 @@ +/* pp_pack.c + * + * Copyright (c) 1991-2001, 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. + * + */ + +#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 + + +PP(pp_unpack) +{ + dSP; + dPOPPOPssrl; + I32 start_sp_offset = SP - PL_stack_base; + I32 gimme = GIMME_V; + SV *sv; + 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; + char *strbeg = s; + register char *patend = pat + llen; + I32 datumtype; + register I32 len; + register I32 bits = 0; + register char *str; + + /* 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; + register U32 culong = 0; + NV cdouble = 0.0; + int commas = 0; + int star; +#ifdef PERL_NATINT_PACK + int natint; /* native integer */ + int unatint; /* unsigned native integer */ +#endif + + if (gimme != G_ARRAY) { /* arrange to do first one only */ + /*SUPPRESS 530*/ + for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ; + if (strchr("aAZbBhHP", *patend) || *pat == '%') { + patend++; + while (isDIGIT(*patend) || *patend == '*') + patend++; + } + else + patend++; + } + while (pat < patend) { + reparse: + datumtype = *pat++ & 0xFF; +#ifdef PERL_NATINT_PACK + natint = 0; +#endif + if (isSPACE(datumtype)) + continue; + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } + if (*pat == '!') { + char *natstr = "sSiIlL"; + + if (strchr(natstr, datumtype)) { +#ifdef PERL_NATINT_PACK + natint = 1; +#endif + pat++; + } + else + DIE(aTHX_ "'!' allowed only after types %s", natstr); + } + star = 0; + if (pat >= patend) + len = 1; + else if (*pat == '*') { + len = strend - strbeg; /* long enough */ + pat++; + star = 1; + } + else if (isDIGIT(*pat)) { + len = *pat++ - '0'; + while (isDIGIT(*pat)) { + len = (len * 10) + (*pat++ - '0'); + if (len < 0) + DIE(aTHX_ "Repeat count in unpack overflows"); + } + } + else + len = (datumtype != '@'); + redo_switch: + switch(datumtype) { + default: + DIE(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') + len = 16; + checksum = len; + culong = 0; + cdouble = 0; + if (pat < patend) + goto reparse; + break; + case '@': + if (len > strend - strbeg) + DIE(aTHX_ "@ outside of string"); + s = strbeg + len; + break; + case 'X': + if (len > s - strbeg) + DIE(aTHX_ "X outside of string"); + s -= len; + break; + case 'x': + if (len > strend - s) + DIE(aTHX_ "x outside of string"); + s += len; + break; + case '/': + if (start_sp_offset >= SP - PL_stack_base) + DIE(aTHX_ "/ must follow a numeric type"); + datumtype = *pat++; + if (*pat == '*') + pat++; /* ignore '*' for compatibility with pack */ + if (isDIGIT(*pat)) + DIE(aTHX_ "/ cannot take a count" ); + len = POPi; + star = 0; + 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); + 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++; + } + 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 */ + } + XPUSHs(sv_2mortal(sv)); + break; + case 'B': + case 'b': + if (star || 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) { + culong += PL_bitcount[*(unsigned char*)s++]; + len -= 8; + } + if (len) { + bits = *s; + if (datumtype == 'b') { + while (len-- > 0) { + if (bits & 1) culong++; + bits >>= 1; + } + } + else { + while (len-- > 0) { + if (bits & 128) culong++; + 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 || 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; + culong += 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': + if (len > strend - s) + len = strend - s; + if (checksum) { + uchar_checksum: + while (len-- > 0) { + auint = *s++ & 255; + culong += 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 > strend - s) + len = strend - s; + if (checksum) { + while (len-- > 0 && s < strend) { + STRLEN alen; + auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0); + along = alen; + s += along; + if (checksum > 32) + cdouble += (NV)auint; + else + culong += auint; + } + } + else { + EXTEND(SP, len); + EXTEND_MORTAL(len); + while (len-- > 0 && s < strend) { + STRLEN alen; + auint = 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); + culong += ashort; + + } + } + else +#endif + { + while (len-- > 0) { + COPY16(s, &ashort); +#if SHORTSIZE > SIZE16 + if (ashort > 32767) + ashort -= 65536; +#endif + s += SIZE16; + culong += 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); + culong += 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 + culong += 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 > 32) + cdouble += (NV)aint; + else + culong += 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 > 32) + cdouble += (NV)auint; + else + culong += 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 '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 > 32) + cdouble += (NV)along; + else + culong += 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 > 32) + cdouble += (NV)along; + else + culong += 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 > 32) + cdouble += (NV)aulong; + else + culong += 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 > 32) + cdouble += (NV)aulong; + else + culong += 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) + DIE(aTHX_ "Unterminated compressed integer"); + } + break; + case 'P': + 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; + 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(Quad_t); + if (len > along) + len = along; + 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': + 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': + 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 '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 > 32 && strchr("iIlLNU", datumtype)) ) { + NV trouble; + + adouble = 1.0; + while (checksum >= 16) { + checksum -= 16; + adouble *= 65536.0; + } + while (checksum >= 4) { + checksum -= 4; + adouble *= 16.0; + } + while (checksum--) + adouble *= 2.0; + along = (1 << checksum) - 1; + while (cdouble < 0.0) + cdouble += adouble; + cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; + sv_setnv(sv, cdouble); + } + else { + if (checksum < 32) { + aulong = (1 << checksum) - 1; + culong &= aulong; + } + sv_setuv(sv, (UV)culong); + } + XPUSHs(sv_2mortal(sv)); + checksum = 0; + } + } + if (SP - PL_stack_base == start_sp_offset && 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); +} + + +PP(pp_pack) +{ + dSP; dMARK; dORIGMARK; dTARGET; + register SV *cat = TARG; + register I32 items; + STRLEN fromlen; + register char *pat = SvPVx(*++MARK, fromlen); + char *patcopy; + register char *patend = pat + 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 = " "; + + /* These must not be in registers: */ + char achar; + I16 ashort; + int aint; + unsigned int auint; + I32 along; + U32 aulong; +#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 = SP - MARK; + MARK++; + sv_setpvn(cat, "", 0); + patcopy = pat; + while (pat < patend) { + SV *lengthcode = Nullsv; +#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no) + datumtype = *pat++ & 0xFF; +#ifdef PERL_NATINT_PACK + natint = 0; +#endif + if (isSPACE(datumtype)) { + patcopy++; + continue; + } +#ifndef PACKED_IS_OCTETS + if (datumtype == 'U' && pat == patcopy+1) + SvUTF8_on(cat); +#endif + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } + if (*pat == '!') { + char *natstr = "sSiIlL"; + + if (strchr(natstr, datumtype)) { +#ifdef PERL_NATINT_PACK + natint = 1; +#endif + pat++; + } + else + DIE(aTHX_ "'!' allowed only after types %s", natstr); + } + if (*pat == '*') { + len = strchr("@Xxu", datumtype) ? 0 : items; + pat++; + } + else if (isDIGIT(*pat)) { + len = *pat++ - '0'; + while (isDIGIT(*pat)) { + len = (len * 10) + (*pat++ - '0'); + if (len < 0) + DIE(aTHX_ "Repeat count in pack overflows"); + } + } + else + len = 1; + if (*pat == '/') { + ++pat; + if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*') + DIE(aTHX_ "/ must be followed by a*, A* or Z*"); + lengthcode = sv_2mortal(newSViv(sv_len(items > 0 + ? *MARK : &PL_sv_no) + + (*pat == 'Z' ? 1 : 0))); + } + switch(datumtype) { + default: + DIE(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 '%': + DIE(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 'X': + shrink: + if (SvCUR(cat) < len) + DIE(aTHX_ "X outside of string"); + SvCUR(cat) -= len; + *SvEND(cat) = '\0'; + break; + 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 (pat[-1] == '*') { + 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 (pat[-1] == '*') + 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 (pat[-1] == '*') + 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 = 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': + case 'F': + while (len-- > 0) { + fromstr = NEXTFROM; + afloat = (float)SvNV(fromstr); + sv_catpvn(cat, (char *)&afloat, sizeof (float)); + } + break; + case 'd': + case 'D': + while (len-- > 0) { + fromstr = NEXTFROM; + adouble = (double)SvNV(fromstr); + sv_catpvn(cat, (char *)&adouble, sizeof (double)); + } + break; + 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 'w': + while (len-- > 0) { + fromstr = NEXTFROM; + adouble = Perl_floor(SvNV(fromstr)); + + if (adouble < 0) + DIE(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) + DIE(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 ;-) */ + DIE(aTHX_ "Cannot compress integer"); + in--; + adouble = next; + } while (adouble > 0); + buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ + sv_catpvn(cat, in, (buf + sizeof(buf)) - in); + } + else + DIE(aTHX_ "Cannot compress non integer"); + } + 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 <= 1) + 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; + } + } + SvSETMAGIC(cat); + SP = ORIGMARK; + PUSHs(cat); + RETURN; +} +#undef NEXTFROM + diff --git a/proto.h b/proto.h index 65b4883..927f3b5 100644 --- a/proto.h +++ b/proto.h @@ -1089,9 +1089,12 @@ STATIC struct perl_thread * S_init_main_thread(pTHX); #endif #if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT) -STATIC void S_doencodes(pTHX_ SV* sv, char* s, I32 len); STATIC SV* S_refto(pTHX_ SV* sv); STATIC U32 S_seed(pTHX); +#endif + +#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT) +STATIC void S_doencodes(pTHX_ SV* sv, char* s, I32 len); STATIC SV* S_mul128(pTHX_ SV *sv, U8 m); STATIC SV* S_is_an_int(pTHX_ char *s, STRLEN l); STATIC int S_div128(pTHX_ SV *pnum, bool *done); diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index f3b5d4d..022dccc 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -267,16 +267,16 @@ FULLLIBS2 = $(LIBS2)|$(THRLIBS1)|$(THRLIBS2) #### End of system configuration section. #### -c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c -c1 = hv.c mg.c locale.c miniperlmain.c numeric.c op.c perl.c perlapi.c perlio.c -c2 = perly.c pp.c pp_ctl.c pp_hot.c pp_sys.c regcomp.c regexec.c run.c scope.c -c3 = sv.c taint.c toke.c universal.c utf8.c util.c vms.c xsutils.c +c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c +c1 = mg.c locale.c miniperlmain.c numeric.c op.c perl.c perlapi.c perlio.c +c2 = perly.c pp.c pp_ctl.c pp_hot.c pp_pack.c pp_sys.c regcomp.c regexec.c +c3 = run.c scope.c sv.c taint.c toke.c universal.c utf8.c util.c vms.c xsutils.c c = $(c0) $(c1) $(c2) $(c3) obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O) obj1 = globals$(O) gv$(O) hv$(O) locale$(O) mg$(O) miniperlmain$(O) numeric$(O) obj2 = op$(O) perl$(O) perlapi$(O) perlio$(O) perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) -obj3 = pp_sys$(O) regcomp$(O) regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O) +obj3 = pp_pack$(O) pp_sys$(O) regcomp$(O) regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O) obj4 = universal$(O) utf8$(O) util$(O) vms$(O) xsutils$(O) obj = $(obj0) $(obj1) $(obj2) $(obj3) $(obj4) @@ -1166,6 +1166,7 @@ pp_ctl$(O) : pp_ctl.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) $(CC) $(CORECFLAGS) $(MMS$SOURCE) pp_hot$(O) : pp_hot.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h $(CC) $(CORECFLAGS) $(MMS$SOURCE) +pp_pack$(O) : pp_pack.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h pp_sys$(O) : pp_sys.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h $(CC) $(CORECFLAGS) $(MMS$SOURCE) regcomp$(O) : regcomp.c extern.h perl.h config.h embed.h handy.h vmsish.h $(SOCKH) iperlsys.h perlsdio.h perl.h regexp.h sv.h util.h form.h gv.h cv.h opnames.h op.h cop.h av.h hv.h mg.h scope.h warnings.h utf8.h perly.h thread.h pp.h proto.h pp_proto.h opcode.h embedvar.h intrpvar.h thrdvar.h perlvars.h patchlevel.h intern.h regcomp.h regnodes.h diff --git a/win32/Makefile b/win32/Makefile index 0df7e29..38458ac 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -511,6 +511,7 @@ MICROCORE_SRC = \ ..\pp.c \ ..\pp_ctl.c \ ..\pp_hot.c \ + ..\pp_pack.c \ ..\pp_sys.c \ ..\regcomp.c \ ..\regexec.c \ diff --git a/win32/makefile.mk b/win32/makefile.mk index 3fd644f..f99b4ce 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -652,7 +652,9 @@ MICROCORE_SRC = \ ..\globals.c \ ..\gv.c \ ..\hv.c \ + ..\locale.c \ ..\mg.c \ + ..\numeric.c \ ..\op.c \ ..\perl.c \ ..\perlapi.c \ @@ -660,6 +662,7 @@ MICROCORE_SRC = \ ..\pp.c \ ..\pp_ctl.c \ ..\pp_hot.c \ + ..\pp_pack.c \ ..\pp_sys.c \ ..\regcomp.c \ ..\regexec.c \ @@ -671,8 +674,6 @@ MICROCORE_SRC = \ ..\universal.c \ ..\utf8.c \ ..\util.c \ - ..\numeric.c \ - ..\locale.c \ ..\xsutils.c EXTRACORE_SRC += perllib.c