summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls6
-rw-r--r--generic/tcl.h32
-rw-r--r--generic/tclAlloc.c20
-rw-r--r--generic/tclBasic.c11
-rw-r--r--generic/tclDecls.h4
-rw-r--r--generic/tclEnsemble.c6
-rw-r--r--generic/tclEnv.c15
-rw-r--r--generic/tclFileName.c85
-rw-r--r--generic/tclHash.c4
-rw-r--r--generic/tclIOSock.c29
-rw-r--r--generic/tclInt.decls27
-rw-r--r--generic/tclIntDecls.h22
-rw-r--r--generic/tclLoad.c32
-rw-r--r--generic/tclOO.c24
-rw-r--r--generic/tclOODefineCmds.c52
-rw-r--r--generic/tclOOInt.h15
-rw-r--r--generic/tclPathObj.c33
-rw-r--r--generic/tclPkgConfig.c4
-rw-r--r--generic/tclPort.h7
-rw-r--r--generic/tclStubInit.c23
-rw-r--r--generic/tclThreadAlloc.c8
-rw-r--r--generic/tclTomMath.decls6
-rw-r--r--generic/tclTomMathDecls.h12
-rw-r--r--generic/tclUtil.c11
-rw-r--r--generic/tclVar.c56
25 files changed, 240 insertions, 304 deletions
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 *)&current, &len);
+ getsockopt((SOCKET)sock, SOL_SOCKET, SO_SNDBUF, (char *)&current, &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 *)&current, &len);
+ getsockopt((SOCKET)sock, SOL_SOCKET, SO_RCVBUF, (char *)&current, &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);
}
/*
generated by cgit v0.12 at 2024-08-20 11:07:07 (GMT)