diff options
43 files changed, 784 insertions, 681 deletions
@@ -1,4 +1,4 @@ -2012-04-?? Jan Nijtmans <nijtmans@users.sf.net> +2012-04-12 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclInt.decls: [Bug 3514475]: remove TclpGetTimeZone * generic/tclIntDecls.h: and TclpGetTZName @@ -7,6 +7,66 @@ * unix/tclUnixTime.c: * unix/tclWinTilemc: +2012-04-11 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tclWinInit.c: [Bug 3448512]: clock scan "1958-01-01" fails only + * win/tcl.m4: in debug compilation. + * win/configure: + * unix/tcl.m4: Use NDEBUG consistantly meaning: no debugging. + * unix/configure: + * generic/tclBasic.c: + * library/dde/pkgIndex.tcl Use [::tcl::pkgconfig get debug] in stead + * library/reg/pkgIndex.tcl of [info exists ::tcl_platform(debug)] + + ***POTENTIAL INCOMPATIBILITY*** + The variables $tcl_platform(debug) and $tcl_platform(threaded) no longer + exist. They don't belong in the tcl_platform array, were never documented, + disturbed the platform-1.1 test, $tcl_platform(debug) was only available + on Windows anyway, and TIP #59 provides a much better alternative. + +2012-04-10 Donal K. Fellows <dkf@users.sf.net> + + * generic/tcl.h (TCL_DEPRECATED_API): [Bug 2458976]: Added macro that + can be used to mark parts of Tcl's API as deprecated. Currently only + used for fields of Tcl_Interp, which TIPs 330 and 336 have deprecated + with a migration strategy; we want to encourage people to move away + from those fields. + +2012-04-09 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclOODefineCmds.c (ClassVarsSet, ObjVarsSet): [Bug 3396896]: + Ensure that the lists of variable names used to drive variable + resolution will never have the same name twice. + + * generic/tclVar.c (AppendLocals): [Bug 2712377]: Fix problem with + reporting of declared variables in methods. It's really a problem with + how [info vars] interacts with variable resolvers; this is just a bit + of a hack so it is no longer a big problem. + +2012-04-04 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclOO.c (Tcl_NewObjectInstance, TclNRNewObjectInstance): + [Bug 3514761]: Fixed bogosity with automated argument description + handling when constructing an instance of a class that is itself a + member of an ensemble. Thanks to Andreas Kupries for identifying that + this was a problem case at all! + (Tcl_CopyObjectInstance): Fix potential bleed-over of ensemble + information into [oo::copy]. + +2012-04-04 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tclWinSock.c: [Bug 510001]: TclSockMinimumBuffers needs plat imp + * generic/tclIOSock.c: + * generic/tclInt.decls: + * generic/tclIntDecls.h: + * generic/tclStubInit.c: + +2012-04-03 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclStubInit.c: Remove the TclpGetTZName implementation for + * generic/tclIntDecls.h: Cygwin (from 2012-04-02 commit), re-generated + * generic/tclIntPlatDecls.h: + 2012-04-02 Donal K. Fellows <dkf@users.sf.net> IMPLEMENTATION OF TIP#396. diff --git a/doc/Notifier.3 b/doc/Notifier.3 index 435f779..f65d580 100644 --- a/doc/Notifier.3 +++ b/doc/Notifier.3 @@ -9,7 +9,7 @@ .TH Notifier 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode \- the event queue and notifier interfaces +Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode, Tcl_ServiceModeHook, Tcl_SetNotifier \- the event queue and notifier interfaces .SH SYNOPSIS .nf \fB#include <tcl.h>\fR diff --git a/generic/tcl.decls b/generic/tcl.decls index 7e5bbbb..8355d99 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -774,10 +774,10 @@ declare 216 { declare 217 { void Tcl_ResetResult(Tcl_Interp *interp) } -declare 218 generic { +declare 218 { int Tcl_ScanElement(const char *src, int *flagPtr) } -declare 219 generic { +declare 219 { int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } # Obsolete @@ -2311,7 +2311,7 @@ declare 627 { Tcl_LoadHandle *handlePtr) } declare 628 { - void* Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle, + void *Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol) } declare 629 { diff --git a/generic/tcl.h b/generic/tcl.h index 875a171..729e521 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -163,6 +163,23 @@ extern "C" { #endif /* + * Allow a part of Tcl's API to be explicitly marked as deprecated. + * + * Used to make TIP 330/336 generate moans even if people use the + * compatibility macros. Change your code, guys! We won't support you forever. + */ + +#if defined(__GNUC__) && ((__GNUC__ >= 4) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 1))) +# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC__MINOR__ >= 5)) +# define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__ (msg))) +# else +# define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__)) +# endif +#else +# define TCL_DEPRECATED_API(msg) /* nothing portable */ +#endif + +/* *---------------------------------------------------------------------------- * Macros used to declare a function to be exported by a DLL. Used by Windows, * maps to no-op declarations on non-Windows systems. The default build on @@ -487,9 +504,11 @@ typedef struct Tcl_Interp { /* TIP #330: Strongly discourage extensions from using the string * result. */ #ifdef USE_INTERP_RESULT - char *result; /* If the last command returned a string + char *result TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult"); + /* If the last command returned a string * result, this points to it. */ - void (*freeProc) (char *blockPtr); + void (*freeProc) (char *blockPtr) + TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult"); /* Zero means the string result is statically * allocated. TCL_DYNAMIC means it was * allocated with ckalloc and should be freed @@ -498,15 +517,16 @@ typedef struct Tcl_Interp { * Tcl_Eval must free it before executing next * command. */ #else - char *unused3; - void (*unused4) (char *); + char *unused3 TCL_DEPRECATED_API("bad field access"); + void (*unused4) (char *) TCL_DEPRECATED_API("bad field access"); #endif #ifdef USE_INTERP_ERRORLINE - int errorLine; /* When TCL_ERROR is returned, this gives the + int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine"); + /* When TCL_ERROR is returned, this gives the * line number within the command where the * error occurred (1 if first line). */ #else - int unused5; + int unused5 TCL_DEPRECATED_API("bad field access"); #endif } Tcl_Interp; diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 6fff92b..ae61e85 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -26,12 +26,6 @@ #if USE_TCLALLOC -#ifdef TCL_DEBUG -# define DEBUG -/* #define MSTATS */ -# define RCHECK -#endif - /* * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait * until Tcl uses config.h properly. @@ -60,7 +54,7 @@ union overhead { unsigned char index; /* bucket # */ unsigned char unused; /* unused */ unsigned char magic1; /* other magic number */ -#ifdef RCHECK +#ifndef NDEBUG unsigned short rmagic; /* range magic number */ unsigned long size; /* actual block size */ unsigned short unused2; /* padding to 8-byte align */ @@ -77,7 +71,7 @@ union overhead { #define MAGIC 0xef /* magic # on accounting info */ #define RMAGIC 0x5555 /* magic # on range info */ -#ifdef RCHECK +#ifndef NDEBUG #define RSLOP sizeof(unsigned short) #else #define RSLOP 0 @@ -142,7 +136,7 @@ static int allocInit = 0; static unsigned int numMallocs[NBUCKETS+1]; #endif -#if defined(DEBUG) || defined(RCHECK) +#if !defined(NDEBUG) #define ASSERT(p) if (!(p)) Tcl_Panic(# p) #define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p) #else @@ -299,7 +293,7 @@ TclpAlloc( numMallocs[NBUCKETS]++; #endif -#ifdef RCHECK +#ifndef NDEBUG /* * Record allocated size of block and bound space with magic numbers. */ @@ -357,7 +351,7 @@ TclpAlloc( numMallocs[bucket]++; #endif -#ifdef RCHECK +#ifndef NDEBUG /* * Record allocated size of block and bound space with magic numbers. */ @@ -577,7 +571,7 @@ TclpRealloc( numMallocs[NBUCKETS]++; #endif -#ifdef RCHECK +#ifndef NDEBUG /* * Record allocated size of block and update magic number bounds. */ @@ -619,7 +613,7 @@ TclpRealloc( * Ok, we don't have to copy, it fits as-is */ -#ifdef RCHECK +#ifndef NDEBUG overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 280290c..8905849 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -928,17 +928,6 @@ Tcl_CreateInterp(void) TclPrecTraceProc, NULL); TclpSetVariables(interp); -#ifdef TCL_THREADS - /* - * The existence of the "threaded" element of the tcl_platform array - * indicates that this particular Tcl shell has been compiled with threads - * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can - * introspect on the interpreter level of thread safety. - */ - - Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY); -#endif - /* * Register Tcl's version number. * TIP #268: Full patchlevel instead of just major.minor diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1f7dfe6..75dbd9a 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1802,7 +1802,7 @@ EXTERN int Tcl_LoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 628 */ -EXTERN void* Tcl_FindSymbol(Tcl_Interp *interp, +EXTERN void * Tcl_FindSymbol(Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 629 */ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, @@ -2470,7 +2470,7 @@ typedef struct TclStubs { int (*tcl_NRExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr); /* 625 */ int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */ int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ - void* (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ + void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ } TclStubs; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 1283446..f33ad31 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1823,11 +1823,6 @@ NsEnsembleImplementationCmdNR( * count both as inserted and removed arguments. */ -#if 0 - if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters, prefixObjc + ensemblePtr->numParameters, objv)) { - TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - } -#else if (iPtr->ensembleRewrite.sourceObjs == NULL) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = @@ -1848,7 +1843,6 @@ NsEnsembleImplementationCmdNR( iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2; } } -#endif /* * Hand off to the target command. diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 980a785..72d6fba 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -45,11 +45,8 @@ MODULE_SCOPE void TclSetEnv(const char *name, const char *value); MODULE_SCOPE void TclUnsetEnv(const char *name); #if defined(__CYGWIN__) -/* On Cygwin, the environment is imported from the Cygwin DLL. */ - DLLIMPORT extern int cygwin_posix_to_win32_path_list_buf_size(char *value); - DLLIMPORT extern void cygwin_posix_to_win32_path_list(char *buf, char *value); -# define putenv TclCygwinPutenv -static void TclCygwinPutenv(char *string); + static void TclCygwinPutenv(char *string); +# define putenv TclCygwinPutenv #endif /* @@ -754,15 +751,11 @@ TclCygwinPutenv( */ if (strcmp(name, "Path") == 0) { -#ifdef __WIN32__ SetEnvironmentVariableA("PATH", NULL); -#endif unsetenv("PATH"); } -#ifdef __WIN32__ SetEnvironmentVariableA(name, value); -#endif } else { char *buf; @@ -770,9 +763,7 @@ TclCygwinPutenv( * Eliminate any Path variable, to prevent any confusion. */ -#ifdef __WIN32__ SetEnvironmentVariableA("Path", NULL); -#endif unsetenv("Path"); if (value == NULL) { @@ -785,9 +776,7 @@ TclCygwinPutenv( cygwin_posix_to_win32_path_list(value, buf); } -#ifdef __WIN32__ SetEnvironmentVariableA(name, buf); -#endif } } #endif /* __CYGWIN__ */ diff --git a/generic/tclFileName.c b/generic/tclFileName.c index adfa2fd..b6b89dd 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -2160,67 +2160,6 @@ DoGlob( } /* - * This block of code is not exercised by the Tcl test suite as of Tcl - * 8.5a0. Simplifications to the calling paths suggest it may not be - * necessary any more, since path separators are handled elsewhere. It is - * left in place in case new bugs are reported. - */ - -#if 0 /* PROBABLY_OBSOLETE */ - /* - * Deal with path separators. - */ - - if (pathPtr == NULL) { - /* - * Length used to be the length of the prefix, and lastChar the - * lastChar of the prefix. But, none of this is used any more. - */ - - int length = 0; - char lastChar = 0; - - switch (tclPlatform) { - case TCL_PLATFORM_WINDOWS: - /* - * If this is a drive relative path, add the colon and the - * trailing slash if needed. Otherwise add the slash if this is - * the first absolute element, or a later relative element. Add an - * extra slash if this is a UNC path. - */ - - if (*name == ':') { - Tcl_DStringAppend(&append, ":", 1); - if (count > 1) { - Tcl_DStringAppend(&append, "/", 1); - } - } else if ((*pattern != '\0') && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(&append, "/", 1); - if ((length == 0) && (count > 1)) { - Tcl_DStringAppend(&append, "/", 1); - } - } - - break; - case TCL_PLATFORM_UNIX: - /* - * Add a separator if this is the first absolute element, or a - * later relative element. - */ - - if ((*pattern != '\0') && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(&append, "/", 1); - } - break; - } - } -#endif /* PROBABLY_OBSOLETE */ - - /* * Look for the first matching pair of braces or the first directory * separator that is not inside a pair of braces. */ @@ -2278,8 +2217,8 @@ DoGlob( if (openBrace != NULL) { char *element; - Tcl_DString newName; + Tcl_DStringInit(&newName); /* @@ -2328,12 +2267,13 @@ DoGlob( */ if (*p != '\0') { + char savedChar = *p; + /* * Note that we are modifying the string in place. This won't work if * the string is a static. */ - char savedChar = *p; *p = '\0'; firstSpecialChar = strpbrk(pattern, "*[]?\\"); *p = savedChar; @@ -2398,6 +2338,7 @@ DoGlob( const char *bytes; int numBytes; Tcl_Obj *fixme, *newObj; + Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme); bytes = Tcl_GetStringFromObj(fixme, &numBytes); newObj = Tcl_NewStringObj(bytes+2, numBytes-2); @@ -2418,6 +2359,9 @@ DoGlob( */ if (*p == '\0') { + int length; + Tcl_DString append; + /* * This is the code path reached by a command like 'glob foo'. * @@ -2430,9 +2374,6 @@ DoGlob( * approach). */ - int length; - Tcl_DString append; - Tcl_DStringInit(&append); Tcl_DStringAppend(&append, pattern, p-pattern); @@ -2453,15 +2394,6 @@ DoGlob( } } -#if defined(__CYGWIN__) && defined(__WIN32__) - { - char winbuf[MAX_PATH+1]; - - cygwin_conv_to_win32_path(Tcl_DStringValue(&append), winbuf); - Tcl_DStringFree(&append); - Tcl_DStringAppend(&append, winbuf, -1); - } -#endif /* __CYGWIN__ && __WIN32__ */ break; case TCL_PLATFORM_UNIX: @@ -2473,8 +2405,9 @@ DoGlob( } } #if defined(__CYGWIN__) && !defined(__WIN32__) - DLLIMPORT extern int cygwin_conv_to_posix_path(const char *, char *); { + DLLIMPORT extern int cygwin_conv_to_posix_path(const char *, + char *); char winbuf[MAXPATHLEN+1]; cygwin_conv_to_posix_path(Tcl_DStringValue(&append), winbuf); diff --git a/generic/tclHash.c b/generic/tclHash.c index c8dc939..90be511 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -46,7 +46,9 @@ static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); /* - * Prototypes for the one word hash key methods. + * Prototypes for the one word hash key methods. Not actually declared because + * this is a critical path that is implemented in the core hash table access + * function. */ #if 0 diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 768428f..7b7b647 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -87,30 +87,29 @@ TclSockGetPort( *---------------------------------------------------------------------- */ -#ifdef _WIN32 -# define PTR2SOCK(a) (SOCKET)a -#else -# define PTR2SOCK(a) PTR2INT(a) +#ifndef _WIN32 +# define SOCKET size_t #endif + int TclSockMinimumBuffers( - ClientData sock, /* Socket file descriptor */ + void *sock, /* Socket file descriptor */ int size) /* Minimum buffer size */ { int current; socklen_t len; len = sizeof(int); - getsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); + getsockopt((SOCKET)sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); if (current < size) { len = sizeof(int); - setsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_SNDBUF, (char *)&size, len); + setsockopt((SOCKET)sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len); } len = sizeof(int); - getsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); + getsockopt((SOCKET)sock, SOL_SOCKET, SO_RCVBUF, (char *)¤t, &len); if (current < size) { len = sizeof(int); - setsockopt(PTR2SOCK(sock), SOL_SOCKET, SO_RCVBUF, (char *)&size, len); + setsockopt((SOCKET)sock, SOL_SOCKET, SO_RCVBUF, (char *)&size, len); } return TCL_OK; } @@ -178,6 +177,7 @@ TclCreateSocketAddress( } hints.ai_socktype = SOCK_STREAM; + #if 0 /* * We found some problems when using AI_ADDRCONFIG, e.g. on systems that @@ -185,15 +185,16 @@ TclCreateSocketAddress( * localhost. See bugs 3385024, 3382419, 3382431. As the advantage of * using AI_ADDRCONFIG in situations where it works, is probably low, * we'll leave it out for now. After all, it is just an optimisation. - */ -#if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux) - /* + * * Missing on: OpenBSD, NetBSD. * Causes failure when used on AIX 5.1 and HP-UX */ + +#if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux) hints.ai_flags |= AI_ADDRCONFIG; -#endif -#endif +#endif /* AI_ADDRCONFIG && !_AIX && !__hpux */ +#endif /* 0 */ + if (willBind) { hints.ai_flags |= AI_PASSIVE; } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 7cac354..ddda097 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -126,8 +126,8 @@ declare 25 { # } # Removed in 8.5 #declare 27 { -# int TclGetDate(char *p, unsigned long now, long zone, -# unsigned long *timePtr) +# int TclGetDate(char *p, Tcl_WideInt now, long zone, +# Tcl_WideInt *timePtr) #} declare 28 { Tcl_Channel TclpGetDefaultStdChannel(int type) @@ -421,7 +421,10 @@ declare 103 { int *portPtr) } declare 104 { - int TclSockMinimumBuffers(ClientData sock, int size) + int TclSockMinimumBuffersOld(int sock, int size) +} +declare 110 { + int TclSockMinimumBuffers(void *sock, int size) } # Replaced by Tcl_FSStat in 8.4: #declare 105 { @@ -736,16 +739,6 @@ declare 177 { # Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) #} -# REMOVED -# Allocate lists without copying arrays -# declare 180 { -# Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv) -# } -#declare 181 { -# Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv, -# const char *file, int line) -#} - # TclpGmtime and TclpLocaltime promoted to the generic interface from unix declare 182 { @@ -996,8 +989,8 @@ declare 248 { } declare 249 { - char* TclDoubleDigits(double dv, int ndigits, int flags, - int* decpt, int* signum, char** endPtr) + char *TclDoubleDigits(double dv, int ndigits, int flags, + int *decpt, int *signum, char **endPtr) } # TIP #285: Script cancellation support. declare 250 { @@ -1236,10 +1229,6 @@ declare 20 unix { declare 22 unix { TclFile TclpCreateTempFile(const char *contents) } -# Removed in 8.6: -#declare 23 unix { -# char *TclpGetTZName(int isdst) -#} declare 24 unix { char *TclWinNoBackslash(char *path) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 4959087..d01d10a 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -262,7 +262,7 @@ EXTERN void TclSetupEnv(Tcl_Interp *interp); EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ -EXTERN int TclSockMinimumBuffers(ClientData sock, int size); +EXTERN int TclSockMinimumBuffersOld(int sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -270,7 +270,8 @@ EXTERN int TclSockMinimumBuffers(ClientData sock, int size); EXTERN void TclTeardownNamespace(Namespace *nsPtr); /* 109 */ EXTERN int TclUpdateReturnInfo(Interp *iPtr); -/* Slot 110 is reserved */ +/* 110 */ +EXTERN int TclSockMinimumBuffers(void *sock, int size); /* 111 */ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, @@ -595,8 +596,8 @@ EXTERN int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 249 */ -EXTERN char* TclDoubleDigits(double dv, int ndigits, int flags, - int*decpt, int*signum, char**endPtr); +EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, + int *decpt, int *signum, char **endPtr); /* 250 */ EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force); @@ -709,13 +710,13 @@ typedef struct TclIntStubs { CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - int (*tclSockMinimumBuffers) (ClientData sock, int size); /* 104 */ + int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */ int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ - void (*reserved110)(void); + int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ @@ -854,7 +855,7 @@ typedef struct TclIntStubs { int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 246 */ void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */ int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ - char* (*tclDoubleDigits) (double dv, int ndigits, int flags, int*decpt, int*signum, char**endPtr); /* 249 */ + char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ } TclIntStubs; @@ -1032,8 +1033,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclSetupEnv) /* 102 */ #define TclSockGetPort \ (tclIntStubsPtr->tclSockGetPort) /* 103 */ -#define TclSockMinimumBuffers \ - (tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */ +#define TclSockMinimumBuffersOld \ + (tclIntStubsPtr->tclSockMinimumBuffersOld) /* 104 */ /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -1041,7 +1042,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclTeardownNamespace) /* 108 */ #define TclUpdateReturnInfo \ (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */ -/* Slot 110 is reserved */ +#define TclSockMinimumBuffers \ + (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ #define Tcl_AppendExportList \ diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 202e66a..008a99d 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -873,40 +873,10 @@ Tcl_UnloadObjCmd( done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&tmp); - if (!complain && code!=TCL_OK) { + if (!complain && (code != TCL_OK)) { code = TCL_OK; Tcl_ResetResult(interp); } - if (code == TCL_OK) { -#if 0 - /* - * Result of [unload] was not documented in TIP#100, so force to be - * the empty string by commenting this out. DKF. - */ - - Tcl_Obj *resultObjPtr, *objPtr[2]; - - /* - * Our result is the two reference counts. - */ - - TclNewIntObj(objPtr[0], trustedRefCount); - TclNewIntObj(objPtr[1], safeRefCount); - if (objPtr[0] == NULL || objPtr[1] == NULL) { - if (objPtr[0]) { - Tcl_DecrRefCount(objPtr[0]); - } - if (objPtr[1]) { - Tcl_DecrRefCount(objPtr[1]); - } - } else { - TclNewListObj(resultObjPtr, 2, objPtr); - if (resultObjPtr != NULL) { - Tcl_SetObjResult(interp, resultObjPtr); - } - } -#endif - } return code; } diff --git a/generic/tclOO.c b/generic/tclOO.c index 9dd8162..d5cc6e1 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1624,6 +1624,15 @@ Tcl_NewObjectInstance( state = Tcl_SaveInterpState(interp, TCL_OK); contextPtr->callPtr->flags |= CONSTRUCTOR; contextPtr->skip = skip; + + /* + * Adjust the ensmble tracking record if necessary. [Bug 3514761] + */ + + if (((Interp*) interp)->ensembleRewrite.sourceObjs) { + ((Interp*) interp)->ensembleRewrite.numInsertedObjs += skip-1; + ((Interp*) interp)->ensembleRewrite.numRemovedObjs += skip-1; + } result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc, objv); @@ -1742,6 +1751,15 @@ TclNRNewObjectInstance( contextPtr->skip = skip; /* + * Adjust the ensmble tracking record if necessary. [Bug 3514761] + */ + + if (((Interp *) interp)->ensembleRewrite.sourceObjs) { + ((Interp *) interp)->ensembleRewrite.numInsertedObjs += skip - 1; + ((Interp *) interp)->ensembleRewrite.numRemovedObjs += skip - 1; + } + + /* * Fire off the constructors non-recursively. */ @@ -1762,7 +1780,6 @@ FinalizeAlloc( Object *oPtr = data[1]; Tcl_InterpState state = data[2]; Tcl_Object *objectPtr = data[3]; - //int flags = oPtr->flags; /* * It's an error if the object was whacked in the constructor. Force this @@ -2050,6 +2067,7 @@ Tcl_CopyObjectInstance( } } + TclResetRewriteEnsemble(interp, 1); contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); if (contextPtr) { args[0] = TclOOObjectName(interp, o2Ptr); @@ -2064,6 +2082,10 @@ Tcl_CopyObjectInstance( TclDecrRefCount(args[1]); TclDecrRefCount(args[2]); TclOODeleteContext(contextPtr); + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (while performing post-copy callback)"); + } if (result != TCL_OK) { Tcl_DeleteCommandFromToken(interp, o2Ptr->command); return NULL; diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 926966b..3d72690 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2306,11 +2306,32 @@ ClassVarsSet( ckalloc(sizeof(Tcl_Obj *) * varc); } } + + oPtr->classPtr->variables.num = 0; if (varc > 0) { - memcpy(oPtr->classPtr->variables.list, varv, - sizeof(Tcl_Obj *) * varc); + int created, n; + Tcl_HashTable uniqueTable; + + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + oPtr->classPtr->variables.list[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } + } + oPtr->classPtr->variables.num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + oPtr->classPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->classPtr->variables.list, + sizeof(Tcl_Obj *) * n); + Tcl_DeleteHashTable(&uniqueTable); } - oPtr->classPtr->variables.num = varc; return TCL_OK; } @@ -2563,10 +2584,31 @@ ObjVarsSet( ckalloc(sizeof(Tcl_Obj *) * varc); } } + oPtr->variables.num = 0; if (varc > 0) { - memcpy(oPtr->variables.list, varv, sizeof(Tcl_Obj *)*varc); + int created, n; + Tcl_HashTable uniqueTable; + + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + oPtr->variables.list[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } + } + oPtr->variables.num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + oPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->variables.list, + sizeof(Tcl_Obj *) * n); + Tcl_DeleteHashTable(&uniqueTable); } - oPtr->variables.num = varc; return TCL_OK; } diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 2d6f324..7988452 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -381,21 +381,6 @@ typedef struct CallContext { #define DESTRUCTOR 0x10 /* This is a destructor. */ /* - * Assorted flags for call frames. Note that bits 1 and 2 are already taken by - * Tcl itself. - */ - -#if 0 -#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's - * clientData field contains a CallContext - * reference. */ -#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of - * the [oo::define] command; the clientData - * field contains an Object reference that has - * been confirmed to refer to a class. */ -#endif - -/* * Structure containing definition information about basic class methods. */ diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 7ab8a4e..ba07808 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2346,9 +2346,6 @@ SetFsPathFromAny( FsPath *fsPathPtr; Tcl_Obj *transPtr; char *name; -#if defined(__CYGWIN__) && defined(__WIN32__) - int copied = 0; -#endif ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); if (pathPtr->typePtr == &tclFsPathType) { @@ -2496,30 +2493,6 @@ SetFsPathFromAny( transPtr = TclJoinPath(1, &pathPtr); } -#if defined(__CYGWIN__) && defined(__WIN32__) - { - char winbuf[MAX_PATH+1]; - - /* - * In the Cygwin world, call conv_to_win32_path in order to use the - * mount table to translate the file name into something Windows will - * understand. Take care when converting empty strings! - */ - - name = Tcl_GetStringFromObj(transPtr, &len); - if (len > 0) { - cygwin_conv_to_win32_path(name, winbuf); - TclWinNoBackslash(winbuf); - if (Tcl_IsShared(transPtr)) { - copied = 1; - transPtr = Tcl_DuplicateObj(transPtr); - Tcl_IncrRefCount(transPtr); - } - Tcl_SetStringObj(transPtr, winbuf, -1); - } - } -#endif /* __CYGWIN__ && __WIN32__ */ - /* * Now we have a translated filename in 'transPtr'. This will have forward * slashes on Windows, and will not contain any ~user sequences. @@ -2545,12 +2518,6 @@ SetFsPathFromAny( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; pathPtr->typePtr = &tclFsPathType; -#if defined(__CYGWIN__) && defined(__WIN32__) - if (copied) { - Tcl_DecrRefCount(transPtr); - } -#endif - return TCL_OK; } diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index 5907a03..466d535 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -22,7 +22,7 @@ * - TCL_COMPILE_STATS OSCMa bytecode compiler statistics. * * - TCL_CFG_DO64BIT NSCMdt tcl is compiled for a 64bit system. - * - TCL_CFG_DEBUG NSCMdt tcl is compiled with symbol info on. + * - NDEBUG NSCMdt tcl is compiled with symbol info off. * - TCL_CFG_OPTIMIZED NSCMdt tcl is compiled with cc optimizations on * - TCL_CFG_PROFILED NSCMdt tcl is compiled with profiling info. * @@ -70,7 +70,7 @@ # define CFG_64 "0" #endif -#ifdef TCL_CFG_DEBUG +#ifndef NDEBUG # define CFG_DEBUG "1" #else # define CFG_DEBUG "0" diff --git a/generic/tclPort.h b/generic/tclPort.h index 23c6191..79bea88 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.h @@ -29,10 +29,13 @@ # define USE_PUTENV 1 # define USE_PUTENV_FOR_UNSET 1 /* On Cygwin, the environment is imported from the Cygwin DLL. */ - DLLIMPORT extern char **__cygwin_environ; - DLLIMPORT extern int cygwin_conv_to_win32_path(const char *, char *); # define environ __cygwin_environ # define timezone _timezone + DLLIMPORT extern char **__cygwin_environ; + DLLIMPORT extern int cygwin_conv_to_win32_path(const char *, char *); + DLLIMPORT extern int cygwin_posix_to_win32_path_list_buf_size(char *value); + DLLIMPORT extern void cygwin_posix_to_win32_path_list(char *buf, char *value); + DLLIMPORT extern void __stdcall SetEnvironmentVariableA(const char*, const char *); #endif #if !defined(LLONG_MIN) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2143574..4d4f509 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -39,6 +39,20 @@ #undef Tcl_CreateHashEntry #undef Tcl_Panic #undef Tcl_FindExecutable +#undef TclSockMinimumBuffers + +/* See bug 510001: TclSockMinimumBuffers needs plat imp */ +#ifdef _WIN64 +# define TclSockMinimumBuffersOld 0 +#else +#define TclSockMinimumBuffersOld sockMinimumBuffersOld +static int TclSockMinimumBuffersOld(sock, size) + int sock; + int size; +{ + return TclSockMinimumBuffers(INT2PTR(sock), size); +} +#endif #ifdef __CYGWIN__ @@ -61,11 +75,6 @@ int __stdcall GetModuleHandleExW(unsigned int, const char *, void *); static Tcl_Encoding winTCharEncoding; -typedef struct ThreadSpecificData { - char tzName[64]; /* Time zone name */ -} ThreadSpecificData; -static Tcl_ThreadDataKey dataKey; - static int TclWinGetPlatformId() { @@ -294,13 +303,13 @@ static const TclIntStubs tclIntStubs = { TclSetPreInitScript, /* 101 */ TclSetupEnv, /* 102 */ TclSockGetPort, /* 103 */ - TclSockMinimumBuffers, /* 104 */ + TclSockMinimumBuffersOld, /* 104 */ 0, /* 105 */ 0, /* 106 */ 0, /* 107 */ TclTeardownNamespace, /* 108 */ TclUpdateReturnInfo, /* 109 */ - 0, /* 110 */ + TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ Tcl_AppendExportList, /* 112 */ Tcl_CreateNamespace, /* 113 */ diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index ad1d510..e4261d6 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -812,15 +812,7 @@ LockBucket( Cache *cachePtr, int bucket) { -#if 0 - if (Tcl_MutexTryLock(bucketInfo[bucket].lockPtr) != TCL_OK) { - Tcl_MutexLock(bucketInfo[bucket].lockPtr); - cachePtr->buckets[bucket].numWaits++; - sharedPtr->buckets[bucket].numWaits++; - } -#else Tcl_MutexLock(bucketInfo[bucket].lockPtr); -#endif cachePtr->buckets[bucket].numLocks++; sharedPtr->buckets[bucket].numLocks++; } diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 29a6a03..ea3abb1 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -213,11 +213,11 @@ declare 60 { int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c) } declare 61 { - int TclBN_mp_init_set_int(mp_int* a, unsigned long i) + int TclBN_mp_init_set_int(mp_int *a, unsigned long i) } declare 62 { - int TclBN_mp_set_int(mp_int* a, unsigned long i) + int TclBN_mp_set_int(mp_int *a, unsigned long i) } declare 63 { - int TclBN_mp_cnt_lsb(const mp_int* a) + int TclBN_mp_cnt_lsb(const mp_int *a) } diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index feaefb3..4f6c3bf 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -270,11 +270,11 @@ EXTERN int TclBN_s_mp_sqr(mp_int *a, mp_int *b); /* 60 */ EXTERN int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c); /* 61 */ -EXTERN int TclBN_mp_init_set_int(mp_int*a, unsigned long i); +EXTERN int TclBN_mp_init_set_int(mp_int *a, unsigned long i); /* 62 */ -EXTERN int TclBN_mp_set_int(mp_int*a, unsigned long i); +EXTERN int TclBN_mp_set_int(mp_int *a, unsigned long i); /* 63 */ -EXTERN int TclBN_mp_cnt_lsb(const mp_int*a); +EXTERN int TclBN_mp_cnt_lsb(const mp_int *a); typedef struct TclTomMathStubs { int magic; @@ -341,9 +341,9 @@ typedef struct TclTomMathStubs { int (*tclBN_s_mp_mul_digs) (mp_int *a, mp_int *b, mp_int *c, int digs); /* 58 */ int (*tclBN_s_mp_sqr) (mp_int *a, mp_int *b); /* 59 */ int (*tclBN_s_mp_sub) (mp_int *a, mp_int *b, mp_int *c); /* 60 */ - int (*tclBN_mp_init_set_int) (mp_int*a, unsigned long i); /* 61 */ - int (*tclBN_mp_set_int) (mp_int*a, unsigned long i); /* 62 */ - int (*tclBN_mp_cnt_lsb) (const mp_int*a); /* 63 */ + int (*tclBN_mp_init_set_int) (mp_int *a, unsigned long i); /* 61 */ + int (*tclBN_mp_set_int) (mp_int *a, unsigned long i); /* 62 */ + int (*tclBN_mp_cnt_lsb) (const mp_int *a); /* 63 */ } TclTomMathStubs; #ifdef __cplusplus diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 6ce430b..a1c1996 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4121,20 +4121,9 @@ TclReToGlob( *exactPtr = (anchorLeft && anchorRight); } -#if 0 - fprintf(stderr, "INPUT RE '%.*s' OUTPUT GLOB '%s' anchor %d:%d \n", - reStrLen, reStr, - Tcl_DStringValue(dsPtr), anchorLeft, anchorRight); - fflush(stderr); -#endif return TCL_OK; invalidGlob: -#if 0 - fprintf(stderr, "INPUT RE '%.*s' NO OUTPUT GLOB %s (%c)\n", - reStrLen, reStr, msg, *p); - fflush(stderr); -#endif if (interp != NULL) { Tcl_AppendResult(interp, msg, NULL); Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); diff --git a/generic/tclVar.c b/generic/tclVar.c index 4df5d43..e92dc5f 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -18,6 +18,7 @@ */ #include "tclInt.h" +#include "tclOOInt.h" /* * Prototypes for the variable hash key methods. @@ -762,7 +763,7 @@ TclObjLookupVarEx( } donePart1: -#if 0 +#if 0 /* ENABLE_NS_VARNAME_CACHING perhaps? */ if (varPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { part1 = TclGetString(part1Ptr); @@ -1892,7 +1893,7 @@ TclPtrSetVar( varPtr->value.objPtr = NULL; } if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { -#if 0 +#if 0 /* ENABLE_NS_VARNAME_CACHING perhaps? */ /* * Can't happen now! */ @@ -6083,7 +6084,7 @@ TclInfoVarsCmd( } } } - } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) { + } else if (iPtr->varFramePtr->procPtr != NULL) { AppendLocals(interp, listPtr, simplePatternPtr, 1); } @@ -6269,17 +6270,21 @@ AppendLocals( { Interp *iPtr = (Interp *) interp; Var *varPtr; - int i, localVarCt; + int i, localVarCt, added; Tcl_Obj **varNamePtr, *objNamePtr; const char *varName; TclVarHashTable *localVarTablePtr; Tcl_HashSearch search; + Tcl_HashTable addedTable; const char *pattern = patternPtr? TclGetString(patternPtr) : NULL; localVarCt = iPtr->varFramePtr->numCompiledLocals; varPtr = iPtr->varFramePtr->compiledLocals; localVarTablePtr = iPtr->varFramePtr->varTablePtr; varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0; + if (includeLinks) { + Tcl_InitObjHashTable(&addedTable); + } for (i = 0; i < localVarCt; i++, varNamePtr++) { /* @@ -6291,6 +6296,9 @@ AppendLocals( varName = TclGetString(*varNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); + if (includeLinks) { + Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); + } } } varPtr++; @@ -6301,7 +6309,7 @@ AppendLocals( */ if (localVarTablePtr == NULL) { - return; + goto objectVars; } /* @@ -6315,9 +6323,13 @@ AppendLocals( && (includeLinks || !TclIsVarLink(varPtr))) { Tcl_ListObjAppendElement(interp, listPtr, VarHashGetKey(varPtr)); + if (includeLinks) { + Tcl_CreateHashEntry(&addedTable, VarHashGetKey(varPtr), + &added); + } } } - return; + goto objectVars; } /* @@ -6333,9 +6345,41 @@ AppendLocals( varName = TclGetString(objNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + if (includeLinks) { + Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + } + } + } + } + + objectVars: + if (!includeLinks) { + return; + } + + if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { + CallContext *contextPtr = iPtr->varFramePtr->clientData; + Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; + + if (mPtr->declaringObjectPtr) { + FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) { + Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + } + } + } else { + FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) { + Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + } } } } + Tcl_DeleteHashTable(&addedTable); } /* diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index 3125ada..194e4cd 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,6 +1,6 @@ -if {![package vsatisfies [package provide Tcl] 8]} {return} +if {![package vsatisfies [package provide Tcl] 8.5]} {return} if {[string compare $::tcl_platform(platform) windows]} {return} -if {[info exists ::tcl_platform(debug)]} { +if {[::tcl::pkgconfig get debug]} { package ifneeded dde 1.3.2 [list load [file join $dir tcldde13g.dll] dde] } else { package ifneeded dde 1.3.2 [list load [file join $dir tcldde13.dll] dde] diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index f07dee4..92335f3 100755 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -1,6 +1,6 @@ -if {![package vsatisfies [package provide Tcl] 8]} {return} +if {![package vsatisfies [package provide Tcl] 8.5]} {return} if {[string compare $::tcl_platform(platform) windows]} {return} -if {[info exists ::tcl_platform(debug)]} { +if {[::tcl::pkgconfig get debug]} { package ifneeded registry 1.3 \ [list load [file join $dir tclreg13g.dll] registry] } else { diff --git a/tests/async.test b/tests/async.test index 7834ed5..35dda88 100644 --- a/tests/async.test +++ b/tests/async.test @@ -17,9 +17,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } testConstraint testasync [llength [info commands testasync]] -testConstraint threaded [expr { - [info exists ::tcl_platform(threaded)] && $::tcl_platform(threaded) -}] +testConstraint threaded [::tcl::pkgconfig get threaded] proc async1 {result code} { global aresult acode diff --git a/tests/oo.test b/tests/oo.test index 150bc97..f3c0bda 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -337,6 +337,45 @@ test oo-2.6 {OO constructor and tailcall - Bug 2414858} -setup { } -cleanup { foo destroy } -result good +test oo-2.7 {construction, method calls and ensembles - Bug 3514761} -setup { + namespace eval k {} +} -body { + namespace eval k { + oo::class create s { + constructor {j} { + # nothing + } + } + namespace export s + namespace ensemble create + } + k s create X +} -returnCodes error -cleanup { + namespace delete k +} -result {wrong # args: should be "k s create X j"} +test oo-2.8 {construction, method calls and ensembles - Bug 3514761} -setup { + namespace eval k {} +} -body { + namespace eval k { + oo::class create s { + constructor {j} { + # nothing + } + } + oo::class create t { + superclass s + constructor args { + k next {*}$args + } + } + interp alias {} ::k::next {} ::oo::Helpers::next + namespace export t next + namespace ensemble create + } + k t create X +} -returnCodes error -cleanup { + namespace delete k +} -result {wrong # args: should be "k next j"} test oo-3.1 {basic test of OO functionality: destructor} -setup { # This is a bit complex because it needs to run in a sub-interp as we're @@ -1726,6 +1765,17 @@ test oo-15.8 {OO: intercept object cloning} -setup { } -cleanup { Foo destroy } -result {cloned ::foo ::bar check ::foo ok check ::bar ok} +test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup { + oo::class create Foo +} -body { + oo::define Foo { + method <cloned> {a b} {} + } + interp alias {} Bar {} oo::copy [Foo create foo] + Bar bar +} -returnCodes error -cleanup { + Foo destroy +} -result {wrong # args: should be "::bar <cloned> a b"} test oo-16.1 {OO: object introspection} -body { info object @@ -2896,6 +2946,92 @@ test oo-27.18 {variables declaration - multiple use} -setup { foo create bar list [bar boo] [bar boo] } -returnCodes error -match glob -result {unknown method "-?": must be *} +test oo-27.19 {variables declaration and [info vars]: Bug 2712377} -setup { + oo::class create Foo + set result {} +} -body { + # This is really a test of problems to do with Tcl's introspection when a + # variable resolver is present... + oo::define Foo { + variable foo bar + method setvars {f b} { + set foo $f + set bar $b + } + method dump1 {} { + lappend ::result <1> + foreach v [lsort [info vars *]] { + lappend ::result $v=[set $v] + } + lappend ::result [info locals] [info locals *] + } + method dump2 {} { + lappend ::result <2> + foreach v [lsort [info vars *]] { + lappend ::result $v=[set $v] + } + lappend ::result | foo=$foo [info locals] [info locals *] + } + } + Foo create stuff + stuff setvars what ever + stuff dump1 + stuff dump2 + return $result +} -cleanup { + Foo destroy +} -result {<1> bar=ever foo=what v v <2> bar=ever foo=what | foo=what v v} +test oo-27.20 {variables declaration and [info vars]: Bug 2712377} -setup { + oo::class create Foo + set result {} +} -body { + # This is really a test of problems to do with Tcl's introspection when a + # variable resolver is present... + oo::define Foo { + variable foo bar + method setvars {f b} { + set foo $f + set bar $b + } + method dump1 {} { + lappend ::result <1> + foreach v [lsort [info vars *o]] { + lappend ::result $v=[set $v] + } + lappend ::result [info locals] [info locals *] + } + method dump2 {} { + lappend ::result <2> + foreach v [lsort [info vars *o]] { + lappend ::result $v=[set $v] + } + lappend ::result | foo=$foo [info locals] [info locals *] + } + } + Foo create stuff + stuff setvars what ever + stuff dump1 + stuff dump2 + return $result +} -cleanup { + Foo destroy +} -result {<1> foo=what v v <2> foo=what | foo=what v v} +test oo-27.21 {variables declaration uniqueifies: Bug 3396896} -setup { + oo::class create Foo +} -body { + oo::define Foo variable v v v t t v t + info class variable Foo +} -cleanup { + Foo destroy +} -result {v t} +test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup { + oo::object create foo +} -body { + oo::objdefine foo variable v v v t t v t + info object variable foo +} -cleanup { + foo destroy +} -result {v t} # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... diff --git a/tests/platform.test b/tests/platform.test index 8cb8dcd..33c96ba 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -18,8 +18,6 @@ testConstraint testWinCPUID [llength [info commands testwincpuid]] test platform-1.1 {TclpSetVariables: tcl_platform} { interp create i - i eval {catch {unset tcl_platform(debug)}} - i eval {catch {unset tcl_platform(threaded)}} set result [i eval {lsort [array names tcl_platform]}] interp delete i set result diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 067d225..0646a3d 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -20,7 +20,7 @@ testConstraint noTk [expr {0 != [catch {package present Tk}]}] testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] # Darwin always uses a threaded notifier testConstraint unthreaded [expr { - (![info exist tcl_platform(threaded)] || !$tcl_platform(threaded)) + ![::tcl::pkgconfig get threaded] && $tcl_platform(os) ne "Darwin" }] diff --git a/unix/Makefile.in b/unix/Makefile.in index 81185b4..a9024db 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1211,7 +1211,7 @@ tclPkg.o: $(GENERIC_DIR)/tclPkg.c # prefix/exec_prefix but all the different paths individually. tclPkgConfig.o: $(GENERIC_DIR)/tclPkgConfig.c - $(CC) -c $(CC_SWITCHES) \ + $(CC) -c $(CC_SWITCHES) \ -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR)\"" \ -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR)\"" \ -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR)\"" \ @@ -1269,7 +1269,7 @@ tclVar.o: $(GENERIC_DIR)/tclVar.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclVar.c tclZlib.o: $(GENERIC_DIR)/tclZlib.c - $(CC) -c $(ZLIB_INCLUDE) $(CC_SWITCHES) $(GENERIC_DIR)/tclZlib.c + $(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c diff --git a/unix/configure b/unix/configure index 64ff7e6..d87b633 100755 --- a/unix/configure +++ b/unix/configure @@ -9319,6 +9319,11 @@ fi; if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' + +cat >>confdefs.h <<\_ACEOF +#define NDEBUG 1 +_ACEOF + echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 @@ -9336,12 +9341,6 @@ echo "${ECHO_T}yes (standard debugging)" >&6 fi - ### FIXME: Surely TCL_CFG_DEBUG should be set to whether we're debugging? - -cat >>confdefs.h <<\_ACEOF -#define TCL_CFG_DEBUG 1 -_ACEOF - if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 74a577d..222c375 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -738,6 +738,7 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [ if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' + AC_DEFINE(NDEBUG, 1, [Is no debugging enabled?]) AC_MSG_RESULT([no]) AC_DEFINE(TCL_CFG_OPTIMIZED, 1, [Is this an optimized build?]) else @@ -749,8 +750,6 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [ fi AC_SUBST(CFLAGS_DEFAULT) AC_SUBST(LDFLAGS_DEFAULT) - ### FIXME: Surely TCL_CFG_DEBUG should be set to whether we're debugging? - AC_DEFINE(TCL_CFG_DEBUG, 1, [Is debugging enabled?]) if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then AC_DEFINE(TCL_MEM_DEBUG, 1, [Is memory debugging enabled?]) diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 42abf34..31466bc 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -362,7 +362,7 @@ #undef TCL_CFGVAL_ENCODING /* Is debugging enabled? */ -#undef TCL_CFG_DEBUG +#undef NDEBUG /* Is this a 64-bit build? */ #undef TCL_CFG_DO64BIT diff --git a/win/configure b/win/configure index aa153a2..f3bd0d9 100755 --- a/win/configure +++ b/win/configure @@ -3336,7 +3336,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - #ifdef __WIN32__ + #ifndef __WIN32__ #error cross-compiler #endif @@ -3370,12 +3370,12 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - ac_cv_cross=yes + ac_cv_cross=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -ac_cv_cross=no +ac_cv_cross=yes fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext @@ -3687,8 +3687,8 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - #ifdef _WIN64 - #error 64-bit + #ifndef _WIN64 + #error 32-bit #endif int @@ -3721,12 +3721,12 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - tcl_win_64bit=no + tcl_win_64bit=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -tcl_win_64bit=yes +tcl_win_64bit=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext @@ -4966,6 +4966,11 @@ fi; CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' DBGX="" + +cat >>confdefs.h <<\_ACEOF +#define NDEBUG 1 +_ACEOF + echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 @@ -4984,24 +4989,23 @@ echo "${ECHO_T}yes (standard debugging)" >&6 fi - cat >>confdefs.h <<\_ACEOF -#define TCL_CFG_DEBUG 1 -_ACEOF - if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then - cat >>confdefs.h <<\_ACEOF + +cat >>confdefs.h <<\_ACEOF #define TCL_MEM_DEBUG 1 _ACEOF fi if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then - cat >>confdefs.h <<\_ACEOF + +cat >>confdefs.h <<\_ACEOF #define TCL_COMPILE_DEBUG 1 _ACEOF - cat >>confdefs.h <<\_ACEOF + +cat >>confdefs.h <<\_ACEOF #define TCL_COMPILE_STATS 1 _ACEOF diff --git a/win/makefile.bc b/win/makefile.bc index 12ba603..338205e 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -136,7 +136,7 @@ BINROOT = .. !IF "$(NODEBUG)" == "1" TMPDIRNAME = Release DBGX = -SYMDEFINES = +SYMDEFINES = -DNDEBUG !ELSE TMPDIRNAME = Debug #DBGX = d diff --git a/win/rules.vc b/win/rules.vc index 01e44e0..316dc05 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -477,6 +477,8 @@ OPTDEFINES = $(OPTDEFINES) -DTCL_NO_DEPRECATED OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DEBUG !elseif $(OPTIMIZING) OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_OPTIMIZED +!else +OPTDEFINES = $(OPTDEFINES) -DNDEBUG !endif !if $(PROFILE) OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_PROFILED @@ -34,7 +34,10 @@ AC_DEFUN([SC_PATH_TCLCONFIG], [ AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist) fi if test ! -f $TCL_BIN_DIR/tclConfig.sh; then - AC_MSG_ERROR(There is no tclConfig.sh in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) + if test ! -f $TCL_BIN_DIR/../unix/tclConfig.sh; then + AC_MSG_ERROR(There is no tclConfig.sh in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) + fi + TCL_BIN_DIR=`cd ${TCL_BIN_DIR}/../unix; pwd` fi AC_MSG_RESULT($TCL_BIN_DIR/tclConfig.sh) ]) @@ -300,6 +303,7 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [ CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' DBGX="" + AC_DEFINE(NDEBUG, 1, [Is no debugging enabled?]) AC_MSG_RESULT([no]) AC_DEFINE(TCL_CFG_OPTIMIZED) @@ -313,15 +317,14 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [ fi AC_SUBST(CFLAGS_DEFAULT) AC_SUBST(LDFLAGS_DEFAULT) - AC_DEFINE(TCL_CFG_DEBUG) if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then - AC_DEFINE(TCL_MEM_DEBUG) + AC_DEFINE(TCL_MEM_DEBUG, 1, [Is memory debugging enabled?]) fi if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then - AC_DEFINE(TCL_COMPILE_DEBUG) - AC_DEFINE(TCL_COMPILE_STATS) + AC_DEFINE(TCL_COMPILE_DEBUG, 1, [Is bytecode debugging enabled?]) + AC_DEFINE(TCL_COMPILE_STATS, 1, [Are bytecode statistics enabled?]) fi if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then @@ -417,12 +420,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK(for cross-compile version of gcc, ac_cv_cross, AC_TRY_COMPILE([ - #ifdef __WIN32__ + #ifndef __WIN32__ #error cross-compiler #endif ], [], - ac_cv_cross=yes, - ac_cv_cross=no) + ac_cv_cross=no, + ac_cv_cross=yes) ) if test "$ac_cv_cross" = "yes"; then @@ -609,12 +612,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ;; *) AC_TRY_COMPILE([ - #ifdef _WIN64 - #error 64-bit + #ifndef _WIN64 + #error 32-bit #endif ], [], - tcl_win_64bit=no, - tcl_win_64bit=yes + tcl_win_64bit=yes, + tcl_win_64bit=no ) if test "$tcl_win_64bit" = "yes" ; then do64bit=amd64 diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 3f4d4d9..e5b927d 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -14,24 +14,22 @@ #include "tclWinInt.h" /* - * Mutex protecting static data in this file; + * Native name of the directory in the native filesystem where DLLs used in + * this process are copied prior to loading, and mutex used to protect its + * allocation. */ -static Tcl_Mutex loadMutex; +static WCHAR *dllDirectoryName = NULL; +static Tcl_Mutex dllDirectoryNameMutex; /* - * Name of the directory in the native filesystem where DLLs used in this - * process are copied prior to loading. + * Static functions defined within this file. */ -static WCHAR* dllDirectoryName = NULL; - -/* Static functions defined within this file */ - -void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, - const char* symbol); -void UnloadFile(Tcl_LoadHandle loadHandle); - +static void * FindSymbol(Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, const char *symbol); +static int InitDLLDirectoryName(void); +static void UnloadFile(Tcl_LoadHandle loadHandle); /* *---------------------------------------------------------------------- @@ -75,8 +73,7 @@ TclpDlopen( */ nativeName = Tcl_FSGetNativePath(pathPtr); - hInstance = LoadLibraryEx(nativeName, NULL, - LOAD_WITH_ALTERED_SEARCH_PATH); + hInstance = LoadLibraryEx(nativeName,NULL,LOAD_WITH_ALTERED_SEARCH_PATH); if (hInstance == NULL) { /* * Let the OS loader examine the binary search path for whatever @@ -85,9 +82,8 @@ TclpDlopen( */ Tcl_DString ds; - const char *fileName = Tcl_GetString(pathPtr); - nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds); + nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); hInstance = LoadLibraryEx(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); @@ -96,23 +92,6 @@ TclpDlopen( if (hInstance == NULL) { DWORD lastError = GetLastError(); -#if 0 - /* - * It would be ideal if the FormatMessage stuff worked better, but - * unfortunately it doesn't seem to want to... - */ - - LPTSTR lpMsgBuf; - char *buf; - int size; - - size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | - FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0, - (LPTSTR) &lpMsgBuf, 0, NULL); - buf = ckalloc(TCL_INTEGER_SPACE + size + 1); - sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf); -#endif - Tcl_AppendResult(interp, "couldn't load library \"", Tcl_GetString(pathPtr), "\": ", NULL); @@ -185,24 +164,25 @@ TclpDlopen( *---------------------------------------------------------------------- */ -void * +static void * FindSymbol( Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol) { + HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData; Tcl_PackageInitProc *proc = NULL; - HINSTANCE hInstance = (HINSTANCE)(loadHandle->clientData); /* * For each symbol, check for both Symbol and _Symbol, since Borland * generates C symbols with a leading '_' by default. */ - proc = (void*) GetProcAddress(hInstance, symbol); + proc = (void *) GetProcAddress(hInstance, symbol); if (proc == NULL) { Tcl_DString ds; - const char* sym2; + const char *sym2; + Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, "_", 1); sym2 = Tcl_DStringAppend(&ds, symbol, -1); @@ -234,7 +214,7 @@ FindSymbol( *---------------------------------------------------------------------- */ -void +static void UnloadFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * TclpDlopen(). The loadHandle is a token @@ -277,7 +257,7 @@ TclGuessPackageName( } /* - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * TclpTempFileNameForLibrary -- * @@ -287,86 +267,125 @@ TclGuessPackageName( * Returns the constructed file name. * * On Windows, a DLL is identified by the final component of its path name. - * Cross linking among DLL's (and hence, preloading) will not work unless - * this name is preserved when copying a DLL from a VFS to a temp file for - * preloading. For this reason, all DLLs in a given process are copied - * to a temp directory, and their names are preserved. + * Cross linking among DLL's (and hence, preloading) will not work unless this + * name is preserved when copying a DLL from a VFS to a temp file for + * preloading. For this reason, all DLLs in a given process are copied to a + * temp directory, and their names are preserved. * - *----------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ -Tcl_Obj* -TclpTempFileNameForLibrary(Tcl_Interp* interp, /* Tcl interpreter */ - Tcl_Obj* path) /* Path name of the DLL in - * the VFS */ +Tcl_Obj * +TclpTempFileNameForLibrary( + Tcl_Interp *interp, /* Tcl interpreter. */ + Tcl_Obj *path) /* Path name of the DLL in the VFS. */ { - size_t nameLen; /* Length of the temp folder name */ - WCHAR name[MAX_PATH]; /* Path name of the temp folder */ - BOOL status; /* Status from Win32 API calls */ - Tcl_Obj* fileName; /* Name of the temp file */ - Tcl_Obj* tail; /* Tail of the source path */ + Tcl_Obj *fileName; /* Name of the temp file. */ + Tcl_Obj *tail; /* Tail of the source path. */ - /* - * Determine the name of the directory to use, and create it. - * (Keep trying with new names until an attempt to create the directory - * succeeds) - */ - - nameLen = 0; + Tcl_MutexLock(&dllDirectoryNameMutex); if (dllDirectoryName == NULL) { - Tcl_MutexLock(&loadMutex); - if (dllDirectoryName == NULL) { - nameLen = GetTempPathW(MAX_PATH, name); - if (nameLen >= MAX_PATH-12) { - Tcl_SetErrno(ENAMETOOLONG); - nameLen = 0; - } else { - wcscpy(name+nameLen, L"TCLXXXXXXXX"); - nameLen += 11; - } - status = 1; - if (nameLen != 0) { - DWORD id; - int i = 0; - id = GetCurrentProcessId(); - for (;;) { - DWORD lastError; - wsprintfW(name+nameLen-8, L"%08x", id); - status = CreateDirectoryW(name, NULL); - if (status) { - break; - } - if ((lastError = GetLastError()) != ERROR_ALREADY_EXISTS) { - TclWinConvertError(lastError); - break; - } else if (++i > 256) { - TclWinConvertError(lastError); - break; - } - id *= 16777619; - } - } - if (status != 0) { - dllDirectoryName = ckalloc((nameLen+1) * sizeof(WCHAR)); - wcscpy(dllDirectoryName, name); - } + if (InitDLLDirectoryName() == TCL_ERROR) { + Tcl_AppendResult(interp, "couldn't create temporary directory: ", + Tcl_PosixError(interp), NULL); + Tcl_MutexUnlock(&dllDirectoryNameMutex); + return NULL; } - Tcl_MutexUnlock(&loadMutex); - } - if (dllDirectoryName == NULL) { - Tcl_AppendResult(interp, "couldn't create temporary directory: ", - Tcl_PosixError(interp), NULL); } + Tcl_MutexUnlock(&dllDirectoryNameMutex); + + /* + * Now we know where to put temporary DLLs, construct the name. + */ + fileName = TclpNativeToNormalized(dllDirectoryName); tail = TclPathPart(interp, path, TCL_PATH_TAIL); if (tail == NULL) { Tcl_DecrRefCount(fileName); return NULL; - } else { - Tcl_AppendToObj(fileName, "/", 1); - Tcl_AppendObjToObj(fileName, tail); - return fileName; } + Tcl_AppendToObj(fileName, "/", 1); + Tcl_AppendObjToObj(fileName, tail); + return fileName; +} + +/* + *---------------------------------------------------------------------- + * + * InitDLLDirectoryName -- + * + * Helper for TclpTempFileNameForLibrary; builds a temporary directory + * that is specific to the current process. Should only be called once + * per process start. Caller must hold dllDirectoryNameMutex. + * + * Results: + * Tcl result code. + * + * Side-effects: + * Creates temp directory. + * Allocates memory pointed to by dllDirectoryName. + * + *---------------------------------------------------------------------- + * [Candidate for process global?] + */ + +static int +InitDLLDirectoryName(void) +{ + size_t nameLen; /* Length of the temp folder name. */ + WCHAR name[MAX_PATH]; /* Path name of the temp folder. */ + DWORD id; /* The process id. */ + DWORD lastError; /* Last error to happen in Win API. */ + int i; + + /* + * Determine the name of the directory to use, and create it. (Keep + * trying with new names until an attempt to create the directory + * succeeds) + */ + + nameLen = GetTempPathW(MAX_PATH, name); + if (nameLen >= MAX_PATH-12) { + Tcl_SetErrno(ENAMETOOLONG); + return TCL_ERROR; + } + + wcscpy(name+nameLen, L"TCLXXXXXXXX"); + nameLen += 11; + + id = GetCurrentProcessId(); + lastError = ERROR_ALREADY_EXISTS; + + for (i=0 ; i<256 ; i++) { + wsprintfW(name+nameLen-8, L"%08x", id); + if (CreateDirectoryW(name, NULL)) { + /* + * Issue: we don't schedule this directory for deletion by anyone. + * Can we ask the OS to do this for us? There appears to be + * potential for using CreateFile (with the flag + * FILE_FLAG_BACKUP_SEMANTICS) and RemoveDirectory to do this... + */ + + goto copyToGlobalBuffer; + } + lastError = GetLastError(); + if (lastError != ERROR_ALREADY_EXISTS) { + break; + } + id *= 16777619; + } + + TclWinConvertError(lastError); + return TCL_ERROR; + + /* + * Store our computed value in the global. + */ + + copyToGlobalBuffer: + dllDirectoryName = ckalloc((nameLen+1) * sizeof(WCHAR)); + wcscpy(dllDirectoryName, name); + return TCL_OK; } /* diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 74c7245..7181701 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -47,6 +47,13 @@ #include "tclWinInt.h" +/* + * Which version of the winsock API do we want? + */ + +#define WSA_VERSION_MAJOR 1 +#define WSA_VERSION_MINOR 1 + #ifdef _MSC_VER # pragma comment (lib, "ws2_32") #endif @@ -91,16 +98,17 @@ static ProcessGlobalValue hostName = { * The following defines declare the messages used on socket windows. */ -#define SOCKET_MESSAGE WM_USER+1 -#define SOCKET_SELECT WM_USER+2 -#define SOCKET_TERMINATE WM_USER+3 -#define SELECT TRUE -#define UNSELECT FALSE +#define SOCKET_MESSAGE WM_USER+1 +#define SOCKET_SELECT WM_USER+2 +#define SOCKET_TERMINATE WM_USER+3 +#define SELECT TRUE +#define UNSELECT FALSE /* * This is needed to comply with the strict aliasing rules of GCC, but it also * simplifies casting between the different sockaddr types. */ + typedef union { struct sockaddr sa; struct sockaddr_in sa4; @@ -206,10 +214,6 @@ static WNDCLASS windowClass; static SocketInfo * CreateSocket(Tcl_Interp *interp, int port, const char *host, int server, const char *myaddr, int myport, int async); -#if 0 -static int CreateSocketAddress(LPSOCKADDR_IN sockaddrPtr, - const char *host, int port); -#endif static void InitSockets(void); static SocketInfo * NewSocketInfo(SOCKET socket); static void SocketExitHandler(ClientData clientData); @@ -284,9 +288,8 @@ static const Tcl_ChannelType tcpChannelType = { static void InitSockets(void) { - DWORD id; + DWORD id, err; WSADATA wsaData; - DWORD err; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); if (!initialized) { @@ -322,11 +325,8 @@ InitSockets(void) * that it not be less than 1.1. */ -#define WSA_VERSION_MAJOR 1 -#define WSA_VERSION_MINOR 1 -#define WSA_VERSION_REQD MAKEWORD(WSA_VERSION_MAJOR, WSA_VERSION_MINOR) - - err = WSAStartup((WORD)WSA_VERSION_REQD, &wsaData); + err = WSAStartup((WORD) MAKEWORD(WSA_VERSION_MAJOR,WSA_VERSION_MINOR), + &wsaData); if (err != 0) { TclWinConvertError(err); goto initFailure; @@ -334,8 +334,8 @@ InitSockets(void) /* * Note the byte positions ae swapped for the comparison, so that - * 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 (1.1). - * We want the comparison to be 0x0200 < 0x0101. + * 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 (1.1). We + * want the comparison to be 0x0200 < 0x0101. */ if (MAKEWORD(HIBYTE(wsaData.wVersion), LOBYTE(wsaData.wVersion)) @@ -344,50 +344,54 @@ InitSockets(void) WSACleanup(); goto initFailure; } - -#undef WSA_VERSION_REQD -#undef WSA_VERSION_MAJOR -#undef WSA_VERSION_MINOR } /* * Check for per-thread initialization. */ - if (tsdPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->socketList = NULL; - tsdPtr->hwnd = NULL; - tsdPtr->threadId = Tcl_GetCurrentThread(); - tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); - if (tsdPtr->readyEvent == NULL) { - goto initFailure; - } - tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL); - if (tsdPtr->socketListLock == NULL) { - goto initFailure; - } - tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, - 0, &id); - if (tsdPtr->socketThread == NULL) { - goto initFailure; - } + if (tsdPtr != NULL) { + return; + } - SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); + /* + * OK, this thread has never done anything with sockets before. Construct + * a worker thread to handle asynchronous events related to sockets + * assigned to _this_ thread. + */ - /* - * Wait for the thread to signal when the window has been created and - * if it is ready to go. - */ + tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr->socketList = NULL; + tsdPtr->hwnd = NULL; + tsdPtr->threadId = Tcl_GetCurrentThread(); + tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); + if (tsdPtr->readyEvent == NULL) { + goto initFailure; + } + tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL); + if (tsdPtr->socketListLock == NULL) { + goto initFailure; + } + tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0, + &id); + if (tsdPtr->socketThread == NULL) { + goto initFailure; + } - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); - if (tsdPtr->hwnd == NULL) { - goto initFailure; /* Trouble creating the window */ - } + /* + * Wait for the thread to signal when the window has been created and if + * it is ready to go. + */ - Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + + if (tsdPtr->hwnd == NULL) { + goto initFailure; /* Trouble creating the window. */ } + + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); return; initFailure: @@ -417,6 +421,7 @@ static int SocketsEnabled(void) { int enabled; + Tcl_MutexLock(&socketMutex); enabled = (initialized == 1); Tcl_MutexUnlock(&socketMutex); @@ -447,6 +452,7 @@ SocketExitHandler( ClientData clientData) /* Not used. */ { Tcl_MutexLock(&socketMutex); + /* * Make sure the socket event handling window is cleaned-up for, at * most, this thread. @@ -483,32 +489,38 @@ TclpFinalizeSockets(void) { ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - if (tsdPtr != NULL) { - if (tsdPtr->socketThread != NULL) { - if (tsdPtr->hwnd != NULL) { - PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0); + /* + * Careful! This is a finalizer! + */ - /* - * Wait for the thread to exit. This ensures that we are - * completely cleaned up before we leave this function. - */ + if (tsdPtr == NULL) { + return; + } - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - tsdPtr->hwnd = NULL; - } - CloseHandle(tsdPtr->socketThread); - tsdPtr->socketThread = NULL; - } - if (tsdPtr->readyEvent != NULL) { - CloseHandle(tsdPtr->readyEvent); - tsdPtr->readyEvent = NULL; - } - if (tsdPtr->socketListLock != NULL) { - CloseHandle(tsdPtr->socketListLock); - tsdPtr->socketListLock = NULL; + if (tsdPtr->socketThread != NULL) { + if (tsdPtr->hwnd != NULL) { + PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0); + + /* + * Wait for the thread to exit. This ensures that we are + * completely cleaned up before we leave this function. + */ + + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + tsdPtr->hwnd = NULL; } - Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL); + CloseHandle(tsdPtr->socketThread); + tsdPtr->socketThread = NULL; } + if (tsdPtr->readyEvent != NULL) { + CloseHandle(tsdPtr->readyEvent); + tsdPtr->readyEvent = NULL; + } + if (tsdPtr->socketListLock != NULL) { + CloseHandle(tsdPtr->socketListLock); + tsdPtr->socketListLock = NULL; + } + Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL); } /* @@ -677,8 +689,7 @@ SocketEventProc( { SocketInfo *infoPtr; SocketEvent *eventPtr = (SocketEvent *) evPtr; - int mask = 0; - int events; + int mask = 0, events; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); TcpFdList *fds; @@ -739,6 +750,7 @@ SocketEventProc( */ Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); mask |= TCL_READABLE|TCL_WRITABLE; } else if (events & FD_READ) { @@ -901,28 +913,28 @@ TcpClose2Proc( int flags) /* Flags that indicate which side to close. */ { SocketInfo *infoPtr = instanceData; - int errorCode = 0; - int sd; + int errorCode = 0, sd; /* * Shutdown the OS socket handle. */ - switch(flags) - { - case TCL_CLOSE_READ: - sd=SD_RECEIVE; - break; - case TCL_CLOSE_WRITE: - sd=SD_SEND; - break; - default: - if (interp) { - Tcl_AppendResult(interp, - "Socket close2proc called bidirectionally", NULL); - } - return TCL_ERROR; + + switch (flags) { + case TCL_CLOSE_READ: + sd = SD_RECEIVE; + break; + case TCL_CLOSE_WRITE: + sd = SD_SEND; + break; + default: + if (interp) { + Tcl_AppendResult(interp, + "Socket close2proc called bidirectionally", NULL); } - if (shutdown(infoPtr->sockets->fd,sd) == SOCKET_ERROR) { + return TCL_ERROR; + } + + if (shutdown(infoPtr->sockets->fd, sd) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); errorCode = Tcl_GetErrno(); } @@ -1012,8 +1024,10 @@ CreateSocket( int asyncConnect = 0; /* Will be 1 if async connect is in * progress. */ unsigned short chosenport = 0; - struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */ - struct addrinfo *myaddrlist = NULL, *myaddrPtr; /* Socket address for client */ + struct addrinfo *addrlist = NULL, *addrPtr; + /* Socket address to connect to. */ + struct addrinfo *myaddrlist = NULL, *myaddrPtr; + /* Socket address for our side. */ const char *errorMsg = NULL; SOCKET sock = INVALID_SOCKET; SocketInfo *infoPtr = NULL; /* The returned value. */ @@ -1029,15 +1043,22 @@ CreateSocket( return NULL; } - if (!TclCreateSocketAddress(interp, &addrlist, host, port, server, &errorMsg)) { + /* + * Construct the addresses for each end of the socket. + */ + + if (!TclCreateSocketAddress(interp, &addrlist, host, port, server, + &errorMsg)) { goto error; } - if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, &errorMsg)) { + if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, + &errorMsg)) { goto error; } if (server) { TcpFdList *fds = NULL, *newfds; + for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { sock = socket(addrPtr->ai_family, SOCK_STREAM, 0); if (sock == INVALID_SOCKET) { @@ -1056,7 +1077,7 @@ CreateSocket( * Set kernel space buffering */ - TclSockMinimumBuffers((ClientData)sock, TCP_BUFFER_SIZE); + TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); /* * Make sure we use the same port when opening two server sockets @@ -1065,9 +1086,10 @@ CreateSocket( * As sockaddr_in6 uses the same offset and size for the port * member as sockaddr_in, we can handle both through the IPv4 API. */ + if (port == 0 && chosenport != 0) { ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = - htons(chosenport); + htons(chosenport); } /* @@ -1081,7 +1103,7 @@ CreateSocket( */ if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) - == SOCKET_ERROR) { + == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); closesocket(sock); continue; @@ -1089,19 +1111,21 @@ CreateSocket( if (port == 0 && chosenport == 0) { address sockname; socklen_t namelen = sizeof(sockname); + /* * Synchronize port numbers when binding to port 0 of multiple * addresses. */ + if (getsockname(sock, &sockname.sa, &namelen) >= 0) { chosenport = ntohs(sockname.sa4.sin_port); } } /* - * Set the maximum number of pending connect requests to the max value - * allowed on each platform (Win32 and Win32s may be different, and - * there may be differences between TCP/IP stacks). + * Set the maximum number of pending connect requests to the max + * value allowed on each platform (Win32 and Win32s may be + * different, and there may be differences between TCP/IP stacks). */ if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { @@ -1144,6 +1168,7 @@ CreateSocket( * No need to try combinations of local and remote addresses * of different families. */ + if (myaddrPtr->ai_family != addrPtr->ai_family) { continue; } @@ -1165,14 +1190,14 @@ CreateSocket( * Set kernel space buffering */ - TclSockMinimumBuffers((ClientData)sock, TCP_BUFFER_SIZE); + TclSockMinimumBuffers((void *) sock, TCP_BUFFER_SIZE); /* * Try to bind to a local port. */ if (bind(sock, myaddrPtr->ai_addr, myaddrPtr->ai_addrlen) - == SOCKET_ERROR) { + == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); goto looperror; } @@ -1180,12 +1205,10 @@ CreateSocket( * Set the socket into nonblocking mode if the connect should * be done in the background. */ - if (async) { - if (ioctlsocket(sock, (long) FIONBIO, &flag) + if (async && ioctlsocket(sock, (long) FIONBIO, &flag) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - goto looperror; - } + TclWinConvertError((DWORD) WSAGetLastError()); + goto looperror; } /* @@ -1193,7 +1216,7 @@ CreateSocket( */ if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) - == SOCKET_ERROR) { + == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); if (Tcl_GetErrno() != EAGAIN) { goto looperror; @@ -1204,10 +1227,9 @@ CreateSocket( */ asyncConnect = 1; - goto connected; - } else { - goto connected; } + goto connected; + looperror: if (sock != INVALID_SOCKET) { closesocket(sock); @@ -1225,8 +1247,8 @@ CreateSocket( infoPtr = NewSocketInfo(sock); /* - * Set up the select mask for read/write events. If the - * connect attempt has not completed, include connect events. + * Set up the select mask for read/write events. If the connect + * attempt has not completed, include connect events. */ infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; @@ -1237,10 +1259,12 @@ CreateSocket( } error: - if (addrlist == NULL) + if (addrlist == NULL) { freeaddrinfo(addrlist); - if (myaddrlist == NULL) + } + if (myaddrlist == NULL) { freeaddrinfo(myaddrlist); + } /* * Register for interest in events in the select mask. Note that this @@ -1249,7 +1273,8 @@ CreateSocket( if (infoPtr != NULL) { ioctlsocket(sock, (long) FIONBIO, &flag); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); return infoPtr; } @@ -1264,80 +1289,6 @@ CreateSocket( return NULL; } -#if 0 -/* - *---------------------------------------------------------------------- - * - * CreateSocketAddress -- - * - * This function initializes a sockaddr structure for a host and port. - * - * Results: - * 1 if the host was valid, 0 if the host could not be converted to an IP - * address. - * - * Side effects: - * Fills in the *sockaddrPtr structure. - * - *---------------------------------------------------------------------- - */ - -static int -CreateSocketAddress( - LPSOCKADDR_IN sockaddrPtr, /* Socket address */ - const char *host, /* Host. NULL implies INADDR_ANY */ - int port) /* Port number */ -{ - struct hostent *hostent; /* Host database entry */ - struct in_addr addr; /* For 64/32 bit madness */ - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - Tcl_SetErrno(EFAULT); - return 0; - } - - ZeroMemory(sockaddrPtr, sizeof(SOCKADDR_IN)); - sockaddrPtr->sin_family = AF_INET; - sockaddrPtr->sin_port = htons((u_short) (port & 0xFFFF)); - if (host == NULL) { - addr.s_addr = INADDR_ANY; - } else { - addr.s_addr = inet_addr(host); - if (addr.s_addr == INADDR_NONE) { - hostent = gethostbyname(host); - if (hostent != NULL) { - memcpy(&addr, hostent->h_addr, (size_t) hostent->h_length); - } else { -#ifdef EHOSTUNREACH - Tcl_SetErrno(EHOSTUNREACH); -#else -#ifdef ENXIO - Tcl_SetErrno(ENXIO); -#endif -#endif - return 0; /* Error. */ - } - } - } - - /* - * NOTE: On 64 bit machines the assignment below is rumored to not do the - * right thing. Please report errors related to this if you observe - * incorrect behavior on 64 bit machines such as DEC Alphas. Should we - * modify this code to do an explicit memcpy? - */ - - sockaddrPtr->sin_addr.s_addr = addr.s_addr; - return 1; /* Success. */ -} -#endif - /* *---------------------------------------------------------------------- * @@ -1377,7 +1328,6 @@ WaitForSocketEvent( SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); @@ -1452,15 +1402,14 @@ Tcl_OpenTcpClient( infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, infoPtr, (TCL_READABLE | TCL_WRITABLE)); - if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation", - "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; - } - if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "") - == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; + if (TCL_ERROR == Tcl_SetChannelOption(NULL, infoPtr->channel, + "-translation", "auto crlf")) { + Tcl_Close(NULL, infoPtr->channel); + return NULL; + } else if (TCL_ERROR == Tcl_SetChannelOption(NULL, infoPtr->channel, + "-eofchar", "")) { + Tcl_Close(NULL, infoPtr->channel); + return NULL; } return infoPtr->channel; } @@ -1501,7 +1450,7 @@ Tcl_MakeTcpClientChannel( * Set kernel space buffering and non-blocking. */ - TclSockMinimumBuffers((ClientData) sock, TCP_BUFFER_SIZE); + TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE); infoPtr = NewSocketInfo((SOCKET) sock); @@ -1510,8 +1459,7 @@ Tcl_MakeTcpClientChannel( */ infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr); sprintf(channelName, "sock%Id", (size_t) infoPtr->sockets->fd); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, @@ -1572,8 +1520,8 @@ Tcl_OpenTcpServer( infoPtr, 0); if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; + Tcl_Close(NULL, infoPtr->channel); + return NULL; } return infoPtr->channel; @@ -1614,12 +1562,13 @@ TcpAccept( len = sizeof(SOCKADDR_IN); - newSocket = accept(fds->fd, (SOCKADDR *)&addr, &len); + newSocket = accept(fds->fd, (SOCKADDR *) &addr, &len); /* * Protect access to sockets (acceptEventCount, readyEvents) in socketList * by the lock. Fix for SF Tcl Bug 3056775. */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); /* @@ -1668,20 +1617,20 @@ TcpAccept( */ newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) newInfoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) newInfoPtr); sprintf(channelName, "sock%Id", (size_t) newInfoPtr->sockets->fd); newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation", "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); + Tcl_Close(NULL, newInfoPtr->channel); return; } if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); + Tcl_Close(NULL, newInfoPtr->channel); return; } @@ -1826,8 +1775,7 @@ TcpInputProc( } } - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr); return bytesRead; } @@ -1935,8 +1883,7 @@ TcpOutputProc( } } - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr); return bytesWritten; } @@ -2117,6 +2064,7 @@ TcpGetOptionProc( (strncmp(optionName, "-peername", len) == 0))) { address peername; socklen_t size = sizeof(peername); + if (getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); @@ -2170,8 +2118,8 @@ TcpGetOptionProc( size = sizeof(sockname); if (getsockname(sock, &(sockname.sa), &size) >= 0) { int flags = reverseDNS; - found = 1; + found = 1; getnameinfo(&sockname.sa, size, host, sizeof(host), NULL, 0, NI_NUMERICHOST); Tcl_DStringAppendElement(dsPtr, host); @@ -2299,7 +2247,7 @@ TcpWatchProc( /* * Update the watch events mask. Only if the socket is not a server - * socket. Fix for SF Tcl Bug #557878. + * socket. [Bug 557878] */ if (!infoPtr->acceptProc) { @@ -2318,6 +2266,7 @@ TcpWatchProc( if (infoPtr->readyEvents & infoPtr->watchEvents) { Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); } } @@ -2379,8 +2328,8 @@ SocketThread( * Create a dummy window receiving socket events. */ - tsdPtr->hwnd = CreateWindow(classname, classname, - WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg); + tsdPtr->hwnd = CreateWindow(classname, classname, WS_TILED, 0, 0, 0, 0, + NULL, NULL, windowClass.hInstance, arg); /* * Signalize thread creator that we are done creating the window. @@ -2677,8 +2626,8 @@ TclWinGetSockOpt( SOCKET s, int level, int optname, - char * optval, - int FAR *optlen) + char *optval, + int *optlen) { /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -2698,7 +2647,7 @@ TclWinSetSockOpt( SOCKET s, int level, int optname, - const char * optval, + const char *optval, int optlen) { /* |