summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls10
-rw-r--r--generic/tclAlloc.c50
-rw-r--r--generic/tclCkalloc.c36
-rw-r--r--generic/tclCmdIL.c6
-rw-r--r--generic/tclDecls.h16
-rw-r--r--generic/tclIO.c75
-rw-r--r--generic/tclInt.decls7
-rw-r--r--generic/tclIntDecls.h10
-rw-r--r--generic/tclStubInit.c5
-rw-r--r--generic/tclVar.c66
10 files changed, 225 insertions, 56 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 0d186f9..890c80d 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tcl.decls,v 1.24 1999/08/02 18:33:43 redman Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.25 1999/08/10 02:42:12 welch Exp $
library tcl
@@ -1334,6 +1334,14 @@ declare 385 generic {
declare 386 generic {
void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr)
}
+declare 387 generic {
+ Tcl_Mutex * Tcl_GetAllocMutex(void)
+}
+declare 388 generic {
+ int Tcl_GetChannelNames(Tcl_Interp *interp)
+}
+
+
##############################################################################
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index c44cf9f..f66dc57 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclAlloc.c,v 1.6 1999/04/16 00:46:42 stanton Exp $
+ * RCS: @(#) $Id: tclAlloc.c,v 1.7 1999/08/10 02:42:12 welch Exp $
*/
#include "tclInt.h"
@@ -110,7 +110,7 @@ static struct block bigBlocks = { /* Big blocks aren't suballocated. */
*/
#ifdef TCL_THREADS
-static TclpMutex allocMutex;
+static Tcl_Mutex *allocMutexPtr;
#endif
static int allocInit = 0;
@@ -162,7 +162,7 @@ TclInitAlloc()
{
if (!allocInit) {
allocInit = 1;
- TclpMutexInit(&allocMutex);
+ allocMutexPtr = Tcl_GetAllocMutex();
}
}
@@ -196,7 +196,7 @@ TclFinalizeAllocSubsystem()
int i;
struct block *blockPtr, *nextPtr;
- TclpMutexLock(&allocMutex);
+ Tcl_MutexLock(allocMutexPtr);
for (blockPtr = blockList; blockPtr != NULL; blockPtr = nextPtr) {
nextPtr = blockPtr->nextPtr;
TclpSysFree(blockPtr);
@@ -220,7 +220,7 @@ TclFinalizeAllocSubsystem()
#ifdef MSTATS
nmalloc[i] = 0;
#endif
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
}
/*
@@ -254,11 +254,9 @@ TclpAlloc(nbytes)
* may be used before any other part of Tcl. E.g., see
* main() for tclsh!
*/
-
- allocInit = 1;
- TclpMutexInit(&allocMutex);
+ TclAllocInit();
}
- TclpMutexLock(&allocMutex);
+ Tcl_MutexLock(allocMutexPtr);
/*
* First the simple case: we simple allocate big blocks directly
*/
@@ -266,7 +264,7 @@ TclpAlloc(nbytes)
bigBlockPtr = (struct block *) TclpSysAlloc((unsigned)
(sizeof(struct block) + OVERHEAD + nbytes), 0);
if (bigBlockPtr == NULL) {
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
return NULL;
}
bigBlockPtr->nextPtr = bigBlocks.nextPtr;
@@ -289,7 +287,7 @@ TclpAlloc(nbytes)
op->ov_rmagic = RMAGIC;
*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
#endif
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
return (void *)(op+1);
}
/*
@@ -307,7 +305,7 @@ TclpAlloc(nbytes)
while (nbytes + OVERHEAD > amt) {
amt <<= 1;
if (amt == 0) {
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
return (NULL);
}
bucket++;
@@ -321,7 +319,7 @@ TclpAlloc(nbytes)
if ((op = nextf[bucket]) == NULL) {
MoreCore(bucket);
if ((op = nextf[bucket]) == NULL) {
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
return (NULL);
}
}
@@ -343,7 +341,7 @@ TclpAlloc(nbytes)
op->ov_rmagic = RMAGIC;
*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
#endif
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
return ((char *)(op + 1));
}
@@ -437,13 +435,13 @@ TclpFree(cp)
return;
}
- TclpMutexLock(&allocMutex);
+ Tcl_MutexLock(allocMutexPtr);
op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */
ASSERT(op->ov_magic1 == MAGIC);
if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) {
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
return;
}
@@ -458,7 +456,7 @@ TclpFree(cp)
bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr;
bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr;
TclpSysFree(bigBlockPtr);
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
return;
}
ASSERT(size < NBUCKETS);
@@ -467,7 +465,7 @@ TclpFree(cp)
#ifdef MSTATS
nmalloc[size]--;
#endif
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
}
/*
@@ -501,14 +499,14 @@ TclpRealloc(cp, nbytes)
return (TclpAlloc(nbytes));
}
- TclpMutexLock(&allocMutex);
+ Tcl_MutexLock(allocMutexPtr);
op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */
ASSERT(op->ov_magic1 == MAGIC);
if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) {
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
return NULL;
}
@@ -528,7 +526,7 @@ TclpRealloc(cp, nbytes)
bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr,
sizeof(struct block) + OVERHEAD + nbytes);
if (bigBlockPtr == NULL) {
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
return NULL;
}
@@ -554,7 +552,7 @@ TclpRealloc(cp, nbytes)
op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
#endif
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
return (char *)(op+1);
}
maxsize = 1 << (i+3);
@@ -568,7 +566,7 @@ TclpRealloc(cp, nbytes)
if (expensive) {
void *newp;
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
newp = TclpAlloc(nbytes);
if ( newp == NULL ) {
@@ -589,7 +587,7 @@ TclpRealloc(cp, nbytes)
op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
#endif
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
return(cp);
}
@@ -621,7 +619,7 @@ mstats(s)
int totfree = 0,
totused = 0;
- TclpMutexLock(&allocMutex);
+ Tcl_MutexLock(allocMutexPtr);
fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
for (i = 0; i < NBUCKETS; i++) {
for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
@@ -637,7 +635,7 @@ mstats(s)
totused, totfree);
fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n",
MAXMALLOC, nmalloc[NBUCKETS]);
- TclpMutexUnlock(&allocMutex);
+ Tcl_MutexUnlock(allocMutexPtr);
}
#endif
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index f19d597..61e744c 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -13,7 +13,7 @@
*
* This code contributed by Karl Lehenbauer and Mark Diekhans
*
- * RCS: @(#) $Id: tclCkalloc.c,v 1.4 1999/04/16 00:46:42 stanton Exp $
+ * RCS: @(#) $Id: tclCkalloc.c,v 1.5 1999/08/10 02:42:12 welch Exp $
*/
#include "tclInt.h"
@@ -119,7 +119,7 @@ static char dumpFile[100]; /* Records where to dump memory allocation
* be explicitly initialized. This is necessary because the self
* initializing mutexes use ckalloc...
*/
-static TclpMutex ckallocMutex;
+static Tcl_Mutex *ckallocMutexPtr;
static int ckallocInit = 0;
/*
@@ -138,8 +138,8 @@ static void ValidateMemory _ANSI_ARGS_((
*----------------------------------------------------------------------
*
* TclInitDbCkalloc --
- * Initialize the locks used by the allocator.
- * This is only appropriate to call in a single threaded environtment,
+ * Initialize the locks used by the allocator.
+ * This is only appropriate to call in a single threaded environment,
* such as during TclInitSubsystems.
*
*----------------------------------------------------------------------
@@ -149,7 +149,7 @@ TclInitDbCkalloc()
{
if (!ckallocInit) {
ckallocInit = 1;
- TclpMutexInit(&ckallocMutex);
+ ckallocMutexPtr = Tcl_GetAllocMutex();
}
}
@@ -265,14 +265,13 @@ Tcl_ValidateAllMemory (file, line)
struct mem_header *memScanP;
if (!ckallocInit) {
- ckallocInit = 1;
- TclpMutexInit(&ckallocMutex);
+ TclInitDbCkalloc();
}
- TclpMutexLock(&ckallocMutex);
+ Tcl_MutexLock(ckallocMutexPtr);
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
ValidateMemory(memScanP, file, line, FALSE);
}
- TclpMutexUnlock(&ckallocMutex);
+ Tcl_MutexUnlock(ckallocMutexPtr);
}
/*
@@ -303,7 +302,7 @@ Tcl_DumpActiveMemory (fileName)
}
}
- TclpMutexLock(&ckallocMutex);
+ Tcl_MutexLock(ckallocMutexPtr);
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
address = &memScanP->body [0];
fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s",
@@ -313,7 +312,7 @@ Tcl_DumpActiveMemory (fileName)
(memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
(void) fputc('\n', fileP);
}
- TclpMutexUnlock(&ckallocMutex);
+ Tcl_MutexUnlock(ckallocMutexPtr);
if (fileP != stderr) {
fclose (fileP);
@@ -372,10 +371,9 @@ Tcl_DbCkalloc(size, file, line)
memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
}
if (!ckallocInit) {
- ckallocInit = 1;
- TclpMutexInit(&ckallocMutex);
+ TclInitDbCkalloc();
}
- TclpMutexLock(&ckallocMutex);
+ Tcl_MutexLock(ckallocMutexPtr);
result->length = size;
result->tagPtr = curTagPtr;
if (curTagPtr != NULL) {
@@ -421,7 +419,7 @@ Tcl_DbCkalloc(size, file, line)
if (current_bytes_malloced > maximum_bytes_malloced)
maximum_bytes_malloced = current_bytes_malloced;
- TclpMutexUnlock(&ckallocMutex);
+ Tcl_MutexUnlock(ckallocMutexPtr);
return result->body;
}
@@ -469,7 +467,7 @@ Tcl_DbCkfree(ptr, file, line)
if (validate_memory)
Tcl_ValidateAllMemory(file, line);
- TclpMutexLock(&ckallocMutex);
+ Tcl_MutexLock(ckallocMutexPtr);
ValidateMemory(memp, file, line, TRUE);
if (init_malloced_bodies) {
memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length);
@@ -496,7 +494,7 @@ Tcl_DbCkfree(ptr, file, line)
if (allocHead == memp)
allocHead = memp->flink;
TclpFree((char *) memp);
- TclpMutexUnlock(&ckallocMutex);
+ Tcl_MutexUnlock(ckallocMutexPtr);
return 0;
}
@@ -957,7 +955,7 @@ void
TclFinalizeMemorySubsystem()
{
#ifdef TCL_MEM_DEBUG
- TclpMutexLock(&ckallocMutex);
+ Tcl_MutexLock(ckallocMutexPtr);
if (tclMemDumpFileName != NULL) {
Tcl_DumpActiveMemory(tclMemDumpFileName);
}
@@ -965,7 +963,7 @@ TclFinalizeMemorySubsystem()
TclpFree((char *) curTagPtr);
}
allocHead = NULL;
- TclpMutexUnlock(&ckallocMutex);
+ Tcl_MutexUnlock(ckallocMutexPtr);
#endif
#if USE_TCLALLOC
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index b121c67..0724cec 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdIL.c,v 1.13 1999/06/17 19:31:50 stanton Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.14 1999/08/10 02:42:13 welch Exp $
*/
#include "tclInt.h"
@@ -915,9 +915,7 @@ InfoExistsCmd(dummy, interp, objc, objv)
}
varName = Tcl_GetString(objv[2]);
- varPtr = TclLookupVar(interp, varName, (char *) NULL,
- 0, "access",
- /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+ varPtr = TclVarTraceExists(interp, varName);
if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
} else {
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 0eda09f..04fd365 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDecls.h,v 1.25 1999/08/02 18:33:43 redman Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.26 1999/08/10 02:42:13 welch Exp $
*/
#ifndef _TCLDECLS
@@ -1208,6 +1208,10 @@ EXTERN int Tcl_RegExpMatchObj _ANSI_ARGS_((Tcl_Interp * interp,
/* 386 */
EXTERN void Tcl_SetNotifier _ANSI_ARGS_((
Tcl_NotifierProcs * notifierProcPtr));
+/* 387 */
+EXTERN Tcl_Mutex * Tcl_GetAllocMutex _ANSI_ARGS_((void));
+/* 388 */
+EXTERN int Tcl_GetChannelNames _ANSI_ARGS_((Tcl_Interp * interp));
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -1662,6 +1666,8 @@ typedef struct TclStubs {
void (*tcl_AppendUnicodeToObj) _ANSI_ARGS_((register Tcl_Obj * objPtr, Tcl_UniChar * unicode, int length)); /* 384 */
int (*tcl_RegExpMatchObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * stringObj, Tcl_Obj * patternObj)); /* 385 */
void (*tcl_SetNotifier) _ANSI_ARGS_((Tcl_NotifierProcs * notifierProcPtr)); /* 386 */
+ Tcl_Mutex * (*tcl_GetAllocMutex) _ANSI_ARGS_((void)); /* 387 */
+ int (*tcl_GetChannelNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 388 */
} TclStubs;
#ifdef __cplusplus
@@ -3255,6 +3261,14 @@ extern TclStubs *tclStubsPtr;
#define Tcl_SetNotifier \
(tclStubsPtr->tcl_SetNotifier) /* 386 */
#endif
+#ifndef Tcl_GetAllocMutex
+#define Tcl_GetAllocMutex \
+ (tclStubsPtr->tcl_GetAllocMutex) /* 387 */
+#endif
+#ifndef Tcl_GetChannelNames
+#define Tcl_GetChannelNames \
+ (tclStubsPtr->tcl_GetChannelNames) /* 388 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclIO.c b/generic/tclIO.c
index c0a33b0..245c7f7 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIO.c,v 1.12 1999/07/30 21:46:47 hobbs Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.13 1999/08/10 02:42:13 welch Exp $
*/
#include "tclInt.h"
@@ -593,6 +593,39 @@ TclFinalizeIOSubsystem()
}
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CloseChannels --
+ *
+ * Close all open channels in this interp, except for the
+ * standard input/output channels. This is useful for cleanup.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * May closes one or more channels.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_CloseChannels(Tcl_Interp *interp)
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Channel *chanPtr, *nextChanPtr;
+
+ for (chanPtr = tsdPtr->firstChanPtr; chanPtr != NULL; chanPtr = nextChanPtr) {
+ nextChanPtr = chanPtr->nextChanPtr;
+ if (chanPtr != (Channel *) tsdPtr->stdinChannel
+ && chanPtr != (Channel *) tsdPtr->stdoutChannel
+ && chanPtr != (Channel *) tsdPtr->stderrChannel) {
+ (void) Tcl_UnregisterChannel(interp, (Tcl_Channel) chanPtr);
+ }
+ }
+}
/*
@@ -8159,4 +8192,44 @@ SetBlockMode(interp, chanPtr, mode)
return TCL_OK;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetChannelNames --
+ *
+ * Return the names of all open channels in the interp.
+ *
+ * Results:
+ * TCL_OK or TCL_ERROR.
+ *
+ * Side effects:
+ * Interp result modified with list of channel names.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+Tcl_GetChannelNames(Tcl_Interp *interp)
+{
+ Channel *chanPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ char *name;
+
+ Tcl_ResetResult(interp);
+ chanPtr = tsdPtr->firstChanPtr;
+ while (chanPtr != NULL) {
+ if (chanPtr == (Channel *) tsdPtr->stdinChannel) {
+ name = "stdin";
+ } else if (chanPtr == (Channel *) tsdPtr->stdoutChannel) {
+ name = "stdout";
+ } else if (chanPtr == (Channel *) tsdPtr->stderrChannel) {
+ name = "stderr";
+ } else {
+ name = chanPtr->channelName;
+ }
+ Tcl_AppendElement(interp, name);
+ chanPtr = chanPtr->nextChanPtr;
+ }
+ return TCL_OK;
+}
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index b4cab7c..52604a6 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.16 1999/08/02 17:45:37 redman Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.17 1999/08/10 02:42:14 welch Exp $
library tcl
@@ -560,6 +560,8 @@ declare 149 generic {
void TclHandleRelease(TclHandle handle)
}
+# Added for Tcl 8.2
+
declare 150 generic {
int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
@@ -587,6 +589,9 @@ declare 156 generic {
void TclRegError (Tcl_Interp *interp, char *msg, \
int status)
}
+declare 157 generic {
+ Var * TclVarTraceExists (Tcl_Interp *interp, char *varName)
+}
##############################################################################
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index b6f3c8f..fea3857 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.16 1999/08/02 17:45:37 redman Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.17 1999/08/10 02:42:14 welch Exp $
*/
#ifndef _TCLINTDECLS
@@ -516,6 +516,9 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((
/* 156 */
EXTERN void TclRegError _ANSI_ARGS_((Tcl_Interp * interp,
char * msg, int status));
+/* 157 */
+EXTERN Var * TclVarTraceExists _ANSI_ARGS_((Tcl_Interp * interp,
+ char * varName));
typedef struct TclIntStubs {
int magic;
@@ -710,6 +713,7 @@ typedef struct TclIntStubs {
int (*tclTestChannelCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, char ** argv)); /* 154 */
int (*tclTestChannelEventCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, char ** argv)); /* 155 */
void (*tclRegError) _ANSI_ARGS_((Tcl_Interp * interp, char * msg, int status)); /* 156 */
+ Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 157 */
} TclIntStubs;
#ifdef __cplusplus
@@ -1347,6 +1351,10 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclRegError \
(tclIntStubsPtr->tclRegError) /* 156 */
#endif
+#ifndef TclVarTraceExists
+#define TclVarTraceExists \
+ (tclIntStubsPtr->tclVarTraceExists) /* 157 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index f79dbd4..c433c97 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.26 1999/08/02 18:33:44 redman Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.27 1999/08/10 02:42:14 welch Exp $
*/
#include "tclInt.h"
@@ -232,6 +232,7 @@ TclIntStubs tclIntStubs = {
TclTestChannelCmd, /* 154 */
TclTestChannelEventCmd, /* 155 */
TclRegError, /* 156 */
+ TclVarTraceExists, /* 157 */
};
TclIntPlatStubs tclIntPlatStubs = {
@@ -780,6 +781,8 @@ TclStubs tclStubs = {
Tcl_AppendUnicodeToObj, /* 384 */
Tcl_RegExpMatchObj, /* 385 */
Tcl_SetNotifier, /* 386 */
+ Tcl_GetAllocMutex, /* 387 */
+ Tcl_GetChannelNames, /* 388 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 2dc867d..67a5cab 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclVar.c,v 1.11 1999/07/22 21:50:54 redman Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.12 1999/08/10 02:42:14 welch Exp $
*/
#include "tclInt.h"
@@ -4668,3 +4668,67 @@ VarErrMsg(interp, part1, part2, operation, reason)
}
Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclTraceVarExists --
+ *
+ * This is called from info exists. We need to trigger read
+ * and/or array traces because they may end up creating a
+ * variable that doesn't currently exist.
+ *
+ * Results:
+ * A pointer to the Var structure, or NULL.
+ *
+ * Side effects:
+ * May fill in error messages in the interp.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Var *
+TclVarTraceExists(interp, varName)
+ Tcl_Interp *interp; /* The interpreter */
+ char *varName; /* The variable name */
+{
+ Var *varPtr;
+ Var *arrayPtr;
+ char *msg;
+
+ /*
+ * The choice of "create" flag values is delicate here, and
+ * matches the semantics of GetVar. Things are still not perfect,
+ * however, because if you do "info exists x" you get a varPtr
+ * and therefore trigger traces. However, if you do
+ * "info exists x(i)", then you only get a varPtr if x is already
+ * known to be an array. Otherwise you get NULL, and no trace
+ * is triggered. This matches Tcl 7.6 semantics.
+ */
+
+ varPtr = TclLookupVar(interp, varName, (char *) NULL,
+ 0, "access",
+ /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ return NULL;
+ }
+ if ((varPtr != NULL) &&
+ ((varPtr->tracePtr != NULL)
+ || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
+ msg = CallTraces((Interp *)interp, arrayPtr, varPtr, varName,
+ (char *) NULL, TCL_TRACE_READS);
+ if (msg != NULL) {
+ /*
+ * If the variable doesn't exist anymore and no-one's using
+ * it, then free up the relevant structures and hash table entries.
+ */
+
+ if (TclIsVarUndefined(varPtr)) {
+ CleanupVar(varPtr, arrayPtr);
+ }
+ return NULL;
+ }
+ }
+ return varPtr;
+}
generated by cgit v0.12 at 2024-11-10 19:15:47 (GMT)