diff options
| author | Kevin B Kenny <kennykb@acm.org> | 2005-01-20 14:53:39 (GMT) |
|---|---|---|
| committer | Kevin B Kenny <kennykb@acm.org> | 2005-01-20 14:53:39 (GMT) |
| commit | 172eba6b059a50c842e7cf74bb5b736e4b4bddb1 (patch) | |
| tree | e32b20cbd0eb3d2afb6672b2d45af066a65f7b80 | |
| parent | c6eed44de770e7984244f53bf6e84860add2a125 (diff) | |
| download | tcl-172eba6b059a50c842e7cf74bb5b736e4b4bddb1.zip tcl-172eba6b059a50c842e7cf74bb5b736e4b4bddb1.tar.gz tcl-172eba6b059a50c842e7cf74bb5b736e4b4bddb1.tar.bz2 | |
reverting to HEAD in preparation for changing from reworked 'mpexpr' to 'libtommath'
33 files changed, 519 insertions, 1671 deletions
diff --git a/doc/BigInt.3 b/doc/BigInt.3 deleted file mode 100644 index 4b37154..0000000 --- a/doc/BigInt.3 +++ /dev/null @@ -1,156 +0,0 @@ -.\" -* nroff -*- -.\" Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. -.\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -'\" RCS: @(#) $Id: BigInt.3,v 1.1.2.3 2004/12/13 21:23:10 kennykb Exp $ -'\" -.so man.macros -.TH Tcl_BigInt 3 8.5 Tcl "Tcl Library Procedures" -.BS -.SH NAME -Tcl_BigIntFromInt, Tcl_BigIntFromWideInt, Tcl_FreeBigInt \- manipulate arbitrary precision integers. -.SH Synopsis -.nf -\fB#include <tcl.h>\fR -.sp -Tcl_BigInt -\fBTcl_BigIntFromInt\fR(\fIintVal\fR) -.sp -Tcl_BigInt -\fBTcl_BigIntFromWideInt\fR(\fIwideVal\fR) -.sp -Tcl_BigInt -\fBTcl_CopyBigInt\fR(\fIbigVal\fR) -.sp -void -\fBTcl_FreeBigInt\fR(\fIbigVal\fR) -.sp -int -\fBTcl_BigIntIsEven\fR(\fIbigVal\fR) -.sp -int -\fBTcl_BigIntIsOdd\fR(\fIbigVal\fR) -.sp -int -\fBTcl_BigIntIsZero\fR(\fIbigVal\fR) -.sp -int -\fBTcl_BigIntIsNegative\fR(\fIbigVal\fR) -.sp -int -\fBTcl_BigIntIsPositive\fR(\fIbigVal\fR) -.sp -int -\fBTcl_BigIntIsUnit\fR(\fIbigVal\fR) -.sp -int -\fBTcl_BigIntIsOne\fR(\fIbigVal\fR) -.sp -int -\fBTcl_BigIntIsMinusOne\fR(\fIbigVal\fR) -.sp -int -\fBTcl_BigIntIsInt\fR(\fIbigVal\fR) -.sp -int -\fBTcl_BigIntIsWideInt\fR(\fIbigVal\fR -.sp -Tcl_BigInt -\fBTcl_AddBigInt\fR(\fIbigVal1\fR, \fIbigVal2\fR).sp -.sp -Tcl_BigInt -\fBTcl_SubtractBigInt\fR(\fIbigVal1\fR, \fIbigVal2\fR) -.sp -Tcl_BigInt -\fBTcl_MultiplyBigIntByNarrowInt\fR(\fIbigVal1\fR,\fInarrowVal2\fR) -.sp -Tcl_BigInt -\fBTcl_ShiftBigInt\fR(\fIbigVal\fR,\fIintVal\fR) -.SH ARGUMENTS -.AS "Tcl_NarrowInt" narrowVal2 in/out -.AP Tcl_BigInt bigVal -The arbitrary-precision integer value to use as an operand. -.AP Tcl_BigInt bigVal1 -The arbitrary-precision integer value to use as the first operand of -an operation. -.AP Tcl_BigInt bigVal2 -The arbitrary-precision integer value to use as the second operand of -an operation. -.AP int intVal in -The native integer value to use as an operand. -.AP Tcl_NarrowInt narrowVal2 -The "narrow" integer value to use as the second operand of an operation -.AP Tcl_WideInt wideVal in -The wide integer value to use as an operand. -.BE - -.SH DESCRIPTION -.PP -The procedures described in this manual entry allow a C program that -links with the Tcl library to manipulate integers of arbitrary -precision. -.PP -\fBTcl_BigIntFromInt\fR and \fBTcl_BigIntFromWideInt\fR construct -arbitrary-precision integers from native integers. Each accepts a -single argument which is an \fBint\fR or a \fBTcl_WideInt\fR -respectively, and constructs a \fBTcl_BigInt\fR that represents the -same value. The value must eventually be freed by passing it to -\fBTcl_FreeBigInt\fR. -.PP -\fBTcl_CopyBigInt\fR makes a copy of a \fBTcl_BigInt\fR (passed -as the \fIbigVal\rR argument) in newly allocated memory. The copy -is returned, and must eventually be freed by passing it to -\fBTcl_FreeBigInt\fR. -.PP -\fBTcl_FreeBigInt\fR frees a big integer value that was previously -allocated by any of the \fBTcl_BigInt\fR procedures. It accepts a single -\fIbigVal\fR argument, and frees all memory associated with it. -.PP -\fBTcl_BigIntIsEven\fR tests whether \fIbigVal\fR is even, returning -1 if it is and 0 if it isn't. Similarly \fBTcl_BigIntIsOdd\fR tests -whether \fIbigVal\fR is odd, \fBTcl_BigIntIsZero\fR tests whether it -is zero, \fBTcl_BigIntIsNegative\fR tests whether it is negative, -\fBTcl_BigIntIsPositive\fR tests whether it is strictly positive, -\fBTcl_BigIntIsUnit\fR tests whether it is either 1 or -1, -\fBTcl_BigIntIsOne\fR tests whether it is equal to 1, and -\fBTcl_BigIntIsMinusOne\fR tests whether it is equal to -1. -.PP -\fBTcl_BigIntIsInt\fR returns 1 if \fIbigVal\fR will fit in a native -\fBint\fR, and 0 if it is too big to fit. Similarly, -\fBTcl_BigIntIsWideInt\fR returns 1 if \fIbigVal\fR will fit in a -\fBTcl_WideInt\fR and 0 otherwise. -.PP -\fBTcl_GetIntFromBigInt\fR returns the value of \fIbigVal\fR converted -to a native \fBint\fR. \fBTcl_GetWideIntFromBigInt\fR returns the -value of \fIbigVal\fR converted to a \fBTcl_WideInt\fR. Both -functions ignore overflow, returning the least significant bits of -a value that is too large to fit. Use \fBTcl_BigIntIsInt\fR or -\fBTcl_BigIntIsWide\fR to check the size of an integer before -conversion if overflow will be a problem. -.PP -\fBTcl_AddBigInt\fR and \fBTcl_SubtractBigInt\fR, respectively, -add and subtract arbitrary-precision integers. \fIbigVal1\fR is the -left operand of these operations, and \fIbigVal2\fR is the right -operand. The result is returned from the functions, and must -eventually be freed by calling \fBTcl_FreeBigInt\fR. -.PP -\fBTcl_MultiplyBigIntByNarrowInt\fR multiplies an arbitrary-precision -integer, \fIbigVal1\fR, by a narrow integer, \fInarrowVal2\fR. The -width of the narrow integer is platform dependent; the function is -useful chiefly for multiplying a large integer by a small constant -such as 2 or 10. The result returned must eventually be freed by -calling \fBTcl_FreeBigInt\fR. -.PP -\fBTcl_ShiftBigInt\fR multiplies an arbitrary-precision integer, -\fIbigVal\fR by a power of two. The exponent of two is passed as -\fIintVal\fR. Multiplication by a negative power of two is possible, -and truncates toward negative infinity. The result returned must -eventually be freed by calling \fBTcl_FreeBigInt\fR. - -.SH "SEE ALSO" -Tcl_IntObj - -.SH KEYWORDS -integer, wide, integer type, arbitrary precision, multiple precision, bignum
\ No newline at end of file diff --git a/doc/lsearch.n b/doc/lsearch.n index 5cfce90..a860ff2 100644 --- a/doc/lsearch.n +++ b/doc/lsearch.n @@ -1,4 +1,3 @@ -'\" -*- nroff -*- '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -8,7 +7,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: lsearch.n,v 1.21 2004/09/02 13:55:55 dkf Exp $ +'\" RCS: @(#) $Id: lsearch.n,v 1.21.2.1 2005/01/20 14:53:39 kennykb Exp $ '\" .so man.macros .TH lsearch n 8.5 Tcl "Tcl Built-In Commands" @@ -171,3 +170,7 @@ lset(n), lsort(n), lrange(n), lreplace(n) .SH KEYWORDS list, match, pattern, regular expression, search, string + +'\" Local Variables: +'\" mode: nroff +'\" End: diff --git a/doc/pkgMkIndex.n b/doc/pkgMkIndex.n index a7291b2..7a2a526 100644 --- a/doc/pkgMkIndex.n +++ b/doc/pkgMkIndex.n @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: pkgMkIndex.n,v 1.14 2003/02/25 23:58:09 dgp Exp $ +'\" RCS: @(#) $Id: pkgMkIndex.n,v 1.14.6.1 2005/01/20 14:53:39 kennykb Exp $ '\" .so man.macros .TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands" @@ -109,7 +109,8 @@ upon \fBpackage require\fR. This is the default. \fB\-lazy\fR The generated index will manage to delay loading the package until the use of one of the commands provided by the package, instead of loading -it immediately upon \fBpackage require\fR. +it immediately upon \fBpackage require\fR. This is not compatible with +the use of \fIauto_reset\fR, and therefore its use is discouraged. .TP 15 \fB\-load \fIpkgPat\fR The index process will pre-load any packages that exist in the diff --git a/doc/re_syntax.n b/doc/re_syntax.n index 63c1405..0ca68f7 100644 --- a/doc/re_syntax.n +++ b/doc/re_syntax.n @@ -1,4 +1,3 @@ -'\" -*- nroff -*- '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation @@ -6,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: re_syntax.n,v 1.5 2004/10/31 16:01:54 dkf Exp $ +'\" RCS: @(#) $Id: re_syntax.n,v 1.5.2.1 2005/01/20 14:53:39 kennykb Exp $ '\" .so man.macros .TH re_syntax n "8.1" Tcl "Tcl Built-In Commands" @@ -654,3 +653,7 @@ RegExp(3), regexp(n), regsub(n), lsearch(n), switch(n), text(n) .SH KEYWORDS match, regular expression, string + +'\" Local Variables: +'\" mode: nroff +'\" End: diff --git a/doc/string.n b/doc/string.n index f0f21ad..ad49901 100644 --- a/doc/string.n +++ b/doc/string.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: string.n,v 1.24 2004/10/27 14:24:37 dkf Exp $ +'\" RCS: @(#) $Id: string.n,v 1.24.2.1 2005/01/20 14:53:39 kennykb Exp $ '\" .so man.macros .TH string n 8.1 Tcl "Tcl Built-In Commands" @@ -286,19 +286,19 @@ specified as for the \fBindex\fR method. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? Returns a value equal to \fIstring\fR except that any leading or -trailing characters from the set given by \fIchars\fR are removed. If +trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (spaces, tabs, newlines, and carriage returns). .TP \fBstring trimleft \fIstring\fR ?\fIchars\fR? Returns a value equal to \fIstring\fR except that any leading -characters from the set given by \fIchars\fR are removed. If +characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (spaces, tabs, newlines, and carriage returns). .TP \fBstring trimright \fIstring\fR ?\fIchars\fR? Returns a value equal to \fIstring\fR except that any trailing -characters from the set given by \fIchars\fR are removed. If +characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (spaces, tabs, newlines, and carriage returns). .TP @@ -334,3 +334,7 @@ expr(n), list(n) .SH KEYWORDS case conversion, compare, index, match, pattern, string, word, equal, ctype + +'\" Local Variables: +'\" mode: nroff +'\" End: diff --git a/generic/tclBigInt.c b/generic/tclBigInt.c deleted file mode 100644 index 128e229..0000000 --- a/generic/tclBigInt.c +++ /dev/null @@ -1,982 +0,0 @@ -/* - *---------------------------------------------------------------------- - * - * tclBigInt.c -- - * - * Procedures that manipulate arbitrary-precision integers within - * the Tcl core. - * - * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. - * - * Based loosely on various files from the 'mpexpr' module, which - * is copyright (c) 1994 by David I. Bell. (Note that all of the - * code here has been reimplemented; none of Bell's original expression - * remains.) - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclBigInt.c,v 1.1.2.4 2004/12/14 18:43:41 kennykb Exp $" - * - *---------------------------------------------------------------------- - */ - -#include "tclInt.h" - -/* - * The 'BigInt' structure holds an arbitrary-precision integer. - */ - -typedef struct BigInt { - - size_t len; /* Number of values in the array */ - int signum; /* Sign of the integer */ - Tcl_NarrowUInt v[1]; /* Little-endian array containing - * the absolute value of the integer */ - -} BigInt; - -/* - * Check assumptions about widths of various values and fail if they - * are incorrect. - */ - -#if ( SIZEOF_INT % TCL_SIZEOF_NARROW_INT != 0 ) -#error "narrow integers are smaller than ordinary ones and do not divide them" -#endif -#if (TCL_SIZEOF_WIDE_INT > TCL_SIZEOF_NARROW_INT ) && ( TCL_SIZEOF_WIDE_INT % TCL_SIZEOF_NARROW_INT != 0 ) -#error "narrow integers are smaller than wide ones and do not divide them" -#endif - -#define NARROW_UINT_MAX ( (Tcl_WideUInt) ~ (Tcl_NarrowUInt) 0 ) -#define NARROW_INT_MAX ( (Tcl_NarrowUInt) (NARROW_UINT_MAX/2) ) -#define NARROW_UINT_BITS ( 8 * sizeof( Tcl_NarrowUInt ) ) -#define NARROW_UINT_PER_INT \ - ( ( sizeof( int ) + sizeof( Tcl_NarrowUInt ) - 1 ) \ - / sizeof( Tcl_NarrowUInt ) ) -#define NARROW_UINT_PER_WIDE_INT \ - ( ( sizeof( Tcl_WideUInt ) + sizeof( Tcl_NarrowUInt ) - 1 ) \ - / sizeof( Tcl_NarrowUInt ) ) -#define BASE ( (Tcl_WideInt) 1 << NARROW_UINT_BITS ) - -#define NewBigInt(n) \ - ( (BigInt*) ( ckalloc( sizeof( BigInt ) \ - + ((n)-1) * sizeof( Tcl_NarrowUInt ) ) ) ) - -/* - * Static functions defined in this file - */ - -static BigInt* AddAbsValues( BigInt* z1, BigInt* z2 ); - /* Add the absolute values of two large - * integers */ -static BigInt* SubtractAbsValues( BigInt* z1, BigInt* z2 ); - /* Subtract the absolute values of two - * large integers */ - - -/* - *---------------------------------------------------------------------- - * - * Tcl_BigIntFromInt -- - * - * Creates a big integer from a native integer. - * - * Results: - * Returns the big integer just created. - * - * This function creates a big integer from a native integer. Refer - * to the user documentation for details. - * - *---------------------------------------------------------------------- - */ - -Tcl_BigInt -Tcl_BigIntFromInt( int intVal ) /* Value to place in the big integer */ -{ - - BigInt* retVal = NewBigInt(NARROW_UINT_PER_INT); -#if ( SIZEOF_INT > TCL_SIZEOF_NARROW_INT ) - size_t i; -#endif - - if ( intVal < 0 ) { - intVal = -intVal; - retVal->signum = 1; - } else { - retVal->signum = 0; - } - -#if ( SIZEOF_INT <= TCL_SIZEOF_NARROW_INT ) - - /* Common case - an integer fits in a single word of retval->v */ - - retVal->v[0] = intVal; - retVal->len = 1; - -#else - - /* Hairy case - we have to pack the integer into multiple words. */ - - i = 0; - do { - retval -> v[ i++ ] = (Tcl_NarrowUInt) ( intVal & NARROW_UINT_MAX ); - intVal >>= NARROW_UINT_BITS; - } while ( intVal != 0 && i < NARROW_UINT_PER_INT ); - -#endif - - return (Tcl_BigInt) retVal; - -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_BigIntFromWideInt -- - * - * Creates a big integer from a native integer. - * - * Results: - * Returns the big integer just created. - * - * This function creates a big integer from a native integer. Refer - * to the user documentation for details. - * - *---------------------------------------------------------------------- - */ - -Tcl_BigInt -Tcl_BigIntFromWideInt( Tcl_WideInt intVal ) - /* Value to place in the big integer */ -{ - BigInt* retVal = NewBigInt( NARROW_UINT_PER_WIDE_INT ); - size_t i; - - if ( intVal < 0 ) { - intVal = -intVal; - retVal->signum = 1; - } else { - retVal->signum = 0; - } - - i = 0; - do { - retVal -> v[ i++ ] = (Tcl_NarrowUInt) ( intVal & NARROW_UINT_MAX ); - intVal >>= NARROW_UINT_BITS; - } while ( intVal != 0 && i < NARROW_UINT_PER_WIDE_INT ); - - return (Tcl_BigInt) retVal; - -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CopyBigInt -- - * - * Make a deep copy of an arbitrary-precision integer. - * - * Results: - * Returns the copy. - * - *---------------------------------------------------------------------- - */ - -Tcl_BigInt -Tcl_CopyBigInt( Tcl_BigInt bigVal ) - /* Value to copy */ -{ - BigInt* v = (BigInt*) bigVal; - BigInt* retVal = NewBigInt( v->len ); - memcpy( retVal, v, sizeof( BigInt ) + v->len * sizeof( Tcl_NarrowUInt ) ); - return (Tcl_BigInt) retVal; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FreeBigInt -- - * - * Frees an arbitrary-precision integer. - * - * Results: - * None. - * - * Side effects: - * Integer is freed. - * - * The Tcl_FreeBigInt function frees an arbitrary-precision integer. - * Refer to the user documentation for details. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FreeBigInt( Tcl_BigInt bigVal ) - /* Value to free */ -{ - BigInt* val = (BigInt*) bigVal; - ckfree( (void*) val ); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_BigIntIsEven, Tcl_BigIntIsOdd, Tcl_BigIntIsZero, - * Tcl_BigIntIsNegative, Tcl_BigIntIsPositive, Tcl_BigIntIsUnit, - * Tcl_BigIntIsOne, Tcl_BigIntIsMinusOne, - * Tcl_BigIntIsInt, Tcl_BigIntIsWideInt -- - * - * Simple predicates applying to Tcl's arbitrary precision integers. - * - * Results: - * Return values of 1 or 0 according to whether the given condition - * is true. - * - * These procedures all do simple tests on a single big-integer value. - * Refer to the user documentation for details. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_BigIntIsEven( Tcl_BigInt bigVal ) - /* Value to test */ -{ - BigInt* z = (BigInt*) bigVal; - return ( (z->v[0] & 1) == 0 ); -} - -int -Tcl_BigIntIsOdd( Tcl_BigInt bigVal ) - /* Value to test */ -{ - BigInt* z = (BigInt*) bigVal; - return ( (z->v[0] & 1) != 0 ); -} - -int -Tcl_BigIntIsZero( Tcl_BigInt bigVal ) - /* Value to test */ -{ - BigInt* z = (BigInt*) bigVal; - return ( z->len == 1 && z->v[0] == 0 ); -} - -int -Tcl_BigIntIsNegative( Tcl_BigInt bigVal ) - /* Value to test */ -{ - BigInt* z = (BigInt*) bigVal; - return ( z->signum ); -} - -int -Tcl_BigIntIsPositive( Tcl_BigInt bigVal ) - /* Value to test */ -{ - BigInt* z = (BigInt*) bigVal; - return ( z->signum == 0 && ( z->len > 1 || z->v[0] != 0 ) ); -} - -int -Tcl_BigIntIsUnit( Tcl_BigInt bigVal ) - /* Value to test */ -{ - BigInt* z = (BigInt*) bigVal; - return ( z->len == 1 && z->v[0] == 1 ); -} - -int -Tcl_BigIntIsOne( Tcl_BigInt bigVal ) - /* Value to test */ -{ - BigInt* z = (BigInt*) bigVal; - return ( z->len == 1 && z->v[0] == 1 && !z->signum ); -} - -int -Tcl_BigIntIsMinusOne( Tcl_BigInt bigVal ) - /* Value to test */ -{ - BigInt* z = (BigInt*) bigVal; - return ( z->len == 1 && z->v[0] == 1 && z->signum ); -} - -int -Tcl_BigIntIsInt( Tcl_BigInt bigVal ) -{ - /* - * ASSUMPTION: This code assumes that the size of Tcl_NarrowUInt - * divides sizeof(int) evenly. The assumption is tested - * in #ifdefs at the head of this file. - */ - BigInt* z = (BigInt*) bigVal; - int mostSigWord; - if ( z->len > NARROW_UINT_PER_INT ) { - return 0; - } - if ( z->len < NARROW_UINT_PER_INT ) { - return 1; - } - mostSigWord = z->v[ NARROW_UINT_PER_INT - 1 ]; - if ( z->signum ) { - return ( mostSigWord-1 <= NARROW_INT_MAX ); - } else { - return ( mostSigWord <= NARROW_INT_MAX ); - } -} - -int -Tcl_BigIntIsWideInt( Tcl_BigInt bigVal ) -{ - BigInt* z = (BigInt*) bigVal; - int mostSigWord; - if ( z->len > NARROW_UINT_PER_WIDE_INT ) { - return 0; - } - if ( z->len < NARROW_UINT_PER_WIDE_INT ) { - return 1; - } - mostSigWord = z->v[ NARROW_UINT_PER_WIDE_INT - 1 ]; - if ( z->signum ) { - return ( mostSigWord-1 <= NARROW_INT_MAX ); - } else { - return ( mostSigWord <= NARROW_INT_MAX ); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetIntFromBigInt, Tcl_GetWideIntFromBigInt -- - * - * Convert an arbitrary-precision integer to a native integer. - * - * Results: - * Returns the converted value. - * - * These two functions convert an arbitrary-precision integer to a - * native one. If the conversion results in an overflow, the - * native integer will be the least significant bits of the - * arbitrary-precision one. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetIntFromBigInt( Tcl_BigInt bigVal ) -{ - BigInt* z = (BigInt*) bigVal; - unsigned int retval; -#if SIZEOF_INT <= TCL_SIZEOF_NARROW_INT - retval = (unsigned int) (z->v[0]); -#else - int i = z->len-1; - if ( i >= NARROW_UINT_PER_INT ) { - i = NARROW_UINT_PER_INT - 1; - } - retval = (unsigned int) (z->v[i--]); - while ( i >= 0 ) { - retval = ( retval << ( 8 * sizeof( Tcl_NarrowUInt ) ) ) - | (unsigned int) (z->v[i--]); - } -#endif - if ( z->signum ) { - return - (int) retval; - } else { - return (int) retval; - } -} - -Tcl_WideInt -Tcl_GetWideIntFromBigInt( Tcl_BigInt bigVal ) -{ - BigInt* z = (BigInt*) bigVal; - Tcl_WideUInt retval; - int i = z->len-1; - if ( i >= NARROW_UINT_PER_WIDE_INT ) { - i = NARROW_UINT_PER_WIDE_INT - 1; - } - retval = (Tcl_WideUInt) (z->v[i--]); - while ( i >= 0 ) { - retval = ( retval << ( 8 * sizeof( Tcl_NarrowUInt ) ) ) - | (Tcl_WideUInt) (z->v[i--]); - } - if ( z->signum ) { - return - (Tcl_WideInt) retval; - } else { - return (Tcl_WideInt) retval; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_BigIntCompare -- - * - * Compares two Tcl_BigInt values to see which is larger. - * - * Results: - * Returns -1 if bigVal1 is smaller, 0 if they are equal, 1 - * if bigVal2 is smaller. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_CompareBigInt( Tcl_BigInt bigVal1, Tcl_BigInt bigVal2 ) -{ - BigInt* z1 = (BigInt*) bigVal1; - BigInt* z2 = (BigInt*) bigVal2; - int sign; - size_t i; - - /* Non-negative numbers are greater than negative ones. */ - - if ( z1->signum < z2->signum ) { - return 1; - } else if ( z2->signum < z1->signum ) { - return -1; - } - - /* If both numbers are negative, reverse the sense of the comparison */ - - if ( z2->signum ) { - sign = -1; - } else { - sign = 1; - } - - /* Longer numbers are greater than shorter ones. */ - - if ( z1->len > z2->len ) { - return sign; - } else if ( z1->len < z2->len ) { - return -sign; - } - - /* - * Compare the individual words of the numbers, most significant parts - * first, and return when one number does not equal the other. */ - - for ( i = z2->len - 1; i >= 0; --i ) { - Tcl_NarrowUInt part1 = z1->v[i]; - Tcl_NarrowUInt part2 = z2->v[i]; - if ( part1 > part2 ) { - return sign; - } else if ( part1 < part2 ) { - return -sign; - } - } - - /* Two numbers are equal. */ - - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AddBigInt -- - * - * Adds together two large integers. - * - * Results: - * Returns the sum. - * - *---------------------------------------------------------------------- - */ - -Tcl_BigInt -Tcl_AddBigInt( Tcl_BigInt bigVal1, Tcl_BigInt bigVal2 ) -{ - BigInt* z1 = (BigInt*) bigVal1; - BigInt* z2 = (BigInt*) bigVal2; - BigInt* retVal; - - /* - * Add numbers of opposite sign by subtracting the absolute - * value of the negative number from the positive one. - */ - - if (z1->signum && !z2->signum) { - retVal = SubtractAbsValues( z2, z1 ); - } else if (z2->signum && !z1->signum) { - retVal = SubtractAbsValues( z1, z2 ); - } else { - - /* - * Add numbers of like sign by adding their absolute values - * and correcting the sign. - */ - - retVal = AddAbsValues( z1, z2 ); - retVal->signum = z1->signum; - } - - return (Tcl_BigInt) retVal; - -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SubtractBigInt -- - * - * Subtracts one large integer from another. - * - * Results: - * Returns the difference (bigVal1-bigVal2). - * - *---------------------------------------------------------------------- - */ - -Tcl_BigInt -Tcl_SubtractBigInt( Tcl_BigInt bigVal1, Tcl_BigInt bigVal2 ) -{ - BigInt* z1 = (BigInt*) bigVal1; - BigInt* z2 = (BigInt*) bigVal2; - BigInt* retVal; - - if ( z1->signum != z2->signum ) { - /* - * Subtracting two numbers of opposite sign is done by adding - * their absolute values. - */ - retVal = AddAbsValues( z1, z2 ); - retVal->signum = z1->signum; - } else { - /* - * Subtracting two numbers of like sign is done by subtracting - * absolute values and correcting the sign. - */ - retVal = SubtractAbsValues( z1, z2 ); - if ( z1->signum && ( retVal->len > 1 || retVal->v[0] != 0 ) ) { - retVal->signum = ! (retVal->signum); - } - } - return (Tcl_BigInt) retVal; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_MultiplyBigIntByNarrow -- - * - * Multiply a Tcl_BigInt by a small constant. - * - * Results: - * Returns the product - * - *---------------------------------------------------------------------- - */ - -Tcl_BigInt -Tcl_MultiplyBigIntByNarrowInt( Tcl_BigInt bigVal, Tcl_NarrowInt smallVal ) -{ - BigInt* z = (BigInt*) bigVal; - BigInt* result; - Tcl_NarrowUInt x; - Tcl_WideUInt carry; - size_t i; - - if ( smallVal == 0 - || ( z->len == 1 && z->v[0] == 0 ) ) { - - /* Multiplication by zero */ - - result = NewBigInt(1); - result->signum = 0; - result->v[0] = 0; - - } else if ( smallVal == 1 || smallVal == -1 ) { - - /* Multiplication by unity. */ - - result = (BigInt*) Tcl_CopyBigInt( bigVal ); - result->signum ^= ( smallVal < 0 ); - - } else { - - /* Multiplication by something else. */ - - result = NewBigInt( z->len + 1 ); - if ( smallVal < 0 ) { - result->signum = -z->signum; - x = - smallVal; - } else { - result->signum = z->signum; - x = smallVal; - } - carry = 0; - for ( i = 0; i < z->len; ++i ) { - carry = carry + x * z->v[i]; - result->v[i] = (Tcl_NarrowUInt) ( carry & NARROW_UINT_MAX ); - carry >>= NARROW_UINT_BITS; - } - if ( carry ) { - result->v[i++] = (Tcl_NarrowUInt) carry; - } - result->len = i; - } - return (Tcl_BigInt) result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ShiftBigInt - * - * Shift a large integer, multiplying it by a power of 2. - * - * Results: - * Returns bigVal * 2**intVal - * - * As is implied by the formula, intVal>0 shifts to the left, - * intVal<0 shifts to the right, intVal==0 does nothing. - * - *---------------------------------------------------------------------- - */ - -Tcl_BigInt -Tcl_ShiftBigInt( Tcl_BigInt bigVal, int intVal ) -{ - BigInt* z = (BigInt*) bigVal; - BigInt* result; - Tcl_WideUInt carry; - Tcl_NarrowUInt *p, *q; - size_t i; - - /* - * Compute the length of the shift, in words and bits. Also - * compute the word size minus the distance to shift. - */ - - size_t words = ( -intVal ) / NARROW_UINT_BITS; - int bits = ( -intVal ) % NARROW_UINT_BITS; - int notbits = NARROW_UINT_BITS - bits; - - if ( intVal == 0 - || ( z->len == 0 && z->v[0] == 0 ) ) { - - /* - * Shift by zero is the identity. Shifting zero by anything - * is zero, hence is also an identity. Handle either case - * by copying the input value. - */ - return Tcl_CopyBigInt( bigVal ); - - } - - /* A negative shift value is a right shift. */ - - if ( intVal < 0 ) { - - size_t l = z->len - words; - Tcl_WideUInt lowmask = (((Tcl_WideUInt) 1) << bits) - 1; - - if ( l <= 0 ) { - - /* - * Shifting a positive number right by more than the length of the - * number yields zero. Shifting a negative number right by more - * than the length of the number yields -1. */ - - result = NewBigInt( 1 ); - result->signum = z->signum; - result->v[0] = z->signum; - return (Tcl_BigInt) result; - - } - - /* - * To preserve truncate-toward-minus-infinity semantics, if the - * number being shifted is negative, we determine whether a one - * bit has been shifted out anywhere, and increment the magnitude - * of the result if it has. - */ - - carry = z->v[0] >> bits; - if ( z->signum ) { - for ( i = 0; i < words; ++i ) { - if ( z->v[i] != 0 ) { - ++carry; - break; - } - } - if ( i >= words - && ( z->v[i] & lowmask ) != 0 ) { - ++carry; - } - } - - if ( bits == 0 && carry == 0 ) { - - /* - * The simple case is shifting by a multiple of the word size - * without awkward carries. - */ - - result = NewBigInt( l ); - result->signum = z->signum; - memcpy( result->v, z->v, l * sizeof( Tcl_NarrowUInt ) ); - return (Tcl_BigInt) result; - - } else { - - /* - * General case - shift right. 'carry' at this point - * contains the least significant 'bits' bits of the result. - * It may exceed that number of bits by one if we are - * shifting a negative number. - * Words 1 through (l-1) of the input argument will be each - * shifted onto this result. - */ - - result = NewBigInt( l + 1 ); - result->signum = z->signum; - - p = z->v + 1; - q = result->v; - for ( i = l; i > 0; --i ) { - carry += *p++ << notbits; - *q++ = (Tcl_NarrowUInt) ( carry & NARROW_UINT_MAX ); - carry >>= NARROW_UINT_BITS; - } - if ( carry ) { - *q++ = (Tcl_NarrowUInt) ( carry & NARROW_UINT_MAX ); - } - - } - - } else { - - /* Shift left */ - - size_t l = z->len + words; - if ( bits == 0 ) { - - /* Easy case - shift left a multiple of the word size. */ - - result = NewBigInt( l ); - result->signum = z->signum; - memset( result->v, 0, words ); - memcpy( result->v + words, z->v, z->len ); - return (Tcl_BigInt) result; - - } else { - - /* Shift left by something other than a multiple of a word */ - - result = NewBigInt( l + 1 ); - carry = 0; - p = z->v; - q = result->v; - for ( i = z->len; i > 0; --i ) { - carry |= ( *p++ << bits ); - *q++ = (Tcl_NarrowUInt) ( carry & NARROW_UINT_MAX ); - carry >>= NARROW_UINT_BITS; - } - *q++ = (Tcl_NarrowUInt) carry; - - } - } - - /* - * The shift may have left a zero in the most significant - * word (or even the most significant two words). - * Find the most significant non-zero word to assign the - * length of the result. - */ - - --q; - while ( q > result->v && *q == 0 ) { - --q; - } - result->len = q + 1 - result->v; - - return (Tcl_BigInt) result; -} - -/* - *---------------------------------------------------------------------- - * - * AddAbsValues -- - * - * Adds the absolute values of two arbitrary-precision integers. - * - * Results: - * Returns an arbitrary-precision integer whose value is the - * sum of the absolute values of the arguments. - * - *---------------------------------------------------------------------- - */ - -static BigInt* -AddAbsValues( BigInt* z1, BigInt* z2 ) -{ - - BigInt* retVal; - Tcl_NarrowUInt *p1, *p2, *pd; - Tcl_WideUInt carry; - size_t len1, len2; - - /* Determine which argument is the longer */ - - if ( z2->len > z1->len ) { - retVal = NewBigInt( z2->len + 1 ); - p1 = z1->v; - p2 = z2->v; - len1 = z1->len; - len2 = z2->len - z1->len; - } else { - retVal = NewBigInt( z1->len + 1 ); - p1 = z1->v; - p2 = z2->v; - len1 = z2->len; - len2 = z1->len - z2->len; - } - - retVal->signum = 0; - carry = 0; - pd = retVal->v; - - /* Add the two arguments */ - - while ( len1-- ) { - carry += (Tcl_WideUInt) (*p1++) + (Tcl_WideUInt) (*p2++); - *pd++ = (Tcl_NarrowUInt) (carry & NARROW_UINT_MAX); - carry >>= NARROW_UINT_BITS; - } - - /* Propagate carries */ - - while ( len2-- ) { - carry += (Tcl_WideUInt) (*p2++); - *pd++ = (Tcl_NarrowUInt) (carry & NARROW_UINT_MAX); - carry >>= NARROW_UINT_BITS; - } - - /* - * If carrying into the most significant word, store the carry; - * otherwise, correct the length. - */ - - if ( carry ) { - *pd = (Tcl_NarrowUInt) carry; - } else { - --( retVal->len ); - } - - return retVal; - -} - -/* - *---------------------------------------------------------------------- - * - * SubtractAbsValues -- - * - * Subtracts the absolute value of the large integer z2 - * from the absolute value of the large integer z1. - * - * Results: - * Returns the difference. - * - *---------------------------------------------------------------------- - */ - -static BigInt* -SubtractAbsValues( BigInt* z1, BigInt* z2 ) -{ - BigInt* retVal; - size_t len1, len2, t; - int bigger2; - Tcl_NarrowUInt *p1, *p2, *pd; - Tcl_WideUInt carry; - - /* - * We need to compute the size of the result before we can - * allocate it. If one operand is longer than the other, the - * size of the result will be the size of the longer operand. - * If the operands are of equal length, we compare them, - * most significant word first, and stop when we find words that - * are different. The size of the result will be one more than - * the position of the first word that differs. - */ - - len1 = z1->len; - len2 = z2->len; - if ( len1 != len2 ) { - bigger2 = (len1 < len2 ); - } else { - p1 = z1->v + ( len1 - 1 ); - p2 = z2->v + ( len2 - 1 ); - while ( ( len1 != 0 ) && ( *p1 == *p2 ) ) { - p1--; - p2--; - len1--; - } - if ( len1 == 0 ) { - retVal = NewBigInt(1); - retVal->signum = 0; - retVal->v[0] = 0; - return retVal; - } - len2 = len1; - bigger2 = ( *p1 < *p2 ); - } - - /* - * At this point, len1 and len2 have the effective lengths of - * operands 1 and 2, respectively. bigger2 is true if the result - * will be negative, and indicates that the absolute value of the - * result will be computed by reversing the sense of the subtraction - * (subtracting z1 from z2). - */ - - if ( bigger2 ) { - retVal = NewBigInt( len2 ); - p1 = z2->v; - p2 = z1->v; - len2 = (len2 - len1); - } else { - retVal = NewBigInt( len1 ); - p1 = z1->v; - p2 = z2->v; - t = (len1 - len2); - len1 = len2; - len2 = t; - } - retVal->signum = bigger2; - pd = retVal->v; - carry = 1; - - /* - * Subtract the two operands. - */ - - while ( len1-- ) { - carry = carry + NARROW_UINT_MAX + *p1++ - *p2++; - *pd++ = (Tcl_NarrowUInt) ( carry & NARROW_UINT_MAX ); - carry >>= NARROW_UINT_BITS; - } - while ( len2-- ) { - carry = carry + NARROW_UINT_MAX + *p1++; - *pd++ = (Tcl_NarrowUInt) ( carry & NARROW_UINT_MAX ); - carry >>= NARROW_UINT_BITS; - } - - /* Clean up any zeroes at the more significant end */ - - while ( pd > retVal->v ) { - if ( *pd != 0 ) break; - --pd; - } - retVal->len = pd + 1 - retVal->v; - - return retVal; - -} diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index a74b6d6..38ec9cf 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFCmd.c,v 1.29 2004/10/19 21:54:07 dgp Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.29.2.1 2005/01/20 14:53:39 kennykb Exp $ */ #include "tclInt.h" @@ -532,14 +532,15 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * permissions, we'll let the actual copy/rename return * an error later. */ -#if !defined(__WIN32__) { - Tcl_Obj* perm = Tcl_NewStringObj("u+w",-1); - Tcl_IncrRefCount(perm); - Tcl_FSFileAttrsSet(NULL, 2, target, perm); - Tcl_DecrRefCount(perm); + Tcl_Obj* perm = Tcl_NewStringObj("u+w",-1); + int index; + Tcl_IncrRefCount(perm); + if (TclFSFileAttrIndex(target, "-permissions", &index) == TCL_OK) { + Tcl_FSFileAttrsSet(NULL, index, target, perm); + } + Tcl_DecrRefCount(perm); } -#endif } if (copyFlag == 0) { diff --git a/generic/tclFileName.c b/generic/tclFileName.c index aba17d7..a89497d 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileName.c,v 1.60 2004/10/07 14:50:21 vincentdarley Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.60.2.1 2005/01/20 14:53:39 kennykb Exp $ */ #include "tclInt.h" @@ -1933,7 +1933,7 @@ static int DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) Tcl_Interp *interp; /* Interpreter to use for error reporting * (e.g. unmatched brace). */ - Tcl_Obj *matchesObj; /* Unshared list object in which to place all + Tcl_Obj *matchesObj; /* Unshared list object in which to place all * resulting filenames. Caller allocates and * deallocates; DoGlob must not touch the * refCount of this object. */ @@ -2259,6 +2259,14 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) Tcl_DStringLength(&append)); } else { joinedPtr = Tcl_DuplicateObj(pathPtr); + if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) { + /* The current prefix must end in a separator */ + int len; + CONST char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + if (strchr(separators, joined[len-1]) == NULL) { + Tcl_AppendToObj(joinedPtr, "/", 1); + } + } Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append), Tcl_DStringLength(&append)); } @@ -2279,6 +2287,14 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) joinedPtr = TclNewFSPathObj(pathPtr, pattern, p-pattern); } else { joinedPtr = Tcl_DuplicateObj(pathPtr); + if (strchr(separators, pattern[0]) == NULL) { + /* The current prefix must end in a separator */ + int len; + CONST char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + if (strchr(separators, joined[len-1]) == NULL) { + Tcl_AppendToObj(joinedPtr, "/", 1); + } + } Tcl_AppendToObj(joinedPtr, pattern, p-pattern); } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 17fd376..08224de 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.113 2004/11/17 00:31:47 dgp Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.113.2.1 2005/01/20 14:53:39 kennykb Exp $ */ #include "tclInt.h" @@ -2292,6 +2292,83 @@ Tcl_FSFileAttrStrings(pathPtr, objPtrRef) /* *---------------------------------------------------------------------- * + * TclFSFileAttrIndex -- + * + * Helper function for converting an attribute name to an index + * into the attribute table. + * + * Results: + * Tcl result code, index written to *indexPtr on result==TCL_OK + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFSFileAttrIndex(pathPtr, attributeName, indexPtr) + Tcl_Obj *pathPtr; /* File whose attributes are to be + * indexed into. */ + CONST char *attributeName; /* The attribute being looked for. */ + int *indexPtr; /* Where to write the found index. */ +{ + Tcl_Obj *listObj = NULL; + CONST char **attrTable; + + /* + * Get the attribute table for the file. + */ + + attrTable = Tcl_FSFileAttrStrings(pathPtr, &listObj); + if (listObj != NULL) { + Tcl_IncrRefCount(listObj); + } + + if (attrTable != NULL) { + /* + * It's a constant attribute table, so use T_GIFO. + */ + + Tcl_Obj *tmpObj = Tcl_NewStringObj(attributeName, -1); + int result; + + result = Tcl_GetIndexFromObj(NULL, tmpObj, attrTable, NULL, TCL_EXACT, + indexPtr); + TclDecrRefCount(tmpObj); + if (listObj != NULL) { + TclDecrRefCount(listObj); + } + return result; + } else if (listObj != NULL) { + /* + * It's a non-constant attribute list, so do a literal search. + */ + + int i, objc; + Tcl_Obj **objv; + + if (Tcl_ListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) { + TclDecrRefCount(listObj); + return TCL_ERROR; + } + for (i=0 ; i<objc ; i++) { + if (!strcmp(attributeName, TclGetString(objv[i]))) { + TclDecrRefCount(listObj); + *indexPtr = i; + return TCL_OK; + } + } + TclDecrRefCount(listObj); + return TCL_ERROR; + } else { + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_FSFileAttrsGet -- * * This procedure implements read access for the hookable 'file @@ -2951,8 +3028,7 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, return -1; } - if (TclCrossFilesystemCopy(interp, pathPtr, - copyToPtr) == TCL_OK) { + if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) == TCL_OK) { Tcl_LoadHandle newLoadHandle = NULL; ClientData newClientData = NULL; Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; @@ -2969,9 +3045,13 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, * we just do this directly, like this: */ + int index; Tcl_Obj* perm = Tcl_NewStringObj("0700",-1); Tcl_IncrRefCount(perm); - Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm); + if (TclFSFileAttrIndex(copyToPtr, "-permissions", + &index) == TCL_OK) { + Tcl_FSFileAttrsSet(NULL, index, copyToPtr, perm); + } Tcl_DecrRefCount(perm); #endif diff --git a/generic/tclPort.h b/generic/tclPort.h index 3d9af28..504a96c 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.h @@ -10,16 +10,16 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPort.h,v 1.13 2004/11/24 21:37:31 davygrvy Exp $ + * RCS: @(#) $Id: tclPort.h,v 1.13.2.1 2005/01/20 14:53:40 kennykb Exp $ */ #ifndef _TCLPORT #define _TCLPORT -#include "tcl.h" #ifdef HAVE_TCL_CONFIG_H #include "tclConfig.h" #endif +#include "tcl.h" #if defined(__WIN32__) # include "../win/tclWinPort.h" diff --git a/library/http/http.tcl b/library/http/http.tcl index 29662a4..7488bc9 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: http.tcl,v 1.48 2004/05/25 22:56:33 hobbs Exp $ +# RCS: @(#) $Id: http.tcl,v 1.48.2.1 2005/01/20 14:53:40 kennykb Exp $ # Rough version history: # 1.0 Old http_get interface @@ -22,10 +22,10 @@ # 2.4 Added -binary option to http::geturl and charset element # to the state array. -package require Tcl 8.2 +package require Tcl 8.4 # keep this in sync with pkgIndex.tcl # and with the install directories in Makefiles -package provide http 2.5.0 +package provide http 2.5.1 namespace eval http { variable http @@ -39,16 +39,17 @@ namespace eval http { set http(-useragent) "Tcl http client package [package provide http]" proc init {} { - variable formMap - variable alphanumeric a-zA-Z0-9 - for {set i 0} {$i <= 256} {incr i} { + # Set up the map for quoting chars + # The spec says: "non-alphanumeric characters are replaced by '%HH'" + for {set i 0} {$i < 256} {incr i} { set c [format %c $i] - if {![string match \[$alphanumeric\] $c]} { - set formMap($c) %[format %.2x $i] + if {![string match {[a-zA-Z0-9]} $c]} { + set map($c) %[format %.2x $i] } } # These are handled specially - array set formMap { " " + \n %0d%0a } + array set map { " " + \n %0d%0a } + variable formMap [array get map] } init @@ -368,7 +369,7 @@ proc http::geturl { url args } { fileevent $s writable [list http::Connect $token] http::wait $token - if {[string equal $state(status) "error"]} { + if {$state(status) eq "error"} { # something went wrong while trying to establish the connection # Clean up after events and such, but DON'T call the command # callback (if available) because we're going to throw an @@ -376,7 +377,7 @@ proc http::geturl { url args } { set err [lindex $state(error) 0] cleanup $token return -code error $err - } elseif {![string equal $state(status) "connect"]} { + } elseif {$state(status) ne "connect"} { # Likely to be connection timeout return $token } @@ -426,7 +427,7 @@ proc http::geturl { url args } { foreach {key value} $state(-headers) { set value [string map [list \n "" \r ""] $value] set key [string trim $key] - if {[string equal $key "Content-Length"]} { + if {$key eq "Content-Length"} { set contDone 1 set state(querylength) $value } @@ -482,7 +483,7 @@ proc http::geturl { url args } { # calls it synchronously, we just do a wait here. wait $token - if {[string equal $state(status) "error"]} { + if {$state(status) eq "error"} { # Something went wrong, so throw the exception, and the # enclosing catch will do cleanup. return -code error [lindex $state(error) 0] @@ -498,7 +499,7 @@ proc http::geturl { url args } { # if state(status) is error, it means someone's already called Finish # to do the above-described clean up. - if {[string equal $state(status) "error"]} { + if {$state(status) eq "error"} { Finish $token $err 1 } cleanup $token @@ -678,7 +679,7 @@ proc http::Event {token} { Eof $token return } - if {[string equal $state(state) "header"]} { + if {$state(state) eq "header"} { if {[catch {gets $s line} n]} { Finish $token $n } elseif {$n == 0} { @@ -816,7 +817,7 @@ proc http::CopyDone {token count {error {}}} { proc http::Eof {token} { variable $token upvar 0 $token state - if {[string equal $state(state) "header"]} { + if {$state(state) eq "header"} { # Premature eof set state(status) eof } else { @@ -866,7 +867,7 @@ proc http::formatQuery {args} { set sep "" foreach i $args { append result $sep [mapReply $i] - if {[string equal $sep "="]} { + if {$sep eq "="} { set sep & } else { set sep = @@ -888,20 +889,23 @@ proc http::formatQuery {args} { proc http::mapReply {string} { variable http variable formMap - variable alphanumeric # The spec says: "non-alphanumeric characters are replaced by '%HH'" - # 1 leave alphanumerics characters alone - # 2 Convert every other character to an array lookup - # 3 Escape constructs that are "special" to the tcl parser - # 4 "subst" the result, doing all the array substitutions + # Use a pre-computed map and [string map] to do the conversion + # (much faster than [regsub]/[subst]). [Bug 1020491] if {$http(-urlencoding) ne ""} { set string [encoding convertto $http(-urlencoding) $string] + return [string map $formMap $string] } - regsub -all \[^$alphanumeric\] $string {$formMap(&)} string - regsub -all {[][{})\\]\)} $string {\\&} string - return [subst -nocommand $string] + set converted [string map $formMap $string] + if {[string match "*\[\u0100-\uffff\]*" $converted]} { + regexp {[\u0100-\uffff]} $converted badChar + # Return this error message for maximum compatability... :^/ + return -code error \ + "can't read \"formMap($badChar)\": no such element in array" + } + return $converted } # http::ProxyRequired -- diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 8efa64c..c937b60 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -8,5 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded http 2.5.0 [list tclPkgSetup $dir http 2.5.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}] +if {![package vsatisfies [package provide Tcl] 8.4]} {return} +package ifneeded http 2.5.1 [list tclPkgSetup $dir http 2.5.1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}] diff --git a/library/tzdata/America/Asuncion b/library/tzdata/America/Asuncion index 23035d6..b85c7e0 100644 --- a/library/tzdata/America/Asuncion +++ b/library/tzdata/America/Asuncion @@ -65,195 +65,195 @@ set TZData(:America/Asuncion) { {1049598000 -14400 0 PYT} {1062907200 -10800 1 PYST} {1081047600 -14400 0 PYT} - {1094356800 -10800 1 PYST} - {1112497200 -14400 0 PYT} - {1125806400 -10800 1 PYST} - {1143946800 -14400 0 PYT} - {1157256000 -10800 1 PYST} - {1175396400 -14400 0 PYT} - {1188705600 -10800 1 PYST} - {1207450800 -14400 0 PYT} - {1220760000 -10800 1 PYST} - {1238900400 -14400 0 PYT} - {1252209600 -10800 1 PYST} - {1270350000 -14400 0 PYT} - {1283659200 -10800 1 PYST} - {1301799600 -14400 0 PYT} - {1315108800 -10800 1 PYST} - {1333249200 -14400 0 PYT} - {1346558400 -10800 1 PYST} - {1365303600 -14400 0 PYT} - {1378008000 -10800 1 PYST} - {1396753200 -14400 0 PYT} - {1410062400 -10800 1 PYST} - {1428202800 -14400 0 PYT} - {1441512000 -10800 1 PYST} - {1459652400 -14400 0 PYT} - {1472961600 -10800 1 PYST} - {1491102000 -14400 0 PYT} - {1504411200 -10800 1 PYST} - {1522551600 -14400 0 PYT} - {1535860800 -10800 1 PYST} - {1554606000 -14400 0 PYT} - {1567310400 -10800 1 PYST} - {1586055600 -14400 0 PYT} - {1599364800 -10800 1 PYST} - {1617505200 -14400 0 PYT} - {1630814400 -10800 1 PYST} - {1648954800 -14400 0 PYT} - {1662264000 -10800 1 PYST} - {1680404400 -14400 0 PYT} - {1693713600 -10800 1 PYST} - {1712458800 -14400 0 PYT} - {1725163200 -10800 1 PYST} - {1743908400 -14400 0 PYT} - {1757217600 -10800 1 PYST} - {1775358000 -14400 0 PYT} - {1788667200 -10800 1 PYST} - {1806807600 -14400 0 PYT} - {1820116800 -10800 1 PYST} - {1838257200 -14400 0 PYT} - {1851566400 -10800 1 PYST} - {1869706800 -14400 0 PYT} - {1883016000 -10800 1 PYST} - {1901761200 -14400 0 PYT} - {1914465600 -10800 1 PYST} - {1933210800 -14400 0 PYT} - {1946520000 -10800 1 PYST} - {1964660400 -14400 0 PYT} - {1977969600 -10800 1 PYST} - {1996110000 -14400 0 PYT} - {2009419200 -10800 1 PYST} - {2027559600 -14400 0 PYT} - {2040868800 -10800 1 PYST} - {2059009200 -14400 0 PYT} - {2072318400 -10800 1 PYST} - {2091063600 -14400 0 PYT} - {2104372800 -10800 1 PYST} - {2122513200 -14400 0 PYT} - {2135822400 -10800 1 PYST} - {2153962800 -14400 0 PYT} - {2167272000 -10800 1 PYST} - {2185412400 -14400 0 PYT} - {2198721600 -10800 1 PYST} - {2216862000 -14400 0 PYT} - {2230171200 -10800 1 PYST} - {2248916400 -14400 0 PYT} - {2261620800 -10800 1 PYST} - {2280366000 -14400 0 PYT} - {2293675200 -10800 1 PYST} - {2311815600 -14400 0 PYT} - {2325124800 -10800 1 PYST} - {2343265200 -14400 0 PYT} - {2356574400 -10800 1 PYST} - {2374714800 -14400 0 PYT} - {2388024000 -10800 1 PYST} - {2406164400 -14400 0 PYT} - {2419473600 -10800 1 PYST} - {2438218800 -14400 0 PYT} - {2450923200 -10800 1 PYST} - {2469668400 -14400 0 PYT} - {2482977600 -10800 1 PYST} - {2501118000 -14400 0 PYT} - {2514427200 -10800 1 PYST} - {2532567600 -14400 0 PYT} - {2545876800 -10800 1 PYST} - {2564017200 -14400 0 PYT} - {2577326400 -10800 1 PYST} - {2596071600 -14400 0 PYT} - {2608776000 -10800 1 PYST} - {2627521200 -14400 0 PYT} - {2640830400 -10800 1 PYST} - {2658970800 -14400 0 PYT} - {2672280000 -10800 1 PYST} - {2690420400 -14400 0 PYT} - {2703729600 -10800 1 PYST} - {2721870000 -14400 0 PYT} - {2735179200 -10800 1 PYST} - {2753319600 -14400 0 PYT} - {2766628800 -10800 1 PYST} - {2785374000 -14400 0 PYT} - {2798078400 -10800 1 PYST} - {2816823600 -14400 0 PYT} - {2830132800 -10800 1 PYST} - {2848273200 -14400 0 PYT} - {2861582400 -10800 1 PYST} - {2879722800 -14400 0 PYT} - {2893032000 -10800 1 PYST} - {2911172400 -14400 0 PYT} - {2924481600 -10800 1 PYST} - {2942622000 -14400 0 PYT} - {2955931200 -10800 1 PYST} - {2974676400 -14400 0 PYT} - {2987985600 -10800 1 PYST} - {3006126000 -14400 0 PYT} - {3019435200 -10800 1 PYST} - {3037575600 -14400 0 PYT} - {3050884800 -10800 1 PYST} - {3069025200 -14400 0 PYT} - {3082334400 -10800 1 PYST} - {3100474800 -14400 0 PYT} - {3113784000 -10800 1 PYST} - {3132529200 -14400 0 PYT} - {3145233600 -10800 1 PYST} - {3163978800 -14400 0 PYT} - {3177288000 -10800 1 PYST} - {3195428400 -14400 0 PYT} - {3208737600 -10800 1 PYST} - {3226878000 -14400 0 PYT} - {3240187200 -10800 1 PYST} - {3258327600 -14400 0 PYT} - {3271636800 -10800 1 PYST} - {3289777200 -14400 0 PYT} - {3303086400 -10800 1 PYST} - {3321831600 -14400 0 PYT} - {3334536000 -10800 1 PYST} - {3353281200 -14400 0 PYT} - {3366590400 -10800 1 PYST} - {3384730800 -14400 0 PYT} - {3398040000 -10800 1 PYST} - {3416180400 -14400 0 PYT} - {3429489600 -10800 1 PYST} - {3447630000 -14400 0 PYT} - {3460939200 -10800 1 PYST} - {3479684400 -14400 0 PYT} - {3492388800 -10800 1 PYST} - {3511134000 -14400 0 PYT} - {3524443200 -10800 1 PYST} - {3542583600 -14400 0 PYT} - {3555892800 -10800 1 PYST} - {3574033200 -14400 0 PYT} - {3587342400 -10800 1 PYST} - {3605482800 -14400 0 PYT} - {3618792000 -10800 1 PYST} - {3636932400 -14400 0 PYT} - {3650241600 -10800 1 PYST} - {3668986800 -14400 0 PYT} - {3681691200 -10800 1 PYST} - {3700436400 -14400 0 PYT} - {3713745600 -10800 1 PYST} - {3731886000 -14400 0 PYT} - {3745195200 -10800 1 PYST} - {3763335600 -14400 0 PYT} - {3776644800 -10800 1 PYST} - {3794785200 -14400 0 PYT} - {3808094400 -10800 1 PYST} - {3826234800 -14400 0 PYT} - {3839544000 -10800 1 PYST} - {3858289200 -14400 0 PYT} - {3871598400 -10800 1 PYST} - {3889738800 -14400 0 PYT} - {3903048000 -10800 1 PYST} - {3921188400 -14400 0 PYT} - {3934497600 -10800 1 PYST} - {3952638000 -14400 0 PYT} - {3965947200 -10800 1 PYST} - {3984087600 -14400 0 PYT} - {3997396800 -10800 1 PYST} - {4016142000 -14400 0 PYT} - {4028846400 -10800 1 PYST} - {4047591600 -14400 0 PYT} - {4060900800 -10800 1 PYST} - {4079041200 -14400 0 PYT} - {4092350400 -10800 1 PYST} + {1097985600 -10800 1 PYST} + {1110682800 -14400 0 PYT} + {1129435200 -10800 1 PYST} + {1142132400 -14400 0 PYT} + {1160884800 -10800 1 PYST} + {1173582000 -14400 0 PYT} + {1192939200 -10800 1 PYST} + {1205031600 -14400 0 PYT} + {1224388800 -10800 1 PYST} + {1236481200 -14400 0 PYT} + {1255838400 -10800 1 PYST} + {1268535600 -14400 0 PYT} + {1287288000 -10800 1 PYST} + {1299985200 -14400 0 PYT} + {1318737600 -10800 1 PYST} + {1331434800 -14400 0 PYT} + {1350792000 -10800 1 PYST} + {1362884400 -14400 0 PYT} + {1382241600 -10800 1 PYST} + {1394334000 -14400 0 PYT} + {1413691200 -10800 1 PYST} + {1425783600 -14400 0 PYT} + {1445140800 -10800 1 PYST} + {1457838000 -14400 0 PYT} + {1476590400 -10800 1 PYST} + {1489287600 -14400 0 PYT} + {1508040000 -10800 1 PYST} + {1520737200 -14400 0 PYT} + {1540094400 -10800 1 PYST} + {1552186800 -14400 0 PYT} + {1571544000 -10800 1 PYST} + {1583636400 -14400 0 PYT} + {1602993600 -10800 1 PYST} + {1615690800 -14400 0 PYT} + {1634443200 -10800 1 PYST} + {1647140400 -14400 0 PYT} + {1665892800 -10800 1 PYST} + {1678590000 -14400 0 PYT} + {1697342400 -10800 1 PYST} + {1710039600 -14400 0 PYT} + {1729396800 -10800 1 PYST} + {1741489200 -14400 0 PYT} + {1760846400 -10800 1 PYST} + {1772938800 -14400 0 PYT} + {1792296000 -10800 1 PYST} + {1804993200 -14400 0 PYT} + {1823745600 -10800 1 PYST} + {1836442800 -14400 0 PYT} + {1855195200 -10800 1 PYST} + {1867892400 -14400 0 PYT} + {1887249600 -10800 1 PYST} + {1899342000 -14400 0 PYT} + {1918699200 -10800 1 PYST} + {1930791600 -14400 0 PYT} + {1950148800 -10800 1 PYST} + {1962846000 -14400 0 PYT} + {1981598400 -10800 1 PYST} + {1994295600 -14400 0 PYT} + {2013048000 -10800 1 PYST} + {2025745200 -14400 0 PYT} + {2044497600 -10800 1 PYST} + {2057194800 -14400 0 PYT} + {2076552000 -10800 1 PYST} + {2088644400 -14400 0 PYT} + {2108001600 -10800 1 PYST} + {2120094000 -14400 0 PYT} + {2139451200 -10800 1 PYST} + {2152148400 -14400 0 PYT} + {2170900800 -10800 1 PYST} + {2183598000 -14400 0 PYT} + {2202350400 -10800 1 PYST} + {2215047600 -14400 0 PYT} + {2234404800 -10800 1 PYST} + {2246497200 -14400 0 PYT} + {2265854400 -10800 1 PYST} + {2277946800 -14400 0 PYT} + {2297304000 -10800 1 PYST} + {2309396400 -14400 0 PYT} + {2328753600 -10800 1 PYST} + {2341450800 -14400 0 PYT} + {2360203200 -10800 1 PYST} + {2372900400 -14400 0 PYT} + {2391652800 -10800 1 PYST} + {2404350000 -14400 0 PYT} + {2423707200 -10800 1 PYST} + {2435799600 -14400 0 PYT} + {2455156800 -10800 1 PYST} + {2467249200 -14400 0 PYT} + {2486606400 -10800 1 PYST} + {2499303600 -14400 0 PYT} + {2518056000 -10800 1 PYST} + {2530753200 -14400 0 PYT} + {2549505600 -10800 1 PYST} + {2562202800 -14400 0 PYT} + {2580955200 -10800 1 PYST} + {2593652400 -14400 0 PYT} + {2613009600 -10800 1 PYST} + {2625102000 -14400 0 PYT} + {2644459200 -10800 1 PYST} + {2656551600 -14400 0 PYT} + {2675908800 -10800 1 PYST} + {2688606000 -14400 0 PYT} + {2707358400 -10800 1 PYST} + {2720055600 -14400 0 PYT} + {2738808000 -10800 1 PYST} + {2751505200 -14400 0 PYT} + {2770862400 -10800 1 PYST} + {2782954800 -14400 0 PYT} + {2802312000 -10800 1 PYST} + {2814404400 -14400 0 PYT} + {2833761600 -10800 1 PYST} + {2846458800 -14400 0 PYT} + {2865211200 -10800 1 PYST} + {2877908400 -14400 0 PYT} + {2896660800 -10800 1 PYST} + {2909358000 -14400 0 PYT} + {2928110400 -10800 1 PYST} + {2940807600 -14400 0 PYT} + {2960164800 -10800 1 PYST} + {2972257200 -14400 0 PYT} + {2991614400 -10800 1 PYST} + {3003706800 -14400 0 PYT} + {3023064000 -10800 1 PYST} + {3035761200 -14400 0 PYT} + {3054513600 -10800 1 PYST} + {3067210800 -14400 0 PYT} + {3085963200 -10800 1 PYST} + {3098660400 -14400 0 PYT} + {3118017600 -10800 1 PYST} + {3130110000 -14400 0 PYT} + {3149467200 -10800 1 PYST} + {3161559600 -14400 0 PYT} + {3180916800 -10800 1 PYST} + {3193009200 -14400 0 PYT} + {3212366400 -10800 1 PYST} + {3225063600 -14400 0 PYT} + {3243816000 -10800 1 PYST} + {3256513200 -14400 0 PYT} + {3275265600 -10800 1 PYST} + {3287962800 -14400 0 PYT} + {3307320000 -10800 1 PYST} + {3319412400 -14400 0 PYT} + {3338769600 -10800 1 PYST} + {3350862000 -14400 0 PYT} + {3370219200 -10800 1 PYST} + {3382916400 -14400 0 PYT} + {3401668800 -10800 1 PYST} + {3414366000 -14400 0 PYT} + {3433118400 -10800 1 PYST} + {3445815600 -14400 0 PYT} + {3464568000 -10800 1 PYST} + {3477265200 -14400 0 PYT} + {3496622400 -10800 1 PYST} + {3508714800 -14400 0 PYT} + {3528072000 -10800 1 PYST} + {3540164400 -14400 0 PYT} + {3559521600 -10800 1 PYST} + {3572218800 -14400 0 PYT} + {3590971200 -10800 1 PYST} + {3603668400 -14400 0 PYT} + {3622420800 -10800 1 PYST} + {3635118000 -14400 0 PYT} + {3654475200 -10800 1 PYST} + {3666567600 -14400 0 PYT} + {3685924800 -10800 1 PYST} + {3698017200 -14400 0 PYT} + {3717374400 -10800 1 PYST} + {3730071600 -14400 0 PYT} + {3748824000 -10800 1 PYST} + {3761521200 -14400 0 PYT} + {3780273600 -10800 1 PYST} + {3792970800 -14400 0 PYT} + {3811723200 -10800 1 PYST} + {3824420400 -14400 0 PYT} + {3843777600 -10800 1 PYST} + {3855870000 -14400 0 PYT} + {3875227200 -10800 1 PYST} + {3887319600 -14400 0 PYT} + {3906676800 -10800 1 PYST} + {3919374000 -14400 0 PYT} + {3938126400 -10800 1 PYST} + {3950823600 -14400 0 PYT} + {3969576000 -10800 1 PYST} + {3982273200 -14400 0 PYT} + {4001630400 -10800 1 PYST} + {4013722800 -14400 0 PYT} + {4033080000 -10800 1 PYST} + {4045172400 -14400 0 PYT} + {4064529600 -10800 1 PYST} + {4076622000 -14400 0 PYT} + {4095979200 -10800 1 PYST} } diff --git a/library/tzdata/America/Rosario b/library/tzdata/America/Rosario index 8b697c7..7040613 100644 --- a/library/tzdata/America/Rosario +++ b/library/tzdata/America/Rosario @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Cordoba)]} { - LoadTimeZoneFile America/Cordoba +if {![info exists TZData(America/Argentina/Cordoba)]} { + LoadTimeZoneFile America/Argentina/Cordoba } -set TZData(:America/Rosario) $TZData(:America/Cordoba) +set TZData(:America/Rosario) $TZData(:America/Argentina/Cordoba) diff --git a/library/tzdata/Asia/Jerusalem b/library/tzdata/Asia/Jerusalem index 3a8189d..c0b2c01 100644 --- a/library/tzdata/Asia/Jerusalem +++ b/library/tzdata/Asia/Jerusalem @@ -79,194 +79,70 @@ set TZData(:Asia/Jerusalem) { {1065132000 7200 0 IST} {1081292400 10800 1 IDT} {1095804000 7200 0 IST} - {1112310000 10800 1 IDT} - {1128117600 7200 0 IST} - {1143846000 10800 1 IDT} - {1159653600 7200 0 IST} - {1175382000 10800 1 IDT} - {1191189600 7200 0 IST} - {1207004400 10800 1 IDT} - {1222812000 7200 0 IST} - {1238540400 10800 1 IDT} - {1254348000 7200 0 IST} - {1270076400 10800 1 IDT} - {1285884000 7200 0 IST} - {1301612400 10800 1 IDT} - {1317420000 7200 0 IST} - {1333234800 10800 1 IDT} - {1349042400 7200 0 IST} - {1364770800 10800 1 IDT} - {1380578400 7200 0 IST} - {1396306800 10800 1 IDT} - {1412114400 7200 0 IST} - {1427842800 10800 1 IDT} - {1443650400 7200 0 IST} - {1459465200 10800 1 IDT} - {1475272800 7200 0 IST} - {1491001200 10800 1 IDT} - {1506808800 7200 0 IST} - {1522537200 10800 1 IDT} - {1538344800 7200 0 IST} - {1554073200 10800 1 IDT} - {1569880800 7200 0 IST} - {1585695600 10800 1 IDT} - {1601503200 7200 0 IST} - {1617231600 10800 1 IDT} - {1633039200 7200 0 IST} - {1648767600 10800 1 IDT} - {1664575200 7200 0 IST} - {1680303600 10800 1 IDT} - {1696111200 7200 0 IST} - {1711926000 10800 1 IDT} - {1727733600 7200 0 IST} - {1743462000 10800 1 IDT} - {1759269600 7200 0 IST} - {1774998000 10800 1 IDT} - {1790805600 7200 0 IST} - {1806534000 10800 1 IDT} - {1822341600 7200 0 IST} - {1838156400 10800 1 IDT} - {1853964000 7200 0 IST} - {1869692400 10800 1 IDT} - {1885500000 7200 0 IST} - {1901228400 10800 1 IDT} - {1917036000 7200 0 IST} - {1932764400 10800 1 IDT} - {1948572000 7200 0 IST} - {1964386800 10800 1 IDT} - {1980194400 7200 0 IST} - {1995922800 10800 1 IDT} - {2011730400 7200 0 IST} - {2027458800 10800 1 IDT} - {2043266400 7200 0 IST} - {2058994800 10800 1 IDT} - {2074802400 7200 0 IST} - {2090617200 10800 1 IDT} - {2106424800 7200 0 IST} - {2122153200 10800 1 IDT} - {2137960800 7200 0 IST} - {2153689200 10800 1 IDT} - {2169496800 7200 0 IST} - {2185225200 10800 1 IDT} - {2201032800 7200 0 IST} - {2216847600 10800 1 IDT} - {2232655200 7200 0 IST} - {2248383600 10800 1 IDT} - {2264191200 7200 0 IST} - {2279919600 10800 1 IDT} - {2295727200 7200 0 IST} - {2311455600 10800 1 IDT} - {2327263200 7200 0 IST} - {2343078000 10800 1 IDT} - {2358885600 7200 0 IST} - {2374614000 10800 1 IDT} - {2390421600 7200 0 IST} - {2406150000 10800 1 IDT} - {2421957600 7200 0 IST} - {2437686000 10800 1 IDT} - {2453493600 7200 0 IST} - {2469308400 10800 1 IDT} - {2485116000 7200 0 IST} - {2500844400 10800 1 IDT} - {2516652000 7200 0 IST} - {2532380400 10800 1 IDT} - {2548188000 7200 0 IST} - {2563916400 10800 1 IDT} - {2579724000 7200 0 IST} - {2595538800 10800 1 IDT} - {2611346400 7200 0 IST} - {2627074800 10800 1 IDT} - {2642882400 7200 0 IST} - {2658610800 10800 1 IDT} - {2674418400 7200 0 IST} - {2690146800 10800 1 IDT} - {2705954400 7200 0 IST} - {2721769200 10800 1 IDT} - {2737576800 7200 0 IST} - {2753305200 10800 1 IDT} - {2769112800 7200 0 IST} - {2784841200 10800 1 IDT} - {2800648800 7200 0 IST} - {2816377200 10800 1 IDT} - {2832184800 7200 0 IST} - {2847999600 10800 1 IDT} - {2863807200 7200 0 IST} - {2879535600 10800 1 IDT} - {2895343200 7200 0 IST} - {2911071600 10800 1 IDT} - {2926879200 7200 0 IST} - {2942607600 10800 1 IDT} - {2958415200 7200 0 IST} - {2974230000 10800 1 IDT} - {2990037600 7200 0 IST} - {3005766000 10800 1 IDT} - {3021573600 7200 0 IST} - {3037302000 10800 1 IDT} - {3053109600 7200 0 IST} - {3068838000 10800 1 IDT} - {3084645600 7200 0 IST} - {3100460400 10800 1 IDT} - {3116268000 7200 0 IST} - {3131996400 10800 1 IDT} - {3147804000 7200 0 IST} - {3163532400 10800 1 IDT} - {3179340000 7200 0 IST} - {3195068400 10800 1 IDT} - {3210876000 7200 0 IST} - {3226690800 10800 1 IDT} - {3242498400 7200 0 IST} - {3258226800 10800 1 IDT} - {3274034400 7200 0 IST} - {3289762800 10800 1 IDT} - {3305570400 7200 0 IST} - {3321298800 10800 1 IDT} - {3337106400 7200 0 IST} - {3352921200 10800 1 IDT} - {3368728800 7200 0 IST} - {3384457200 10800 1 IDT} - {3400264800 7200 0 IST} - {3415993200 10800 1 IDT} - {3431800800 7200 0 IST} - {3447529200 10800 1 IDT} - {3463336800 7200 0 IST} - {3479151600 10800 1 IDT} - {3494959200 7200 0 IST} - {3510687600 10800 1 IDT} - {3526495200 7200 0 IST} - {3542223600 10800 1 IDT} - {3558031200 7200 0 IST} - {3573759600 10800 1 IDT} - {3589567200 7200 0 IST} - {3605382000 10800 1 IDT} - {3621189600 7200 0 IST} - {3636918000 10800 1 IDT} - {3652725600 7200 0 IST} - {3668454000 10800 1 IDT} - {3684261600 7200 0 IST} - {3699990000 10800 1 IDT} - {3715797600 7200 0 IST} - {3731612400 10800 1 IDT} - {3747420000 7200 0 IST} - {3763148400 10800 1 IDT} - {3778956000 7200 0 IST} - {3794684400 10800 1 IDT} - {3810492000 7200 0 IST} - {3826220400 10800 1 IDT} - {3842028000 7200 0 IST} - {3857842800 10800 1 IDT} - {3873650400 7200 0 IST} - {3889378800 10800 1 IDT} - {3905186400 7200 0 IST} - {3920914800 10800 1 IDT} - {3936722400 7200 0 IST} - {3952450800 10800 1 IDT} - {3968258400 7200 0 IST} - {3984073200 10800 1 IDT} - {3999880800 7200 0 IST} - {4015609200 10800 1 IDT} - {4031416800 7200 0 IST} - {4047145200 10800 1 IDT} - {4062952800 7200 0 IST} - {4078681200 10800 1 IDT} - {4094488800 7200 0 IST} + {1114380000 10800 1 IDT} + {1128805200 7200 0 IST} + {1144965600 10800 1 IDT} + {1159650000 7200 0 IST} + {1175637600 10800 1 IDT} + {1189890000 7200 0 IST} + {1208728800 10800 1 IDT} + {1223154000 7200 0 IST} + {1239314400 10800 1 IDT} + {1253998800 7200 0 IST} + {1269986400 10800 1 IDT} + {1284238800 7200 0 IST} + {1303250400 10800 1 IDT} + {1317502800 7200 0 IST} + {1333836000 10800 1 IDT} + {1348347600 7200 0 IST} + {1364335200 10800 1 IDT} + {1378587600 7200 0 IST} + {1397599200 10800 1 IDT} + {1411851600 7200 0 IST} + {1428184800 10800 1 IDT} + {1442696400 7200 0 IST} + {1461448800 10800 1 IDT} + {1475960400 7200 0 IST} + {1491948000 10800 1 IDT} + {1506200400 7200 0 IST} + {1522533600 10800 1 IDT} + {1537045200 7200 0 IST} + {1555797600 10800 1 IDT} + {1570309200 7200 0 IST} + {1586469600 10800 1 IDT} + {1601154000 7200 0 IST} + {1616968800 10800 1 IDT} + {1631394000 7200 0 IST} + {1650146400 10800 1 IDT} + {1664658000 7200 0 IST} + {1680818400 10800 1 IDT} + {1695502800 7200 0 IST} + {1713909600 10800 1 IDT} + {1728162000 7200 0 IST} + {1744581600 10800 1 IDT} + {1759006800 7200 0 IST} + {1775167200 10800 1 IDT} + {1789851600 7200 0 IST} + {1808431200 10800 1 IDT} + {1823115600 7200 0 IST} + {1839103200 10800 1 IDT} + {1853355600 7200 0 IST} + {1869688800 10800 1 IDT} + {1884200400 7200 0 IST} + {1902780000 10800 1 IDT} + {1917464400 7200 0 IST} + {1933452000 10800 1 IDT} + {1947704400 7200 0 IST} + {1964037600 10800 1 IDT} + {1978549200 7200 0 IST} + {1997128800 10800 1 IDT} + {2011813200 7200 0 IST} + {2027800800 10800 1 IDT} + {2042053200 7200 0 IST} + {2061064800 10800 1 IDT} + {2075317200 7200 0 IST} + {2091650400 10800 1 IDT} + {2106162000 7200 0 IST} + {2122149600 10800 1 IDT} + {2136402000 7200 0 IST} } diff --git a/library/tzdata/Brazil/Acre b/library/tzdata/Brazil/Acre index a01f883..791e175 100644 --- a/library/tzdata/Brazil/Acre +++ b/library/tzdata/Brazil/Acre @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Porto_Acre)]} { - LoadTimeZoneFile America/Porto_Acre +if {![info exists TZData(America/Rio_Branco)]} { + LoadTimeZoneFile America/Rio_Branco } -set TZData(:Brazil/Acre) $TZData(:America/Porto_Acre) +set TZData(:Brazil/Acre) $TZData(:America/Rio_Branco) diff --git a/library/tzdata/GMT+0 b/library/tzdata/GMT+0 index 65e2ee1..f80e0df 100644 --- a/library/tzdata/GMT+0 +++ b/library/tzdata/GMT+0 @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Etc/GMT+0)]} { - LoadTimeZoneFile Etc/GMT+0 +if {![info exists TZData(Etc/GMT)]} { + LoadTimeZoneFile Etc/GMT } -set TZData(:GMT+0) $TZData(:Etc/GMT+0) +set TZData(:GMT+0) $TZData(:Etc/GMT) diff --git a/library/tzdata/GMT-0 b/library/tzdata/GMT-0 index 663dc3e..56dc64c 100644 --- a/library/tzdata/GMT-0 +++ b/library/tzdata/GMT-0 @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Etc/GMT-0)]} { - LoadTimeZoneFile Etc/GMT-0 +if {![info exists TZData(Etc/GMT)]} { + LoadTimeZoneFile Etc/GMT } -set TZData(:GMT-0) $TZData(:Etc/GMT-0) +set TZData(:GMT-0) $TZData(:Etc/GMT) diff --git a/library/tzdata/GMT0 b/library/tzdata/GMT0 index e037cd6..88b9f3b 100644 --- a/library/tzdata/GMT0 +++ b/library/tzdata/GMT0 @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Etc/GMT0)]} { - LoadTimeZoneFile Etc/GMT0 +if {![info exists TZData(Etc/GMT)]} { + LoadTimeZoneFile Etc/GMT } -set TZData(:GMT0) $TZData(:Etc/GMT0) +set TZData(:GMT0) $TZData(:Etc/GMT) diff --git a/library/tzdata/Greenwich b/library/tzdata/Greenwich index a8cc50b..3b2639b 100644 --- a/library/tzdata/Greenwich +++ b/library/tzdata/Greenwich @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Etc/Greenwich)]} { - LoadTimeZoneFile Etc/Greenwich +if {![info exists TZData(Etc/GMT)]} { + LoadTimeZoneFile Etc/GMT } -set TZData(:Greenwich) $TZData(:Etc/Greenwich) +set TZData(:Greenwich) $TZData(:Etc/GMT) diff --git a/library/tzdata/Navajo b/library/tzdata/Navajo index ea7e89a..594f177 100644 --- a/library/tzdata/Navajo +++ b/library/tzdata/Navajo @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Shiprock)]} { - LoadTimeZoneFile America/Shiprock +if {![info exists TZData(America/Denver)]} { + LoadTimeZoneFile America/Denver } -set TZData(:Navajo) $TZData(:America/Shiprock) +set TZData(:Navajo) $TZData(:America/Denver) diff --git a/library/tzdata/Universal b/library/tzdata/Universal index 3859f3a..9d0ccb3 100644 --- a/library/tzdata/Universal +++ b/library/tzdata/Universal @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Etc/Universal)]} { - LoadTimeZoneFile Etc/Universal +if {![info exists TZData(Etc/UTC)]} { + LoadTimeZoneFile Etc/UTC } -set TZData(:Universal) $TZData(:Etc/Universal) +set TZData(:Universal) $TZData(:Etc/UTC) diff --git a/library/tzdata/Zulu b/library/tzdata/Zulu index e878dca..81bab4e 100644 --- a/library/tzdata/Zulu +++ b/library/tzdata/Zulu @@ -1,5 +1,5 @@ # created by ../tools/tclZIC.tcl - do not edit -if {![info exists TZData(Etc/Zulu)]} { - LoadTimeZoneFile Etc/Zulu +if {![info exists TZData(Etc/UTC)]} { + LoadTimeZoneFile Etc/UTC } -set TZData(:Zulu) $TZData(:Etc/Zulu) +set TZData(:Zulu) $TZData(:Etc/UTC) diff --git a/tests/compile.test b/tests/compile.test index 5025671..b3edbdb 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compile.test,v 1.34 2004/12/02 11:10:49 dkf Exp $ +# RCS: @(#) $Id: compile.test,v 1.34.2.1 2005/01/20 14:53:40 kennykb Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -587,6 +587,37 @@ test compile-16.23.$noComp { } ;# End of noComp loop +# These tests are messy because it wrecks the interpreter it runs in! +# They demonstrate issues arising from [FRQ 1101710] +test compile-17.1 {Command interpretation binding for compiled code} -constraints knownBug -setup { + set i [interp create] +} -body { + $i eval { + if 1 { + expr [ + proc expr args {return substituted} + format {[subst compiled]} + ] + } + } +} -cleanup { + interp delete $i +} -result substituted +test compile-17.2 {Command interpretation binding for non-compiled code} -setup { + set i [interp create] +} -body { + $i eval { + if 1 { + [subst expr] [ + proc expr args {return substituted} + format {[subst compiled]} + ] + } + } +} -cleanup { + interp delete $i +} -result substituted + # cleanup catch {rename p ""} catch {namespace delete test_ns_compile} diff --git a/tests/fCmd.test b/tests/fCmd.test index 1c234b3..c6fbaaf 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fCmd.test,v 1.44 2004/11/11 01:14:29 das Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.44.2.1 2005/01/20 14:53:40 kennykb Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -1635,7 +1635,7 @@ test fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -forc set result } {1} test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} \ - {notRoot} { + {notRoot notNetworkFilesystem} { catch {file delete -force -- tfa tfad} file mkdir tfa tfad/tfa/file set r1 [catch {file rename -force tfa tfad}] diff --git a/tests/winDde.test b/tests/winDde.test index d1b0ee1..2126d04 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winDde.test,v 1.26 2004/12/01 14:02:49 dkf Exp $ +# RCS: @(#) $Id: winDde.test,v 1.26.2.1 2005/01/20 14:53:40 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -219,7 +219,7 @@ test winDde-5.4 {DDE eval bad arguments} -constraints {win dde} -body { test winDde-6.1 {DDE servername bad arguments} -constraints {win dde} -body { dde servername -z -z -z -} -returnCodes error -result {unknown option "-z": should be -force, -handler or --} +} -returnCodes error -result {bad option "-z": must be -force, -handler, or --} test winDde-6.2 {DDE servername set name} -constraints {win dde} -body { dde servername -- winDde-6.2 } -result {winDde-6.2} diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 378c721..8aaa601 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -1,9 +1,8 @@ # This Makefile is used to create several test cases for Tcl's load # command. It also illustrates how to take advantage of configuration # exported by Tcl to set up Makefiles for shared libraries. -# RCS: @(#) $Id: Makefile.in,v 1.16 2004/11/12 20:27:29 das Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.16.2.1 2005/01/20 14:53:41 kennykb Exp $ -TCL_DBGX = @TCL_DBGX@ CC = @CC@ LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @TCL_LIBS@ AC_FLAGS = @DEFS@ diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index bc20165..1f83e5c 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -63,9 +63,6 @@ /* Does putenv() copy strings or incorporate them by reference? */ #undef HAVE_PUTENV_THAT_COPIES -/* Define to 1 if you have the `readdir_r' function. */ -#undef HAVE_READDIR_R - /* Are characters signed? */ #undef HAVE_SIGNED_CHAR diff --git a/unix/tclConfig.sh.in b/unix/tclConfig.sh.in index a2496a9..fe7df20 100644 --- a/unix/tclConfig.sh.in +++ b/unix/tclConfig.sh.in @@ -9,7 +9,7 @@ # # The information in this file is specific to a single platform. # -# RCS: @(#) $Id: tclConfig.sh.in,v 1.19 2004/06/15 20:28:03 hobbs Exp $ +# RCS: @(#) $Id: tclConfig.sh.in,v 1.19.2.1 2005/01/20 14:53:40 kennykb Exp $ # Tcl's version number. TCL_VERSION='@TCL_VERSION@' @@ -23,9 +23,9 @@ TCL_CC='@CC@' # -D flags for use with the C compiler. TCL_DEFS='@DEFS@' -# If TCL was built with debugging symbols, generated libraries contain -# this string at the end of the library name (before the extension). -TCL_DBGX=@TCL_DBGX@ +# TCL_DBGX used to be used to distinguish debug vs. non-debug builds. +# This was a righteous pain so the core doesn't do that any more. +TCL_DBGX= # Default flags used in an optimized and debuggable build, respectively. TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@' diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index f0f852e..c5eef27 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFCmd.c,v 1.40 2004/11/11 01:14:41 das Exp $ + * RCS: @(#) $Id: tclUnixFCmd.c,v 1.40.2.1 2005/01/20 14:53:41 kennykb Exp $ * * Portions of this code were derived from NetBSD source code which has * the following copyright notice: @@ -477,8 +477,8 @@ TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts) { int srcFd; int dstFd; - u_int blockSize; /* Optimal I/O blocksize for filesystem */ - char *buffer; /* Data buffer for copy */ + unsigned blockSize; /* Optimal I/O blocksize for filesystem */ + char *buffer; /* Data buffer for copy */ size_t nread; #ifdef DJGPP diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index 190fc5f..3aac301 100644 --- a/unix/tclUnixPort.h +++ b/unix/tclUnixPort.h @@ -19,7 +19,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixPort.h,v 1.39 2004/11/12 14:18:29 dkf Exp $ + * RCS: @(#) $Id: tclUnixPort.h,v 1.39.2.1 2005/01/20 14:53:41 kennykb Exp $ */ #ifndef _TCLUNIXPORT @@ -56,11 +56,9 @@ #ifdef HAVE_STRUCT_DIRENT64 typedef struct dirent64 Tcl_DirEntry; # define TclOSreaddir readdir64 -# define TclOSreaddir_r readdir64_r #else typedef struct dirent Tcl_DirEntry; # define TclOSreaddir readdir -# define TclOSreaddir_r readdir_r #endif #ifdef HAVE_TYPE_OFF64_T @@ -558,17 +556,13 @@ typedef pthread_mutex_t TclpMutex; EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr)); -EXTERN Tcl_DirEntry * TclpReaddir(DIR *); EXTERN struct tm * TclpLocaltime(CONST time_t *); EXTERN struct tm * TclpGmtime(CONST time_t *); EXTERN char * TclpInetNtoa(struct in_addr); -# define readdir(x) TclpReaddir(x) /* #define localtime(x) TclpLocaltime(x) * #define gmtime(x) TclpGmtime(x) */ # undef inet_ntoa # define inet_ntoa(x) TclpInetNtoa(x) -# undef TclOSreaddir -# define TclOSreaddir(x) TclpReaddir(x) # ifdef MAC_OSX_TCL /* * On Mac OS X, realpath is currently not diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 17130a7..f163782 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -20,10 +20,6 @@ typedef struct ThreadSpecificData { char nabuf[16]; - struct { - Tcl_DirEntry ent; - char name[MAXNAMLEN+1]; - } rdbuf; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -65,7 +61,7 @@ static pthread_mutex_t *allocLockPtr = &allocLock; /* *---------------------------------------------------------------------- * - * TclpThreadCreaet -- + * TclpThreadCreate -- * * This procedure creates a new thread. * @@ -867,56 +863,18 @@ TclpFinalizeCondition(condPtr) * Side effects: * See documentation of C functions. * + * Notes: + * TclpReaddir is no longer used by the core (see 1095909), + * but it appears in the internal stubs table (see #589526). *---------------------------------------------------------------------- */ -#if defined(TCL_THREADS) && !defined(HAVE_READDIR_R) -TCL_DECLARE_MUTEX( rdMutex ) -#undef readdir -#endif - Tcl_DirEntry * TclpReaddir(DIR * dir) { - Tcl_DirEntry *ent; -#ifdef TCL_THREADS - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - -#ifdef HAVE_READDIR_R - ent = &tsdPtr->rdbuf.ent; -# ifdef HAVE_TWO_ARG_READDIR_R - if (TclOSreaddir_r(dir, ent) != 0) { -# else /* HAVE_THREE_ARG_READDIR_R */ - if (TclOSreaddir_r(dir, ent, &ent) != 0) { -# endif /* HAVE_TWO_ARG_READDIR_R */ - ent = NULL; - } - -#else /* !HAVE_READDIR_R */ - - Tcl_MutexLock(&rdMutex); -# ifdef HAVE_STRUCT_DIRENT64 - ent = readdir64(dir); -# else /* !HAVE_STRUCT_DIRENT64 */ - ent = readdir(dir); -# endif /* HAVE_STRUCT_DIRENT64 */ - if (ent != NULL) { - memcpy((VOID *) &tsdPtr->rdbuf.ent, (VOID *) ent, - sizeof(tsdPtr->rdbuf)); - ent = &tsdPtr->rdbuf.ent; - } - Tcl_MutexUnlock(&rdMutex); - -#endif /* HAVE_READDIR_R */ -#else -# ifdef HAVE_STRUCT_DIRENT64 - ent = readdir64(dir); -# else /* !HAVE_STRUCT_DIRENT64 */ - ent = readdir(dir); -# endif /* HAVE_STRUCT_DIRENT64 */ -#endif - return ent; + return TclOSreaddir(dir); } + char * TclpInetNtoa(struct in_addr addr) { diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 7dd3dae..2eb2bb3 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinChan.c,v 1.37 2004/10/20 14:50:44 dkf Exp $ + * RCS: @(#) $Id: tclWinChan.c,v 1.37.2.1 2005/01/20 14:53:42 kennykb Exp $ */ #include "tclWinInt.h" @@ -395,6 +395,8 @@ FileCloseProc(instanceData, interp) Tcl_Interp *interp; /* Not used. */ { FileInfo *fileInfoPtr = (FileInfo *) instanceData; + FileInfo *infoPtr; + ThreadSpecificData *tsdPtr; int errorCode = 0; /* @@ -419,6 +421,23 @@ FileCloseProc(instanceData, interp) } } + /* + * See if this FileInfo* is still on the thread local list. + */ + tsdPtr = TCL_TSD_INIT(&dataKey); + for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr == fileInfoPtr) { + /* + * This channel exists on the thread local list. It should + * have been removed by an earlier call to TclpCutFileChannel, + * but do that now since just deallocating fileInfoPtr would + * leave an deallocated pointer on the thread local list. + */ + TclpCutFileChannel(fileInfoPtr->channel); + break; + } + } ckfree((char *)fileInfoPtr); return errorCode; } |