X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=ad6d40156ff266c6e708b1bbda240b5d413ee064;hb=6137113dfd943e6f896f8b9c1a4df2b7d4e355ae;hp=b196d9b4c0547f2f5d7651fe13433f362a527e98;hpb=4b5190b5321b9b9e2ec46674b256120d4fdab72a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index b196d9b..ad6d401 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. @@ -18,10 +18,7 @@ #include "perl.h" #ifndef PERL_MICRO -#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include -#endif - #ifndef SIG_ERR # define SIG_ERR ((Sighandler_t) -1) #endif @@ -75,7 +72,9 @@ Perl_safesysmalloc(MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; + /* Can't use PerlIO to write as it allocates memory */ + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); my_exit(1); return Nullch; } @@ -122,7 +121,9 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; + /* Can't use PerlIO to write as it allocates memory */ + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); my_exit(1); return Nullch; } @@ -174,7 +175,9 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; + /* Can't use PerlIO to write as it allocates memory */ + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); my_exit(1); return Nullch; } @@ -1221,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(): @@ -1307,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 */ @@ -1743,7 +1746,7 @@ Perl_my_ntohl(pTHX_ long l) * -DWS */ -#define HTOV(name,type) \ +#define HTOLE(name,type) \ type \ name (register type n) \ { \ @@ -1752,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) \ { \ @@ -1768,28 +1771,219 @@ 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) { @@ -3660,19 +3854,21 @@ an RV. Function must be called with an already existing SV like - sv = NEWSV(92,0); - s = scan_version(s,sv); + sv = newSV(0); + s = scan_version(s,SV *sv, bool qv); Performs some preprocessing to the string to ensure that it has the correct characteristics of a version. Flags the object if it contains an underscore (which denotes this -is a beta version). +is a alpha version). The boolean qv denotes that the version +should be interpreted as if it had multiple decimals, even if +it doesn't. =cut */ char * -Perl_scan_version(pTHX_ char *s, SV *rv) +Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) { const char *start = s; char *pos = s; @@ -3700,7 +3896,10 @@ Perl_scan_version(pTHX_ char *s, SV *rv) } pos = s; - if (*pos == 'v') pos++; /* get past 'v' */ + if (*pos == 'v') { + pos++; /* get past 'v' */ + qv = 1; /* force quoted version processing */ + } while (isDIGIT(*pos)) pos++; if (!isALPHA(*pos)) { @@ -3716,14 +3915,14 @@ Perl_scan_version(pTHX_ char *s, SV *rv) I32 mult = 1; I32 orev; if ( s < pos && s > start && *(s-1) == '_' ) { - mult *= -1; /* beta version */ + mult *= -1; /* alpha version */ } /* the following if() will only be true after the decimal * point of a version originally created with a bare * floating point number, i.e. not quoted in any way */ - if ( 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; @@ -3755,12 +3954,17 @@ Perl_scan_version(pTHX_ char *s, SV *rv) 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; } @@ -3781,24 +3985,21 @@ SV * Perl_new_version(pTHX_ SV *ver) { SV *rv = newSV(0); - char *version; - if ( SvNOK(ver) ) /* may get too much accuracy */ - { - char tbuf[64]; - sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); - version = savepv(tbuf); - } #ifdef SvVOK - else if ( SvVOK(ver) ) { /* already a v-string */ + if ( SvVOK(ver) ) { /* already a v-string */ + char *version; MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); + sv_setpv(rv,version); + Safefree(version); } + else { #endif - else /* must be a string or something like a string */ - { - version = (char *)SvPV(ver,PL_na); + sv_setsv(rv,ver); /* make a duplicate */ +#ifdef SvVOK } - version = scan_version(version,rv); +#endif + upg_version(rv); return rv; } @@ -3817,14 +4018,29 @@ Returns a pointer to the upgraded SV. SV * Perl_upg_version(pTHX_ SV *ver) { - char *version = savepvn(SvPVX(ver),SvCUR(ver)); + char *version; + bool qv = 0; + + if ( SvNOK(ver) ) /* may get too much accuracy */ + { + char tbuf[64]; + sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); + version = savepv(tbuf); + } #ifdef SvVOK - if ( SvVOK(ver) ) { /* already a v-string */ + else if ( SvVOK(ver) ) { /* already a v-string */ MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); + qv = 1; } #endif - version = scan_version(version,ver); + else /* must be a string or something like a string */ + { + STRLEN n_a; + version = savepv(SvPV(ver,n_a)); + } + (void)scan_version(version, ver, qv); + Safefree(version); return ver; } @@ -3847,7 +4063,7 @@ SV * Perl_vnumify(pTHX_ SV *vs) { I32 i, len, digit; - SV *sv = NEWSV(92,0); + SV *sv = newSV(0); if ( SvROK(vs) ) vs = SvRV(vs); len = av_len((AV *)vs); @@ -3857,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. @@ -3884,10 +4112,10 @@ contained within the RV. */ SV * -Perl_vstringify(pTHX_ SV *vs) +Perl_vnormal(pTHX_ SV *vs) { I32 i, len, digit; - SV *sv = NEWSV(92,0); + SV *sv = newSV(0); if ( SvROK(vs) ) vs = SvRV(vs); len = av_len((AV *)vs); @@ -3906,12 +4134,41 @@ Perl_vstringify(pTHX_ SV *vs) else Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit); } - if ( len == 0 ) - Perl_sv_catpv(aTHX_ sv,".0"); + + if ( len <= 2 ) { /* short version, must be at least three */ + for ( len = 2 - len; len != 0; len-- ) + Perl_sv_catpv(aTHX_ sv,".0"); + } + return sv; } /* +=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 @@ -3937,23 +4194,36 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv) { I32 left = SvIV(*av_fetch((AV *)lsv,i,0)); I32 right = SvIV(*av_fetch((AV *)rsv,i,0)); - bool lbeta = left < 0 ? 1 : 0; - bool rbeta = right < 0 ? 1 : 0; - left = PERL_ABS(left); - right = PERL_ABS(right); - if ( left < right || (left == right && lbeta && !rbeta) ) + bool lalpha = left < 0 ? 1 : 0; + bool ralpha = right < 0 ? 1 : 0; + left = abs(left); + right = abs(right); + if ( left < right || (left == right && lalpha && !ralpha) ) retval = -1; - if ( left > right || (left == right && rbeta && !lbeta) ) + if ( left > right || (left == right && ralpha && !lalpha) ) retval = +1; i++; } - if ( l != r && retval == 0 ) /* possible match except for trailing 0 */ + if ( l != r && retval == 0 ) /* possible match except for trailing 0's */ { - if ( !( l < r && r-l == 1 && SvIV(*av_fetch((AV *)rsv,r,0)) == 0 ) && - !( l-r == 1 && SvIV(*av_fetch((AV *)lsv,l,0)) == 0 ) ) + if ( l < r ) + { + while ( i <= r && retval == 0 ) + { + if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 ) + retval = -1; /* not a match after all */ + i++; + } + } + else { - retval = l < r ? -1 : +1; /* not a match after all */ + while ( i <= l && retval == 0 ) + { + if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 ) + retval = +1; /* not a match after all */ + i++; + } } } return retval; @@ -4427,7 +4697,7 @@ Perl_get_hash_seed(pTHX) Perl_croak(aTHX_ "Your random numbers are not that random"); } } - PL_new_hash_seed_set = TRUE; + PL_rehash_seed_set = TRUE; return myseed; }