From 3a26c6d4498ad6fad866d54c7b23cb221fe21898 Mon Sep 17 00:00:00 2001 From: welch Date: Tue, 10 Aug 1999 02:42:12 +0000 Subject: 1 Added use of Tcl_GetAllocMutex to tclAlloc.c and tclCkalloc.c so they can be linked against alternate thread packages. 2 Added Tcl_GetChannelNames to tclIO.c 3 Added TclVarTraceExists hook so "info exists" triggers read traces exactly like it did in Tcl 7.6 4 Stubs table changes to reflect new internal and external APIs --- generic/tcl.decls | 10 ++++++- generic/tclAlloc.c | 50 +++++++++++++++++----------------- generic/tclCkalloc.c | 36 ++++++++++++------------- generic/tclCmdIL.c | 6 ++--- generic/tclDecls.h | 16 ++++++++++- generic/tclIO.c | 75 ++++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclInt.decls | 7 ++++- generic/tclIntDecls.h | 10 ++++++- generic/tclStubInit.c | 5 +++- generic/tclVar.c | 66 ++++++++++++++++++++++++++++++++++++++++++++- 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; +} -- cgit v0.12