From ed80f025f6f87f144ee7b63931890efb4421ee78 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Nov 2016 10:06:18 +0000 Subject: This is patch.002 from ticket [0b9d3ba2ba3e1e3fc33c97d5a9fa7ef85d11a696|0b9d3ba2ba], as first start of tip-456 implementation --- generic/tclIOCmd.c | 15 ++++++++++++--- unix/tclUnixSock.c | 20 ++++++++++++++++++++ win/tclWinSock.c | 4 ++-- 3 files changed, 34 insertions(+), 5 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index de65da5..9dc8f07 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1485,12 +1485,12 @@ Tcl_SocketObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const socketOptions[] = { - "-async", "-myaddr", "-myport", "-server", NULL + "-async", "-myaddr", "-myport", "-server", "-reuseport", NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER, SKT_REUSEPORT }; - int optionIndex, a, server = 0, port, myport = 0, async = 0; + int optionIndex, a, server = 0, port, myport = 0, async = 0, reuseport = 0; const char *host, *myaddr = NULL; Tcl_Obj *script = NULL; Tcl_Channel chan; @@ -1557,6 +1557,9 @@ Tcl_SocketObjCmd( } script = objv[a]; break; + case SKT_REUSEPORT: + reuseport = 1; + break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } @@ -1600,6 +1603,12 @@ Tcl_SocketObjCmd( Tcl_IncrRefCount(script); acceptCallbackPtr->script = script; acceptCallbackPtr->interp = interp; + + /* Hint for Tcl_OpenTcpServer to set socket option REUSEPORT */ + if(reuseport) { + port |= (1 << 16); + } + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, acceptCallbackPtr); if (chan == NULL) { diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 170aea9..d8a33f9 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -113,6 +113,11 @@ struct TcpState { #define SOCKET_BUFSIZE 4096 +#ifdef SO_REUSEPORT +/* Bitmask to check if the setting of SO_REUSEPORT was requested by the caller. */ +#define USE_SOCK_REUSEPORT (1 << 16) +#endif + /* * Static routines for this file: */ @@ -1435,6 +1440,10 @@ Tcl_OpenTcpServer( char channelName[SOCK_CHAN_LENGTH]; const char *errorMsg = NULL; TcpFdList *fds = NULL, *newfds; +#ifdef SO_REUSEPORT + int reuseport = port & USE_SOCK_REUSEPORT; + CLEAR_BITS(port, USE_SOCK_REUSEPORT); +#endif /* * Try to record and return the most meaningful error message, i.e. the @@ -1512,6 +1521,17 @@ Tcl_OpenTcpServer( (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &reuseaddr, sizeof(reuseaddr)); +#ifdef SO_REUSEPORT + /* + * Set up to allows multiple sockets on the same host to bind to the same port. + * The flag can be switched on by setting the lowest bit above the valid maximum port (0xffff). + */ + if(reuseport) { + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, + (char *) &reuseport, sizeof(reuseport)); + } +#endif + /* * Make sure we use the same port number when opening two server * sockets for IPv4 and IPv6 on a random port. diff --git a/win/tclWinSock.c b/win/tclWinSock.c index ec881d2..af8dda1 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -2111,8 +2111,8 @@ Tcl_OpenTcpServer( /* * Bind to the specified port. Note that we must not call - * setsockopt with SO_REUSEADDR because Microsoft allows addresses - * to be reused even if they are still in use. + * setsockopt with SO_REUSEADDR or SO_REUSEPORT because Microsoft + * allows addresses and ports to be reused even if they are still in use. * * Bind should not be affected by the socket having already been * set into nonblocking mode. If there is trouble, this is one -- cgit v0.12 From 490b4bf1f8778fddb9814d30cdf2c4bd89d9581d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Nov 2016 11:21:00 +0000 Subject: Added stub entry for tip #456. Documentation and tests still missing. Doesn't conform to TIP yet. --- generic/tcl.decls | 11 +++++++++++ generic/tclDecls.h | 8 ++++++++ generic/tclIOCmd.c | 15 +++++---------- generic/tclIOSock.c | 24 ++++++++++++++++++++++++ generic/tclStubInit.c | 1 + unix/tclUnixSock.c | 14 ++++++-------- win/tclWinSock.c | 5 +++-- 7 files changed, 58 insertions(+), 20 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 574b49b..20c3f3e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2326,6 +2326,17 @@ declare 630 { # ----- BASELINE -- FOR -- 8.6.0 ----- # +# TIP #456 +declare 631 { + Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, int port, + const char *host, int flags, Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData) +} + +# ----- BASELINE -- FOR -- 8.7.0 ----- # + + + ############################################################################## # Define the platform specific public Tcl interface. These functions are only diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b022d3c..d1c1170 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1816,6 +1816,11 @@ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, EXTERN void Tcl_ZlibStreamSetCompressionDictionary( Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); +/* 631 */ +EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, int port, + const char *host, int flags, + Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2482,6 +2487,7 @@ 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 */ + Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, int port, const char *host, int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3774,6 +3780,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ +#define Tcl_OpenTcpServerEx \ + (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 9dc8f07..883c6b7 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1490,7 +1490,7 @@ Tcl_SocketObjCmd( enum socketOptions { SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER, SKT_REUSEPORT }; - int optionIndex, a, server = 0, port, myport = 0, async = 0, reuseport = 0; + int optionIndex, a, server = 0, port, myport = 0, async = 0, flags = 0; const char *host, *myaddr = NULL; Tcl_Obj *script = NULL; Tcl_Channel chan; @@ -1557,9 +1557,9 @@ Tcl_SocketObjCmd( } script = objv[a]; break; - case SKT_REUSEPORT: - reuseport = 1; - break; + case SKT_REUSEPORT: + flags |= 1; + break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } @@ -1604,12 +1604,7 @@ Tcl_SocketObjCmd( acceptCallbackPtr->script = script; acceptCallbackPtr->interp = interp; - /* Hint for Tcl_OpenTcpServer to set socket option REUSEPORT */ - if(reuseport) { - port |= (1 << 16); - } - - chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + chan = Tcl_OpenTcpServerEx(interp, port, host, flags, AcceptCallbackProc, acceptCallbackPtr); if (chan == NULL) { Tcl_DecrRefCount(script); diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 7ed751c..72a0b5a 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -283,6 +283,30 @@ TclCreateSocketAddress( } return 1; } + +/* + *---------------------------------------------------------------------- + * + * 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) +{ + return Tcl_OpenTcpServerEx(interp, port, host, 0, acceptProc, callbackData); +} + /* * Local Variables: diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2f1bb8b..23da6dc 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1416,6 +1416,7 @@ const TclStubs tclStubs = { Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ + Tcl_OpenTcpServerEx, /* 631 */ }; /* !END!: Do not edit above this line. */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index d8a33f9..6286b2f 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -115,7 +115,7 @@ struct TcpState { #ifdef SO_REUSEPORT /* Bitmask to check if the setting of SO_REUSEPORT was requested by the caller. */ -#define USE_SOCK_REUSEPORT (1 << 16) +#define USE_SOCK_REUSEPORT 1 #endif /* @@ -1410,7 +1410,7 @@ TclpMakeTcpClientChannelMode( /* *---------------------------------------------------------------------- * - * Tcl_OpenTcpServer -- + * Tcl_OpenTcpServerEx -- * * Opens a TCP server socket and creates a channel around it. * @@ -1425,10 +1425,11 @@ TclpMakeTcpClientChannelMode( */ Tcl_Channel -Tcl_OpenTcpServer( +Tcl_OpenTcpServerEx( Tcl_Interp *interp, /* For error reporting - may be NULL. */ int port, /* Port number to open. */ const char *myHost, /* Name of local host. */ + int flags, /* Flags. */ Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ @@ -1440,10 +1441,6 @@ Tcl_OpenTcpServer( char channelName[SOCK_CHAN_LENGTH]; const char *errorMsg = NULL; TcpFdList *fds = NULL, *newfds; -#ifdef SO_REUSEPORT - int reuseport = port & USE_SOCK_REUSEPORT; - CLEAR_BITS(port, USE_SOCK_REUSEPORT); -#endif /* * Try to record and return the most meaningful error message, i.e. the @@ -1526,7 +1523,8 @@ Tcl_OpenTcpServer( * Set up to allows multiple sockets on the same host to bind to the same port. * The flag can be switched on by setting the lowest bit above the valid maximum port (0xffff). */ - if(reuseport) { + if (flags & USE_SOCK_REUSEPORT) { + int reuseport = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, (char *) &reuseport, sizeof(reuseport)); } diff --git a/win/tclWinSock.c b/win/tclWinSock.c index af8dda1..a389d45 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -2020,7 +2020,7 @@ Tcl_MakeTcpClientChannel( /* *---------------------------------------------------------------------- * - * Tcl_OpenTcpServer -- + * Tcl_OpenTcpServerEx -- * * Opens a TCP server socket and creates a channel around it. * @@ -2035,10 +2035,11 @@ Tcl_MakeTcpClientChannel( */ Tcl_Channel -Tcl_OpenTcpServer( +Tcl_OpenTcpServerEx( Tcl_Interp *interp, /* For error reporting - may be NULL. */ int port, /* Port number to open. */ const char *myHost, /* Name of local host. */ + int flags, /* Flags (not used) */ Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ -- cgit v0.12 From 33ded984ff02df26e0faf1d254abd2ea6acc0070 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Nov 2016 11:24:48 +0000 Subject: Fix indenting --- unix/tclUnixSock.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 6286b2f..4767522 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1519,15 +1519,15 @@ Tcl_OpenTcpServerEx( (char *) &reuseaddr, sizeof(reuseaddr)); #ifdef SO_REUSEPORT - /* - * Set up to allows multiple sockets on the same host to bind to the same port. - * The flag can be switched on by setting the lowest bit above the valid maximum port (0xffff). - */ - if (flags & USE_SOCK_REUSEPORT) { + /* + * Set up to allows multiple sockets on the same host to bind to the same port. + * The flag can be switched on by setting the lowest bit above the valid maximum port (0xffff). + */ + if (flags & USE_SOCK_REUSEPORT) { int reuseport = 1; - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, - (char *) &reuseport, sizeof(reuseport)); - } + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, + (char *) &reuseport, sizeof(reuseport)); + } #endif /* -- cgit v0.12 From 5b33616e5080b53d8b1e8b8608a98d824a952ee9 Mon Sep 17 00:00:00 2001 From: limeboy Date: Thu, 24 Nov 2016 12:47:21 +0000 Subject: Implement the whole TIP 456 specification. Also introduces the `-reuseaddr' and `-reuseport' options for the `socket' command. --- generic/tcl.decls | 2 +- generic/tcl.h | 7 +++++++ generic/tclDecls.h | 4 ++-- generic/tclIOCmd.c | 23 ++++++++++++++++++----- generic/tclIOSock.c | 6 +++--- unix/tclUnixSock.c | 41 ++++++++++++++++++++--------------------- win/tclWinSock.c | 2 +- 7 files changed, 52 insertions(+), 33 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 20c3f3e..af496b3 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2329,7 +2329,7 @@ declare 630 { # TIP #456 declare 631 { Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, int port, - const char *host, int flags, Tcl_TcpAcceptProc *acceptProc, + const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData) } diff --git a/generic/tcl.h b/generic/tcl.h index eb53c70..75a947a 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2371,6 +2371,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/tclDecls.h b/generic/tclDecls.h index d1c1170..4810c51 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1818,7 +1818,7 @@ EXTERN void Tcl_ZlibStreamSetCompressionDictionary( Tcl_Obj *compressionDictionaryObj); /* 631 */ EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, int port, - const char *host, int flags, + const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); @@ -2487,7 +2487,7 @@ 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 */ - Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, int port, const char *host, int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */ + Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, int port, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */ } TclStubs; extern const TclStubs *tclStubsPtr; diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 883c6b7..b4696fd 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1485,12 +1485,15 @@ Tcl_SocketObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const socketOptions[] = { - "-async", "-myaddr", "-myport", "-server", "-reuseport", NULL + "-async", "-myaddr", "-myport", "-server", "-reuseaddr", "-reuseport", + NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER, SKT_REUSEPORT + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER, SKT_REUSEADDR, + SKT_REUSEPORT }; - int optionIndex, a, server = 0, port, myport = 0, async = 0, flags = 0; + int optionIndex, a, server = 0, port, myport = 0, async = 0; + unsigned int flags = 0; const char *host, *myaddr = NULL; Tcl_Obj *script = NULL; Tcl_Channel chan; @@ -1557,8 +1560,11 @@ Tcl_SocketObjCmd( } script = objv[a]; break; + case SKT_REUSEADDR: + flags |= TCL_TCPSERVER_REUSEADDR; + break; case SKT_REUSEPORT: - flags |= 1; + flags |= TCL_TCPSERVER_REUSEPORT; break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); @@ -1583,7 +1589,14 @@ 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? ?-reuseport? ?-myaddr addr? port"); + return TCL_ERROR; + } + + if (!server && flags != 0) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "options -reuseaddr and -reuseport are only valid for servers", + -1)); return TCL_ERROR; } diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 72a0b5a..b6e99ba 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -283,7 +283,7 @@ TclCreateSocketAddress( } return 1; } - + /* *---------------------------------------------------------------------- * @@ -304,9 +304,9 @@ Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData) { - return Tcl_OpenTcpServerEx(interp, port, host, 0, acceptProc, callbackData); + return Tcl_OpenTcpServerEx(interp, port, host, TCL_TCPSERVER_REUSEADDR, + acceptProc, callbackData); } - /* * Local Variables: diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 4767522..bb75ed3 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -113,11 +113,6 @@ struct TcpState { #define SOCKET_BUFSIZE 4096 -#ifdef SO_REUSEPORT -/* Bitmask to check if the setting of SO_REUSEPORT was requested by the caller. */ -#define USE_SOCK_REUSEPORT 1 -#endif - /* * Static routines for this file: */ @@ -1429,13 +1424,13 @@ Tcl_OpenTcpServerEx( Tcl_Interp *interp, /* For error reporting - may be NULL. */ int port, /* Port number to open. */ const char *myHost, /* Name of local host. */ - int flags, /* Flags. */ + unsigned int flags, /* Flags. */ Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ ClientData acceptProcData) /* Data for the callback. */ { - int status = 0, sock = -1, reuseaddr = 1, chosenport; + int status = 0, sock = -1, optvalue, chosenport; struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */ TcpState *statePtr = NULL; char channelName[SOCK_CHAN_LENGTH]; @@ -1511,24 +1506,28 @@ Tcl_OpenTcpServerEx( TclSockMinimumBuffers(INT2PTR(sock), SOCKET_BUFSIZE); /* - * Set up to reuse server addresses automatically and bind to the - * specified port. + * Set up to reuse server addresses and/or ports if requested. */ - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, - (char *) &reuseaddr, sizeof(reuseaddr)); - -#ifdef SO_REUSEPORT - /* - * Set up to allows multiple sockets on the same host to bind to the same port. - * The flag can be switched on by setting the lowest bit above the valid maximum port (0xffff). - */ - if (flags & USE_SOCK_REUSEPORT) { - int reuseport = 1; - (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, - (char *) &reuseport, sizeof(reuseport)); + if (flags & TCL_TCPSERVER_REUSEADDR) { + optvalue = 1; + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, + (char *) &optvalue, sizeof(optvalue)); } + + if (flags & TCL_TCPSERVER_REUSEPORT) { +#ifndef SO_REUSEPORT + /* + * If the platform doesn't support the SO_REUSEPORT flag we can't do + * much beside erroring out. + */ + errorMsg = "SO_REUSEPORT isn't supported by this platform"; + goto error; #endif + optvalue = 1; + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, + (char *) &optvalue, sizeof(optvalue)); + } /* * Make sure we use the same port number when opening two server diff --git a/win/tclWinSock.c b/win/tclWinSock.c index a389d45..b228730 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -2039,7 +2039,7 @@ Tcl_OpenTcpServerEx( Tcl_Interp *interp, /* For error reporting - may be NULL. */ int port, /* Port number to open. */ const char *myHost, /* Name of local host. */ - int flags, /* Flags (not used) */ + unsigned int flags, /* Flags (not used) */ Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ -- cgit v0.12 From a3a4e02afa38968088c4f32a658ddb26391bc117 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Nov 2016 13:18:10 +0000 Subject: Fix compile error if SO_REUSEPORT not supported. Put command options in alphabetical order --- generic/tclIOCmd.c | 6 +++--- unix/tclUnixSock.c | 3 ++- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index b4696fd..930f5a3 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1485,12 +1485,12 @@ Tcl_SocketObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const socketOptions[] = { - "-async", "-myaddr", "-myport", "-server", "-reuseaddr", "-reuseport", + "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server", NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER, SKT_REUSEADDR, - SKT_REUSEPORT + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, + SKT_SERVER }; int optionIndex, a, server = 0, port, myport = 0, async = 0; unsigned int flags = 0; diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index bb75ed3..187c157 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1523,10 +1523,11 @@ Tcl_OpenTcpServerEx( */ errorMsg = "SO_REUSEPORT isn't supported by this platform"; goto error; -#endif +#else optvalue = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, (char *) &optvalue, sizeof(optvalue)); +#endif } /* -- cgit v0.12 From ef3c261b6dcd49b4bae9b133b7d402090863ddc9 Mon Sep 17 00:00:00 2001 From: limeboy Date: Thu, 24 Nov 2016 15:00:36 +0000 Subject: Adjust the tests and add a handful of new ones. --- tests/socket.test | 31 +++++++++++++++++++++++++------ 1 file changed, 25 insertions(+), 6 deletions(-) diff --git a/tests/socket.test b/tests/socket.test index d43c41c..82dc800 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -265,13 +265,13 @@ test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket s } -returnCodes error -result {no argument given for -server option} test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr? ?-reuseport? ?-myaddr addr? port"} test socket_$af-1.3 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr } -returnCodes error -result {no argument given for -myaddr option} test socket_$af-1.4 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr $localhost -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr? ?-reuseport? ?-myaddr addr? port"} test socket_$af-1.5 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport } -returnCodes error -result {no argument given for -myport option} @@ -280,19 +280,19 @@ test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket s } -returnCodes error -result {expected integer but got "xxxx"} test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport 2522 -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr? ?-reuseport? ?-myaddr addr? port"} test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -froboz -} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, or -server} +} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, -server, -reuseaddr, or -reuseport} test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -myport 2521 3333 } -returnCodes error -result {option -myport is not valid for servers} test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket host 2528 -junk -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr? ?-reuseport? ?-myaddr addr? port"} test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server callback 2520 -- -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr? ?-reuseport? ?-myaddr addr? port"} test socket_$af-1.12 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket foo badport } -returnCodes error -result {expected integer but got "badport"} @@ -302,6 +302,12 @@ test socket_$af-1.13 {arg parsing for socket command} -constraints [list socket test socket_$af-1.14 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -async } -returnCodes error -result {cannot set -async option for server sockets} +test socket_$af-1.15 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseaddr 4242 +} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} +test socket_$af-1.16 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseport 4242 +} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} set path(script) [makeFile {} script] @@ -2360,6 +2366,19 @@ test socket-14.18 {bug c6ed4acfd8: running async socket connect made other conne catch {close $csock2} } -result {} +test socket-14.19 {tip 456 -- introduce the -reuseport option} \ + -constraints {socket} \ + -body { + proc accept {channel address port} {} + set port [randport] + set ssock1 [socket -server accept -reuseport $port] + set ssock2 [socket -server accept -reuseport $port] + return ok +} -cleanup { + catch {close $ssock1} + catch {close $ssock2} + } -result ok + set num 0 set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}} -- cgit v0.12 From db2389176bddb30734048a790ac9e6c6f2ec5d45 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Nov 2016 16:20:05 +0000 Subject: Starting implementing the "package files" command. TIP still to be written. --- generic/tclInt.h | 1 + generic/tclLoad.c | 8 ++++- generic/tclPkg.c | 92 ++++++++++++++++++++++++++++++++++++++++++++++++------ tests/package.test | 2 +- 4 files changed, 92 insertions(+), 11 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 4257ea1..bfcd002 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3100,6 +3100,7 @@ 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 Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_PathPart portion); MODULE_SCOPE char * TclpReadlink(const char *fileName, diff --git a/generic/tclLoad.c b/generic/tclLoad.c index be296b3..184c158 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -397,6 +397,12 @@ Tcl_LoadObjCmd( goto done; } + if (target == interp) { + /* Only register the file if the load is done in the + * current interpreter */ + TclPkgFileSeen(target, Tcl_GetString(objv[1])); + } + /* * Create a new record to describe this package. */ @@ -998,7 +1004,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. */ diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 244eb94..3d052a6 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. */ + 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,29 @@ Tcl_PkgProvideEx( *---------------------------------------------------------------------- */ +static void PkgFilesCleanupProc(ClientData clientData, + Tcl_Interp *interp) +{ + PkgFiles *pkgFiles = (PkgFiles *) clientData; + + while (pkgFiles->names) { + PkgName *name = pkgFiles->names; + pkgFiles->names = name->nextPtr; + ckfree(name); + } + Tcl_DeleteHashTable(&pkgFiles->table); + return; +} + +void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName) +{ + PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (pkgFiles) { + const char *name = pkgFiles->names->name; + printf("Seen %s for package %s\n", fileName, name); + } +} + #undef Tcl_PkgRequire const char * Tcl_PkgRequire( @@ -489,12 +523,31 @@ PkgRequireCore( */ char *versionToProvide = bestPtr->version; + PkgFiles *pkgFiles; + PkgName *pkgName; script = bestPtr->script; pkgPtr->clientData = versionToProvide; - Tcl_Preserve(script); Tcl_Preserve(versionToProvide); + Tcl_Preserve(script); + /* If assocdata "tclPkgFiles" doesn't exist yet, create it */ + 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); + } + /* 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*/ + pkgName = pkgFiles->names; + pkgFiles->names = pkgFiles->names->nextPtr; + ckfree(pkgName); Tcl_Release(script); pkgPtr = FindPackage(interp, name); @@ -764,14 +817,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,6 +847,27 @@ Tcl_PackageObjCmd( return TCL_ERROR; } switch ((enum pkgOptions) optionIndex) { + case PKG_FILES: { + const char *keyString; + Tcl_Obj *result = Tcl_NewObj(); + + for (i = 2; i < objc; i++) { + keyString = TclGetString(objv[i]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); + if (hPtr == NULL) { + continue; + } + pkgPtr = Tcl_GetHashValue(hPtr); + availPtr = pkgPtr->availPtr; + while (availPtr != NULL) { + Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(availPtr->script, -1)); + availPtr = availPtr->nextPtr; + } + ckfree(pkgPtr); + } + Tcl_SetObjResult(interp, result); + break; + } case PKG_FORGET: { const char *keyString; @@ -1220,7 +1294,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/tests/package.test b/tests/package.test index 49346d8..99f9f06 100644 --- a/tests/package.test +++ b/tests/package.test @@ -832,7 +832,7 @@ test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { } {0} test package-4.53 {Tcl_PackageCmd procedure, "versions" option} -body { package foo -} -returnCodes error -result {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} +} -returnCodes error -result {bad option "foo": must be files, forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} test package-4.54 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { package vsatisfies 2.1 2.1-3.2-4.5 } -returnCodes error -result {expected versionMin-versionMax but got "2.1-3.2-4.5"} -- cgit v0.12 From 994c07125e17358a895eddd8f573065b68d83d68 Mon Sep 17 00:00:00 2001 From: limeboy Date: Thu, 24 Nov 2016 20:28:42 +0000 Subject: First round of documentation update. --- doc/OpenTcp.3 | 13 ++++++++++++- doc/socket.n | 10 ++++++++++ 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/doc/OpenTcp.3 b/doc/OpenTcp.3 index 4a7dc1e..040a8e2 100644 --- a/doc/OpenTcp.3 +++ b/doc/OpenTcp.3 @@ -9,7 +9,7 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer \- procedures to open channels using TCP sockets +Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer, Tcl_OpenTcpServerEx \- procedures to open channels using TCP sockets .SH SYNOPSIS .nf \fB#include \fR @@ -23,6 +23,9 @@ Tcl_Channel Tcl_Channel \fBTcl_OpenTcpServer\fR(\fIinterp, port, myaddr, proc, clientData\fR) .sp +Tcl_Channel +\fBTcl_OpenTcpServerEx\fR(\fIinterp, port, myaddr, flags, proc, clientData\fR) +.sp .SH ARGUMENTS .AS Tcl_TcpAcceptProc clientData .AP Tcl_Interp *interp in @@ -41,6 +44,9 @@ for the local end of the connection. If NULL, a default interface is chosen. .AP int async in If nonzero, the client socket is connected asynchronously to the server. +.AP "unsigned int" flags in +ORed combination of \fBTCL_TCPSERVER\fR flags that specify additional +informations about the socket being created. .AP ClientData sock in Platform-specific handle for client TCP socket. .AP Tcl_TcpAcceptProc *proc in @@ -158,6 +164,11 @@ register it, use \fBTcl_RegisterChannel\fR. If one of the standard channels, \fBstdin\fR, \fBstdout\fR or \fBstderr\fR was previously closed, the act of creating the new channel also assigns it as a replacement for the standard channel. +.SS TCL_OPENTCPSERVEREX +.PP +\fBTcl_OpenTcpServerEx\fR behaviour is identical to \fBTcl_OpenTcpServer\fR but +gives more flexibility to the user by providing a mean to further customize some +aspects of the socket via the \fIflags\fR parameter. .SH "PLATFORM ISSUES" .PP On Unix platforms, the socket handle is a Unix file descriptor as diff --git a/doc/socket.n b/doc/socket.n index 3efdb37..3d77bab 100644 --- a/doc/socket.n +++ b/doc/socket.n @@ -131,6 +131,16 @@ wildcard address so that it can accept connections from any interface. If \fIaddr\fR is a domain name that resolves to multiple IP addresses that are available on the local machine, the socket will listen on all of them. +.TP +\fB\-reuseaddr\fI boolean\fR +. +Tells the kernel whether to reuse the local address if there's no active socket +listening on it. This is the default on Windows. +.TP +\fB\-reuseport\fI boolean\fR +. +Tells the kernel whether to allow the binding of multiple sockets to the same +socket address. This is the default on Windows. .PP Server channels cannot be used for input or output; their sole use is to accept new client connections. The channels created for each incoming -- cgit v0.12 From c7c008ed87d396afec9a6f9879a22660d6afa490 Mon Sep 17 00:00:00 2001 From: limeboy Date: Thu, 24 Nov 2016 21:01:43 +0000 Subject: Allow a boolean argument to be passed. --- generic/tclIOCmd.c | 42 +++++++++++++++++++++++++++++++++++------- tests/socket.test | 18 +++++++++--------- unix/tclUnixSock.c | 3 ++- 3 files changed, 46 insertions(+), 17 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index b4696fd..49c7c06 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1485,14 +1485,14 @@ Tcl_SocketObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const socketOptions[] = { - "-async", "-myaddr", "-myport", "-server", "-reuseaddr", "-reuseport", + "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "server", NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER, SKT_REUSEADDR, - SKT_REUSEPORT + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, + SKT_SERVER }; - int optionIndex, a, server = 0, port, myport = 0, async = 0; + int optionIndex, a, server = 0, port, myport = 0, async = 0, boolTmp; unsigned int flags = 0; const char *host, *myaddr = NULL; Tcl_Obj *script = NULL; @@ -1552,6 +1552,7 @@ Tcl_SocketObjCmd( return TCL_ERROR; } server = 1; + flags = TCL_TCPSERVER_REUSEADDR; a++; if (a >= objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -1561,10 +1562,36 @@ Tcl_SocketObjCmd( script = objv[a]; break; case SKT_REUSEADDR: - flags |= TCL_TCPSERVER_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], &boolTmp) != TCL_OK) { + return TCL_ERROR; + } + if (boolTmp) { + flags |= TCL_TCPSERVER_REUSEADDR; + } else { + flags &= ~TCL_TCPSERVER_REUSEADDR; + } break; case SKT_REUSEPORT: - flags |= TCL_TCPSERVER_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], &boolTmp) != TCL_OK) { + return TCL_ERROR; + } + if (boolTmp) { + flags |= TCL_TCPSERVER_REUSEPORT; + } else { + flags &= ~TCL_TCPSERVER_REUSEPORT; + } break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); @@ -1589,7 +1616,8 @@ Tcl_SocketObjCmd( "?-myaddr addr? ?-myport myport? ?-async? host port"); iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, - "-server command ?-reuseaddr? ?-reuseport? ?-myaddr addr? port"); + "-server command ?-reuseaddr boolean? ?-reuseport boolean? " + "?-myaddr addr? port"); return TCL_ERROR; } diff --git a/tests/socket.test b/tests/socket.test index 82dc800..387e08e 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -265,13 +265,13 @@ test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket s } -returnCodes error -result {no argument given for -server option} test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr? ?-reuseport? ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.3 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr } -returnCodes error -result {no argument given for -myaddr option} test socket_$af-1.4 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr $localhost -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr? ?-reuseport? ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.5 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport } -returnCodes error -result {no argument given for -myport option} @@ -280,7 +280,7 @@ test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket s } -returnCodes error -result {expected integer but got "xxxx"} test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport 2522 -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr? ?-reuseport? ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -froboz } -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, -server, -reuseaddr, or -reuseport} @@ -289,10 +289,10 @@ test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket s } -returnCodes error -result {option -myport is not valid for servers} test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket host 2528 -junk -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr? ?-reuseport? ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server callback 2520 -- -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr? ?-reuseport? ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.12 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket foo badport } -returnCodes error -result {expected integer but got "badport"} @@ -303,10 +303,10 @@ test socket_$af-1.14 {arg parsing for socket command} -constraints [list socket socket -server foo -async } -returnCodes error -result {cannot set -async option for server sockets} test socket_$af-1.15 {arg parsing for socket command} -constraints [list socket supported_$af] -body { - socket -reuseaddr 4242 + socket -reuseaddr yes 4242 } -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} test socket_$af-1.16 {arg parsing for socket command} -constraints [list socket supported_$af] -body { - socket -reuseport 4242 + socket -reuseport yes 4242 } -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} set path(script) [makeFile {} script] @@ -2371,8 +2371,8 @@ test socket-14.19 {tip 456 -- introduce the -reuseport option} \ -body { proc accept {channel address port} {} set port [randport] - set ssock1 [socket -server accept -reuseport $port] - set ssock2 [socket -server accept -reuseport $port] + set ssock1 [socket -server accept -reuseport yes $port] + set ssock2 [socket -server accept -reuseport yes $port] return ok } -cleanup { catch {close $ssock1} diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index bb75ed3..187c157 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1523,10 +1523,11 @@ Tcl_OpenTcpServerEx( */ errorMsg = "SO_REUSEPORT isn't supported by this platform"; goto error; -#endif +#else optvalue = 1; (void) setsockopt(sock, SOL_SOCKET, SO_REUSEPORT, (char *) &optvalue, sizeof(optvalue)); +#endif } /* -- cgit v0.12 From bb43812d0c072311a503fa53ef663342c3eed4c1 Mon Sep 17 00:00:00 2001 From: limeboy Date: Fri, 25 Nov 2016 13:27:56 +0000 Subject: Minor documentation touchups. --- doc/socket.n | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/socket.n b/doc/socket.n index 3d77bab..532ea2e 100644 --- a/doc/socket.n +++ b/doc/socket.n @@ -134,13 +134,13 @@ listen on all of them. .TP \fB\-reuseaddr\fI boolean\fR . -Tells the kernel whether to reuse the local address if there's no active socket -listening on it. This is the default on Windows. +Tells the kernel whether to reuse the local address if there is no socket +actively listening on it. This is the default on Windows. .TP \fB\-reuseport\fI boolean\fR . Tells the kernel whether to allow the binding of multiple sockets to the same -socket address. This is the default on Windows. +address and port as long as all of them specify the \fB-reuseport\fR option. .PP Server channels cannot be used for input or output; their sole use is to accept new client connections. The channels created for each incoming -- cgit v0.12 From 644cb60988ea393b62e1e6fc23588ef660c8272d Mon Sep 17 00:00:00 2001 From: limeboy Date: Fri, 25 Nov 2016 14:53:20 +0000 Subject: Windows support and minor touchups to the documentation. --- doc/socket.n | 2 +- win/tclWinSock.c | 17 +++++++++++++---- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/doc/socket.n b/doc/socket.n index 532ea2e..823dbd5 100644 --- a/doc/socket.n +++ b/doc/socket.n @@ -140,7 +140,7 @@ actively listening on it. This is the default on Windows. \fB\-reuseport\fI boolean\fR . Tells the kernel whether to allow the binding of multiple sockets to the same -address and port as long as all of them specify the \fB-reuseport\fR option. +address and port. .PP Server channels cannot be used for input or output; their sole use is to accept new client connections. The channels created for each incoming diff --git a/win/tclWinSock.c b/win/tclWinSock.c index b228730..af22cf8 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -2039,7 +2039,7 @@ Tcl_OpenTcpServerEx( Tcl_Interp *interp, /* For error reporting - may be NULL. */ int port, /* Port number to open. */ const char *myHost, /* Name of local host. */ - unsigned int flags, /* Flags (not used) */ + unsigned int flags, /* Flags. */ Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ @@ -2053,6 +2053,7 @@ Tcl_OpenTcpServerEx( char channelName[SOCK_CHAN_LENGTH]; u_long flag = 1; /* Indicates nonblocking mode. */ const char *errorMsg = NULL; + int optvalue; if (TclpHasSockets(interp) != TCL_OK) { return NULL; @@ -2111,9 +2112,17 @@ Tcl_OpenTcpServerEx( } /* - * Bind to the specified port. Note that we must not call - * setsockopt with SO_REUSEADDR or SO_REUSEPORT because Microsoft - * allows addresses and ports to be reused even if they are still in use. + * The SO_REUSEADDR option on Windows behaves like SO_REUSEPORT on unix + * systems. + */ + if (flags & TCL_TCPSERVER_REUSEPORT) { + optvalue = 1; + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, + (char *) &optvalue, sizeof(optvalue)); + } + + /* + * Bind to the specified port. * * Bind should not be affected by the socket having already been * set into nonblocking mode. If there is trouble, this is one -- cgit v0.12 From fabd3e7dc8882faee98b35feb738939c197e23b5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 26 Nov 2016 17:47:27 +0000 Subject: Add "package files" testcase, which doesn give the right answer. So still work to do --- tests/load.test | 4 ++-- tests/package.test | 12 ++++++++++-- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/tests/load.test b/tests/load.test index 7c4b47f..94451e9 100644 --- a/tests/load.test +++ b/tests/load.test @@ -197,14 +197,14 @@ test load-8.2 {TclGetLoadedPackages procedure} -body { } -returnCodes error -result {could not find interpreter "gorp"} test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] { lsort -index 1 [info loaded {}] -} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkge$ext] Pkge] {*}$alreadyLoaded]] test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] { lsort -index 1 [info loaded child] } [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] { load [file join $testDir pkgb$ext] pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] -} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] +} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkge$ext] Pkge] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \ diff --git a/tests/package.test b/tests/package.test index 99f9f06..7e8a42d 100644 --- a/tests/package.test +++ b/tests/package.test @@ -55,8 +55,8 @@ test package-1.7 {pkg::create gives correct output for 1 direct source} { ::pkg::create -name foo -version 1.0 -source test.tcl } {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]} test package-1.8 {pkg::create gives correct output for 2 direct sources} { - ::pkg::create -name foo -version 1.0 -source test.tcl -source test2.tcl -} {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]\n[list source [file join $dir test2.tcl]]} + list [::pkg::create -name foo -version 1.0 -source test.tcl -source test2.tcl] [package files foo] +} {{package ifneeded foo 1.0 [list source [file join $dir test.tcl]]\n[list source [file join $dir test2.tcl]]} {}} test package-1.9 {pkg::create gives correct output for 1 direct load} { ::pkg::create -name foo -version 1.0 -load test.so } {package ifneeded foo 1.0 [list load [file join $dir test.so]]} @@ -870,6 +870,14 @@ test package-5.2 {TclFreePackageInfo procedure} -body { } foo eval package require x 3.1 } -returnCodes error -match glob -result * +test package-5.3 {package files} -body { + interp create foo + foo eval { + package ifneeded t 2.4 {package provide t 2.4;package require http} + } + foo eval package require t 2.4 + foo eval {list [package files http] [package files t]} +} -result "[list {}] [file join $tcl_library http http.tcl]" test package-6.1 {CheckVersion procedure} { package vcompare 1 2.1 -- cgit v0.12 From e506fbc42c805d0a6dfe2982a6169a0397aeddad Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Nov 2016 13:17:47 +0000 Subject: Complete implementation, tests and documentation --- doc/info.n | 7 +-- doc/package.n | 8 ++++ generic/tclCmdMZ.c | 27 ++++++++++- generic/tclInt.h | 1 + generic/tclInterp.c | 19 +++++++- generic/tclPkg.c | 24 ++++++---- library/init.tcl | 2 +- library/package.tcl | 2 +- library/tclIndex | 134 ++++++++++++++++++++++++++-------------------------- tests/package.test | 2 +- 10 files changed, 140 insertions(+), 86 deletions(-) diff --git a/doc/info.n b/doc/info.n index 477e272..01ca10b 100644 --- a/doc/info.n +++ b/doc/info.n @@ -297,10 +297,11 @@ scripts are stored. This is actually the value of the \fBtcl_library\fR variable and may be changed by setting \fBtcl_library\fR. .TP -\fBinfo loaded \fR?\fIinterp\fR? +\fBinfo loaded \fR?\fIinterp\fR? \fR?\fIpackage\fR? . -Returns a list describing all of the packages that have been loaded into -\fIinterp\fR with the \fBload\fR command. +Returns the filename loaded as part of \fIpackage\fR. If \fIpackage\fR +is not specified, returns a list describing all of the packages +that have been loaded into \fIinterp\fR with the \fBload\fR command. Each list element is a sub-list with two elements consisting of the name of the file from which the package was loaded and the name of the package. diff --git a/doc/package.n b/doc/package.n index 47b2aa6..5687480 100644 --- a/doc/package.n +++ b/doc/package.n @@ -12,6 +12,7 @@ package \- Facilities for package loading and version control .SH SYNOPSIS .nf +\fBpackage files\fR \fIpackage\fR \fBpackage forget\fR ?\fIpackage package ...\fR? \fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR? \fBpackage names\fR @@ -43,6 +44,13 @@ primarily by system scripts that maintain the package database. The behavior of the \fBpackage\fR command is determined by its first argument. The following forms are permitted: .TP +\fBpackage files\fR \fIpackage\fR +. +Lists all files forming part of \fIpackage\fR. Auto-loaded files are not +included in this list, only files which were directly sourced during package +initialization. The list order corresponds with the order in which the +files were sourced. +.TP \fBpackage forget\fR ?\fIpackage package ...\fR? . Removes all information about each specified package from this interpreter, diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index ed3d9a5..7f2a2f3 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -989,8 +989,11 @@ TclNRSourceObjCmd( { const char *encodingName = NULL; Tcl_Obj *fileName; + int result; + void **pkgFiles = NULL; + void *names = NULL; - if (objc != 2 && objc !=4) { + if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } @@ -1008,8 +1011,28 @@ TclNRSourceObjCmd( return TCL_ERROR; } encodingName = TclGetString(objv[2]); + } else if (objc == 3) { + static const char *const nopkgoptions[] = { + "-nopkg", NULL + }; + int index; + + if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions, + "option", TCL_EXACT, &index)) { + return TCL_ERROR; + } + pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + /* Make sure that during the following TclNREvalFile no filenames + * are recorded for inclusion in the "package files" command */ + names = *pkgFiles; + *pkgFiles = NULL; } - return TclNREvalFile(interp, fileName, encodingName); + result = TclNREvalFile(interp, fileName, encodingName); + if (pkgFiles) { + /* restore "tclPkgFiles" assocdata to how it was. */ + *pkgFiles = names; + } + return result; } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index bfcd002..9422a03 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3101,6 +3101,7 @@ 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 1bfe76a..7874de9 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" @@ -445,6 +456,10 @@ Tcl_Init( " }\n" "}\n" "tclInit", -1, 0); + +end: + *names = (*names)->nextPtr; + return result; } /* diff --git a/generic/tclPkg.c b/generic/tclPkg.c index c258987..c3cc54e 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -38,7 +38,7 @@ typedef struct PkgName { } PkgName; typedef struct PkgFiles { - PkgName *names; /* Package names being initialized. */ + PkgName *names; /* Package names being initialized. Must be first field*/ Tcl_HashTable table; /* Table which contains files for each package */ } PkgFiles; @@ -222,6 +222,19 @@ static void PkgFilesCleanupProc(ClientData clientData, 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); @@ -549,14 +562,7 @@ PkgRequireCore( pkgPtr->clientData = versionToProvide; Tcl_Preserve(versionToProvide); Tcl_Preserve(script); - /* If assocdata "tclPkgFiles" doesn't exist yet, create it */ - 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); - } + pkgFiles = TclInitPkgFiles(interp); /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ pkgName = ckalloc(sizeof(PkgName) + strlen(name)); pkgName->nextPtr = pkgFiles->names; diff --git a/library/init.tcl b/library/init.tcl index 544ea77..bac6270 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -483,7 +483,7 @@ proc auto_load_index {} { set dir [lindex $auto_path $i] set f "" if {$issafe} { - catch {source [file join $dir tclIndex]} + catch {source -nopkg [file join $dir tclIndex]} } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { continue } else { diff --git a/library/package.tcl b/library/package.tcl index 44e3b28..cb1bea6 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -488,7 +488,7 @@ proc tclPkgUnknown {name args} { set dir [file dirname $file] if {![info exists procdDirs($dir)]} { try { - source $file + source -nopkg $file } trap {POSIX EACCES} {} { # $file was not readable; silently ignore continue diff --git a/library/tclIndex b/library/tclIndex index 26603c1..2762ce4 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -1,75 +1,75 @@ # Tcl autoload index file, version 2.0 # -*- tcl -*- # This file is generated by the "auto_mkindex" command -# and sourced to set up indexing information for one or +# and source -nopkgd to set up indexing information for one or # more commands. Typically each line is a command that # sets an element in the auto_index array, where the # element name is the name of a command and the value is # a script that loads the command. -set auto_index(auto_reset) [list source [file join $dir auto.tcl]] -set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]] -set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]] -set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]] -set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]] -set auto_index(history) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistClear) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistInfo) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]] -set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]] -set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]] -set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]] -set auto_index(::tcl::MacOSXPkgUnknown) [list source [file join $dir package.tcl]] -set auto_index(::pkg::create) [list source [file join $dir package.tcl]] -set auto_index(parray) [list source [file join $dir parray.tcl]] -set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]] -set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]] -set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]] -set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]] -set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]] -set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]] -set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]] -set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]] -set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]] -set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]] -set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]] -set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]] -set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]] -set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::Log) [list source [file join $dir safe.tcl]] -set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]] -set auto_index(::safe::AliasGlob) [list source [file join $dir safe.tcl]] -set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]] -set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]] -set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::DirInAccessPath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]] -set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]] -set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]] -set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]] -set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]] -set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]] -set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]] -set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]] -set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::Defaults) [list source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::path) [list source [file join $dir tm.tcl]] +set auto_index(auto_reset) [list source -nopkg [file join $dir auto.tcl]] +set auto_index(tcl_findLibrary) [list source -nopkg [file join $dir auto.tcl]] +set auto_index(auto_mkindex) [list source -nopkg [file join $dir auto.tcl]] +set auto_index(auto_mkindex_old) [list source -nopkg [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::init) [list source -nopkg [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::cleanup) [list source -nopkg [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::mkindex) [list source -nopkg [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::hook) [list source -nopkg [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::slavehook) [list source -nopkg [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::command) [list source -nopkg [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::commandInit) [list source -nopkg [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::fullname) [list source -nopkg [file join $dir auto.tcl]] +set auto_index(history) [list source -nopkg [file join $dir history.tcl]] +set auto_index(::tcl::HistAdd) [list source -nopkg [file join $dir history.tcl]] +set auto_index(::tcl::HistKeep) [list source -nopkg [file join $dir history.tcl]] +set auto_index(::tcl::HistClear) [list source -nopkg [file join $dir history.tcl]] +set auto_index(::tcl::HistInfo) [list source -nopkg [file join $dir history.tcl]] +set auto_index(::tcl::HistRedo) [list source -nopkg [file join $dir history.tcl]] +set auto_index(::tcl::HistIndex) [list source -nopkg [file join $dir history.tcl]] +set auto_index(::tcl::HistEvent) [list source -nopkg [file join $dir history.tcl]] +set auto_index(::tcl::HistChange) [list source -nopkg [file join $dir history.tcl]] +set auto_index(pkg_mkIndex) [list source -nopkg [file join $dir package.tcl]] +set auto_index(tclPkgSetup) [list source -nopkg [file join $dir package.tcl]] +set auto_index(tclPkgUnknown) [list source -nopkg [file join $dir package.tcl]] +set auto_index(::tcl::MacOSXPkgUnknown) [list source -nopkg [file join $dir package.tcl]] +set auto_index(::pkg::create) [list source -nopkg [file join $dir package.tcl]] +set auto_index(parray) [list source -nopkg [file join $dir parray.tcl]] +set auto_index(::safe::InterpStatics) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::InterpNested) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::interpCreate) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::interpInit) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::CheckInterp) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::interpConfigure) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::InterpCreate) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::InterpSetConfig) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::interpFindInAccessPath) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::interpAddToAccessPath) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::InterpInit) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::AddSubDirs) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::interpDelete) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::setLogCmd) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::SyncAccessPath) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::PathToken) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::TranslatePath) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::Log) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::CheckFileName) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::AliasGlob) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::AliasSource) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::AliasLoad) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::FileInAccessPath) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::DirInAccessPath) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::Subset) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::AliasSubset) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(::safe::AliasEncoding) [list source -nopkg [file join $dir safe.tcl]] +set auto_index(tcl_wordBreakAfter) [list source -nopkg [file join $dir word.tcl]] +set auto_index(tcl_wordBreakBefore) [list source -nopkg [file join $dir word.tcl]] +set auto_index(tcl_endOfWord) [list source -nopkg [file join $dir word.tcl]] +set auto_index(tcl_startOfNextWord) [list source -nopkg [file join $dir word.tcl]] +set auto_index(tcl_startOfPreviousWord) [list source -nopkg [file join $dir word.tcl]] +set auto_index(::tcl::tm::add) [list source -nopkg [file join $dir tm.tcl]] +set auto_index(::tcl::tm::remove) [list source -nopkg [file join $dir tm.tcl]] +set auto_index(::tcl::tm::list) [list source -nopkg [file join $dir tm.tcl]] +set auto_index(::tcl::tm::Defaults) [list source -nopkg [file join $dir tm.tcl]] +set auto_index(::tcl::tm::UnknownHandler) [list source -nopkg [file join $dir tm.tcl]] +set auto_index(::tcl::tm::roots) [list source -nopkg [file join $dir tm.tcl]] +set auto_index(::tcl::tm::path) [list source -nopkg [file join $dir tm.tcl]] diff --git a/tests/package.test b/tests/package.test index 7e8a42d..55bba8a 100644 --- a/tests/package.test +++ b/tests/package.test @@ -877,7 +877,7 @@ test package-5.3 {package files} -body { } foo eval package require t 2.4 foo eval {list [package files http] [package files t]} -} -result "[list {}] [file join $tcl_library http http.tcl]" +} -result {{} {}} test package-6.1 {CheckVersion procedure} { package vcompare 1 2.1 -- cgit v0.12 From 5f5b7e42b2337f1fc7e33bccf2bcd8155fe968bc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Nov 2016 15:29:36 +0000 Subject: slightly simpler --- generic/tclPkg.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index c3cc54e..c8f418c 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -570,8 +570,7 @@ PkgRequireCore( pkgFiles->names = pkgName; code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ - pkgName = pkgFiles->names; - pkgFiles->names = pkgFiles->names->nextPtr; + pkgFiles->names = pkgName->nextPtr; ckfree(pkgName); Tcl_Release(script); -- cgit v0.12 From 99d3d95f4b8ae074c1c23d5599e32d976a6cb529 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Nov 2016 09:45:20 +0000 Subject: Implement the "package forget" part, which was still missing. Handle the case that a filename contains spaces. --- generic/tclPkg.c | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index c8f418c..42dd08d 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -243,15 +243,16 @@ void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName) Tcl_HashTable *table = &pkgFiles->table; int new; Tcl_HashEntry *entry = Tcl_CreateHashEntry(table, name, &new); - Tcl_Obj *obj = Tcl_NewStringObj(fileName, -1); + Tcl_Obj *list; if (new) { - Tcl_SetHashValue(entry, obj); - Tcl_IncrRefCount(obj); + list = Tcl_NewObj(); + Tcl_SetHashValue(entry, list); + Tcl_IncrRefCount(list); } else { - Tcl_Obj *list = Tcl_GetHashValue(entry); - Tcl_ListObjAppendElement(interp, list, obj); + list = Tcl_GetHashValue(entry); } + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1)); } } @@ -889,9 +890,19 @@ Tcl_PackageObjCmd( } 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; -- cgit v0.12 From fdc5267c5f6488e6f8065453fc078e0ebc45d861 Mon Sep 17 00:00:00 2001 From: limeboy Date: Wed, 14 Dec 2016 15:49:27 +0000 Subject: Make OpenTcpServerEx accept a 'service' string parameter instead of a port. --- generic/tcl.decls | 2 +- generic/tclDecls.h | 7 ++++--- generic/tclIOCmd.c | 25 +++++++++++++++---------- unix/tclUnixSock.c | 9 +++++++-- win/tclWinSock.c | 9 +++++++-- 5 files changed, 34 insertions(+), 18 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index af496b3..ba047a0 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2328,7 +2328,7 @@ declare 630 { # TIP #456 declare 631 { - Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, int port, + Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 4810c51..49ac440 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1817,8 +1817,9 @@ EXTERN void Tcl_ZlibStreamSetCompressionDictionary( Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 631 */ -EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, int port, - const char *host, unsigned int flags, +EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, + const char *service, const char *host, + unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); @@ -2487,7 +2488,7 @@ 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 */ - Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, int port, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */ + Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */ } TclStubs; extern const TclStubs *tclStubsPtr; diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index d6637a0..951fb5a 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1492,9 +1492,9 @@ Tcl_SocketObjCmd( SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, SKT_SERVER }; - int optionIndex, a, server = 0, port, myport = 0, async = 0, boolTmp; + int optionIndex, a, server = 0, myport = 0, async = 0, boolTmp; unsigned int flags = 0; - const char *host, *myaddr = NULL; + const char *host, *port, *myaddr = NULL; Tcl_Obj *script = NULL; Tcl_Channel chan; @@ -1628,15 +1628,14 @@ Tcl_SocketObjCmd( return TCL_ERROR; } - if (a == objc-1) { - if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", - &port) != TCL_OK) { - return TCL_ERROR; - } - } else { + // 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)); @@ -1646,7 +1645,7 @@ Tcl_SocketObjCmd( acceptCallbackPtr->interp = interp; chan = Tcl_OpenTcpServerEx(interp, port, host, flags, AcceptCallbackProc, - acceptCallbackPtr); + acceptCallbackPtr); if (chan == NULL) { Tcl_DecrRefCount(script); ckfree(acceptCallbackPtr); @@ -1670,7 +1669,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/unix/tclUnixSock.c b/unix/tclUnixSock.c index 187c157..8e97543 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1422,7 +1422,7 @@ TclpMakeTcpClientChannelMode( Tcl_Channel Tcl_OpenTcpServerEx( Tcl_Interp *interp, /* For error reporting - may be NULL. */ - int port, /* Port number to open. */ + const char *service, /* Port number to open. */ const char *myHost, /* Name of local host. */ unsigned int flags, /* Flags. */ Tcl_TcpAcceptProc *acceptProc, @@ -1430,7 +1430,7 @@ Tcl_OpenTcpServerEx( * clients. */ ClientData acceptProcData) /* Data for the callback. */ { - int status = 0, sock = -1, optvalue, chosenport; + int status = 0, sock = -1, optvalue, port, chosenport; struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */ TcpState *statePtr = NULL; char channelName[SOCK_CHAN_LENGTH]; @@ -1476,6 +1476,11 @@ Tcl_OpenTcpServerEx( retry++; chosenport = 0; + if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) { + errorMsg = "invalid port number"; + goto error; + } + if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) { my_errno = errno; goto error; diff --git a/win/tclWinSock.c b/win/tclWinSock.c index af22cf8..5e0d7c8 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -2037,7 +2037,7 @@ Tcl_MakeTcpClientChannel( Tcl_Channel Tcl_OpenTcpServerEx( Tcl_Interp *interp, /* For error reporting - may be NULL. */ - int port, /* Port number to open. */ + const char *service, /* Port number to open. */ const char *myHost, /* Name of local host. */ unsigned int flags, /* Flags. */ Tcl_TcpAcceptProc *acceptProc, @@ -2053,7 +2053,7 @@ Tcl_OpenTcpServerEx( char channelName[SOCK_CHAN_LENGTH]; u_long flag = 1; /* Indicates nonblocking mode. */ const char *errorMsg = NULL; - int optvalue; + int optvalue, port; if (TclpHasSockets(interp) != TCL_OK) { return NULL; @@ -2073,6 +2073,11 @@ Tcl_OpenTcpServerEx( * Construct the addresses for each end of the socket. */ + if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) { + errorMsg = "invalid port number"; + goto error; + } + if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) { goto error; } -- cgit v0.12 From b802a6e420e47172714baa9bc52fd03a5bb91f43 Mon Sep 17 00:00:00 2001 From: limeboy Date: Wed, 14 Dec 2016 15:52:21 +0000 Subject: Fix for the argument parsing phase in the [socket] command. --- generic/tclIOCmd.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 951fb5a..0eb8f99 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1493,7 +1493,7 @@ Tcl_SocketObjCmd( SKT_SERVER }; int optionIndex, a, server = 0, myport = 0, async = 0, boolTmp; - unsigned int flags = 0; + unsigned int flags = TCL_TCPSERVER_REUSEADDR; const char *host, *port, *myaddr = NULL; Tcl_Obj *script = NULL; Tcl_Channel chan; @@ -1552,7 +1552,6 @@ Tcl_SocketObjCmd( return TCL_ERROR; } server = 1; - flags = TCL_TCPSERVER_REUSEADDR; a++; if (a >= objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( -- cgit v0.12 From a63b9bacf55e153bdb8f470146bf3056156b29e6 Mon Sep 17 00:00:00 2001 From: limeboy Date: Wed, 14 Dec 2016 15:59:43 +0000 Subject: Adjust OpenTcpServer for the latest changes to OpenTcpServerEx --- generic/tclIOSock.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index b6e99ba..8ad268a 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -304,7 +304,11 @@ Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData) { - return Tcl_OpenTcpServerEx(interp, port, host, TCL_TCPSERVER_REUSEADDR, + char portbuf[TCL_INTEGER_SPACE]; + + TclFormatInt(portbuf, port); + + return Tcl_OpenTcpServerEx(interp, portbuf, host, TCL_TCPSERVER_REUSEADDR, acceptProc, callbackData); } -- cgit v0.12 From b8271467dc712230e7eecf2818f7232c2ebda8b4 Mon Sep 17 00:00:00 2001 From: limeboy Date: Wed, 14 Dec 2016 16:03:53 +0000 Subject: Update the documentation --- doc/OpenTcp.3 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/doc/OpenTcp.3 b/doc/OpenTcp.3 index a39f6f6..10a4815 100644 --- a/doc/OpenTcp.3 +++ b/doc/OpenTcp.3 @@ -24,7 +24,7 @@ Tcl_Channel \fBTcl_OpenTcpServer\fR(\fIinterp, port, myaddr, proc, clientData\fR) .sp Tcl_Channel -\fBTcl_OpenTcpServerEx\fR(\fIinterp, port, myaddr, flags, proc, clientData\fR) +\fBTcl_OpenTcpServerEx\fR(\fIinterp, service, myaddr, flags, proc, clientData\fR) .sp .SH ARGUMENTS .AS Tcl_TcpAcceptProc clientData @@ -33,6 +33,9 @@ Tcl interpreter to use for error reporting. If non-NULL and an error occurs, an error message is left in the interpreter's result. .AP int port in A port number to connect to as a client or to listen on as a server. +.AP "const char" *service in +A string specifying the port number to connect to as a client or to listen on as + a server. .AP "const char" *host in A string specifying a host name or address for the remote end of the connection. .AP int myport in -- cgit v0.12 From d4daeaf6fdc234980b6b7e28b281185896c2dd11 Mon Sep 17 00:00:00 2001 From: limeboy Date: Tue, 20 Dec 2016 10:22:22 +0000 Subject: Correct the handling of -server and its options. --- generic/tclIOCmd.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 0eb8f99..fb37ff6 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1493,7 +1493,7 @@ Tcl_SocketObjCmd( SKT_SERVER }; int optionIndex, a, server = 0, myport = 0, async = 0, boolTmp; - unsigned int flags = TCL_TCPSERVER_REUSEADDR; + unsigned int flags = 0; const char *host, *port, *myaddr = NULL; Tcl_Obj *script = NULL; Tcl_Channel chan; @@ -1552,6 +1552,7 @@ Tcl_SocketObjCmd( return TCL_ERROR; } server = 1; + flags |= TCL_TCPSERVER_REUSEADDR; a++; if (a >= objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( -- cgit v0.12 From bbe8ae73e2e5c693a20ea16c964949279ff83045 Mon Sep 17 00:00:00 2001 From: limeboy Date: Tue, 20 Dec 2016 10:56:53 +0000 Subject: Decouple the switch handling. --- generic/tclIOCmd.c | 25 ++++++++++--------------- 1 file changed, 10 insertions(+), 15 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index fb37ff6..e64e31d 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1492,7 +1492,8 @@ Tcl_SocketObjCmd( SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, SKT_SERVER }; - int optionIndex, a, server = 0, myport = 0, async = 0, boolTmp; + int optionIndex, a, server = 0, myport = 0, async = 0, reusep = 0, + reusea = 0; unsigned int flags = 0; const char *host, *port, *myaddr = NULL; Tcl_Obj *script = NULL; @@ -1552,7 +1553,8 @@ Tcl_SocketObjCmd( return TCL_ERROR; } server = 1; - flags |= TCL_TCPSERVER_REUSEADDR; + /* [TIP#456] Set for backward-compatibility. */ + reusea = 1; a++; if (a >= objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -1568,14 +1570,9 @@ Tcl_SocketObjCmd( "no argument given for -reuseaddr option", -1)); return TCL_ERROR; } - if (Tcl_GetBooleanFromObj(interp, objv[a], &boolTmp) != TCL_OK) { + if (Tcl_GetBooleanFromObj(interp, objv[a], &reusea) != TCL_OK) { return TCL_ERROR; } - if (boolTmp) { - flags |= TCL_TCPSERVER_REUSEADDR; - } else { - flags &= ~TCL_TCPSERVER_REUSEADDR; - } break; case SKT_REUSEPORT: a++; @@ -1584,14 +1581,9 @@ Tcl_SocketObjCmd( "no argument given for -reuseport option", -1)); return TCL_ERROR; } - if (Tcl_GetBooleanFromObj(interp, objv[a], &boolTmp) != TCL_OK) { + if (Tcl_GetBooleanFromObj(interp, objv[a], &reusep) != TCL_OK) { return TCL_ERROR; } - if (boolTmp) { - flags |= TCL_TCPSERVER_REUSEPORT; - } else { - flags &= ~TCL_TCPSERVER_REUSEPORT; - } break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); @@ -1621,13 +1613,16 @@ Tcl_SocketObjCmd( return TCL_ERROR; } - if (!server && flags != 0) { + if (!server && (reusea != 0 || reusep != 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "options -reuseaddr and -reuseport are only valid for servers", -1)); return TCL_ERROR; } + flags |= reusea ? TCL_TCPSERVER_REUSEADDR : 0; + flags |= reusep ? TCL_TCPSERVER_REUSEPORT : 0; + // All the arguments should have been parsed by now, 'a' points to the last // one, the port number. if (a != objc-1) { -- cgit v0.12 From 05119eaad1bb3205fa0a31abacf99d6ae33f20e1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 20 Dec 2016 12:35:33 +0000 Subject: Make options -reuseaddr/-reuseport forbidden without -server, no matter the value being true or false. Some additional test-cases. --- generic/tclIOCmd.c | 12 +++++------- tests/socket.test | 12 ++++++++++++ 2 files changed, 17 insertions(+), 7 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index e64e31d..682eaf4 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1492,8 +1492,8 @@ Tcl_SocketObjCmd( SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, SKT_SERVER }; - int optionIndex, a, server = 0, myport = 0, async = 0, reusep = 0, - reusea = 0; + 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; @@ -1553,8 +1553,6 @@ Tcl_SocketObjCmd( return TCL_ERROR; } server = 1; - /* [TIP#456] Set for backward-compatibility. */ - reusea = 1; a++; if (a >= objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -1613,15 +1611,15 @@ Tcl_SocketObjCmd( return TCL_ERROR; } - if (!server && (reusea != 0 || reusep != 0)) { + if (!server && (reusea != -1 || reusep != -1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "options -reuseaddr and -reuseport are only valid for servers", -1)); return TCL_ERROR; } - flags |= reusea ? TCL_TCPSERVER_REUSEADDR : 0; - flags |= reusep ? TCL_TCPSERVER_REUSEPORT : 0; + if (reusea!=0) flags |= TCL_TCPSERVER_REUSEADDR; + if (reusep==1) flags |= TCL_TCPSERVER_REUSEPORT; // All the arguments should have been parsed by now, 'a' points to the last // one, the port number. diff --git a/tests/socket.test b/tests/socket.test index c1076eb..80b0251 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -306,8 +306,20 @@ test socket_$af-1.15 {arg parsing for socket command} -constraints [list socket socket -reuseaddr yes 4242 } -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} test socket_$af-1.16 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseaddr no 4242 +} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} +test socket_$af-1.17 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseaddr +} -returnCodes error -result {no argument given for -reuseaddr option} +test socket_$af-1.18 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -reuseport yes 4242 } -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} +test socket_$af-1.19 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseport no 4242 +} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} +test socket_$af-1.20 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseport +} -returnCodes error -result {no argument given for -reuseport option} set path(script) [makeFile {} script] -- cgit v0.12 From 7628e8f3871e65f729e55364626f5684b172bddc Mon Sep 17 00:00:00 2001 From: limeboy Date: Sun, 1 Jan 2017 22:19:26 +0000 Subject: Make the code slightly more pleasing to the eyes. --- generic/tclIOCmd.c | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 682eaf4..1bd3fe7 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1618,8 +1618,16 @@ Tcl_SocketObjCmd( return TCL_ERROR; } - if (reusea!=0) flags |= TCL_TCPSERVER_REUSEADDR; - if (reusep==1) flags |= TCL_TCPSERVER_REUSEPORT; + // 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. -- cgit v0.12 From 6c67fa6248b76a800bbd47bdc27bfec84e1f0de4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Jan 2017 13:51:26 +0000 Subject: Fix 2 test-cases, due to changed command options. --- tests/info.test | 4 ++-- tests/package.test | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/info.test b/tests/info.test index a6a5919..fd89b47 100644 --- a/tests/info.test +++ b/tests/info.test @@ -397,8 +397,8 @@ test info-10.3 {info library option} -body { set tcl_library $savedLibrary; unset savedLibrary test info-11.1 {info loaded option} -body { - info loaded a b -} -returnCodes error -result {wrong # args: should be "info loaded ?interp?"} + info loaded a b c +} -returnCodes error -result {wrong # args: should be "info loaded ?interp? ?packageName?"} test info-11.2 {info loaded option} -body { info loaded {}; info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} diff --git a/tests/package.test b/tests/package.test index 49346d8..99f9f06 100644 --- a/tests/package.test +++ b/tests/package.test @@ -832,7 +832,7 @@ test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { } {0} test package-4.53 {Tcl_PackageCmd procedure, "versions" option} -body { package foo -} -returnCodes error -result {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} +} -returnCodes error -result {bad option "foo": must be files, forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} test package-4.54 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { package vsatisfies 2.1 2.1-3.2-4.5 } -returnCodes error -result {expected versionMin-versionMax but got "2.1-3.2-4.5"} -- cgit v0.12 From 707993b1dd4f01322cdbea334c71a1202373fa9b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Jan 2017 15:16:31 +0000 Subject: Fix safe.tcl test-cases: "source -nopkg" is not necessary here: "source" is an alias for "::safe::AliasSource", which doesn't use "source" --- library/init.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/init.tcl b/library/init.tcl index 65a19aa..e3d4ef0 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -486,7 +486,7 @@ proc auto_load_index {} { set dir [lindex $auto_path $i] set f "" if {$issafe} { - catch {source -nopkg [file join $dir tclIndex]} + catch {source [file join $dir tclIndex]} } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { continue } else { -- cgit v0.12 From 9f5fab9296c69ae125f5d288a5cca0d1dc3321ec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Jan 2017 16:23:23 +0000 Subject: In stead of "source -nopkg" use a ::tcl::Pkg::source utility function. --- generic/tclCmdMZ.c | 28 ++---------- library/init.tcl | 24 ++++++++++- library/package.tcl | 2 +- library/tclIndex | 120 +++++++++++++++++++++++++++++----------------------- 4 files changed, 92 insertions(+), 82 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index fbc9d8f..23e6bd1 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -989,11 +989,8 @@ TclNRSourceObjCmd( { const char *encodingName = NULL; Tcl_Obj *fileName; - int result; - void **pkgFiles = NULL; - void *names = NULL; - if (objc < 2 || objc > 4) { + if (objc != 2 && objc !=4) { Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } @@ -1011,28 +1008,9 @@ TclNRSourceObjCmd( return TCL_ERROR; } encodingName = TclGetString(objv[2]); - } else if (objc == 3) { - static const char *const nopkgoptions[] = { - "-nopkg", NULL - }; - int index; - - if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions, - "option", TCL_EXACT, &index)) { - return TCL_ERROR; - } - pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - /* Make sure that during the following TclNREvalFile no filenames - * are recorded for inclusion in the "package files" command */ - names = *pkgFiles; - *pkgFiles = NULL; - } - result = TclNREvalFile(interp, fileName, encodingName); - if (pkgFiles) { - /* restore "tclPkgFiles" assocdata to how it was. */ - *pkgFiles = names; } - return result; + + return TclNREvalFile(interp, fileName, encodingName); } /* diff --git a/library/init.tcl b/library/init.tcl index e3d4ef0..9101e35 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -46,8 +46,6 @@ if {![info exists auto_path]} { } } -source [file join $::tcl_library auto.tcl] - namespace eval tcl { variable Dir foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { @@ -115,6 +113,8 @@ namespace eval tcl { } } +namespace eval tcl::Pkg {} + # Windows specific end of initialization if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { @@ -460,6 +460,26 @@ proc auto_load {cmd {namespace {}}} { return 0 } +# ::tcl::Pkg::source -- +# This procedure provides an alternative "source" command, which doesn't +# register the file for the "package files" command. Safe interpreters +# don't have to do anything special. +# +# Arguments: +# filename + +proc ::tcl::Pkg::source {filename} { + if {[interp issafe]} { + uplevel 1 [list ::source $filename] + } else { + set f [open $filename] + fconfigure $f -eofchar \032 + set contents [read $f] + close $f + uplevel 1 [list eval $contents] + } +} + # auto_load_index -- # Loads the contents of tclIndex files on the auto_path directory # list. This is usually invoked within auto_load to load the index diff --git a/library/package.tcl b/library/package.tcl index cb1bea6..1cb2d3d 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -488,7 +488,7 @@ proc tclPkgUnknown {name args} { set dir [file dirname $file] if {![info exists procdDirs($dir)]} { try { - source -nopkg $file + ::tcl::Pkg::source $file } trap {POSIX EACCES} {} { # $file was not readable; silently ignore continue diff --git a/library/tclIndex b/library/tclIndex index 09aba56..87a2814 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -7,57 +7,69 @@ # element name is the name of a command and the value is # a script that loads the command. -set auto_index(history) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistClear) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistInfo) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]] -set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]] -set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]] -set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]] -set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]] -set auto_index(::tcl::MacOSXPkgUnknown) [list source [file join $dir package.tcl]] -set auto_index(::pkg::create) [list source [file join $dir package.tcl]] -set auto_index(parray) [list source [file join $dir parray.tcl]] -set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]] -set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]] -set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]] -set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]] -set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]] -set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]] -set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]] -set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]] -set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]] -set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]] -set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]] -set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]] -set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]] -set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::Log) [list source [file join $dir safe.tcl]] -set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]] -set auto_index(::safe::AliasGlob) [list source [file join $dir safe.tcl]] -set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]] -set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]] -set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::DirInAccessPath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]] -set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]] -set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]] -set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]] -set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]] -set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]] -set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]] -set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]] -set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::Defaults) [list source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]] -set auto_index(::tcl::tm::path) [list source [file join $dir tm.tcl]] +set auto_index(auto_reset) [list ::tcl::Pkg::source [file join $dir auto.tcl]] +set auto_index(tcl_findLibrary) [list ::tcl::Pkg::source [file join $dir auto.tcl]] +set auto_index(auto_mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]] +set auto_index(auto_mkindex_old) [list ::tcl::Pkg::source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::init) [list ::tcl::Pkg::source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::cleanup) [list ::tcl::Pkg::source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::hook) [list ::tcl::Pkg::source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::slavehook) [list ::tcl::Pkg::source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::command) [list ::tcl::Pkg::source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::commandInit) [list ::tcl::Pkg::source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::fullname) [list ::tcl::Pkg::source [file join $dir auto.tcl]] +set auto_index(history) [list ::tcl::Pkg::source [file join $dir history.tcl]] +set auto_index(::tcl::HistAdd) [list ::tcl::Pkg::source [file join $dir history.tcl]] +set auto_index(::tcl::HistKeep) [list ::tcl::Pkg::source [file join $dir history.tcl]] +set auto_index(::tcl::HistClear) [list ::tcl::Pkg::source [file join $dir history.tcl]] +set auto_index(::tcl::HistInfo) [list ::tcl::Pkg::source [file join $dir history.tcl]] +set auto_index(::tcl::HistRedo) [list ::tcl::Pkg::source [file join $dir history.tcl]] +set auto_index(::tcl::HistIndex) [list ::tcl::Pkg::source [file join $dir history.tcl]] +set auto_index(::tcl::HistEvent) [list ::tcl::Pkg::source [file join $dir history.tcl]] +set auto_index(::tcl::HistChange) [list ::tcl::Pkg::source [file join $dir history.tcl]] +set auto_index(pkg_mkIndex) [list ::tcl::Pkg::source [file join $dir package.tcl]] +set auto_index(tclPkgSetup) [list ::tcl::Pkg::source [file join $dir package.tcl]] +set auto_index(tclPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]] +set auto_index(::tcl::MacOSXPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]] +set auto_index(::pkg::create) [list ::tcl::Pkg::source [file join $dir package.tcl]] +set auto_index(parray) [list ::tcl::Pkg::source [file join $dir parray.tcl]] +set auto_index(::safe::InterpStatics) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::InterpNested) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::interpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::interpInit) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::CheckInterp) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::interpConfigure) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::InterpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::InterpSetConfig) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::interpFindInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::interpAddToAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::InterpInit) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::AddSubDirs) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::interpDelete) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::setLogCmd) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::SyncAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::PathToken) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::TranslatePath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::Log) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::CheckFileName) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::AliasGlob) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::AliasSource) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::AliasLoad) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::FileInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::DirInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::Subset) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::AliasSubset) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::AliasEncoding) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(tcl_wordBreakAfter) [list ::tcl::Pkg::source [file join $dir word.tcl]] +set auto_index(tcl_wordBreakBefore) [list ::tcl::Pkg::source [file join $dir word.tcl]] +set auto_index(tcl_endOfWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] +set auto_index(tcl_startOfNextWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] +set auto_index(tcl_startOfPreviousWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] +set auto_index(::tcl::tm::add) [list ::tcl::Pkg::source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::remove) [list ::tcl::Pkg::source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::list) [list ::tcl::Pkg::source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::Defaults) [list ::tcl::Pkg::source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::UnknownHandler) [list ::tcl::Pkg::source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::roots) [list ::tcl::Pkg::source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::path) [list ::tcl::Pkg::source [file join $dir tm.tcl]] -- cgit v0.12 From 7660a167e1a0bfce591e4b2a7b6b7043e72925af Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 5 Jan 2017 13:09:26 +0000 Subject: One more ::tcl::Pkg::source, for the Mac --- library/package.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/package.tcl b/library/package.tcl index 5257cd6..c72fbfb 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -590,7 +590,7 @@ proc tcl::MacOSXPkgUnknown {original name args} { set dir [file dirname $file] if {![info exists procdDirs($dir)]} { try { - source $file + ::tcl::Pkg::source $file } trap {POSIX EACCES} {} { # $file was not readable; silently ignore continue -- cgit v0.12 From 2ba138980311e60d5317ba5ed8814e11d9c4a997 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 5 Jan 2017 14:27:20 +0000 Subject: Fix [7c7d3b4481d4e4e86420b54031f4abd1df18d64|7c7d3b4481]: load test failures. There's a difference between "" and NULL as interpreter name. --- generic/tclCmdIL.c | 3 --- generic/tclLoad.c | 42 +++++++++++++++++++++--------------------- 2 files changed, 21 insertions(+), 24 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index ec85741..a7a5f43 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1728,9 +1728,6 @@ InfoLoadedCmd( interpName = NULL; } else { /* Get pkgs just in specified interp. */ interpName = TclGetString(objv[1]); - if (!interpName[0]) { - interpName = NULL; - } } if (objc < 3) { /* Get loaded files in all packages. */ packageName = NULL; diff --git a/generic/tclLoad.c b/generic/tclLoad.c index aabe3bb..44085d6 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -1051,7 +1051,7 @@ TclGetLoadedPackagesEx( * otherwise, just return info about this * interpreter. */ const char *packageName) /* Package name or NULL. If NULL, return info - * all packages. + * for all packages. */ { Tcl_Interp *target; @@ -1060,26 +1060,6 @@ TclGetLoadedPackagesEx( Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { - /* - * Return information about all of the available packages. - */ - if (packageName) { - resultObj = NULL; - Tcl_MutexLock(&packageMutex); - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; - pkgPtr = pkgPtr->nextPtr) { - if (!strcmp(packageName, pkgPtr->packageName)) { - resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); - break; - } - } - Tcl_MutexUnlock(&packageMutex); - if (resultObj) { - Tcl_SetObjResult(interp, resultObj); - } - return TCL_OK; - } - resultObj = Tcl_NewObj(); Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; @@ -1095,6 +1075,26 @@ TclGetLoadedPackagesEx( } /* + * Return information about all of the available packages. + */ + if (packageName) { + resultObj = NULL; + Tcl_MutexLock(&packageMutex); + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; + pkgPtr = pkgPtr->nextPtr) { + if (!strcmp(packageName, pkgPtr->packageName)) { + resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); + break; + } + } + Tcl_MutexUnlock(&packageMutex); + if (resultObj) { + Tcl_SetObjResult(interp, resultObj); + } + return TCL_OK; + } + + /* * Return information about only the packages that are loaded in a given * interpreter. */ -- cgit v0.12 From 1952bac5479aeb7c7493591cd707ed9ed8ba6b54 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 5 Jan 2017 15:13:58 +0000 Subject: Make TclGetLoadedPackagesEx() work with other than the only current interpreter (didn't really think about that earlier ... ). Actually slightly more correct. --- generic/tclLoad.c | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 44085d6..bcda420 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -1074,20 +1074,27 @@ TclGetLoadedPackagesEx( return TCL_OK; } + 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; - Tcl_MutexLock(&packageMutex); - for (pkgPtr = firstPackagePtr; pkgPtr != NULL; - pkgPtr = pkgPtr->nextPtr) { + + for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + pkgPtr = ipPtr->pkgPtr; + if (!strcmp(packageName, pkgPtr->packageName)) { resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); break; } } - Tcl_MutexUnlock(&packageMutex); + if (resultObj) { Tcl_SetObjResult(interp, resultObj); } @@ -1099,11 +1106,6 @@ TclGetLoadedPackagesEx( * interpreter. */ - target = Tcl_GetSlave(interp, targetName); - if (target == NULL) { - return TCL_ERROR; - } - ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL); resultObj = Tcl_NewObj(); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; -- cgit v0.12 From d886a33b76f26c9aa0866cd569f4b15bc2a68402 Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 9 Jan 2017 19:09:49 +0000 Subject: New performance measurement routine "timerate" in opposition to "time" the execution limited by fixed time (in milliseconds) instead of repetition count (more precise results, to prevent very long execution time it is no more necessary to estimate repetition count) Syntax: timerate ?-direct? ?-calibrate? ?-overhead double? command ?time? --- generic/tclBasic.c | 1 + generic/tclCmdMZ.c | 333 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 333 insertions(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 81b3513..dec26b4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -286,6 +286,7 @@ static const CmdInfo builtInCmds[] = { {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0}, {"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE}, {"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE}, {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, {"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE}, {"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE}, diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 23e6bd1..c660596 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -17,6 +17,7 @@ */ #include "tclInt.h" +#include "tclCompile.h" #include "tclRegexp.h" #include "tclStringTrim.h" @@ -3984,7 +3985,7 @@ Tcl_TimeObjCmd( start = TclpGetWideClicks(); #endif while (i-- > 0) { - result = Tcl_EvalObjEx(interp, objPtr, 0); + result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); if (result != TCL_OK) { return result; } @@ -4024,6 +4025,336 @@ Tcl_TimeObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_TimeRateObjCmd -- + * + * This object-based procedure is invoked to process the "timerate" Tcl + * command. + * This is similar to command "time", except the execution limited by + * given time (in milliseconds) instead of repetition count. + * + * Example: + * timerate {after 5} 1000 ; # equivalent for `time {after 5} [expr 1000/5]` + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TimeRateObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static + double measureOverhead = 0; /* global measure-overhead */ + double overhead = -1; /* given measure-overhead */ + register Tcl_Obj *objPtr; + register int result, i; + Tcl_Obj *calibrate = NULL, *direct = NULL; + Tcl_WideInt count = 0; /* Holds repetition count */ + Tcl_WideInt maxms = -0x7FFFFFFFFFFFFFFFL; + /* Maximal running time (in milliseconds) */ + Tcl_WideInt threshold = 1; /* Current threshold for check time (faster + * repeat count without time check) */ + Tcl_WideInt maxIterTm = 1; /* Max time of some iteration as max threshold + * additionally avoid divide to zero (never < 1) */ + register Tcl_WideInt start, middle, stop; +#ifndef TCL_WIDE_CLICKS + Tcl_Time now; +#endif + + static const char *const options[] = { + "-direct", "-overhead", "-calibrate", "--", NULL + }; + enum options { + TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST + }; + + NRE_callback *rootPtr; + ByteCode *codePtr = NULL; + + for (i = 1; i < objc - 1; i++) { + int index; + if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT, + &index) != TCL_OK) { + break; + } + if (index == TMRT_LAST) { + i++; + break; + } + switch ((enum options) index) { + case TMRT_EV_DIRECT: + direct = objv[i]; + break; + case TMRT_OVERHEAD: + if (++i >= objc - 1) { + goto usage; + } + if (Tcl_GetDoubleFromObj(interp, objv[i], &overhead) != TCL_OK) { + return TCL_ERROR; + } + break; + case TMRT_CALIBRATE: + calibrate = objv[i]; + break; + } + } + + if (i >= objc || i < objc-2) { +usage: + Tcl_WrongNumArgs(interp, 1, objv, "?-direct? ?-calibrate? ?-overhead double? command ?time?"); + return TCL_ERROR; + } + objPtr = objv[i++]; + if (i < objc) { + result = TclGetWideIntFromObj(interp, objv[i], &maxms); + if (result != TCL_OK) { + return result; + } + } + + /* if calibrate */ + if (calibrate) { + + /* if no time specified for the calibration */ + if (maxms == -0x7FFFFFFFFFFFFFFFL) { + Tcl_Obj *clobjv[6]; + Tcl_WideInt maxCalTime = 5000; + double lastMeasureOverhead = measureOverhead; + + clobjv[0] = objv[0]; + i = 1; + if (direct) { + clobjv[i++] = direct; + } + clobjv[i++] = objPtr; + + /* reset last measurement overhead */ + measureOverhead = (double)0; + + /* self-call with 100 milliseconds to warm-up, + * before entering the calibration cycle */ + TclNewLongObj(clobjv[i], 100); + Tcl_IncrRefCount(clobjv[i]); + result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv); + Tcl_DecrRefCount(clobjv[i]); + if (result != TCL_OK) { + return result; + } + + i--; + clobjv[i++] = calibrate; + clobjv[i++] = objPtr; + + /* set last measurement overhead to max */ + measureOverhead = (double)0x7FFFFFFFFFFFFFFFL; + + /* calibration cycle until it'll be preciser */ + maxms = -1000; + do { + lastMeasureOverhead = measureOverhead; + TclNewLongObj(clobjv[i], (int)maxms); + Tcl_IncrRefCount(clobjv[i]); + result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv); + Tcl_DecrRefCount(clobjv[i]); + if (result != TCL_OK) { + return result; + } + maxCalTime += maxms; + /* increase maxms for preciser calibration */ + maxms -= (-maxms / 4); + /* as long as new value more as 0.05% better */ + } while ( (measureOverhead >= lastMeasureOverhead + || measureOverhead / lastMeasureOverhead <= 0.9995) + && maxCalTime > 0 + ); + + return result; + } + if (maxms == 0) { + /* reset last measurement overhead */ + measureOverhead = 0; + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); + return TCL_OK; + } + + /* if time is negative - make current overhead more precise */ + if (maxms > 0) { + /* set last measurement overhead to max */ + measureOverhead = (double)0x7FFFFFFFFFFFFFFFL; + } else { + maxms = -maxms; + } + + } + + if (maxms == -0x7FFFFFFFFFFFFFFFL) { + maxms = 1000; + } + if (overhead == -1) { + overhead = measureOverhead; + } + + /* be sure that resetting of result will not smudge the further measurement */ + Tcl_ResetResult(interp); + + /* compile object */ + if (!direct) { + if (TclInterpReady(interp) != TCL_OK) { + return TCL_ERROR; + } + codePtr = TclCompileObj(interp, objPtr, NULL, 0); + TclPreserveByteCode(codePtr); + } + + /* get start and stop time */ +#ifndef TCL_WIDE_CLICKS + Tcl_GetTime(&now); + start = now.sec; start *= 1000000; start += now.usec; +#else + start = TclpGetWideClicks(); +#endif + + /* start measurement */ + stop = start + maxms * 1000; + middle = start; + while (1) { + /* eval single iteration */ + count++; + + if (!direct) { + /* precompiled */ + rootPtr = TOP_CB(interp); + result = TclNRExecuteByteCode(interp, codePtr); + result = TclNRRunCallbacks(interp, result, rootPtr); + } else { + /* eval */ + result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); + } + if (result != TCL_OK) { + goto done; + } + + /* don't check time up to threshold */ + if (--threshold > 0) continue; + + /* check stop time reached, estimate new threshold */ + #ifndef TCL_WIDE_CLICKS + Tcl_GetTime(&now); + middle = now.sec; middle *= 1000000; middle += now.usec; + #else + middle = TclpGetWideClicks(); + #endif + if (middle >= stop) { + break; + } + /* average iteration time in microsecs */ + threshold = (middle - start) / count; + if (threshold > maxIterTm) { + maxIterTm = threshold; + } + /* as relation between remaining time and time since last check */ + threshold = ((stop - middle) / maxIterTm) / 4; + if (threshold > 100000) { /* fix for too large threshold */ + threshold = 100000; + } + } + + { + Tcl_Obj *objarr[8], **objs = objarr; + Tcl_WideInt val; + const char *fmt; + + middle -= start; /* execution time in microsecs */ + + /* if not calibrate */ + if (!calibrate) { + /* minimize influence of measurement overhead */ + if (overhead > 0) { + /* estimate the time of overhead (microsecs) */ + Tcl_WideInt curOverhead = overhead * count; + if (middle > curOverhead) { + middle -= curOverhead; + } else { + middle = 1; + } + } + } else { + /* calibration - obtaining new measurement overhead */ + if (measureOverhead > (double)middle / count) { + measureOverhead = (double)middle / count; + } + objs[0] = Tcl_NewDoubleObj(measureOverhead); + TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */ + objs += 2; + } + + val = middle / count; /* microsecs per iteration */ + if (val >= 1000000) { + objs[0] = Tcl_NewWideIntObj(val); + } else { + if (val < 10) { fmt = "%.6f"; } else + if (val < 100) { fmt = "%.4f"; } else + if (val < 1000) { fmt = "%.3f"; } else + if (val < 10000) { fmt = "%.2f"; } else + { fmt = "%.1f"; }; + objs[0] = Tcl_ObjPrintf(fmt, ((double)middle)/count); + } + + objs[2] = Tcl_NewWideIntObj(count); /* iterations */ + + /* calculate speed as rate (count) per sec */ + if (!middle) middle++; /* +1 ms, just to avoid divide by zero */ + if (count < (0x7FFFFFFFFFFFFFFFL / 1000000)) { + val = (count * 1000000) / middle; + if (val < 100000) { + if (val < 100) { fmt = "%.3f"; } else + if (val < 1000) { fmt = "%.2f"; } else + { fmt = "%.1f"; }; + objs[4] = Tcl_ObjPrintf(fmt, ((double)(count * 1000000)) / middle); + } else { + objs[4] = Tcl_NewWideIntObj(val); + } + } else { + objs[4] = Tcl_NewWideIntObj((count / middle) * 1000000); + } + + /* estimated net execution time (in millisecs) */ + if (!calibrate) { + objs[6] = Tcl_ObjPrintf("%.3f", (double)middle / 1000); + TclNewLiteralStringObj(objs[7], "nett-ms"); + } + + /* + * Construct the result as a list because many programs have always parsed + * as such (extracting the first element, typically). + */ + + TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#"); /* mics/# */ + TclNewLiteralStringObj(objs[3], "#"); + TclNewLiteralStringObj(objs[5], "#/sec"); + Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr)); + } + +done: + + if (codePtr != NULL) { + TclReleaseByteCode(codePtr); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_TryObjCmd, TclNRTryObjCmd -- * * This procedure is invoked to process the "try" Tcl command. See the -- cgit v0.12 From d05b600d32d4e5a5bf8c06244a5fc1a0368ff87c Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 9 Jan 2017 19:31:08 +0000 Subject: missing entry of tclInt.h added --- generic/tclInt.h | 3 +++ 1 file changed, 3 insertions(+) diff --git a/generic/tclInt.h b/generic/tclInt.h index dd0c11a..1b37d84 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3461,6 +3461,9 @@ MODULE_SCOPE int Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp, MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_TimeRateObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -- cgit v0.12 From de7fe4dd0fea3795e66e91109721ce68c5d7005b Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 9 Jan 2017 19:33:23 +0000 Subject: [win] load win-registry library also in development environment (uninstalled) --- library/reg/pkgIndex.tcl | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index b1fe234..ab022ab 100755 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -1,9 +1,19 @@ if {([info commands ::tcl::pkgconfig] eq "") - || ([info sharedlibextension] ne ".dll")} return + || ([info sharedlibextension] ne ".dll")} return if {[::tcl::pkgconfig get debug]} { + if {[info exists [file join $dir tclreg13g.dll]]} { package ifneeded registry 1.3.2 \ [list load [file join $dir tclreg13g.dll] registry] + } else { + package ifneeded registry 1.3.2 \ + [list load tclreg13g registry] + } } else { + if {[info exists [file join $dir tclreg13.dll]]} { package ifneeded registry 1.3.2 \ [list load [file join $dir tclreg13.dll] registry] + } else { + package ifneeded registry 1.3.2 \ + [list load tclreg13 registry] + } } -- cgit v0.12 From f39edc377395db21fa57a8bf93bdbf367b3a5254 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 11 Jan 2017 16:23:18 +0000 Subject: Use more Tcl_AppendResult(), in order to prevent the use of a (char *) type case. --- generic/tclTest.c | 56 +++++++++++++++++++++++++++---------------------------- 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 85e4a29..faecbc6 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, (char *)"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, (char *)"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, (char *)"??", 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, (char *)"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, (char *)"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, (char *)"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, (char *)"short", TCL_STATIC); + Tcl_AppendResult(interp, "short", NULL); } else if (strcmp(argv[2], "staticlarge") == 0) { - Tcl_SetResult(interp, (char *)"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, (char *)"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, (char *)"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, (char *)"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, (char *)"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; @@ -4486,7 +4486,7 @@ TestseterrorcodeCmd( const char **argv) /* Argument strings. */ { if (argc > 6) { - Tcl_SetResult(interp, (char *)"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, (char *)"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, (char *)"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, (char *)"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, (char *)"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, (char *)"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, (char *)"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, (char *)"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, (char *)"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, (char *)"wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } else { int val, i, total=0; -- cgit v0.12 From dcb024402d1a3c73cf744af89c99f82339dc215c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 13 Jan 2017 11:17:17 +0000 Subject: Patch from Zoran Vasiljevic, fix for missing proper initialization of the threaded allocator in some situations. --- generic/tclEvent.c | 3 --- generic/tclThreadAlloc.c | 1 + unix/tclUnixThrd.c | 2 -- 3 files changed, 1 insertion(+), 5 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 0eabc13..b0b8188 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1043,9 +1043,6 @@ TclInitSubsystems(void) #if USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - TclpInitAllocCache(); -#endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* Process wide mutex init */ #endif diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index 2ee758e..fc281db 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -210,6 +210,7 @@ GetCache(void) 1 << (NBUCKETS - 2 - i) : 1; bucketInfo[i].lockPtr = TclpNewAllocMutex(); } + TclpInitAllocCache(); } Tcl_MutexUnlock(initLockPtr); } diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 7394545..805599d 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -711,9 +711,7 @@ TclpFreeAllocMutex( void TclpInitAllocCache(void) { - pthread_mutex_lock(allocLockPtr); pthread_key_create(&key, NULL); - pthread_mutex_unlock(allocLockPtr); } void -- cgit v0.12 From c3dbeb6e6ff78ff7393f4546ab4156aa1262e859 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 17 Jan 2017 12:02:43 +0000 Subject: Implement tag "deprecated" in genStubs.tcl. Will be used in Tk 8.7, for tagging the deprecated function Tk_FreeXId() --- tools/genStubs.tcl | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index 9f2c6ca..742aa46 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -199,6 +199,13 @@ proc genStubs::declare {args} { set stubs($curName,$platform,lastNum) $index } } + if {$platformList eq "deprecated"} { + set stubs($curName,generic,$index) $decl + if {![info exists stubs($curName,generic,lastNum)] \ + || ($index > $stubs($curName,generic,lastNum))} { + set stubs($curName,$platform,lastNum) $index + } + } } return } @@ -455,10 +462,16 @@ proc genStubs::parseArg {arg} { proc genStubs::makeDecl {name decl index} { variable scspec + variable stubs + variable libraryName lassign $decl rtype fname args append text "/* $index */\n" + if {[info exists stubs($name,deprecated,$index)]} { + set line "[string toupper $libraryName]_DEPRECATED $rtype" + } else { set line "$scspec $rtype" + } set count [expr {2 - ([string length $line] / 8)}] append line [string range "\t\t\t" 0 $count] set pad [expr {24 - [string length $line]}] @@ -682,7 +695,10 @@ proc genStubs::forAllStubs {name slotProc onAll textVar for {set i 0} {$i <= $lastNum} {incr i} { set slots [array names stubs $name,*,$i] set emit 0 - if {[info exists stubs($name,generic,$i)]} { + if {[info exists stubs($name,deprecated,$i)]} { + append text [$slotProc $name $stubs($name,generic,$i) $i] + set emit 1 + } elseif {[info exists stubs($name,generic,$i)]} { if {[llength $slots] > 1} { puts stderr "conflicting generic and platform entries:\ $name $i" -- cgit v0.12 From d95abe6b6fe069f55ce27900c99fec5949d63a15 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 25 Jan 2017 12:22:16 +0000 Subject: If TCL_NO_DEPRECATED is defined, remove the "case" statement, and use much less interp->result. Implementation mostly taken over from "novem". If TCL_NO_DEPRECATED is not defined, nothing changes. --- generic/tclBasic.c | 2 +- generic/tclCmdAH.c | 3 ++- generic/tclDecls.h | 16 +++++++++++++++ generic/tclIO.c | 41 -------------------------------------- generic/tclInt.h | 2 ++ generic/tclResult.c | 55 +++++++++++++++++++++++++++++++++++++++------------ generic/tclStubInit.c | 41 ++++++++++++++++++++++++++++++++++++-- generic/tclTest.c | 20 ++++++++----------- generic/tclUtil.c | 17 ++++++++++++---- tests/case.test | 5 +++++ tests/result.test | 4 ++-- tools/configure | 2 +- 12 files changed, 131 insertions(+), 77 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 37dd699..b4d0a7b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -203,7 +203,7 @@ static const CmdInfo builtInCmds[] = { {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, -#ifndef EXCLUDE_OBSOLETE_COMMANDS +#ifndef TCL_NO_DEPRECATED {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, #endif {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 4c299f8..9c6f6a1 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -149,7 +149,7 @@ Tcl_BreakObjCmd( * *---------------------------------------------------------------------- */ - +#ifndef TCL_NO_DEPRECATED /* ARGSUSED */ int Tcl_CaseObjCmd( @@ -267,6 +267,7 @@ Tcl_CaseObjCmd( return TCL_OK; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 504af18..0dbf345 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3869,6 +3869,22 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_AddObjErrorInfo #define Tcl_AddObjErrorInfo(interp, message, length) \ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) +#ifdef TCL_NO_DEPRECATED +#undef Tcl_SetResult +#define Tcl_SetResult(interp, result, freeProc) \ + do { \ + char *__result = result; \ + Tcl_FreeProc *__freeProc = freeProc; \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \ + if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \ + if (__freeProc == TCL_DYNAMIC) { \ + ckfree(__result); \ + } else { \ + (*__freeProc)(__result); \ + } \ + } \ + } while(0) +#endif /* TCL_NO_DEPRECATED */ #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 5c39e19..506e6d5 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7127,47 +7127,6 @@ Tcl_Tell( /* *--------------------------------------------------------------------------- * - * Tcl_SeekOld, Tcl_TellOld -- - * - * Backward-compatibility versions of the seek/tell interface that do not - * support 64-bit offsets. This interface is not documented or expected - * to be supported indefinitely. - * - * Results: - * As for Tcl_Seek and Tcl_Tell respectively, except truncated to - * whatever value will fit in an 'int'. - * - * Side effects: - * As for Tcl_Seek and Tcl_Tell respectively. - * - *--------------------------------------------------------------------------- - */ - -int -Tcl_SeekOld( - Tcl_Channel chan, /* The channel on which to seek. */ - int offset, /* Offset to seek to. */ - int mode) /* Relative to which location to seek? */ -{ - Tcl_WideInt wOffset, wResult; - - wOffset = Tcl_LongAsWide((long) offset); - wResult = Tcl_Seek(chan, wOffset, mode); - return (int) Tcl_WideAsLong(wResult); -} - -int -Tcl_TellOld( - Tcl_Channel chan) /* The channel to return pos for. */ -{ - Tcl_WideInt wResult = Tcl_Tell(chan); - - return (int) Tcl_WideAsLong(wResult); -} - -/* - *--------------------------------------------------------------------------- - * * Tcl_TruncateChannel -- * * Truncate a channel to the given length. diff --git a/generic/tclInt.h b/generic/tclInt.h index 8516385..5074378 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3219,9 +3219,11 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +#ifndef TCL_NO_DEPRECATED MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +#endif MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/tclResult.c b/generic/tclResult.c index 9d0714c..6346636 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -27,7 +27,9 @@ enum returnKeys { static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); +#ifndef TCL_NO_DEPRECATED static void SetupAppendBuffer(Interp *iPtr, int newSpace); +#endif /* !TCL_NO_DEPRECATED */ /* * This structure is used to take a snapshot of the interpreter state in @@ -35,7 +37,7 @@ static void SetupAppendBuffer(Interp *iPtr, int newSpace); * then back up to the result or the error that was previously in progress. */ -typedef struct InterpState { +typedef struct { int status; /* return code status */ int flags; /* Each remaining field saves the */ int returnLevel; /* corresponding field of the Interp */ @@ -407,6 +409,7 @@ Tcl_DiscardResult( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED void Tcl_SetResult( Tcl_Interp *interp, /* Interpreter with which to associate the @@ -461,6 +464,7 @@ Tcl_SetResult( ResetObjResult(iPtr); } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -483,18 +487,21 @@ const char * Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { + Interp *iPtr = (Interp *) interp; +#ifdef TCL_NO_DEPRECATED + return Tcl_GetString(iPtr->objResultPtr); +#else /* * If the string result is empty, move the object result to the string * result, then reset the object result. */ - Interp *iPtr = (Interp *) interp; - if (*(iPtr->result) == 0) { Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } return iPtr->result; +#endif } /* @@ -536,6 +543,7 @@ Tcl_SetObjResult( TclDecrRefCount(oldObjResult); +#ifndef TCL_NO_DEPRECATED /* * Reset the string result since we just set the result object. */ @@ -550,6 +558,7 @@ Tcl_SetObjResult( } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif } /* @@ -578,6 +587,7 @@ Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; +#ifndef TCL_NO_DEPRECATED Tcl_Obj *objResultPtr; int length; @@ -604,6 +614,7 @@ Tcl_GetObjResult( iPtr->result = iPtr->resultSpace; iPtr->result[0] = 0; } +#endif /* !TCL_NO_DEPRECATED */ return iPtr->objResultPtr; } @@ -722,6 +733,21 @@ Tcl_AppendElement( * to result. */ { Interp *iPtr = (Interp *) interp; +#ifdef TCL_NO_DEPRECATED + Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1); + Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr); + const char *bytes; + + if (Tcl_IsShared(iPtr->objResultPtr)) { + Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); + } + bytes = TclGetString(iPtr->objResultPtr); + if (TclNeedSpace(bytes, bytes+iPtr->objResultPtr->length)) { + Tcl_AppendToObj(iPtr->objResultPtr, " ", 1); + } + Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); + Tcl_DecrRefCount(listPtr); +#else char *dst; int size; int flags; @@ -765,6 +791,7 @@ Tcl_AppendElement( flags |= TCL_DONT_QUOTE_HASH; } iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); +#endif /* !TCL_NO_DEPRECATED */ } /* @@ -786,6 +813,7 @@ Tcl_AppendElement( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED static void SetupAppendBuffer( Interp *iPtr, /* Interpreter whose result is being set up. */ @@ -846,6 +874,7 @@ SetupAppendBuffer( Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -875,6 +904,7 @@ Tcl_FreeResult( { register Interp *iPtr = (Interp *) interp; +#ifndef TCL_NO_DEPRECATED if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -884,6 +914,7 @@ Tcl_FreeResult( iPtr->freeProc = 0; } +#endif /* !TCL_NO_DEPRECATED */ ResetObjResult(iPtr); } @@ -913,6 +944,7 @@ Tcl_ResetResult( register Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); +#ifndef TCL_NO_DEPRECATED if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -923,6 +955,7 @@ Tcl_ResetResult( } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { @@ -1276,10 +1309,8 @@ TclProcessReturn( Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { - int infoLen; - - (void) TclGetStringFromObj(valuePtr, &infoLen); - if (infoLen) { + (void) TclGetString(valuePtr); + if (valuePtr->length) { iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; @@ -1382,13 +1413,11 @@ TclMergeReturnOptions( Tcl_Obj **keys = GetKeys(); for (; objc > 1; objv += 2, objc -= 2) { - int optLen; - const char *opt = TclGetStringFromObj(objv[0], &optLen); - int compareLen; - const char *compare = - TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen); + const char *opt = TclGetString(objv[0]); + const char *compare = TclGetString(keys[KEY_OPTIONS]); - if ((optLen == compareLen) && (memcmp(opt, compare, optLen) == 0)) { + if ((objv[0]->length == keys[KEY_OPTIONS]->length) + && (memcmp(opt, compare, objv[0]->length) == 0)) { Tcl_DictSearch search; int done = 0; Tcl_Obj *keyPtr; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 23da6dc..561b9dd 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -290,10 +290,47 @@ static int formatInt(char *buffer, int n){ #endif #else /* UNIX and MAC */ -# define TclpLocaltime_unix TclpLocaltime -# define TclpGmtime_unix TclpGmtime +# ifdef TCL_NO_DEPRECATED +# define TclpLocaltime_unix 0 +# define TclpGmtime_unix 0 +# else +# define TclpLocaltime_unix TclpLocaltime +# define TclpGmtime_unix TclpGmtime +# endif #endif +#ifdef TCL_NO_DEPRECATED +# define Tcl_SeekOld 0 +# define Tcl_TellOld 0 +# undef Tcl_SetResult +# define Tcl_SetResult 0 +#else /* TCL_NO_DEPRECATED */ +# define Tcl_SeekOld seekOld +# define Tcl_TellOld tellOld + +static int +seekOld( + Tcl_Channel chan, /* The channel on which to seek. */ + int offset, /* Offset to seek to. */ + int mode) /* Relative to which location to seek? */ +{ + Tcl_WideInt wOffset, wResult; + + wOffset = Tcl_LongAsWide((long) offset); + wResult = Tcl_Seek(chan, wOffset, mode); + return (int) Tcl_WideAsLong(wResult); +} + +static int +tellOld( + Tcl_Channel chan) /* The channel to return pos for. */ +{ + Tcl_WideInt wResult = Tcl_Tell(chan); + + return (int) Tcl_WideAsLong(wResult); +} +#endif /* !TCL_NO_DEPRECATED */ + /* * WARNING: The contents of this file is automatically generated by the * tools/genStubs.tcl script. Any modifications to the function declarations diff --git a/generic/tclTest.c b/generic/tclTest.c index faecbc6..a9dc1ca 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -290,12 +290,14 @@ static int TestlinkCmd(ClientData dummy, static int TestlocaleCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +#ifndef TCL_NO_DEPRECATED static int TestMathFunc(ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr); static int TestMathFunc2(ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr); +#endif /* TCL_NO_DEPRECATED */ static int TestmainthreadCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetmainloopCmd(ClientData dummy, @@ -329,12 +331,10 @@ static int TestreturnObjCmd(ClientData dummy, Tcl_Obj *const objv[]); static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); -#ifndef TCL_NO_DEPRECATED static int TestsaveresultCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestsaveresultFree(char *blockPtr); -#endif /* TCL_NO_DEPRECATED */ static int TestsetassocdataCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetCmd(ClientData dummy, @@ -555,7 +555,7 @@ Tcltest_Init( } /* TIP #268: Full patchlevel instead of just major.minor */ - if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { + if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; } @@ -658,10 +658,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); -#ifndef TCL_NO_DEPRECATED Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); -#endif /* TCL_NO_DEPRECATED */ Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, @@ -3341,6 +3339,7 @@ TestlocaleCmd( */ /* ARGSUSED */ +#ifndef TCL_NO_DEPRECATED static int TestMathFunc( ClientData clientData, /* Integer value to return. */ @@ -3460,6 +3459,7 @@ TestMathFunc2( } return result; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -5144,7 +5144,6 @@ Testset2Cmd( } } -#ifndef TCL_NO_DEPRECATED /* *---------------------------------------------------------------------- * @@ -5197,6 +5196,7 @@ TestsaveresultCmd( return TCL_ERROR; } + freeCount = 0; objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: @@ -5221,7 +5221,6 @@ TestsaveresultCmd( break; } - freeCount = 0; Tcl_SaveResult(interp, &state); if (((enum options) index) == RESULT_OBJECT) { @@ -5239,11 +5238,9 @@ TestsaveresultCmd( switch ((enum options) index) { case RESULT_DYNAMIC: { - int present = iPtr->freeProc == TestsaveresultFree; - int called = freeCount; + int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount; - Tcl_AppendElement(interp, called ? "called" : "notCalled"); - Tcl_AppendElement(interp, present ? "present" : "missing"); + Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak"); break; } case RESULT_OBJECT: @@ -5278,7 +5275,6 @@ TestsaveresultFree( { freeCount++; } -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 531f386..ba709cc 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2894,7 +2894,6 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { - Tcl_ResetResult(interp); Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); } @@ -2924,6 +2923,14 @@ Tcl_DStringGetResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { +#ifdef TCL_NO_DEPRECATED + Tcl_Obj *obj = Tcl_GetObjResult(interp); + const char *bytes = TclGetString(obj); + + Tcl_DStringFree(dsPtr); + Tcl_DStringAppend(dsPtr, bytes, obj->length); + Tcl_ResetResult(interp); +#else Interp *iPtr = (Interp *) interp; if (dsPtr->string != dsPtr->staticSpace) { @@ -2932,7 +2939,7 @@ Tcl_DStringGetResult( /* * Do more efficient transfer when we know the result is a Tcl_Obj. When - * there's no st`ring result, we only have to deal with two cases: + * there's no string result, we only have to deal with two cases: * * 1. When the string rep is the empty string, when we don't copy but * instead use the staticSpace in the DString to hold an empty string. @@ -2995,6 +3002,7 @@ Tcl_DStringGetResult( iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ } /* @@ -3576,7 +3584,7 @@ TclGetIntForIndex( int *indexPtr) /* Location filled in with an integer * representing an index. */ { - int length; + size_t length; char *opPtr; const char *bytes; @@ -3594,7 +3602,8 @@ TclGetIntForIndex( return TCL_OK; } - bytes = TclGetStringFromObj(objPtr, &length); + bytes = TclGetString(objPtr); + length = objPtr->length; /* * Leading whitespace is acceptable in an index. diff --git a/tests/case.test b/tests/case.test index 6d63cea..d7558a9 100644 --- a/tests/case.test +++ b/tests/case.test @@ -11,6 +11,11 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. +if {![llength [info commands case]]} { + # No "case" command? So no need to test + return +} + if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* diff --git a/tests/result.test b/tests/result.test index 9e8a66b..859e546 100644 --- a/tests/result.test +++ b/tests/result.test @@ -31,7 +31,7 @@ test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} { } {append result} test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 0 -} {dynamic result notCalled present} +} {dynamic result presentOrFreed} test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 0 } {object result same} @@ -43,7 +43,7 @@ test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} { } {42} test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 1 -} {42 called missing} +} {42 presentOrFreed} test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 1 } {42 different} diff --git a/tools/configure b/tools/configure index 7c4d3db..5903cc8 100755 --- a/tools/configure +++ b/tools/configure @@ -1681,7 +1681,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu # not, assume that its top-level directory is a sibling of ours. #-------------------------------------------------------------------- -DEF_VER=8.6 +DEF_VER=8.7 # Check whether --with-tcl was given. -- cgit v0.12 From 368a29cbf01f4aa930631726ce71aafe9c853f12 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Jan 2017 14:31:12 +0000 Subject: Some code cleanup: More internal use of size_t, less type casts (because of this). No functional changes. --- generic/tclLink.c | 66 ++++++++++++++++++++++--------------------------------- generic/tclObj.c | 17 +++++++------- generic/tclProc.c | 10 ++++----- 3 files changed, 40 insertions(+), 53 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index 2ead6df..46471f5 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -67,10 +67,8 @@ 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); +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 @@ -263,7 +261,8 @@ LinkTraceProc( int flags) /* Miscellaneous additional information. */ { Link *linkPtr = clientData; - int changed, valueLength; + int changed; + size_t valueLength; const char *value; char **pp; Tcl_Obj *valueObj; @@ -384,8 +383,7 @@ LinkTraceProc( case TCL_LINK_INT: if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { - if (GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) - != TCL_OK) { + 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"; @@ -397,8 +395,7 @@ LinkTraceProc( case TCL_LINK_WIDE_INT: if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { + if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have integer value"; @@ -441,8 +438,7 @@ LinkTraceProc( case TCL_LINK_CHAR: if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { + if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have char value"; @@ -455,8 +451,7 @@ LinkTraceProc( case TCL_LINK_UCHAR: if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK || valueInt < 0 || valueInt > UCHAR_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { + 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"; @@ -469,8 +464,7 @@ LinkTraceProc( case TCL_LINK_SHORT: if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { + if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have short value"; @@ -483,8 +477,7 @@ LinkTraceProc( case TCL_LINK_USHORT: if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK || valueInt < 0 || valueInt > USHRT_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { + 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"; @@ -497,8 +490,7 @@ LinkTraceProc( case TCL_LINK_UINT: if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK || valueWide < 0 || valueWide > UINT_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { + 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"; @@ -513,8 +505,7 @@ LinkTraceProc( case TCL_LINK_LONG: if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK || valueWide < LONG_MIN || valueWide > LONG_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { + if (GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have long value"; @@ -529,8 +520,7 @@ LinkTraceProc( case TCL_LINK_ULONG: if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { + 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"; @@ -547,8 +537,7 @@ LinkTraceProc( * FIXME: represent as a bignum. */ if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { + 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"; @@ -575,12 +564,12 @@ LinkTraceProc( break; case TCL_LINK_STRING: - value = TclGetStringFromObj(valueObj, &valueLength); - valueLength++; + value = TclGetString(valueObj); + valueLength = valueObj->length + 1; pp = (char **) linkPtr->addr; *pp = ckrealloc(*pp, valueLength); - memcpy(*pp, value, (unsigned) valueLength); + memcpy(*pp, value, valueLength); break; default: @@ -688,17 +677,16 @@ static Tcl_ObjType invalidRealType = { 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] == '.')){ + str = TclGetString(objPtr); + if ((objPtr->length == 1) && (str[0] == '.')){ objPtr->typePtr = &invalidRealType; objPtr->internalRep.doubleValue = 0.0; return TCL_OK; } - if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr, + if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->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. */ @@ -708,7 +696,7 @@ SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { if (*endPtr == 0) { double doubleValue = 0.0; Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); - if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr); + TclFreeIntRep(objPtr); objPtr->typePtr = &invalidRealType; objPtr->internalRep.doubleValue = doubleValue; return TCL_OK; @@ -726,17 +714,15 @@ SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { * (upperand lowercase). See bug [39f6304c2e]. */ int -GetInvalidIntFromObj(Tcl_Obj *objPtr, - int *intPtr) +GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr) { - int length; - const char *str = TclGetStringFromObj(objPtr, &length); + const char *str = TclGetString(objPtr); - if ((length == 1) && strchr("+-", str[0])) { + if ((objPtr->length == 1) && strchr("+-", str[0])) { *intPtr = (str[0] == '+'); return TCL_OK; - } else if ((length == 0) || - ((length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1]))) { + } else if ((objPtr->length == 0) || + ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1]))) { *intPtr = 0; return TCL_OK; } diff --git a/generic/tclObj.c b/generic/tclObj.c index df900ce..d0f7480 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2004,9 +2004,10 @@ static int ParseBoolean( register Tcl_Obj *objPtr) /* The object to parse/convert. */ { - int i, length, newBool; + int newBool; char lowerCase[6]; - const char *str = TclGetStringFromObj(objPtr, &length); + const char *str = TclGetString(objPtr); + size_t i, length = objPtr->length; if ((length == 0) || (length > 5)) { /* @@ -2058,25 +2059,25 @@ ParseBoolean( /* * Checking the 'y' is redundant, but makes the code clearer. */ - if (strncmp(lowerCase, "yes", (size_t) length) == 0) { + if (strncmp(lowerCase, "yes", length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'n': - if (strncmp(lowerCase, "no", (size_t) length) == 0) { + if (strncmp(lowerCase, "no", length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; case 't': - if (strncmp(lowerCase, "true", (size_t) length) == 0) { + if (strncmp(lowerCase, "true", length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'f': - if (strncmp(lowerCase, "false", (size_t) length) == 0) { + if (strncmp(lowerCase, "false", length) == 0) { newBool = 0; goto goodBoolean; } @@ -2085,10 +2086,10 @@ ParseBoolean( if (length < 2) { return TCL_ERROR; } - if (strncmp(lowerCase, "on", (size_t) length) == 0) { + if (strncmp(lowerCase, "on", length) == 0) { newBool = 1; goto goodBoolean; - } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { + } else if (strncmp(lowerCase, "off", length) == 0) { newBool = 0; goto goodBoolean; } diff --git a/generic/tclProc.c b/generic/tclProc.c index bed520a..373192c 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -500,7 +500,8 @@ TclCreateProc( } for (i = 0; i < numArgs; i++) { - int fieldCount, nameLength, valueLength; + int fieldCount, nameLength; + size_t valueLength; const char **fieldValues; /* @@ -602,12 +603,11 @@ TclCreateProc( */ if (localPtr->defValuePtr != NULL) { - int tmpLength; - const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, - &tmpLength); + const char *tmpPtr = TclGetString(localPtr->defValuePtr); + size_t tmpLength = localPtr->defValuePtr->length; if ((valueLength != tmpLength) || - strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { + strncmp(fieldValues[1], tmpPtr, tmpLength)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter \"%s\" has " "default value inconsistent with precompiled body", -- cgit v0.12 From 1c6496c269fc6be350eae56e9b2351ce6e7e6dac Mon Sep 17 00:00:00 2001 From: ashok Date: Sat, 28 Jan 2017 06:38:22 +0000 Subject: Added assoc, ftype and move as auto_execok shell built-ins on Windows. --- library/init.tcl | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/library/init.tcl b/library/init.tcl index 544ea77..5a9e87c 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -636,8 +636,9 @@ proc auto_execok name { } set auto_execs($name) "" - set shellBuiltins [list cls copy date del dir echo erase md mkdir \ - mklink rd ren rename rmdir start time type ver vol] + set shellBuiltins [list assoc cls copy date del dir echo erase ftype \ + md mkdir mklink move rd ren rename rmdir start \ + time type ver vol] if {[info exists env(PATHEXT)]} { # Add an initial ; to have the {} extension check first. set execExtensions [split ";$env(PATHEXT)" ";"] -- cgit v0.12 From e2779b6b41c0ecc07005f1da41c7b6aa5895ed36 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 3 Feb 2017 11:47:02 +0000 Subject: In TclGetNumberFromObj() macro (tclExecute.c): Don't fill in type if TCL_ERROR is returned: The caller doesn't do anything with this. Don't access (non-const) variable tclEmptyStringRep any more, use its value (&tclEmptyString) directly. Only keep it in tclPkg.c, for error checking. --- generic/tclBasic.c | 2 +- generic/tclDictObj.c | 2 +- generic/tclExecute.c | 4 ++-- generic/tclInt.h | 9 ++++----- generic/tclListObj.c | 16 ++++++++-------- generic/tclObj.c | 5 ++--- generic/tclPathObj.c | 2 +- generic/tclPkg.c | 2 ++ generic/tclResult.c | 4 ++-- generic/tclStringObj.c | 12 ++++++------ generic/tclUtil.c | 6 +++--- unix/tclUnixSock.c | 2 +- 12 files changed, 33 insertions(+), 33 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b4d0a7b..63c5590 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -6055,7 +6055,7 @@ TclNREvalObjEx( TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, objPtr, NULL); - ListObjGetElements(listPtr, objc, objv); + TclListObjGetElements(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 1115999..970978f 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -506,7 +506,7 @@ UpdateStringOfDict( /* Handle empty list case first, simplifies what follows */ if (numElems == 0) { - dictPtr->bytes = tclEmptyStringRep; + dictPtr->bytes = &tclEmptyString; dictPtr->length = 0; return; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c0dc9c0..c244b08 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -512,7 +512,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ + ? TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ @@ -532,7 +532,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ + ? TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #endif /* TCL_WIDE_INT_IS_LONG */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 5074378..4b87962 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2745,7 +2745,6 @@ MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; * shared by all new objects allocated by Tcl_NewObj. */ -MODULE_SCOPE char * tclEmptyStringRep; MODULE_SCOPE char tclEmptyString; /* @@ -4066,7 +4065,7 @@ typedef const char *TclDTraceStr; TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ - (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->bytes = &tclEmptyString; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TCL_DTRACE_OBJ_CREATE(objPtr) @@ -4083,7 +4082,7 @@ typedef const char *TclDTraceStr; if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \ TCL_DTRACE_OBJ_FREE(objPtr); \ if ((objPtr)->bytes \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ + && ((objPtr)->bytes != &tclEmptyString)) { \ ckfree((objPtr)->bytes); \ } \ (objPtr)->length = -1; \ @@ -4244,7 +4243,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TclInitStringRep(objPtr, bytePtr, len) \ if ((len) == 0) { \ - (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->bytes = &tclEmptyString; \ (objPtr)->length = 0; \ } else { \ (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ @@ -4302,7 +4301,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TclInvalidateStringRep(objPtr) \ if ((objPtr)->bytes != NULL) { \ - if ((objPtr)->bytes != tclEmptyStringRep) { \ + if ((objPtr)->bytes != &tclEmptyString) { \ ckfree((objPtr)->bytes); \ } \ (objPtr)->bytes = NULL; \ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index c9fd333..11374cc 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -374,7 +374,7 @@ Tcl_SetListObj( listRepPtr = NewListIntRep(objc, objv, 1); ListSetIntRep(objPtr, listRepPtr); } else { - objPtr->bytes = tclEmptyStringRep; + objPtr->bytes = &tclEmptyString; objPtr->length = 0; } } @@ -465,7 +465,7 @@ Tcl_ListObjGetElements( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == tclEmptyStringRep) { + if (listPtr->bytes == &tclEmptyString) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; @@ -575,7 +575,7 @@ Tcl_ListObjAppendElement( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == tclEmptyStringRep) { + if (listPtr->bytes == &tclEmptyString) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } @@ -739,7 +739,7 @@ Tcl_ListObjIndex( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == tclEmptyStringRep) { + if (listPtr->bytes == &tclEmptyString) { *objPtrPtr = NULL; return TCL_OK; } @@ -792,7 +792,7 @@ Tcl_ListObjLength( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == tclEmptyStringRep) { + if (listPtr->bytes == &tclEmptyString) { *intPtr = 0; return TCL_OK; } @@ -863,7 +863,7 @@ Tcl_ListObjReplace( Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } if (listPtr->typePtr != &tclListType) { - if (listPtr->bytes == tclEmptyStringRep) { + if (listPtr->bytes == &tclEmptyString) { if (!objc) { return TCL_OK; } @@ -1650,7 +1650,7 @@ TclListObjSetElement( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == tclEmptyStringRep) { + if (listPtr->bytes == &tclEmptyString) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); @@ -1979,7 +1979,7 @@ UpdateStringOfList( */ if (numElems == 0) { - listPtr->bytes = tclEmptyStringRep; + listPtr->bytes = &tclEmptyString; listPtr->length = 0; return; } diff --git a/generic/tclObj.c b/generic/tclObj.c index 90df579..1abbb31 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -49,7 +49,6 @@ Tcl_Mutex tclObjMutex; */ char tclEmptyString = '\0'; -char *tclEmptyStringRep = &tclEmptyString; #if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) /* @@ -1060,7 +1059,7 @@ TclDbInitNewObj( * debugging. */ { objPtr->refCount = 0; - objPtr->bytes = tclEmptyStringRep; + objPtr->bytes = &tclEmptyString; objPtr->length = 0; objPtr->typePtr = NULL; @@ -3395,7 +3394,7 @@ GetBignumFromObj( objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = NULL; if (objPtr->bytes == NULL) { - TclInitStringRep(objPtr, tclEmptyStringRep, 0); + TclInitStringRep(objPtr, &tclEmptyString, 0); } } return TCL_OK; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 68ec2c4..0053041 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2608,7 +2608,7 @@ UpdateStringOfFsPath( pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; - copy->bytes = tclEmptyStringRep; + copy->bytes = &tclEmptyString; copy->length = 0; TclDecrRefCount(copy); } diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 42dd08d..2925c34 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -17,6 +17,8 @@ #include "tclInt.h" +MODULE_SCOPE char *tclEmptyStringRep = &tclEmptyString; + /* * Each invocation of the "package ifneeded" command creates a structure of * the following type, which is used to load the package into the interpreter diff --git a/generic/tclResult.c b/generic/tclResult.c index 6346636..ddf764b 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1015,11 +1015,11 @@ ResetObjResult( Tcl_IncrRefCount(objResultPtr); iPtr->objResultPtr = objResultPtr; } else { - if (objResultPtr->bytes != tclEmptyStringRep) { + if (objResultPtr->bytes != &tclEmptyString) { if (objResultPtr->bytes) { ckfree(objResultPtr->bytes); } - objResultPtr->bytes = tclEmptyStringRep; + objResultPtr->bytes = &tclEmptyString; objResultPtr->length = 0; } TclFreeIntRep(objResultPtr); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index db233b3..c45baa1 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -136,7 +136,7 @@ GrowStringBuffer( char *ptr = NULL; int attempt; - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { objPtr->bytes = NULL; } if (flag == 0 || stringPtr->allocated > 0) { @@ -767,7 +767,7 @@ Tcl_SetObjLength( /* * Need to enlarge the buffer. */ - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { objPtr->bytes = ckalloc(length + 1); } else { objPtr->bytes = ckrealloc(objPtr->bytes, length + 1); @@ -873,7 +873,7 @@ Tcl_AttemptSetObjLength( char *newBytes; - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { newBytes = attemptckalloc(length + 1); } else { newBytes = attemptckrealloc(objPtr->bytes, length + 1); @@ -1202,7 +1202,7 @@ Tcl_AppendObjToObj( * that appending nothing to anything leaves that starting anything... */ - if (appendObjPtr->bytes == tclEmptyStringRep) { + if (appendObjPtr->bytes == &tclEmptyString) { return; } @@ -1213,7 +1213,7 @@ Tcl_AppendObjToObj( * information; this is a special-case optimization only. */ - if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep) + if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString) && TclIsPureByteArray(appendObjPtr)) { /* @@ -3603,7 +3603,7 @@ UpdateStringOfString( stringPtr->allocated = 0; if (stringPtr->numChars == 0) { - TclInitStringRep(objPtr, tclEmptyStringRep, 0); + TclInitStringRep(objPtr, &tclEmptyString, 0); } else { (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode, stringPtr->numChars); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index ba709cc..a4d523a 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1384,7 +1384,7 @@ TclConvertElement( */ if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { - src = tclEmptyStringRep; + src = &tclEmptyString; length = 0; conversion = CONVERT_BRACE; } @@ -2954,7 +2954,7 @@ Tcl_DStringGetResult( if (!iPtr->result[0] && iPtr->objResultPtr && !Tcl_IsShared(iPtr->objResultPtr)) { - if (iPtr->objResultPtr->bytes == tclEmptyStringRep) { + if (iPtr->objResultPtr->bytes == &tclEmptyString) { dsPtr->string = dsPtr->staticSpace; dsPtr->string[0] = 0; dsPtr->length = 0; @@ -2964,7 +2964,7 @@ Tcl_DStringGetResult( dsPtr->length = iPtr->objResultPtr->length; dsPtr->spaceAvl = dsPtr->length + 1; TclFreeIntRep(iPtr->objResultPtr); - iPtr->objResultPtr->bytes = tclEmptyStringRep; + iPtr->objResultPtr->bytes = &tclEmptyString; iPtr->objResultPtr->length = 0; } return; diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 8e97543..9387d05 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -240,7 +240,7 @@ InitializeHostName( } } if (native == NULL) { - native = tclEmptyStringRep; + native = &tclEmptyString; } #else /* !NO_UNAME */ /* -- cgit v0.12 From f3ca0e45dc4faf67ceb9d9cab12b06ca7ed60a6b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 3 Feb 2017 14:29:50 +0000 Subject: Split tclEmptyStringRep declaration over two lines. Otherwise gcc warning. --- generic/tclPkg.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 2925c34..0759faa 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -17,7 +17,9 @@ #include "tclInt.h" -MODULE_SCOPE char *tclEmptyStringRep = &tclEmptyString; +MODULE_SCOPE char *tclEmptyStringRep; + +char *tclEmptyStringRep = &tclEmptyString; /* * Each invocation of the "package ifneeded" command creates a structure of -- cgit v0.12 From 59d58114edd5bd6eef5c80dc0e3a9cf1d59938a1 Mon Sep 17 00:00:00 2001 From: bch Date: Mon, 6 Feb 2017 21:58:48 +0000 Subject: cherrypick typo fix. --- doc/Eval.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Eval.3 b/doc/Eval.3 index 8661923..191bace 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -205,7 +205,7 @@ and sets \fIinterp\fR's result to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code -from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. +from \fBTcl_EvalObjEx\fR other than \fBTCL_OK\fR or \fBTCL_ERROR\fR. .SH KEYWORDS execute, file, global, result, script, value -- cgit v0.12 From 8eedc41ff2550dbd1882d89dd2770074fcfd4bcd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Feb 2017 11:42:12 +0000 Subject: FlightAware feedback: "Aside: Any way to find out what the pkgIndex.tcl file a package was defined in was, or does that happen at too high a level?" Answer: Even though the name of the pkgIndex file is available earlier, it is very well possible to remember it and store it with the other files. This commit does exactly that. --- generic/tclPkg.c | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 0759faa..9ad3cb7 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -32,6 +32,7 @@ typedef struct PkgAvail { char *script; /* Script to invoke to provide this version of * the package. Malloc'ed and protected by * Tcl_Preserve and Tcl_Release. */ + char *pkgIndex; /* Full file name of pkgIndex file */ struct PkgAvail *nextPtr; /* Next in list of available versions of the * same package. */ } PkgAvail; @@ -573,6 +574,9 @@ PkgRequireCore( pkgName->nextPtr = pkgFiles->names; strcpy(pkgName->name, name); pkgFiles->names = pkgName; + if (bestPtr->pkgIndex) { + TclPkgFileSeen(interp, bestPtr->pkgIndex); + } code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ pkgFiles->names = pkgName->nextPtr; @@ -921,6 +925,9 @@ Tcl_PackageObjCmd( pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + } ckfree(availPtr); } ckfree(pkgPtr); @@ -971,6 +978,9 @@ Tcl_PackageObjCmd( return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + } break; } } @@ -981,6 +991,7 @@ Tcl_PackageObjCmd( } if (availPtr == NULL) { availPtr = ckalloc(sizeof(PkgAvail)); + availPtr->pkgIndex = 0; DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { @@ -991,6 +1002,10 @@ Tcl_PackageObjCmd( prevPtr->nextPtr = availPtr; } } + if (iPtr->scriptFile) { + argv4 = TclGetStringFromObj(iPtr->scriptFile, &length); + DupBlock(availPtr->pkgIndex, argv4, (unsigned) length + 1); + } argv4 = TclGetStringFromObj(objv[4], &length); DupBlock(availPtr->script, argv4, (unsigned) length + 1); break; @@ -1346,6 +1361,9 @@ TclFreePackageInfo( pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + } ckfree(availPtr); } ckfree(pkgPtr); -- cgit v0.12 From f0d4f625858cad553260fa36346ff6f023a77473 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Feb 2017 14:32:13 +0000 Subject: Shortcut in TclParseNumber(): If obj is a dict or list, don't bother to generate the string representation if we know already beforehand that the parsing will fail. Use TCL_NO_DEPRECATED in stead of KILL_OCTAL for removing the (deprecated un-prefixed) octal support. Adapt test-cases, so they work without octal support as well. --- generic/tclHistory.c | 5 ++--- generic/tclStrToD.c | 27 +++++++++++++++++---------- tests/get.test | 8 ++++---- tests/parseExpr.test | 5 ++--- 4 files changed, 25 insertions(+), 20 deletions(-) diff --git a/generic/tclHistory.c b/generic/tclHistory.c index b08e352..47806d4 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -62,15 +62,14 @@ Tcl_RecordAndEval( * instead of Tcl_Eval. */ { register Tcl_Obj *cmdPtr; - int length = strlen(cmd); int result; - if (length > 0) { + if (cmd[0]) { /* * Call Tcl_RecordAndEvalObj to do the actual work. */ - cmdPtr = Tcl_NewStringObj(cmd, length); + cmdPtr = Tcl_NewStringObj(cmd, -1); Tcl_IncrRefCount(cmdPtr); result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 6da6df3..77e1839 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -18,13 +18,6 @@ #include /* - * Define KILL_OCTAL to suppress interpretation of numbers with leading zero - * as octal. (Ceterum censeo: numeros octonarios delendos esse.) - */ - -#undef KILL_OCTAL - -/* * This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754 * floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be * uniquely determined by radix and by the widths of significand and exponent. @@ -546,6 +539,20 @@ TclParseNumber( */ if (bytes == NULL) { + if (endPtrPtr == NULL) { + if (objPtr->typePtr == &tclDictType) { + /* A dict can never be a (single) number */ + return TCL_ERROR; + } + if (objPtr->typePtr == &tclListType) { + int length; + /* A list can only be a (single) number if its length == 1 */ + TclListObjLength(NULL, objPtr, &length); + if (length != 1) { + return TCL_ERROR; + } + } + } bytes = TclGetString(objPtr); } @@ -657,7 +664,7 @@ TclParseNumber( state = ZERO_O; break; } -#ifdef KILL_OCTAL +#ifdef TCL_NO_DEPRECATED goto decimal; #endif /* FALLTHROUGH */ @@ -740,7 +747,7 @@ TclParseNumber( goto endgame; } -#ifndef KILL_OCTAL +#ifndef TCL_NO_DEPRECATED /* * Scanned a number with a leading zero that contains an 8, 9, @@ -879,7 +886,7 @@ TclParseNumber( * digits. */ -#ifdef KILL_OCTAL +#ifdef TCL_NO_DEPRECATED decimal: #endif acceptState = state; diff --git a/tests/get.test b/tests/get.test index 7aa06c1..d6a7206 100644 --- a/tests/get.test +++ b/tests/get.test @@ -98,17 +98,17 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} { } {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}} # Bug 7114ac6141 test get-3.3 {tcl_GetInt with iffy numbers} testgetint { - lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} { + lmap x {0 " 0" "0 " " 0 " " 0xa " " 007 " " 0o10 " " 0b10 "} { catch {testgetint 44 $x} x set x } -} {44 44 44 44 54 52 52 46} +} {44 44 44 44 54 51 52 46} test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj { - lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} { + lmap x {0 0.0 " .0" ".0 " " 0e0 " "07" "- 0" "-0" "0o12" "0b10"} { catch {testdoubleobj set 1 $x} x set x } -} {0.0 0.0 0.0 0.0 0.0 {expected floating-point number but got "09" (looks like invalid octal number)} {expected floating-point number but got "- 0"} 0.0 10.0 2.0} +} {0.0 0.0 0.0 0.0 0.0 7.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0} # cleanup ::tcltest::cleanupTests diff --git a/tests/parseExpr.test b/tests/parseExpr.test index fda25b7..47dbec5 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -1044,9 +1044,8 @@ test parseExpr-22.13 {Bug 3401704} -constraints testexprparser -body { } -result {- {} 0 subexpr naner() 1 operator naner 0 {}} test parseExpr-22.14 {Bug 3401704} -constraints testexprparser -body { - catch {testexprparser 08 -1} m o - dict get $o -errorcode -} -result {TCL PARSE EXPR BADNUMBER OCTAL} + testexprparser 07 -1 +} -result {- {} 0 subexpr 07 1 text 07 0 {}} test parseExpr-22.15 {Bug 3401704} -constraints testexprparser -body { catch {testexprparser 0o8 -1} m o dict get $o -errorcode -- cgit v0.12 From 1ff982ffd6785745b647bbe0bb46aca7e13ace8e Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 9 Feb 2017 11:34:43 +0000 Subject: =?UTF-8?q?resolve=20warning:=20enumeration=20value=20=E2=80=98TMR?= =?UTF-8?q?T=5FLAST=E2=80=99=20not=20handled=20in=20switch=20(impossible?= =?UTF-8?q?=20to=20handle=20in=20switch=20because=20of=20break);?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- generic/tclCmdMZ.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index c660596..319799c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4089,7 +4089,7 @@ Tcl_TimeRateObjCmd( i++; break; } - switch ((enum options) index) { + switch (index) { case TMRT_EV_DIRECT: direct = objv[i]; break; -- cgit v0.12 From fb811680f60f0555a27685601c519ff931956593 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 9 Feb 2017 11:36:17 +0000 Subject: [timerate] bug fix: missing scale conversion by Mac OSX on platform where high resolution clicks are not microseconds based; [win] use high resolution timer for the wide clicks and microseconds directly, prevent several forwards/backwards conversions; [win, unix, mac-osx] normalize some functions for common usage in different time units (clicks, micro- and nanoseconds) --- generic/tclClock.c | 9 +-- generic/tclCmdMZ.c | 24 +++++--- generic/tclInt.h | 16 ++++++ unix/tclUnixTime.c | 71 +++++++++++++++++++++++ win/tclWinTime.c | 166 ++++++++++++++++++++++++++++++++++++++++++----------- 5 files changed, 238 insertions(+), 48 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 27009fd..5da9511 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1760,8 +1760,7 @@ ClockClicksObjCmd( #endif break; case CLICKS_MICROS: - Tcl_GetTime(&now); - clicks = ((Tcl_WideInt) now.sec * 1000000) + now.usec; + clicks = TclpGetMicroseconds(); break; } @@ -1831,15 +1830,11 @@ ClockMicrosecondsObjCmd( int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter values */ { - Tcl_Time now; - if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - Tcl_GetTime(&now); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - ((Tcl_WideInt) now.sec * 1000000) + now.usec)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds())); return TCL_OK; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 319799c..b0212c3 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4215,16 +4215,19 @@ usage: } /* get start and stop time */ -#ifndef TCL_WIDE_CLICKS +#ifdef TCL_WIDE_CLICKS + start = middle = TclpGetWideClicks(); + /* time to stop execution (in wide clicks) */ + stop = start + (maxms * 1000 / TclpWideClickInMicrosec()); +#else Tcl_GetTime(&now); start = now.sec; start *= 1000000; start += now.usec; -#else - start = TclpGetWideClicks(); + middle = start; + /* time to stop execution (in microsecs) */ + stop = start + maxms * 1000; #endif /* start measurement */ - stop = start + maxms * 1000; - middle = start; while (1) { /* eval single iteration */ count++; @@ -4246,11 +4249,11 @@ usage: if (--threshold > 0) continue; /* check stop time reached, estimate new threshold */ - #ifndef TCL_WIDE_CLICKS + #ifdef TCL_WIDE_CLICKS + middle = TclpGetWideClicks(); + #else Tcl_GetTime(&now); middle = now.sec; middle *= 1000000; middle += now.usec; - #else - middle = TclpGetWideClicks(); #endif if (middle >= stop) { break; @@ -4274,6 +4277,11 @@ usage: middle -= start; /* execution time in microsecs */ + #ifdef TCL_WIDE_CLICKS + /* convert execution time in wide clicks to microsecs */ + middle *= TclpWideClickInMicrosec(); + #endif + /* if not calibrate */ if (!calibrate) { /* minimize influence of measurement overhead */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 1b37d84..fb0bcb7 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3189,7 +3189,23 @@ MODULE_SCOPE void TclFinalizeThreadStorage(void); #ifdef TCL_WIDE_CLICKS MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); +MODULE_SCOPE double TclpWideClickInMicrosec(void); +#else +# ifdef _WIN32 +# define TCL_WIDE_CLICKS 1 +MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); +# define TclpWideClicksToNanoseconds(clicks) \ + ((double)(clicks) * 1000) +# define TclpWideClickInMicrosec() (1) +# endif #endif +#ifndef _WIN32 +MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void); +#else +# define TclpGetMicroseconds() \ + TclpGetWideClicks() +#endif + MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index d634449..8ec6e8a 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -84,6 +84,32 @@ TclpGetSeconds(void) /* *---------------------------------------------------------------------- * + * TclpGetMicroseconds -- + * + * This procedure returns the number of microseconds from the epoch. + * On most Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * + * Results: + * Number of microseconds from the epoch. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_WideInt +TclpGetMicroseconds(void) +{ + Tcl_Time time; + + tclGetTimeProcPtr(&time, tclTimeClientData); + return ((Tcl_WideInt)time.sec)*1000000 + time.usec; +} + +/* + *---------------------------------------------------------------------- + * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution @@ -216,6 +242,51 @@ TclpWideClicksToNanoseconds( return nsec; } + +/* + *---------------------------------------------------------------------- + * + * TclpWideClickInMicrosec -- + * + * This procedure return scale to convert click values from the + * TclpGetWideClicks native resolution to microsecond resolution + * and back. + * + * Results: + * 1 click in microseconds as double. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +double +TclpWideClickInMicrosec(void) +{ + if (tclGetTimeProcPtr != NativeGetTime) { + return 1.0; + } else { +#ifdef MAC_OSX_TCL + static int initialized = 0; + static double scale = 0.0; + + if (initialized) { + return scale; + } else { + mach_timebase_info_data_t tb; + + mach_timebase_info(&tb); + /* value of tb.numer / tb.denom = 1 click in nanoseconds */ + scale = ((double)tb.numer) / tb.denom / 1000; + initialized = 1; + return scale; + } +#else +#error Wide high-resolution clicks not implemented on this platform +#endif + } +} #endif /* TCL_WIDE_CLICKS */ /* diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 81d9458..06ea6cd 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -123,6 +123,7 @@ static Tcl_WideInt AccumulateSample(Tcl_WideInt perfCounter, Tcl_WideUInt fileTime); static void NativeScaleTime(Tcl_Time* timebuf, ClientData clientData); +static Tcl_WideInt NativeGetMicroseconds(void); static void NativeGetTime(Tcl_Time* timebuf, ClientData clientData); @@ -154,10 +155,19 @@ ClientData tclTimeClientData = NULL; unsigned long TclpGetSeconds(void) { - Tcl_Time t; + Tcl_WideInt usecSincePosixEpoch; - tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */ - return t.sec; + /* Try to use high resolution timer */ + if ( tclGetTimeProcPtr == NativeGetTime + && (usecSincePosixEpoch = NativeGetMicroseconds()) + ) { + return usecSincePosixEpoch / 1000000; + } else { + Tcl_Time t; + + tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */ + return t.sec; + } } /* @@ -182,19 +192,66 @@ TclpGetSeconds(void) unsigned long TclpGetClicks(void) { - /* - * Use the Tcl_GetTime abstraction to get the time in microseconds, as - * nearly as we can, and return it. - */ + Tcl_WideInt usecSincePosixEpoch; - Tcl_Time now; /* Current Tcl time */ - unsigned long retval; /* Value to return */ + /* Try to use high resolution timer */ + if ( tclGetTimeProcPtr == NativeGetTime + && (usecSincePosixEpoch = NativeGetMicroseconds()) + ) { + return (unsigned long)usecSincePosixEpoch; + } else { + /* + * Use the Tcl_GetTime abstraction to get the time in microseconds, as + * nearly as we can, and return it. + */ - tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ + Tcl_Time now; /* Current Tcl time */ - retval = (now.sec * 1000000) + now.usec; - return retval; + tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ + return (unsigned long)(now.sec * 1000000) + now.usec; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetWideClicks -- + * + * This procedure returns a WideInt value that represents the highest + * resolution clock in microseconds available on the system. + * + * Results: + * Number of microseconds (from the epoch). + * + * Side effects: + * This should be used for time-delta resp. for measurement purposes + * only, because on some platforms can return microseconds from some + * start time (not from the epoch). + * + *---------------------------------------------------------------------- + */ + +Tcl_WideInt +TclpGetWideClicks(void) +{ + Tcl_WideInt usecSincePosixEpoch; + + /* Try to use high resolution timer */ + if ( tclGetTimeProcPtr == NativeGetTime + && (usecSincePosixEpoch = NativeGetMicroseconds()) + ) { + return usecSincePosixEpoch; + } else { + /* + * Use the Tcl_GetTime abstraction to get the time in microseconds, as + * nearly as we can, and return it. + */ + + Tcl_Time now; + tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ + return (((Tcl_WideInt)now.sec) * 1000000) + now.usec; + } } /* @@ -223,7 +280,17 @@ void Tcl_GetTime( Tcl_Time *timePtr) /* Location to store time information. */ { - tclGetTimeProcPtr(timePtr, tclTimeClientData); + Tcl_WideInt usecSincePosixEpoch; + + /* Try to use high resolution timer */ + if ( tclGetTimeProcPtr == NativeGetTime + && (usecSincePosixEpoch = NativeGetMicroseconds()) + ) { + timePtr->sec = (long) (usecSincePosixEpoch / 1000000); + timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); + } else { + tclGetTimeProcPtr(timePtr, tclTimeClientData); + } } /* @@ -256,13 +323,14 @@ NativeScaleTime( /* *---------------------------------------------------------------------- * - * NativeGetTime -- + * NativeGetMicroseconds -- * - * TIP #233: Gets the current system time in seconds and microseconds - * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * Gets the current system time in microseconds since the beginning + * of the epoch: 00:00 UCT, January 1, 1970. * * Results: - * Returns the current time in timePtr. + * Returns the wide integer with number of microseconds from the epoch, or + * 0 if high resolution timer is not available. * * Side effects: * On the first call, initializes a set of static variables to keep track @@ -275,13 +343,9 @@ NativeScaleTime( *---------------------------------------------------------------------- */ -static void -NativeGetTime( - Tcl_Time *timePtr, - ClientData clientData) +static Tcl_WideInt +NativeGetMicroseconds(void) { - struct _timeb t; - /* * Initialize static storage on the first trip through. * @@ -432,9 +496,7 @@ NativeGetTime( if (curCounter.QuadPart <= perfCounterLastCall.QuadPart) { usecSincePosixEpoch = (fileTimeLastCall.QuadPart - posixEpoch.QuadPart) / 10; - timePtr->sec = (long) (usecSincePosixEpoch / 1000000); - timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); - return; + return usecSincePosixEpoch; } /* @@ -455,19 +517,57 @@ NativeGetTime( * 10000000 / curCounterFreq.QuadPart); usecSincePosixEpoch = (curFileTime - posixEpoch.QuadPart) / 10; - timePtr->sec = (long) (usecSincePosixEpoch / 1000000); - timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); - return; + return usecSincePosixEpoch; } } /* - * High resolution timer is not available. Just use ftime. + * High resolution timer is not available. */ + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * NativeGetTime -- + * + * TIP #233: Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * See NativeGetMicroseconds for more information. + * + *---------------------------------------------------------------------- + */ - _ftime(&t); - timePtr->sec = (long)t.time; - timePtr->usec = t.millitm * 1000; +static void +NativeGetTime( + Tcl_Time *timePtr, + ClientData clientData) +{ + Tcl_WideInt usecSincePosixEpoch; + + /* + * Try to use high resolution timer. + */ + if ( (usecSincePosixEpoch = NativeGetMicroseconds()) ) { + timePtr->sec = (long) (usecSincePosixEpoch / 1000000); + timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); + } else { + /* + * High resolution timer is not available. Just use ftime. + */ + + struct _timeb t; + + _ftime(&t); + timePtr->sec = (long)t.time; + timePtr->usec = t.millitm * 1000; + } } /* -- cgit v0.12 From c88fb138612db4499a9e841453cd14bfd5db7224 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 9 Feb 2017 13:45:14 +0000 Subject: =?UTF-8?q?[win]=20accomplished=20winTime=20module=20using=20very?= =?UTF-8?q?=20fast=20wide=20clicks,=20with=20denominator=20scale=20to/from?= =?UTF-8?q?=20microseconds,=20and=20therefore=20more=20precise=20"timerate?= =?UTF-8?q?"=20results=20under=20windows=20(using=20similar=20mechanisms?= =?UTF-8?q?=20as=20by=20Mac=20OSX).=20Especially=20multi-threaded,=20becau?= =?UTF-8?q?se=20it=20works=20without=20lock=20opposite=20to=20microseconds?= =?UTF-8?q?=20(that=20use=20crictical=20section,=20because=20of=20the=20ca?= =?UTF-8?q?libration=20thread).=20The=20reason=20for=20usage=20of=20wide?= =?UTF-8?q?=20clicks=20instead=20microseconds=20explains=20following=20exa?= =?UTF-8?q?mple=20(shows=2020%=20performance=20deference):=20%=20timerate?= =?UTF-8?q?=20-calibrate=20{}=20%=20timerate=20{clock=20microseconds}=2050?= =?UTF-8?q?00=200.297037=20=C2=B5s/#=2014465901=20#=203366585=20#/sec=2042?= =?UTF-8?q?96.906=20nett-ms=20%=20timerate=20{clock=20clicks}=205000=200.2?= =?UTF-8?q?47797=20=C2=B5s/#=2016869084=20#=204035554=20#/sec=204180.116?= =?UTF-8?q?=20nett-ms?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- generic/tclInt.h | 10 ++---- win/tclWinTime.c | 107 +++++++++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 103 insertions(+), 14 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index fb0bcb7..3c21de0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3186,6 +3186,7 @@ MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer, MODULE_SCOPE void TclInitThreadStorage(void); MODULE_SCOPE void TclFinalizeThreadDataThread(void); MODULE_SCOPE void TclFinalizeThreadStorage(void); + #ifdef TCL_WIDE_CLICKS MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); @@ -3194,17 +3195,12 @@ MODULE_SCOPE double TclpWideClickInMicrosec(void); # ifdef _WIN32 # define TCL_WIDE_CLICKS 1 MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); +MODULE_SCOPE double TclpWideClickInMicrosec(void); # define TclpWideClicksToNanoseconds(clicks) \ - ((double)(clicks) * 1000) -# define TclpWideClickInMicrosec() (1) + ((double)(clicks) * TclpWideClickInMicrosec() * 1000) # endif #endif -#ifndef _WIN32 MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void); -#else -# define TclpGetMicroseconds() \ - TclpGetWideClicks() -#endif MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 06ea6cd..7cbc1ba 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -110,6 +110,17 @@ static TimeInfo timeInfo = { }; /* + * Scale to convert wide click values from the TclpGetWideClicks native + * resolution to microsecond resolution and back. + */ +static struct { + int initialized; /* 1 if initialized, 0 otherwise */ + int perfCounter; /* 1 if performance counter usable for wide clicks */ + double microsecsScale; /* Denominator scale between clock / microsecs */ +} wideClick = {0, 0.0}; + + +/* * Declarations for functions defined later in this file. */ @@ -221,7 +232,7 @@ TclpGetClicks(void) * resolution clock in microseconds available on the system. * * Results: - * Number of microseconds (from the epoch). + * Number of microseconds (from some start time). * * Side effects: * This should be used for time-delta resp. for measurement purposes @@ -234,6 +245,87 @@ TclpGetClicks(void) Tcl_WideInt TclpGetWideClicks(void) { + LARGE_INTEGER curCounter; + + if (!wideClick.initialized) { + LARGE_INTEGER perfCounterFreq; + + /* + * The frequency of the performance counter is fixed at system boot and + * is consistent across all processors. Therefore, the frequency need + * only be queried upon application initialization. + */ + if (QueryPerformanceFrequency(&perfCounterFreq)) { + wideClick.perfCounter = 1; + wideClick.microsecsScale = 1000000.0 / perfCounterFreq.QuadPart; + } else { + /* fallback using microseconds */ + wideClick.perfCounter = 0; + wideClick.microsecsScale = 1; + } + + wideClick.initialized = 1; + } + if (wideClick.perfCounter) { + if (QueryPerformanceCounter(&curCounter)) { + return (Tcl_WideInt)curCounter.QuadPart; + } + /* fallback using microseconds */ + wideClick.perfCounter = 0; + wideClick.microsecsScale = 1; + return TclpGetMicroseconds(); + } else { + return TclpGetMicroseconds(); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpWideClickInMicrosec -- + * + * This procedure return scale to convert wide click values from the + * TclpGetWideClicks native resolution to microsecond resolution + * and back. + * + * Results: + * 1 click in microseconds as double. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +double +TclpWideClickInMicrosec(void) +{ + if (!wideClick.initialized) { + (void)TclpGetWideClicks(); /* initialize */ + } + return wideClick.microsecsScale; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetMicroseconds -- + * + * This procedure returns a WideInt value that represents the highest + * resolution clock in microseconds available on the system. + * + * Results: + * Number of microseconds (from the epoch). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_WideInt +TclpGetMicroseconds(void) +{ Tcl_WideInt usecSincePosixEpoch; /* Try to use high resolution timer */ @@ -346,6 +438,9 @@ NativeScaleTime( static Tcl_WideInt NativeGetMicroseconds(void) { + static LARGE_INTEGER posixEpoch; + /* Posix epoch expressed as 100-ns ticks since + * the windows epoch. */ /* * Initialize static storage on the first trip through. * @@ -356,6 +451,10 @@ NativeGetMicroseconds(void) if (!timeInfo.initialized) { TclpInitLock(); if (!timeInfo.initialized) { + + posixEpoch.LowPart = 0xD53E8000; + posixEpoch.HighPart = 0x019DB1DE; + timeInfo.perfCounterAvailable = QueryPerformanceFrequency(&timeInfo.nominalFreq); @@ -468,15 +567,9 @@ NativeGetMicroseconds(void) /* Current performance counter. */ Tcl_WideInt curFileTime;/* Current estimated time, expressed as 100-ns * ticks since the Windows epoch. */ - static LARGE_INTEGER posixEpoch; - /* Posix epoch expressed as 100-ns ticks since - * the windows epoch. */ Tcl_WideInt usecSincePosixEpoch; /* Current microseconds since Posix epoch. */ - posixEpoch.LowPart = 0xD53E8000; - posixEpoch.HighPart = 0x019DB1DE; - QueryPerformanceCounter(&curCounter); /* -- cgit v0.12 From 3d6a406232dc52b9f475ef7ef3cfa77f8fa01b35 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Feb 2017 14:25:08 +0000 Subject: On Windows, Cygwin and 64-bit platforms, no need to handle 'long' in tclLink.c, since its size is equal to either 'int' or 'Tcl_WideInt'. This enhances interoperabilty between win64 extensions loaded in cygwin64 using Tcl_LinkVar(), whill still being 100% compatible. init.tcl: unnecessary spacing. --- generic/tcl.h | 5 +++++ generic/tclLink.c | 16 ++++++++++++++++ library/init.tcl | 4 ++-- 3 files changed, 23 insertions(+), 2 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index c0cee27..d678229 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1147,8 +1147,13 @@ typedef struct Tcl_DString { #define TCL_LINK_SHORT 8 #define TCL_LINK_USHORT 9 #define TCL_LINK_UINT 10 +#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__) +#define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT) +#define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT) +#else #define TCL_LINK_LONG 11 #define TCL_LINK_ULONG 12 +#endif #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 #define TCL_LINK_READ_ONLY 0x80 diff --git a/generic/tclLink.c b/generic/tclLink.c index 1507804..a39dfcd 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -36,8 +36,10 @@ typedef struct Link { unsigned int ui; short s; unsigned short us; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) long l; unsigned long ul; +#endif Tcl_WideInt w; Tcl_WideUInt uw; float f; @@ -129,6 +131,14 @@ Tcl_LinkVar( Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; linkPtr->type = type & ~TCL_LINK_READ_ONLY; +#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \ + || defined(_WIN32) || defined(__CYGWIN__)) + if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) { + linkPtr->type = TCL_LINK_LONG; + } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) { + linkPtr->type = TCL_LINK_ULONG; + } +#endif if (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; } else { @@ -335,12 +345,14 @@ LinkTraceProc( case TCL_LINK_UINT: changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); break; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: changed = (LinkedVar(long) != linkPtr->lastValue.l); break; case TCL_LINK_ULONG: changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); break; +#endif case TCL_LINK_FLOAT: changed = (LinkedVar(float) != linkPtr->lastValue.f); break; @@ -483,6 +495,7 @@ LinkTraceProc( LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide; break; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) @@ -504,6 +517,7 @@ LinkTraceProc( } LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide; break; +#endif case TCL_LINK_WIDE_UINT: /* @@ -597,12 +611,14 @@ ObjValue( case TCL_LINK_UINT: linkPtr->lastValue.ui = LinkedVar(unsigned int); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui); +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: linkPtr->lastValue.l = LinkedVar(long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l); case TCL_LINK_ULONG: linkPtr->lastValue.ul = LinkedVar(unsigned long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); +#endif case TCL_LINK_FLOAT: linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); diff --git a/library/init.tcl b/library/init.tcl index 49a523c..fac1722 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -470,9 +470,9 @@ proc auto_load {cmd {namespace {}}} { proc ::tcl::Pkg::source {filename} { if {[interp issafe]} { - uplevel 1 [list ::source $filename] + uplevel 1 [list ::source $filename] } else { - uplevel 1 [list ::source -nopkg $filename] + uplevel 1 [list ::source -nopkg $filename] } } -- cgit v0.12 From 3b5e7e9792b9b34111146557a3353756711b8133 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Feb 2017 14:04:15 +0000 Subject: More internal use of size_t in stead of int, e.g. for epoch's --- generic/tclBasic.c | 2 +- generic/tclCompile.h | 2 +- generic/tclEnsemble.c | 2 +- generic/tclIO.c | 2 +- generic/tclIO.h | 2 +- generic/tclInt.h | 12 ++++++------ generic/tclObj.c | 6 +++--- 7 files changed, 14 insertions(+), 14 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 63c5590..6ff5faa 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4705,7 +4705,7 @@ TEOV_RunEnterTraces( { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + size_t newEpoch, cmdEpoch = cmdPtr->cmdEpoch; int length, traceCode = TCL_OK; const char *command = TclGetStringFromObj(commandPtr, &length); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5ef154e..5bc3e81 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -425,7 +425,7 @@ typedef struct ByteCode { * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ - int nsEpoch; /* Value of nsPtr->resolverEpoch when this + size_t nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 6ada155..f3e8187 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -92,7 +92,7 @@ static const Tcl_ObjType ensembleCmdType = { */ typedef struct { - int epoch; /* Used to confirm when the data in this + size_t epoch; /* Used to confirm when the data in this * really structure matches up with the * ensemble. */ Command *token; /* Reference to the command for which this diff --git a/generic/tclIO.c b/generic/tclIO.c index 506e6d5..6bf8451 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -321,7 +321,7 @@ static int WillRead(Channel *chanPtr); typedef struct ResolvedChanName { ChannelState *statePtr; /* The saved lookup result */ Tcl_Interp *interp; /* The interp in which the lookup was done. */ - int epoch; /* The epoch of the channel when the lookup + size_t epoch; /* The epoch of the channel when the lookup * was done. Use to verify validity. */ size_t refCount; /* Share this struct among many Tcl_Obj. */ } ResolvedChanName; diff --git a/generic/tclIO.h b/generic/tclIO.h index ffbfa31..07c54fa 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -214,7 +214,7 @@ typedef struct ChannelState { * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ - int epoch; /* Used to test validity of stored channelname + size_t epoch; /* Used to test validity of stored channelname * lookup results. */ } ChannelState; diff --git a/generic/tclInt.h b/generic/tclInt.h index 4b87962..f078d18 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -265,7 +265,7 @@ typedef struct Namespace { * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif - long nsId; /* Unique id for the namespace. */ + size_t nsId; /* Unique id for the namespace. */ Tcl_Interp *interp; /* The interpreter containing this * namespace. */ int flags; /* OR-ed combination of the namespace status @@ -299,12 +299,12 @@ typedef struct Namespace { * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - int cmdRefEpoch; /* Incremented if a newly added command + size_t cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ - int resolverEpoch; /* Incremented whenever (a) the name + size_t resolverEpoch; /* Incremented whenever (a) the name * resolution rules change for this namespace * or (b) a newly added command shadows a * command that is compiled to bytecodes. This @@ -331,7 +331,7 @@ typedef struct Namespace { * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - int exportLookupEpoch; /* Incremented whenever a command is added to + size_t exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be @@ -432,7 +432,7 @@ typedef struct EnsembleConfig { * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - int epoch; /* The epoch at which this ensemble's table of + size_t epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same @@ -1639,7 +1639,7 @@ typedef struct Command { * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - int cmdEpoch; /* Incremented to invalidate any references + size_t cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL diff --git a/generic/tclObj.c b/generic/tclObj.c index 1abbb31..7ec259f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -344,17 +344,17 @@ typedef struct ResolvedCmdName { * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - long refNsId; /* refNsPtr's unique namespace id. Used to + size_t refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid (e.g., * it's possible that the cmd's containing * namespace was deleted and a new one created * at the same address). */ - int refNsCmdEpoch; /* Value of the referencing namespace's + size_t refNsCmdEpoch; /* Value of the referencing namespace's * cmdRefEpoch when the pointer was cached. * Before using the cached pointer, we check * if the namespace's epoch was incremented; * if so, this cached pointer is invalid. */ - int cmdEpoch; /* Value of the command's cmdEpoch when this + size_t cmdEpoch; /* Value of the command's cmdEpoch when this * pointer was cached. Before using the cached * pointer, we check if the cmd's epoch was * incremented; if so, the cmd was renamed, -- cgit v0.12 From 08192ab42f794f6a486fdc21a537cce794f04472 Mon Sep 17 00:00:00 2001 From: avl Date: Sun, 5 Mar 2017 15:05:48 +0000 Subject: Fix for Ticket [71c0878b71] + test cases --- generic/tclStrToD.c | 2 +- tests/incr.test | 12 ++++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 77e1839..224ab45 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -539,7 +539,7 @@ TclParseNumber( */ if (bytes == NULL) { - if (endPtrPtr == NULL) { + if (interp == NULL && endPtrPtr == NULL) { if (objPtr->typePtr == &tclDictType) { /* A dict can never be a (single) number */ return TCL_ERROR; diff --git a/tests/incr.test b/tests/incr.test index 9243be0..aa2872a 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -494,6 +494,18 @@ test incr-2.31 {incr command (compiled): bad increment} { (reading increment) invoked from within "incr x 1a"}} +test incr-2.32 {incr command (compiled): bad pure list increment} { + list [catch {incr x [list 1 2]} msg] $msg $::errorInfo +} {1 {expected integer but got "1 2"} {expected integer but got "1 2" + (reading increment) + invoked from within +"incr x [list 1 2]"}} +test incr-2.33 {incr command (compiled): bad pure dict increment} { + list [catch {incr x [dict create 1 2]} msg] $msg $::errorInfo +} {1 {expected integer but got "1 2"} {expected integer but got "1 2" + (reading increment) + invoked from within +"incr x [dict create 1 2]"}} test incr-3.1 {increment by wide amount: bytecode route} { set x 0 -- cgit v0.12 From db083499bfff8aee794512e3da2f0ad2f201f6b0 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 7 Mar 2017 11:35:03 +0000 Subject: timerate: don't calculate threshold by too few iterations, because sometimes first iteration(s) can be too fast (cached, delayed clean up, etc). --- generic/tclCmdMZ.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 14ff5f0..b62ccf8 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4282,6 +4282,13 @@ usage: if (middle >= stop) { break; } + + /* don't calculate threshold by few iterations, because sometimes + * first iteration(s) can be too fast (cached, delayed clean up, etc) */ + if (count < 10) { + threshold = 1; continue; + } + /* average iteration time in microsecs */ threshold = (middle - start) / count; if (threshold > maxIterTm) { -- cgit v0.12