X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=d145262a4c8171972efa09f1886a88ec09a1aa2c;hb=25a9bd2a66ab90bebdf152f1b70a957b5876ed63;hp=092747743250544922a9b899fb433ed9ea44bf5e;hpb=137d6fc09ef3595c225f4474cf527a89e2099776;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 0927477..d145262 100644 --- a/util.c +++ b/util.c @@ -1,7 +1,7 @@ /* util.c * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -1224,8 +1224,9 @@ Perl_croak_nocontext(const char *pat, ...) =for apidoc croak This is the XSUB-writer's interface to Perl's C function. -Normally use this function the same way you use the C C -function. See C. +Normally call this function the same way you call the C C +function. Calling C returns control directly to Perl, +sidestepping the normal C order of execution. See C. If you want to throw an exception object, assign the object to C<$@> and then pass C to croak(): @@ -1310,9 +1311,8 @@ Perl_warn_nocontext(const char *pat, ...) /* =for apidoc warn -This is the XSUB-writer's interface to Perl's C function. Use this -function the same way you use the C C function. See -C. +This is the XSUB-writer's interface to Perl's C function. Call this +function the same way you call the C C function. See C. =cut */ @@ -1746,7 +1746,7 @@ Perl_my_ntohl(pTHX_ long l) * -DWS */ -#define HTOV(name,type) \ +#define HTOLE(name,type) \ type \ name (register type n) \ { \ @@ -1755,14 +1755,14 @@ Perl_my_ntohl(pTHX_ long l) char c[sizeof(type)]; \ } u; \ register I32 i; \ - register I32 s; \ - for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ + register I32 s = 0; \ + for (i = 0; i < sizeof(u.c); i++, s += 8) { \ u.c[i] = (n >> s) & 0xFF; \ } \ return u.value; \ } -#define VTOH(name,type) \ +#define LETOH(name,type) \ type \ name (register type n) \ { \ @@ -1771,27 +1771,218 @@ Perl_my_ntohl(pTHX_ long l) char c[sizeof(type)]; \ } u; \ register I32 i; \ - register I32 s; \ + register I32 s = 0; \ u.value = n; \ n = 0; \ - for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ - n += (u.c[i] & 0xFF) << s; \ + for (i = 0; i < sizeof(u.c); i++, s += 8) { \ + n |= ((type)(u.c[i] & 0xFF)) << s; \ } \ return n; \ } +/* + * Big-endian byte order functions. + */ + +#define HTOBE(name,type) \ + type \ + name (register type n) \ + { \ + union { \ + type value; \ + char c[sizeof(type)]; \ + } u; \ + register I32 i; \ + register I32 s = 8*(sizeof(u.c)-1); \ + for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ + u.c[i] = (n >> s) & 0xFF; \ + } \ + return u.value; \ + } + +#define BETOH(name,type) \ + type \ + name (register type n) \ + { \ + union { \ + type value; \ + char c[sizeof(type)]; \ + } u; \ + register I32 i; \ + register I32 s = 8*(sizeof(u.c)-1); \ + u.value = n; \ + n = 0; \ + for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ + n |= ((type)(u.c[i] & 0xFF)) << s; \ + } \ + return n; \ + } + +/* + * If we just can't do it... + */ + +#define NOT_AVAIL(name,type) \ + type \ + name (register type n) \ + { \ + Perl_croak_nocontext(#name "() not available"); \ + return n; /* not reached */ \ + } + + #if defined(HAS_HTOVS) && !defined(htovs) -HTOV(htovs,short) +HTOLE(htovs,short) #endif #if defined(HAS_HTOVL) && !defined(htovl) -HTOV(htovl,long) +HTOLE(htovl,long) #endif #if defined(HAS_VTOHS) && !defined(vtohs) -VTOH(vtohs,short) +LETOH(vtohs,short) #endif #if defined(HAS_VTOHL) && !defined(vtohl) -VTOH(vtohl,long) +LETOH(vtohl,long) +#endif + +#ifdef PERL_NEED_MY_HTOLE16 +# if U16SIZE == 2 +HTOLE(Perl_my_htole16,U16) +# else +NOT_AVAIL(Perl_my_htole16,U16) +# endif +#endif +#ifdef PERL_NEED_MY_LETOH16 +# if U16SIZE == 2 +LETOH(Perl_my_letoh16,U16) +# else +NOT_AVAIL(Perl_my_letoh16,U16) +# endif +#endif +#ifdef PERL_NEED_MY_HTOBE16 +# if U16SIZE == 2 +HTOBE(Perl_my_htobe16,U16) +# else +NOT_AVAIL(Perl_my_htobe16,U16) +# endif +#endif +#ifdef PERL_NEED_MY_BETOH16 +# if U16SIZE == 2 +BETOH(Perl_my_betoh16,U16) +# else +NOT_AVAIL(Perl_my_betoh16,U16) +# endif +#endif + +#ifdef PERL_NEED_MY_HTOLE32 +# if U32SIZE == 4 +HTOLE(Perl_my_htole32,U32) +# else +NOT_AVAIL(Perl_my_htole32,U32) +# endif +#endif +#ifdef PERL_NEED_MY_LETOH32 +# if U32SIZE == 4 +LETOH(Perl_my_letoh32,U32) +# else +NOT_AVAIL(Perl_my_letoh32,U32) +# endif +#endif +#ifdef PERL_NEED_MY_HTOBE32 +# if U32SIZE == 4 +HTOBE(Perl_my_htobe32,U32) +# else +NOT_AVAIL(Perl_my_htobe32,U32) +# endif +#endif +#ifdef PERL_NEED_MY_BETOH32 +# if U32SIZE == 4 +BETOH(Perl_my_betoh32,U32) +# else +NOT_AVAIL(Perl_my_betoh32,U32) +# endif +#endif + +#ifdef PERL_NEED_MY_HTOLE64 +# if U64SIZE == 8 +HTOLE(Perl_my_htole64,U64) +# else +NOT_AVAIL(Perl_my_htole64,U64) +# endif +#endif +#ifdef PERL_NEED_MY_LETOH64 +# if U64SIZE == 8 +LETOH(Perl_my_letoh64,U64) +# else +NOT_AVAIL(Perl_my_letoh64,U64) +# endif +#endif +#ifdef PERL_NEED_MY_HTOBE64 +# if U64SIZE == 8 +HTOBE(Perl_my_htobe64,U64) +# else +NOT_AVAIL(Perl_my_htobe64,U64) +# endif +#endif +#ifdef PERL_NEED_MY_BETOH64 +# if U64SIZE == 8 +BETOH(Perl_my_betoh64,U64) +# else +NOT_AVAIL(Perl_my_betoh64,U64) +# endif +#endif + +#ifdef PERL_NEED_MY_HTOLES +HTOLE(Perl_my_htoles,short) +#endif +#ifdef PERL_NEED_MY_LETOHS +LETOH(Perl_my_letohs,short) +#endif +#ifdef PERL_NEED_MY_HTOBES +HTOBE(Perl_my_htobes,short) #endif +#ifdef PERL_NEED_MY_BETOHS +BETOH(Perl_my_betohs,short) +#endif + +#ifdef PERL_NEED_MY_HTOLEI +HTOLE(Perl_my_htolei,int) +#endif +#ifdef PERL_NEED_MY_LETOHI +LETOH(Perl_my_letohi,int) +#endif +#ifdef PERL_NEED_MY_HTOBEI +HTOBE(Perl_my_htobei,int) +#endif +#ifdef PERL_NEED_MY_BETOHI +BETOH(Perl_my_betohi,int) +#endif + +#ifdef PERL_NEED_MY_HTOLEL +HTOLE(Perl_my_htolel,long) +#endif +#ifdef PERL_NEED_MY_LETOHL +LETOH(Perl_my_letohl,long) +#endif +#ifdef PERL_NEED_MY_HTOBEL +HTOBE(Perl_my_htobel,long) +#endif +#ifdef PERL_NEED_MY_BETOHL +BETOH(Perl_my_betohl,long) +#endif + +void +Perl_my_swabn(void *ptr, int n) +{ + register char *s = (char *)ptr; + register char *e = s + (n-1); + register char tc; + + for (n /= 2; n > 0; s++, e--, n--) { + tc = *s; + *s = *e; + *e = tc; + } +} PerlIO * Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) @@ -3730,8 +3921,8 @@ Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) * point of a version originally created with a bare * floating point number, i.e. not quoted in any way */ - if ( !qv && s > start+1 && saw_period == 1 && !saw_under ) { - mult = 100; + if ( !qv && s > start+1 && saw_period == 1 ) { + mult *= 100; while ( s < end ) { orev = rev; rev += (*s - '0') * mult; @@ -3763,12 +3954,17 @@ Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) break; } while ( isDIGIT(*pos) ) { - if ( !saw_under && saw_period == 1 && pos-s == 3 ) + if ( saw_period == 1 && pos-s == 3 ) break; pos++; } } } + if ( qv ) { /* quoted versions always become full version objects */ + I32 len = av_len((AV *)sv); + for ( len = 2 - len; len != 0; len-- ) + av_push((AV *)sv, newSViv(0)); + } return s; } @@ -3877,25 +4073,37 @@ Perl_vnumify(pTHX_ SV *vs) return sv; } digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"%d.", PERL_ABS(digit)); - for ( i = 1 ; i <= len ; i++ ) + Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit)); + for ( i = 1 ; i < len ; i++ ) { digit = SvIVX(*av_fetch((AV *)vs, i, 0)); - Perl_sv_catpvf(aTHX_ sv,"%03d", PERL_ABS(digit)); + Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit)); + } + + if ( len > 0 ) + { + digit = SvIVX(*av_fetch((AV *)vs, len, 0)); + + /* Don't display any additional trailing zeros */ + if ( (int)PERL_ABS(digit) != 0 || len == 1 ) + { + Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit)); + } } - if ( len == 0 ) + else /* len == 0 */ + { Perl_sv_catpv(aTHX_ sv,"000"); - sv_setnv(sv, SvNV(sv)); + } return sv; } /* -=for apidoc vstringify +=for apidoc vnormal Accepts a version object and returns the normalized string representation. Call like: - sv = vstringify(rv); + sv = vnormal(rv); NOTE: you can pass either the object directly or the SV contained within the RV. @@ -3904,7 +4112,7 @@ contained within the RV. */ SV * -Perl_vstringify(pTHX_ SV *vs) +Perl_vnormal(pTHX_ SV *vs) { I32 i, len, digit; SV *sv = newSV(0); @@ -3936,6 +4144,31 @@ Perl_vstringify(pTHX_ SV *vs) } /* +=for apidoc vstringify + +In order to maintain maximum compatibility with earlier versions +of Perl, this function will return either the floating point +notation or the multiple dotted notation, depending on whether +the original version contained 1 or more dots, respectively + +=cut +*/ + +SV * +Perl_vstringify(pTHX_ SV *vs) +{ + I32 len; + if ( SvROK(vs) ) + vs = SvRV(vs); + len = av_len((AV *)vs); + + if ( len < 2 ) + return vnumify(vs); + else + return vnormal(vs); +} + +/* =for apidoc vcmp Version object aware cmp. Both operands must already have been