diff options
author | dgp <dgp@users.sourceforge.net> | 2017-01-12 20:59:53 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2017-01-12 20:59:53 (GMT) |
commit | 940547a862d57d30fbce2e7a43beaf558a50f832 (patch) | |
tree | ede9400a7f2d9a343d5df8959506d3b64b0b6a97 /generic | |
parent | 986cc9a1d8abe7ab0abc0971982fcb5f367cba18 (diff) | |
parent | 7b39886f02248093aab85c82068ee768586cf19e (diff) | |
download | tcl-940547a862d57d30fbce2e7a43beaf558a50f832.zip tcl-940547a862d57d30fbce2e7a43beaf558a50f832.tar.gz tcl-940547a862d57d30fbce2e7a43beaf558a50f832.tar.bz2 |
merge trunk
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tcl.decls | 17 | ||||
-rw-r--r-- | generic/tcl.h | 7 | ||||
-rw-r--r-- | generic/tclAlloc.c | 44 | ||||
-rw-r--r-- | generic/tclBasic.c | 5 | ||||
-rw-r--r-- | generic/tclBinary.c | 8 | ||||
-rw-r--r-- | generic/tclCmdIL.c | 15 | ||||
-rw-r--r-- | generic/tclDecls.h | 44 | ||||
-rw-r--r-- | generic/tclIO.c | 4 | ||||
-rw-r--r-- | generic/tclIOCmd.c | 79 | ||||
-rw-r--r-- | generic/tclIOSock.c | 28 | ||||
-rw-r--r-- | generic/tclIOUtil.c | 1 | ||||
-rw-r--r-- | generic/tclInt.h | 5 | ||||
-rw-r--r-- | generic/tclInterp.c | 19 | ||||
-rw-r--r-- | generic/tclLink.c | 212 | ||||
-rw-r--r-- | generic/tclLoad.c | 55 | ||||
-rw-r--r-- | generic/tclPkg.c | 122 | ||||
-rw-r--r-- | generic/tclStubInit.c | 11 | ||||
-rw-r--r-- | generic/tclTest.c | 68 |
18 files changed, 573 insertions, 171 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index d435fe4..617ac0b 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2326,22 +2326,29 @@ declare 630 { # ----- BASELINE -- FOR -- 8.6.0 ----- # -# TIP #445 +# TIP #456 declare 631 { - void Tcl_FreeIntRep(Tcl_Obj *objPtr) + Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service, + const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData) } + +# TIP #445 declare 632 { + void Tcl_FreeIntRep(Tcl_Obj *objPtr) +} +declare 633 { char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes) } -declare 633 { +declare 634 { Tcl_ObjIntRep *Tcl_FetchIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr) } -declare 634 { +declare 635 { void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr) } -declare 635 { +declare 636 { int Tcl_HasStringRep(Tcl_Obj *objPtr) } diff --git a/generic/tcl.h b/generic/tcl.h index 197fa00..ce24fa4 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2375,6 +2375,13 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp, /* *---------------------------------------------------------------------------- + * Definitions needed for the Tcl_OpenTcpServerEx function. [TIP #456] + */ +#define TCL_TCPSERVER_REUSEADDR (1<<0) +#define TCL_TCPSERVER_REUSEPORT (1<<1) + +/* + *---------------------------------------------------------------------------- * Single public declaration for NRE. */ diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index cda1f38..64df1a2 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -32,7 +32,7 @@ */ #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) -typedef unsigned long caddr_t; +typedef size_t caddr_t; #endif /* @@ -56,7 +56,7 @@ union overhead { unsigned char magic1; /* other magic number */ #ifndef NDEBUG unsigned short rmagic; /* range magic number */ - unsigned long size; /* actual block size */ + size_t size; /* actual block size */ unsigned short unused2; /* padding to 8-byte align */ #endif } ovu; @@ -133,7 +133,7 @@ static int allocInit = 0; * a given block size. */ -static unsigned int numMallocs[NBUCKETS+1]; +static size_t numMallocs[NBUCKETS+1]; #endif #if !defined(NDEBUG) @@ -148,7 +148,7 @@ static unsigned int numMallocs[NBUCKETS+1]; * Prototypes for functions used only in this file. */ -static void MoreCore(int bucket); +static void MoreCore(size_t bucket); /* *------------------------------------------------------------------------- @@ -254,7 +254,7 @@ TclpAlloc( unsigned int numBytes) /* Number of bytes to allocate. */ { register union overhead *overPtr; - register long bucket; + register size_t bucket; register unsigned amount; struct block *bigBlockPtr = NULL; @@ -385,12 +385,12 @@ TclpAlloc( static void MoreCore( - int bucket) /* What bucket to allocat to. */ + size_t bucket) /* What bucket to allocate to. */ { register union overhead *overPtr; - register long size; /* size of desired block */ - long amount; /* amount to allocate */ - int numBlocks; /* how many blocks we get */ + register size_t size; /* size of desired block */ + size_t amount; /* amount to allocate */ + size_t numBlocks; /* how many blocks we get */ struct block *blockPtr; /* @@ -398,14 +398,14 @@ MoreCore( * VAX, I think) or for a negative arg. */ - size = 1 << (bucket + 3); + size = ((size_t)1) << (bucket + 3); ASSERT(size > 0); amount = MAXMALLOC; numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = (struct block *) TclpSysAlloc((unsigned) + blockPtr = (struct block *) TclpSysAlloc( (sizeof(struct block) + amount), 1); /* no more room! */ if (blockPtr == NULL) { @@ -448,7 +448,7 @@ void TclpFree( char *oldPtr) /* Pointer to memory to free. */ { - register long size; + register size_t size; register union overhead *overPtr; struct block *bigBlockPtr; @@ -518,7 +518,7 @@ TclpRealloc( union overhead *overPtr; struct block *bigBlockPtr; int expensive; - unsigned long maxSize; + size_t maxSize; if (oldPtr == NULL) { return TclpAlloc(numBytes); @@ -645,30 +645,30 @@ void mstats( char *s) /* Where to write info. */ { - register int i, j; + register unsigned int i, j; register union overhead *overPtr; - int totalFree = 0, totalUsed = 0; + size_t totalFree = 0, totalUsed = 0; Tcl_MutexLock(allocMutexPtr); fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) { - fprintf(stderr, " %d", j); + fprintf(stderr, " %u", j); } - totalFree += j * (1 << (i + 3)); + totalFree += ((size_t)j) * (1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { - fprintf(stderr, " %d", numMallocs[i]); + fprintf(stderr, " %" TCL_LL_MODIFIER "d", (Tcl_WideInt)numMallocs[i]); totalUsed += numMallocs[i] * (1 << (i + 3)); } - fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", - totalUsed, totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", - MAXMALLOC, numMallocs[NBUCKETS]); + fprintf(stderr, "\n\tTotal small in use: %" TCL_LL_MODIFIER "d, total free: %" TCL_LL_MODIFIER "d\n", + (Tcl_WideInt)totalUsed, (Tcl_WideInt)totalFree); + fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_LL_MODIFIER "d\n", + MAXMALLOC, (Tcl_WideInt)numMallocs[NBUCKETS]); Tcl_MutexUnlock(allocMutexPtr); } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 9d5147b..d1cea62 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -6707,11 +6707,10 @@ Tcl_AppendObjToErrorInfo( * pertains. */ Tcl_Obj *objPtr) /* Message to record. */ { - int length; - const char *message = TclGetStringFromObj(objPtr, &length); + const char *message = TclGetString(objPtr); Tcl_IncrRefCount(objPtr); - Tcl_AddObjErrorInfo(interp, message, length); + Tcl_AddObjErrorInfo(interp, message, objPtr->length); Tcl_DecrRefCount(objPtr); } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 6369a86..d0066e5 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -176,7 +176,7 @@ static const EnsembleImplMap decodeMap[] = { * where the codepoint of each character is the value of corresponding byte. * This approach creates a one-to-one map between all bytearray values * and a subset of Tcl string values. - * + * * When converting a Tcl string value to the bytearray internal rep, the * question arises what to do with strings outside that subset? That is, * those Tcl strings containing at least one codepoint greater than 255? @@ -184,7 +184,7 @@ static const EnsembleImplMap decodeMap[] = { * does not represent any valid bytearray value. Full Stop. The * setFromAnyProc signature has a completion code return value for just * this reason, to reject invalid inputs. - * + * * Unfortunately this was not the path taken by the authors of the * original tclByteArrayType. They chose to accept all Tcl string values * as acceptable string encodings of the bytearray values that result @@ -208,7 +208,7 @@ static const EnsembleImplMap decodeMap[] = { * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr) * * has a guarantee to always return a non-NULL value, but that value - * points to a byte sequence that cannot be used by the caller to + * points to a byte sequence that cannot be used by the caller to * process the Tcl value absent some sideband testing that objPtr * is "pure". Tcl offers no public interface to perform this test, * so callers either break encapsulation or are unavoidably buggy. Tcl @@ -222,7 +222,7 @@ static const EnsembleImplMap decodeMap[] = { * Bytearrays should simply be usable as bytearrays without a kabuki * dance of testing. * - * The Tcl_ObjType "properByteArrayType" is (nearly) a correct + * The Tcl_ObjType "properByteArrayType" is (nearly) a correct * implementation of bytearrays. Any Tcl value with the type * properByteArrayType can have its bytearray value fetched and * used with confidence that acting on that value is equivalent to diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 9058d0f..7f18f30 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1707,19 +1707,24 @@ InfoLoadedCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *interpName; + const char *interpName, *packageName; - if ((objc != 1) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); + if (objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?"); return TCL_ERROR; } - if (objc == 1) { /* Get loaded pkgs in all interpreters. */ + if (objc < 2) { /* Get loaded pkgs in all interpreters. */ interpName = NULL; } else { /* Get pkgs just in specified interp. */ interpName = TclGetString(objv[1]); } - return TclGetLoadedPackages(interp, interpName); + if (objc < 3) { /* Get loaded files in all packages. */ + packageName = NULL; + } else { /* Get pkgs just in specified interp. */ + packageName = TclGetString(objv[2]); + } + return TclGetLoadedPackagesEx(interp, interpName, packageName); } /* diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 71598ab..6ad4f54 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1817,18 +1817,24 @@ EXTERN void Tcl_ZlibStreamSetCompressionDictionary( Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 631 */ -EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr); +EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, + const char *service, const char *host, + unsigned int flags, + Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData); /* 632 */ +EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr); +/* 633 */ EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); -/* 633 */ +/* 634 */ EXTERN Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); -/* 634 */ +/* 635 */ EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); -/* 635 */ +/* 636 */ EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr); typedef struct { @@ -2496,11 +2502,12 @@ typedef struct TclStubs { void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ - void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 631 */ - char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 632 */ - Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 633 */ - void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 634 */ - int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 635 */ + Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */ + void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 632 */ + char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 633 */ + Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 634 */ + void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 635 */ + int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 636 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3793,16 +3800,18 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ +#define Tcl_OpenTcpServerEx \ + (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */ #define Tcl_FreeIntRep \ - (tclStubsPtr->tcl_FreeIntRep) /* 631 */ + (tclStubsPtr->tcl_FreeIntRep) /* 632 */ #define Tcl_InitStringRep \ - (tclStubsPtr->tcl_InitStringRep) /* 632 */ + (tclStubsPtr->tcl_InitStringRep) /* 633 */ #define Tcl_FetchIntRep \ - (tclStubsPtr->tcl_FetchIntRep) /* 633 */ + (tclStubsPtr->tcl_FetchIntRep) /* 634 */ #define Tcl_StoreIntRep \ - (tclStubsPtr->tcl_StoreIntRep) /* 634 */ + (tclStubsPtr->tcl_StoreIntRep) /* 635 */ #define Tcl_HasStringRep \ - (tclStubsPtr->tcl_HasStringRep) /* 635 */ + (tclStubsPtr->tcl_HasStringRep) /* 636 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3817,7 +3826,6 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_SetVar # undef Tcl_ObjSetVar2 # undef Tcl_StaticPackage -# undef TclFSGetNativePath # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) # define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) # define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) @@ -3884,6 +3892,12 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_UpVar #define Tcl_UpVar(interp, frameName, varName, localName, flags) \ Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags) +#undef Tcl_AddErrorInfo +#define Tcl_AddErrorInfo(interp, message) \ + Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1)) +#undef Tcl_AddObjErrorInfo +#define Tcl_AddObjErrorInfo(interp, message, length) \ + Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) # if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG) diff --git a/generic/tclIO.c b/generic/tclIO.c index 291c13d..31c5c97 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -323,7 +323,7 @@ typedef struct ResolvedChanName { Tcl_Interp *interp; /* The interp in which the lookup was done. */ int epoch; /* The epoch of the channel when the lookup * was done. Use to verify validity. */ - int refCount; /* Share this struct among many Tcl_Obj. */ + size_t refCount; /* Share this struct among many Tcl_Obj. */ } ResolvedChanName; static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); @@ -11207,7 +11207,7 @@ FreeChannelIntRep( ChanGetIntRep(objPtr, resPtr); assert(resPtr); - if (--resPtr->refCount) { + if (resPtr->refCount-- > 1) { return; } Tcl_Release(resPtr->statePtr); diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index de65da5..1bd3fe7 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1485,13 +1485,17 @@ Tcl_SocketObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const socketOptions[] = { - "-async", "-myaddr", "-myport", "-server", NULL + "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server", + NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, + SKT_SERVER }; - int optionIndex, a, server = 0, port, myport = 0, async = 0; - const char *host, *myaddr = NULL; + int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1, + reusea = -1; + unsigned int flags = 0; + const char *host, *port, *myaddr = NULL; Tcl_Obj *script = NULL; Tcl_Channel chan; @@ -1557,6 +1561,28 @@ Tcl_SocketObjCmd( } script = objv[a]; break; + case SKT_REUSEADDR: + a++; + if (a >= objc) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -reuseaddr option", -1)); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[a], &reusea) != TCL_OK) { + return TCL_ERROR; + } + break; + case SKT_REUSEPORT: + a++; + if (a >= objc) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -reuseport option", -1)); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[a], &reusep) != TCL_OK) { + return TCL_ERROR; + } + break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } @@ -1580,19 +1606,37 @@ Tcl_SocketObjCmd( "?-myaddr addr? ?-myport myport? ?-async? host port"); iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, - "-server command ?-myaddr addr? port"); + "-server command ?-reuseaddr boolean? ?-reuseport boolean? " + "?-myaddr addr? port"); return TCL_ERROR; } - if (a == objc-1) { - if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", - &port) != TCL_OK) { - return TCL_ERROR; - } - } else { + if (!server && (reusea != -1 || reusep != -1)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "options -reuseaddr and -reuseport are only valid for servers", + -1)); + return TCL_ERROR; + } + + // Set the options to their default value if the user didn't override their + // value. + if (reusep == -1) reusep = 0; + if (reusea == -1) reusea = 1; + + // Build the bitset with the flags values. + if (reusea) + flags |= TCL_TCPSERVER_REUSEADDR; + if (reusep) + flags |= TCL_TCPSERVER_REUSEPORT; + + // All the arguments should have been parsed by now, 'a' points to the last + // one, the port number. + if (a != objc-1) { goto wrongNumArgs; } + port = TclGetString(objv[a]); + if (server) { AcceptCallback *acceptCallbackPtr = ckalloc(sizeof(AcceptCallback)); @@ -1600,8 +1644,9 @@ Tcl_SocketObjCmd( Tcl_IncrRefCount(script); acceptCallbackPtr->script = script; acceptCallbackPtr->interp = interp; - chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, - acceptCallbackPtr); + + chan = Tcl_OpenTcpServerEx(interp, port, host, flags, AcceptCallbackProc, + acceptCallbackPtr); if (chan == NULL) { Tcl_DecrRefCount(script); ckfree(acceptCallbackPtr); @@ -1625,7 +1670,13 @@ Tcl_SocketObjCmd( Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr); } else { - chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + int portNum; + + if (TclSockGetPort(interp, port, "tcp", &portNum) != TCL_OK) { + return TCL_ERROR; + } + + chan = Tcl_OpenTcpClient(interp, portNum, host, myaddr, myport, async); if (chan == NULL) { return TCL_ERROR; } diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 7ed751c..8ad268a 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -285,6 +285,34 @@ TclCreateSocketAddress( } /* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpServer -- + * + * Opens a TCP server socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. If an error occurred, an error message + * is left in the interp's result if interp is not NULL. + * + * Side effects: + * Opens a server socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ +Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, + const char *host, Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData) +{ + char portbuf[TCL_INTEGER_SPACE]; + + TclFormatInt(portbuf, port); + + return Tcl_OpenTcpServerEx(interp, portbuf, host, TCL_TCPSERVER_REUSEADDR, + acceptProc, callbackData); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index e3a6b2a..de5d62d 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1890,6 +1890,7 @@ TclNREvalFile( Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } + TclPkgFileSeen(interp, Tcl_GetString(pathPtr)); /* * The eofchar is \32 (^Z). This is the usual on Windows, but we effect diff --git a/generic/tclInt.h b/generic/tclInt.h index a10a22b..68cd6ab 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2976,6 +2976,9 @@ MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, unsigned int *sizePtr); +MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp, + const char *targetName, + const char *packageName); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); @@ -3102,6 +3105,8 @@ MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); +MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName); +MODULE_SCOPE void *TclInitPkgFiles(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_PathPart portion); MODULE_SCOPE char * TclpReadlink(const char *fileName, diff --git a/generic/tclInterp.c b/generic/tclInterp.c index daa7e9d..cad7f3f 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -331,13 +331,24 @@ TclSetPreInitScript( *---------------------------------------------------------------------- */ +typedef struct PkgName { + struct PkgName *nextPtr; /* Next in list of package names being initialized. */ + char name[4]; +} PkgName; + int Tcl_Init( Tcl_Interp *interp) /* Interpreter to initialize. */ { + PkgName pkgName = {NULL, "Tcl"}; + PkgName **names = TclInitPkgFiles(interp); + int result = TCL_ERROR; + + pkgName.nextPtr = *names; + *names = &pkgName; if (tclPreInitScript != NULL) { if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) { - return TCL_ERROR; + goto end; } } @@ -382,7 +393,7 @@ Tcl_Init( * alternate tclInit command before calling Tcl_Init(). */ - return Tcl_EvalEx(interp, + result = Tcl_EvalEx(interp, "if {[namespace which -command tclInit] eq \"\"} {\n" " proc tclInit {} {\n" " global tcl_libPath tcl_library env tclDefaultLibrary\n" @@ -446,6 +457,10 @@ Tcl_Init( " }\n" "}\n" "tclInit", -1, 0); + +end: + *names = (*names)->nextPtr; + return result; } /* diff --git a/generic/tclLink.c b/generic/tclLink.c index 61c2076..348ce56 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -67,6 +67,10 @@ typedef struct Link { static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); +static int GetInvalidIntFromObj(Tcl_Obj *objPtr, + int *intPtr); +static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, + double *doublePtr); /* * Convenience macro for accessing the value of the C variable pointed to by a @@ -380,9 +384,12 @@ LinkTraceProc( case TCL_LINK_INT: if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + if (GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; + return (char *) "variable must have integer value"; + } } LinkedVar(int) = linkPtr->lastValue.i; break; @@ -390,12 +397,15 @@ LinkTraceProc( case TCL_LINK_WIDE_INT: if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; - } else { - LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w; + return (char *) "variable must have integer value"; + } + linkPtr->lastValue.w = (Tcl_WideInt) valueInt; } + LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w; break; case TCL_LINK_DOUBLE: @@ -405,13 +415,15 @@ LinkTraceProc( Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(valueObj, &tclDoubleType); if (irPtr == NULL) { #endif - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have real value"; + if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have real value"; + } #ifdef ACCEPT_NAN - } else { - linkPtr->lastValue.d = irPtr->doubleValue; } + linkPtr->lastValue.d = irPtr->doubleValue; #endif } LinkedVar(double) = linkPtr->lastValue.d; @@ -430,9 +442,12 @@ LinkTraceProc( case TCL_LINK_CHAR: if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have char value"; + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have char value"; + } } linkPtr->lastValue.c = (char)valueInt; LinkedVar(char) = linkPtr->lastValue.c; @@ -441,9 +456,12 @@ LinkTraceProc( case TCL_LINK_UCHAR: if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK || valueInt < 0 || valueInt > UCHAR_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned char value"; + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned char value"; + } } linkPtr->lastValue.uc = (unsigned char) valueInt; LinkedVar(unsigned char) = linkPtr->lastValue.uc; @@ -452,9 +470,12 @@ LinkTraceProc( case TCL_LINK_SHORT: if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have short value"; + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have short value"; + } } linkPtr->lastValue.s = (short)valueInt; LinkedVar(short) = linkPtr->lastValue.s; @@ -463,9 +484,12 @@ LinkTraceProc( case TCL_LINK_USHORT: if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK || valueInt < 0 || valueInt > USHRT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned short value"; + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned short value"; + } } linkPtr->lastValue.us = (unsigned short)valueInt; LinkedVar(unsigned short) = linkPtr->lastValue.us; @@ -474,9 +498,13 @@ LinkTraceProc( case TCL_LINK_UINT: if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK || valueWide < 0 || valueWide > UINT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned int value"; + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned int value"; + } + linkPtr->lastValue.ui = (unsigned int)valueInt; } else { linkPtr->lastValue.ui = (unsigned int)valueWide; } @@ -486,9 +514,13 @@ LinkTraceProc( case TCL_LINK_LONG: if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK || valueWide < LONG_MIN || valueWide > LONG_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have long value"; + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have long value"; + } + linkPtr->lastValue.l = (long)valueInt; } else { linkPtr->lastValue.l = (long)valueWide; } @@ -498,9 +530,13 @@ LinkTraceProc( case TCL_LINK_ULONG: if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned long value"; + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned long value"; + } + linkPtr->lastValue.ul = (unsigned long)valueInt; } else { linkPtr->lastValue.ul = (unsigned long)valueWide; } @@ -512,9 +548,13 @@ LinkTraceProc( * FIXME: represent as a bignum. */ if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned wide int value"; + if (GetInvalidIntFromObj(valueObj, &valueInt) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned wide int value"; + } + linkPtr->lastValue.uw = (Tcl_WideUInt)valueInt; } else { linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; } @@ -524,12 +564,14 @@ LinkTraceProc( case TCL_LINK_FLOAT: if (Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have float value"; - } else { - linkPtr->lastValue.f = (float)valueDouble; + if (GetInvalidDoubleFromObj(valueObj, &valueDouble) + != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have float value"; + } } + linkPtr->lastValue.f = (float)valueDouble; LinkedVar(float) = linkPtr->lastValue.f; break; @@ -634,6 +676,96 @@ ObjValue( return resultObj; } } + +static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); + +static Tcl_ObjType invalidRealType = { + "invalidReal", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetInvalidRealFromAny /* setFromAnyProc */ +}; + +static int +SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { + int length; + const char *str; + const char *endPtr; + + str = TclGetStringFromObj(objPtr, &length); + if ((length == 1) && (str[0] == '.')){ + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = 0.0; + return TCL_OK; + } + if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr, + TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { + /* If number is followed by [eE][+-]?, then it is an invalid + * double, but it could be the start of a valid double. */ + if (*endPtr == 'e' || *endPtr == 'E') { + ++endPtr; + if (*endPtr == '+' || *endPtr == '-') ++endPtr; + if (*endPtr == 0) { + double doubleValue = 0.0; + Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); + if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr); + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = doubleValue; + return TCL_OK; + } + } + } + return TCL_ERROR; +} + + +/* + * This function checks for integer representations, which are valid + * when linking with C variables, but which are invalid in other + * contexts in Tcl. Handled are "+", "-", "0x", "0b" and "0o" (upper- + * and lowercase). See bug [39f6304c2e]. + */ +int +GetInvalidIntFromObj(Tcl_Obj *objPtr, + int *intPtr) +{ + int length; + const char *str = TclGetStringFromObj(objPtr, &length); + + if ((length == 1) && strchr("+-", str[0])) { + *intPtr = (str[0] == '+'); + return TCL_OK; + } else if ((length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1])) { + *intPtr = 0; + return TCL_OK; + } + return TCL_ERROR; +} + +/* + * This function checks for double representations, which are valid + * when linking with C variables, but which are invalid in other + * contexts in Tcl. Handled are ".", "+", "-", "0x", "0b" and "0o" + * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e]. + */ +int +GetInvalidDoubleFromObj(Tcl_Obj *objPtr, + double *doublePtr) +{ + int intValue, result; + + if ((objPtr->typePtr == &invalidRealType) || + (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK)) { + *doublePtr = objPtr->internalRep.doubleValue; + return TCL_OK; + } + result = GetInvalidIntFromObj(objPtr, &intValue); + if (result == TCL_OK) { + *doublePtr = (double) intValue; + } + return result; +} /* * Local Variables: diff --git a/generic/tclLoad.c b/generic/tclLoad.c index be296b3..bcda420 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -998,7 +998,7 @@ Tcl_StaticPackage( } /* - * Package isn't loade in the current interp yet. Mark it as now being + * Package isn't loaded in the current interp yet. Mark it as now being * loaded. */ @@ -1012,7 +1012,7 @@ Tcl_StaticPackage( /* *---------------------------------------------------------------------- * - * TclGetLoadedPackages -- + * TclGetLoadedPackages, TclGetLoadedPackagesEx -- * * This function returns information about all of the files that are * loaded (either in a particular interpreter, or for all interpreters). @@ -1039,16 +1039,27 @@ TclGetLoadedPackages( * otherwise, just return info about this * interpreter. */ { + return TclGetLoadedPackagesEx(interp, targetName, NULL); +} + +int +TclGetLoadedPackagesEx( + Tcl_Interp *interp, /* Interpreter in which to return information + * or error message. */ + const char *targetName, /* Name of target interpreter or NULL. If + * NULL, return info about all interps; + * otherwise, just return info about this + * interpreter. */ + const char *packageName) /* Package name or NULL. If NULL, return info + * for all packages. + */ +{ Tcl_Interp *target; LoadedPackage *pkgPtr; InterpPackage *ipPtr; Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { - /* - * Return information about all of the available packages. - */ - resultObj = Tcl_NewObj(); Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; @@ -1063,16 +1074,38 @@ TclGetLoadedPackages( return TCL_OK; } - /* - * Return information about only the packages that are loaded in a given - * interpreter. - */ - target = Tcl_GetSlave(interp, targetName); if (target == NULL) { return TCL_ERROR; } ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL); + + /* + * Return information about all of the available packages. + */ + if (packageName) { + resultObj = NULL; + + for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + pkgPtr = ipPtr->pkgPtr; + + if (!strcmp(packageName, pkgPtr->packageName)) { + resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); + break; + } + } + + if (resultObj) { + Tcl_SetObjResult(interp, resultObj); + } + return TCL_OK; + } + + /* + * Return information about only the packages that are loaded in a given + * interpreter. + */ + resultObj = Tcl_NewObj(); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 244eb94..42dd08d 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -32,6 +32,17 @@ typedef struct PkgAvail { * same package. */ } PkgAvail; +typedef struct PkgName { + struct PkgName *nextPtr; /* Next in list of package names being initialized. */ + char name[1]; +} PkgName; + +typedef struct PkgFiles { + PkgName *names; /* Package names being initialized. Must be first field*/ + Tcl_HashTable table; /* Table which contains files for each package */ +} PkgFiles; + + /* * For each package that is known in any way to an interpreter, there is one * record of the following type. These records are stored in the @@ -81,7 +92,7 @@ static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, ((v) = ckalloc(len), memcpy((v),(s),(len))) #define DupString(v,s) \ do { \ - unsigned local__len = (unsigned) (strlen(s) + 1); \ + size_t local__len = strlen(s) + 1; \ DupBlock((v),(s),local__len); \ } while (0) @@ -189,6 +200,62 @@ Tcl_PkgProvideEx( *---------------------------------------------------------------------- */ +static void PkgFilesCleanupProc(ClientData clientData, + Tcl_Interp *interp) +{ + PkgFiles *pkgFiles = (PkgFiles *) clientData; + Tcl_HashSearch search; + Tcl_HashEntry *entry; + + while (pkgFiles->names) { + PkgName *name = pkgFiles->names; + pkgFiles->names = name->nextPtr; + ckfree(name); + } + entry = Tcl_FirstHashEntry(&pkgFiles->table, &search); + while (entry) { + Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry); + Tcl_DecrRefCount(obj); + entry = Tcl_NextHashEntry(&search); + } + Tcl_DeleteHashTable(&pkgFiles->table); + return; +} + +void *TclInitPkgFiles(Tcl_Interp *interp) +{ + /* If assocdata "tclPkgFiles" doesn't exist yet, create it */ + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (!pkgFiles) { + pkgFiles = ckalloc(sizeof(PkgFiles)); + pkgFiles->names = NULL; + Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS); + Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles); + } + return pkgFiles; +} + +void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName) +{ + PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (pkgFiles && pkgFiles->names) { + const char *name = pkgFiles->names->name; + Tcl_HashTable *table = &pkgFiles->table; + int new; + Tcl_HashEntry *entry = Tcl_CreateHashEntry(table, name, &new); + Tcl_Obj *list; + + if (new) { + list = Tcl_NewObj(); + Tcl_SetHashValue(entry, list); + Tcl_IncrRefCount(list); + } else { + list = Tcl_GetHashValue(entry); + } + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1)); + } +} + #undef Tcl_PkgRequire const char * Tcl_PkgRequire( @@ -489,12 +556,23 @@ PkgRequireCore( */ char *versionToProvide = bestPtr->version; + PkgFiles *pkgFiles; + PkgName *pkgName; script = bestPtr->script; pkgPtr->clientData = versionToProvide; - Tcl_Preserve(script); Tcl_Preserve(versionToProvide); + Tcl_Preserve(script); + pkgFiles = TclInitPkgFiles(interp); + /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ + pkgName = ckalloc(sizeof(PkgName) + strlen(name)); + pkgName->nextPtr = pkgFiles->names; + strcpy(pkgName->name, name); + pkgFiles->names = pkgName; code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); + /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ + pkgFiles->names = pkgName->nextPtr; + ckfree(pkgName); Tcl_Release(script); pkgPtr = FindPackage(interp, name); @@ -764,14 +842,14 @@ Tcl_PackageObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const pkgOptions[] = { - "forget", "ifneeded", "names", "prefer", "present", - "provide", "require", "unknown", "vcompare", "versions", - "vsatisfies", NULL + "files", "forget", "ifneeded", "names", "prefer", + "present", "provide", "require", "unknown", "vcompare", + "versions", "vsatisfies", NULL }; enum pkgOptions { - PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, - PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, - PKG_VSATISFIES + PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, + PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, + PKG_VERSIONS, PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; int optionIndex, exact, i, satisfies; @@ -794,11 +872,37 @@ Tcl_PackageObjCmd( return TCL_ERROR; } switch ((enum pkgOptions) optionIndex) { + case PKG_FILES: { + PkgFiles *pkgFiles; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "package"); + return TCL_ERROR; + } + pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (pkgFiles) { + Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2])); + if (entry) { + Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); + } + } + break; + } case PKG_FORGET: { const char *keyString; + PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); for (i = 2; i < objc; i++) { keyString = TclGetString(objv[i]); + if (pkgFiles) { + hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString); + if (hPtr) { + Tcl_Obj *obj = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + Tcl_DecrRefCount(obj); + } + } + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); if (hPtr == NULL) { continue; @@ -1220,7 +1324,7 @@ FindPackage( void TclFreePackageInfo( - Interp *iPtr) /* Interpereter that is being deleted. */ + Interp *iPtr) /* Interpreter that is being deleted. */ { Package *pkgPtr; Tcl_HashSearch search; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 4fb1f9e..7c363b9 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1416,11 +1416,12 @@ const TclStubs tclStubs = { Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ - Tcl_FreeIntRep, /* 631 */ - Tcl_InitStringRep, /* 632 */ - Tcl_FetchIntRep, /* 633 */ - Tcl_StoreIntRep, /* 634 */ - Tcl_HasStringRep, /* 635 */ + Tcl_OpenTcpServerEx, /* 631 */ + Tcl_FreeIntRep, /* 632 */ + Tcl_InitStringRep, /* 633 */ + Tcl_FetchIntRep, /* 634 */ + Tcl_StoreIntRep, /* 635 */ + Tcl_HasStringRep, /* 636 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index ef0a4d5..7575b43 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -90,7 +90,7 @@ static Tcl_Trace cmdTrace; * TestdelCmd: */ -typedef struct DelCmd { +typedef struct { Tcl_Interp *interp; /* Interpreter in which command exists. */ char *deleteCmd; /* Script to execute when command is deleted. * Malloc'ed. */ @@ -101,7 +101,7 @@ typedef struct DelCmd { * command. */ -typedef struct TclEncoding { +typedef struct { Tcl_Interp *interp; char *toUtfCmd; char *fromUtfCmd; @@ -124,7 +124,7 @@ static int exitMainLoop = 0; * Event structure used in testing the event queue management procedures. */ -typedef struct TestEvent { +typedef struct { Tcl_Event header; /* Header common to all events */ Tcl_Interp *interp; /* Interpreter that will handle the event */ Tcl_Obj *command; /* Command to evaluate when the event occurs */ @@ -823,7 +823,7 @@ TestasyncCmd( if (argc < 2) { wrongNumArgs: - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { @@ -913,7 +913,7 @@ TestasyncCmd( if (Tcl_CreateThread(&threadID, AsyncThreadProc, INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { - Tcl_SetResult(interp, "can't create thread", TCL_STATIC); + Tcl_AppendResult(interp, "can't create thread", NULL); Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } @@ -1060,7 +1060,7 @@ TestcmdinfoCmd( Tcl_DStringResult(interp, &delString); } else if (strcmp(argv[1], "get") == 0) { if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { - Tcl_SetResult(interp, "??", TCL_STATIC); + Tcl_AppendResult(interp, "??", NULL); return TCL_OK; } if (info.proc == CmdProc1) { @@ -1187,7 +1187,7 @@ TestcmdtokenCmd( token = Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", NULL); sprintf(buf, "%p", (void *)token); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_AppendResult(interp, buf, NULL); } else if (strcmp(argv[1], "name") == 0) { Tcl_Obj *objPtr; @@ -1293,7 +1293,7 @@ TestcmdtraceCmd( result = Tcl_EvalEx(interp, argv[2], -1, 0); Tcl_DeleteTrace(interp, cmdTrace); if (!deleteCalled) { - Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC); + Tcl_AppendResult(interp, "Delete wasn't called", NULL); return TCL_ERROR; } else { return result; @@ -1593,7 +1593,7 @@ TestdelCmd( Tcl_Interp *slave; if (argc != 4) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } @@ -1798,7 +1798,7 @@ TestdstringCmd( if (argc < 2) { wrongNumArgs: - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } if (strcmp(argv[1], "append") == 0) { @@ -1834,9 +1834,9 @@ TestdstringCmd( goto wrongNumArgs; } if (strcmp(argv[2], "staticsmall") == 0) { - Tcl_SetResult(interp, "short", TCL_STATIC); + Tcl_AppendResult(interp, "short", NULL); } else if (strcmp(argv[2], "staticlarge") == 0) { - Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC); + Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL); } else if (strcmp(argv[2], "free") == 0) { char *s = ckalloc(100); strcpy(s, "This is a malloc-ed string"); @@ -1996,7 +1996,7 @@ EncodingToUtfProc( TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_EvalEx(encodingPtr->interp,encodingPtr->toUtfCmd,-1,TCL_EVAL_GLOBAL); + Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, -1, TCL_EVAL_GLOBAL); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { @@ -2028,7 +2028,7 @@ EncodingFromUtfProc( TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd,-1,TCL_EVAL_GLOBAL); + Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, -1, TCL_EVAL_GLOBAL); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { @@ -2436,7 +2436,7 @@ TestexprlongCmd( " expression\"", NULL); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2478,7 +2478,7 @@ TestexprlongobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprLongObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2521,7 +2521,7 @@ TestexprdoubleCmd( " expression\"", NULL); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprDouble(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2564,7 +2564,7 @@ TestexprdoubleobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; @@ -3406,7 +3406,7 @@ TestMathFunc2( resultPtr->type = TCL_WIDE_INT; resultPtr->wideValue = ((w0 > w1)? w0 : w1); } else { - Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + Tcl_SetResult(interp, (char *)"T3: wrong type for arg 2", TCL_STATIC); result = TCL_ERROR; } } else if (args[0].type == TCL_DOUBLE) { @@ -3428,7 +3428,7 @@ TestMathFunc2( resultPtr->type = TCL_DOUBLE; resultPtr->doubleValue = ((d0 > d1)? d0 : d1); } else { - Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + Tcl_SetResult(interp, (char *)"T3: wrong type for arg 2", TCL_STATIC); result = TCL_ERROR; } } else if (args[0].type == TCL_WIDE_INT) { @@ -3451,11 +3451,11 @@ TestMathFunc2( resultPtr->type = TCL_WIDE_INT; resultPtr->wideValue = ((w0 > w1)? w0 : w1); } else { - Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + Tcl_SetResult(interp, (char *)"T3: wrong type for arg 2", TCL_STATIC); result = TCL_ERROR; } } else { - Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC); + Tcl_SetResult(interp, (char *)"T3: wrong type for arg 1", TCL_STATIC); result = TCL_ERROR; } return result; @@ -3849,7 +3849,7 @@ TestprintObjCmd( Tcl_WideInt argv1 = 0; if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "format wideint"); + Tcl_WrongNumArgs(interp, 1, objv, "format wideint"); } if (objc > 1) { @@ -4486,7 +4486,7 @@ TestseterrorcodeCmd( const char **argv) /* Argument strings. */ { if (argc > 6) { - Tcl_SetResult(interp, "too many args", TCL_STATIC); + Tcl_AppendResult(interp, "too many args", NULL); return TCL_ERROR; } switch (argc) { @@ -5090,7 +5090,7 @@ TestsetCmd( const char *value; if (argc == 2) { - Tcl_SetResult(interp, "before get", TCL_STATIC); + Tcl_AppendResult(interp, "before get", NULL); value = Tcl_GetVar2(interp, argv[1], NULL, flags); if (value == NULL) { return TCL_ERROR; @@ -5098,7 +5098,7 @@ TestsetCmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 3) { - Tcl_SetResult(interp, "before set", TCL_STATIC); + Tcl_AppendResult(interp, "before set", NULL); value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -5122,7 +5122,7 @@ Testset2Cmd( const char *value; if (argc == 3) { - Tcl_SetResult(interp, "before get", TCL_STATIC); + Tcl_AppendResult(interp, "before get", NULL); value = Tcl_GetVar2(interp, argv[1], argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -5130,7 +5130,7 @@ Testset2Cmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 4) { - Tcl_SetResult(interp, "before set", TCL_STATIC); + Tcl_AppendResult(interp, "before set", NULL); value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags); if (value == NULL) { return TCL_ERROR; @@ -5200,7 +5200,7 @@ TestsaveresultCmd( objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: - Tcl_SetResult(interp, "small result", TCL_VOLATILE); + Tcl_AppendResult(interp, "small result", NULL); break; case RESULT_APPEND: Tcl_AppendResult(interp, "append result", NULL); @@ -5310,7 +5310,7 @@ TestmainthreadCmd( Tcl_SetObjResult(interp, idObj); return TCL_OK; } else { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } } @@ -6111,7 +6111,7 @@ TestWrongNumArgsObjCmd( * Don't use Tcl_WrongNumArgs here, as that is the function * we want to test! */ - Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } @@ -6128,7 +6128,7 @@ TestWrongNumArgsObjCmd( /* * Asked for more arguments than were given. */ - Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } @@ -6905,7 +6905,7 @@ TestgetintCmd( const char **argv) { if (argc < 2) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } else { int val, i, total=0; @@ -7423,7 +7423,7 @@ InterpCmdResolver( */ CallFrame *parentFramePtr = varFramePtr->callerPtr; - char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; + const char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) { resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); |