From 9d8f556865a0a282039621759755c0cf44664039 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 15 Nov 2012 20:25:01 +0000 Subject: Contributed patch from Andy Goth. --- generic/tclBinary.c | 91 ++++++++++++++++++++++++++++++++++++++--------------- tests/binary.test | 21 +++++++++++++ 2 files changed, 86 insertions(+), 26 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 3d8b24c..b29f1d8 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2658,7 +2658,7 @@ BinaryDecode64( Tcl_Obj *const objv[]) { Tcl_Obj *resultObj = NULL; - unsigned char *data, *datastart, *dataend, c; + unsigned char *data, *datastart, *dataend, c = '\0'; unsigned char *begin = NULL; unsigned char *cursor = NULL; int strict = 0; @@ -2691,43 +2691,82 @@ BinaryDecode64( while (data < dataend) { unsigned long value = 0; - for (i=0 ; i<4 ; i++) { + /* + * Decode the current block. Each base64 block consists of four input + * characters A-Z, a-z, 0-9, +, or /. Each character supplies six bits + * of output data, so each block's output is 24 bits (three bytes) in + * length. The final block can be shorter by one or two bytes, denoted + * by the input ending with one or two ='s, respectively. + */ + for (i = 0; i < 4; i++) { + /* + * Get the next input character. At end of input, pad with at most + * two ='s. If more than two ='s would be needed, instead discard + * the block read thus far. + */ if (data < dataend) { c = *data++; + } else if (i > 1) { + c = '='; + } else { + cut += 3; + break; + } - if (c >= 'A' && c <= 'Z') { - value = (value << 6) | ((c - 'A') & 0x3f); - } else if (c >= 'a' && c <= 'z') { - value = (value << 6) | ((c - 'a' + 26) & 0x3f); - } else if (c >= '0' && c <= '9') { - value = (value << 6) | ((c - '0' + 52) & 0x3f); - } else if (c == '+') { - value = (value << 6) | 0x3e; - } else if (c == '/') { - value = (value << 6) | 0x3f; - } else if (c == '=') { - value <<= 6; - if (cut < 2) { - cut++; - } + /* + * Load the character into the block value. Handle ='s specially + * because they're only valid as the last character or two of the + * final block of input. Unless strict mode is enabled, skip any + * input whitespace characters. + */ + if (cut) { + if (c == '=' && i > 1) { + value <<= 6; + cut++; + } else if (!strict && isspace(c)) { + i--; } else { - if (strict || !isspace(c)) { - goto bad64; - } - i--; - continue; + goto bad64; } - } else { + } else if (c >= 'A' && c <= 'Z') { + value = (value << 6) | ((c - 'A') & 0x3f); + } else if (c >= 'a' && c <= 'z') { + value = (value << 6) | ((c - 'a' + 26) & 0x3f); + } else if (c >= '0' && c <= '9') { + value = (value << 6) | ((c - '0' + 52) & 0x3f); + } else if (c == '+') { + value = (value << 6) | 0x3e; + } else if (c == '/') { + value = (value << 6) | 0x3f; + } else if (c == '=') { value <<= 6; cut++; + } else if (strict || !isspace(c)) { + goto bad64; + } else { + i--; } } *cursor++ = UCHAR((value >> 16) & 0xff); *cursor++ = UCHAR((value >> 8) & 0xff); *cursor++ = UCHAR(value & 0xff); - } - if (cut > size) { - cut = size; + + /* + * Since = is only valid within the final block, if it was encountered + * but there are still more input characters, confirm that strict mode + * is off and all subsequent characters are whitespace. + */ + if (cut && data < dataend) { + if (strict) { + goto bad64; + } else { + for (; data < dataend; data++) { + if (!isspace(*data)) { + goto bad64; + } + } + } + } } Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); Tcl_SetObjResult(interp, resultObj); diff --git a/tests/binary.test b/tests/binary.test index 6c00508..ccd0f29 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2642,6 +2642,27 @@ test binary-73.23 {binary decode base64} -body { test binary-73.24 {binary decode base64} -body { string length [binary decode base64 " "] } -result 0 +test binary-73.25 {binary decode base64} -body { + list [string length [set r [binary decode base64 WA==\n]]] $r +} -result {1 X} +test binary-73.26 {binary decode base64} -body { + list [string length [set r [binary decode base64 WFk=\n]]] $r +} -result {2 XY} +test binary-73.27 {binary decode base64} -body { + list [string length [set r [binary decode base64 WFla\n]]] $r +} -result {3 XYZ} +test binary-73.28 {binary decode base64} -body { + list [string length [set r [binary decode base64 -strict WA==\n]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} +test binary-73.29 {binary decode base64} -body { + list [string length [set r [binary decode base64 -strict WFk=\n]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} +test binary-73.30 {binary decode base64} -body { + list [string length [set r [binary decode base64 -strict WFla\n]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} +test binary-73.31 {binary decode base64} -body { + list [string length [set r [binary decode base64 WA==WFla]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} test binary-74.1 {binary encode uuencode} -body { binary encode uuencode -- cgit v0.12 From 2742530e9d84e0347a415ae41cc5057a80a23d35 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 20 Nov 2012 12:04:51 +0000 Subject: very minor style tweaks --- generic/tclBinary.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index b29f1d8..5c33308 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2663,7 +2663,7 @@ BinaryDecode64( unsigned char *cursor = NULL; int strict = 0; int i, index, size, cut = 0, count = 0; - enum {OPT_STRICT }; + enum { OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { @@ -2698,12 +2698,14 @@ BinaryDecode64( * length. The final block can be shorter by one or two bytes, denoted * by the input ending with one or two ='s, respectively. */ + for (i = 0; i < 4; i++) { /* * Get the next input character. At end of input, pad with at most * two ='s. If more than two ='s would be needed, instead discard * the block read thus far. */ + if (data < dataend) { c = *data++; } else if (i > 1) { @@ -2719,6 +2721,7 @@ BinaryDecode64( * final block of input. Unless strict mode is enabled, skip any * input whitespace characters. */ + if (cut) { if (c == '=' && i > 1) { value <<= 6; @@ -2756,14 +2759,14 @@ BinaryDecode64( * but there are still more input characters, confirm that strict mode * is off and all subsequent characters are whitespace. */ + if (cut && data < dataend) { if (strict) { goto bad64; - } else { - for (; data < dataend; data++) { - if (!isspace(*data)) { - goto bad64; - } + } + for (; data < dataend; data++) { + if (!isspace(*data)) { + goto bad64; } } } -- cgit v0.12 From 0b73c62416cae2c14de0924d798addd849cb5ac2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 22 Nov 2012 08:45:39 +0000 Subject: Fix bug reported by Brian Griffin:

[http://code.activestate.com/lists/tcl-core/12524/] --- generic/tclIndexObj.c | 4 ---- 1 file changed, 4 deletions(-) diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 1076e32..cc50fd3 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -207,10 +207,6 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, entryPtr = NEXT_ENTRY(entryPtr, offset), i++) { for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { if (*p1 == '\0') { - if (p1 == key) { - /* empty keys never match */ - continue; - } index = i; goto done; } -- cgit v0.12 From d75ffb6da4c2a55321744117c7e7ae7943392060 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 26 Nov 2012 15:27:44 +0000 Subject: doc formatting goofs --- doc/Load.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Load.3 b/doc/Load.3 index 9602b77..bbfc662 100644 --- a/doc/Load.3 +++ b/doc/Load.3 @@ -31,7 +31,7 @@ Array of names of symbols to be resolved during the load of the library, or NULL if no symbols are to be resolved. If an array is given, the last entry in the array must be NULL. .AP int flags in -The value should normally be 0, but \fITCL_LOAD_GLOBALfR or \fITCL_LOAD_LAZYfR +The value should normally be 0, but \fITCL_LOAD_GLOBAL\fR or \fITCL_LOAD_LAZY\fR or a combination of those two is allowed as well. .AP void *procPtrs out Points to an array that will hold the addresses of the functions described in -- cgit v0.12 From 3c5b4af0d42e9175d48a6e114ec5f3ec05e1b915 Mon Sep 17 00:00:00 2001 From: max Date: Mon, 26 Nov 2012 17:40:29 +0000 Subject: Factor out creation of the -sockname and -peername lists from TcpGetOptionProc() to TcpHostPortList(). Make it robust against implementations of getnameinfo() that error out if reverse mapping fails instead of falling back to the numeric representation. --- ChangeLog | 8 ++++ unix/tclUnixSock.c | 118 +++++++++++++++++++++++++++++++---------------------- 2 files changed, 78 insertions(+), 48 deletions(-) diff --git a/ChangeLog b/ChangeLog index 9b4772c..c9d3cb3 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-11-26 Reinhard Max + + * unix/tclUnixSock.c: Factor out creation of the -sockname and + -peername lists from TcpGetOptionProc() to TcpHostPortList(). + Make it robust against implementations of getnameinfo() that error + out if reverse mapping fails instead of falling back to the + numeric representation. + 2012-11-20 Donal K. Fellows * generic/tclBinary.c (BinaryDecode64): [Bug 3033307]: Corrected diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 102c620..31daa62 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -627,6 +627,74 @@ TcpClose2Proc( /* *---------------------------------------------------------------------- * + * TcpHostPortList -- + * + * This function is called by the -gethostname and -getpeername + * switches of TcpGetOptionProc() to add three list elements + * with the textual representation of the given address to the + * given DString. + * + * Results: + * None. + * + * Side effects: + * Adds three elements do dsPtr + * + *---------------------------------------------------------------------- + */ +static void +TcpHostPortList( + Tcl_Interp *interp, + Tcl_DString *dsPtr, + address addr, + socklen_t salen) +{ +#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" + char host[NI_MAXHOST], nhost[NI_MAXHOST], nport[NI_MAXSERV]; + int flags = 0; + + getnameinfo(&addr.sa, salen, + nhost, sizeof(nhost), nport, sizeof(nport), + NI_NUMERICHOST | NI_NUMERICSERV); + Tcl_DStringAppendElement(dsPtr, nhost); + /* + * We don't want to resolve INADDR_ANY and sin6addr_any; they + * can sometimes cause problems (and never have a name). + */ + if (addr.sa.sa_family == AF_INET) { + if (addr.sa4.sin_addr.s_addr == INADDR_ANY) { + flags |= NI_NUMERICHOST; + } +#ifndef NEED_FAKE_RFC2553 + } else if (addr.sa.sa_family == AF_INET6) { + if ((IN6_ARE_ADDR_EQUAL(&addr.sa6.sin6_addr, + &in6addr_any)) + || (IN6_IS_ADDR_V4MAPPED(&addr.sa6.sin6_addr) && + addr.sa6.sin6_addr.s6_addr[12] == 0 && + addr.sa6.sin6_addr.s6_addr[13] == 0 && + addr.sa6.sin6_addr.s6_addr[14] == 0 && + addr.sa6.sin6_addr.s6_addr[15] == 0)) { + flags |= NI_NUMERICHOST; + } +#endif /* NEED_FAKE_RFC2553 */ + } + /* Check if reverse DNS has been switched off globally */ + if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) { + flags |= NI_NUMERICHOST; + } + if (getnameinfo(&addr.sa, salen, host, sizeof(host), NULL, 0, flags) == 0) { + /* Reverse mapping worked */ + Tcl_DStringAppendElement(dsPtr, host); + } else { + /* Reverse mappong failed - use the numeric rep once more */ + Tcl_DStringAppendElement(dsPtr, nhost); + } + Tcl_DStringAppendElement(dsPtr, nport); +} + +/* + *---------------------------------------------------------------------- + * * TcpGetOptionProc -- * * Computes an option value for a TCP socket based channel, or a list of @@ -656,10 +724,7 @@ TcpGetOptionProc( * initialized by caller. */ { TcpState *statePtr = instanceData; - char host[NI_MAXHOST], port[NI_MAXSERV]; size_t len = 0; - int reverseDNS = 0; -#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" if (optionName != NULL) { len = strlen(optionName); @@ -686,10 +751,6 @@ TcpGetOptionProc( return TCL_OK; } - if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) { - reverseDNS = NI_NUMERICHOST; - } - if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { address peername; @@ -700,14 +761,7 @@ TcpGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } - - getnameinfo(&peername.sa, size, host, sizeof(host), NULL, 0, - NI_NUMERICHOST); - Tcl_DStringAppendElement(dsPtr, host); - getnameinfo(&peername.sa, size, host, sizeof(host), port, - sizeof(port), reverseDNS | NI_NUMERICSERV); - Tcl_DStringAppendElement(dsPtr, host); - Tcl_DStringAppendElement(dsPtr, port); + TcpHostPortList(interp, dsPtr, peername, size); if (len) { return TCL_OK; } @@ -745,40 +799,8 @@ TcpGetOptionProc( for (fds = &statePtr->fds; fds != NULL; fds = fds->next) { size = sizeof(sockname); if (getsockname(fds->fd, &(sockname.sa), &size) >= 0) { - int flags = reverseDNS; - found = 1; - getnameinfo(&sockname.sa, size, host, sizeof(host), NULL, 0, - NI_NUMERICHOST); - Tcl_DStringAppendElement(dsPtr, host); - - /* - * We don't want to resolve INADDR_ANY and sin6addr_any; they - * can sometimes cause problems (and never have a name). - */ - - flags |= NI_NUMERICSERV; - if (sockname.sa.sa_family == AF_INET) { - if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) { - flags |= NI_NUMERICHOST; - } -#ifndef NEED_FAKE_RFC2553 - } else if (sockname.sa.sa_family == AF_INET6) { - if ((IN6_ARE_ADDR_EQUAL(&sockname.sa6.sin6_addr, - &in6addr_any)) - || (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr) && - sockname.sa6.sin6_addr.s6_addr[12] == 0 && - sockname.sa6.sin6_addr.s6_addr[13] == 0 && - sockname.sa6.sin6_addr.s6_addr[14] == 0 && - sockname.sa6.sin6_addr.s6_addr[15] == 0)) { - flags |= NI_NUMERICHOST; - } -#endif /* NEED_FAKE_RFC2553 */ - } - getnameinfo(&sockname.sa, size, host, sizeof(host), port, - sizeof(port), flags); - Tcl_DStringAppendElement(dsPtr, host); - Tcl_DStringAppendElement(dsPtr, port); + TcpHostPortList(interp, dsPtr, sockname, size); } } if (found) { -- cgit v0.12 From 9652ccdb2f5dbc810445ea5431b278cf4417a9c1 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 28 Nov 2012 00:04:31 +0000 Subject: [3590483]: Some compilers cannot initialize with complex non-constants. --- ChangeLog | 8 +++++++- generic/tclZlib.c | 51 +++++++++++++++++++++++++++------------------------ 2 files changed, 34 insertions(+), 25 deletions(-) diff --git a/ChangeLog b/ChangeLog index c9d3cb3..6f8c8ae 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2012-11-28 Donal K. Fellows + + * generic/tclZlib.c (ZlibStreamSubcmd): [Bug 3590483]: Use a mechanism + for complex option resolution that has fewer problems with more + finicky compilers. + 2012-11-26 Reinhard Max * unix/tclUnixSock.c: Factor out creation of the -sockname and @@ -5,7 +11,7 @@ Make it robust against implementations of getnameinfo() that error out if reverse mapping fails instead of falling back to the numeric representation. - + 2012-11-20 Donal K. Fellows * generic/tclBinary.c (BinaryDecode64): [Bug 3033307]: Corrected diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 11490f1..c63c306 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2177,29 +2177,35 @@ ZlibStreamSubcmd( FMT_INFLATE }; int i, format, mode = 0, option, level; + enum objIndices { + OPT_COMPRESSION_DICTIONARY = 0, + OPT_GZIP_HEADER = 1, + OPT_COMPRESSION_LEVEL = 2 + }; + Tcl_Obj *obj[3] = { NULL, NULL, NULL }; +#define compDictObj obj[OPT_COMPRESSION_DICTIONARY] +#define gzipHeaderObj obj[OPT_GZIP_HEADER] +#define levelObj obj[OPT_COMPRESSION_LEVEL] typedef struct { const char *name; - Tcl_Obj **valueVar; + enum objIndices offset; } OptDescriptor; - Tcl_Obj *compDictObj = NULL; - Tcl_Obj *gzipHeaderObj = NULL; - Tcl_Obj *levelObj = NULL; - const OptDescriptor compressionOpts[] = { - { "-dictionary", &compDictObj }, - { "-level", &levelObj }, - { NULL, NULL } + static const OptDescriptor compressionOpts[] = { + { "-dictionary", OPT_COMPRESSION_DICTIONARY }, + { "-level", OPT_COMPRESSION_LEVEL }, + { NULL, 0 } }; - const OptDescriptor gzipOpts[] = { - { "-header", &gzipHeaderObj }, - { "-level", &levelObj }, - { NULL, NULL } + static const OptDescriptor gzipOpts[] = { + { "-header", OPT_GZIP_HEADER }, + { "-level", OPT_COMPRESSION_LEVEL }, + { NULL, 0 } }; - const OptDescriptor expansionOpts[] = { - { "-dictionary", &compDictObj }, - { NULL, NULL } + static const OptDescriptor expansionOpts[] = { + { "-dictionary", OPT_COMPRESSION_DICTIONARY }, + { NULL, 0 } }; - const OptDescriptor gunzipOpts[] = { - { NULL, NULL } + static const OptDescriptor gunzipOpts[] = { + { NULL, 0 } }; const OptDescriptor *desc = NULL; Tcl_ZlibStream zh; @@ -2262,13 +2268,7 @@ ZlibStreamSubcmd( sizeof(OptDescriptor), "option", 0, &option) != TCL_OK) { return TCL_ERROR; } - *desc[option].valueVar = objv[i+1]; - - /* - * Drop the cache on the option name; table address not constant. - */ - - TclFreeIntRep(objv[i]); + obj[desc[option].offset] = objv[i+1]; } /* @@ -2300,6 +2300,9 @@ ZlibStreamSubcmd( } Tcl_SetObjResult(interp, Tcl_ZlibStreamGetCommandName(zh)); return TCL_OK; +#undef compDictObj +#undef gzipHeaderObj +#undef levelObj } /* -- cgit v0.12 From da12d58e11aba7b3a5f30364766ee0d5f30ce00b Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 28 Nov 2012 08:52:00 +0000 Subject: Silence some (unimportant) warnings from the MIPSpro compiler. --- generic/tclZlib.c | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index c63c306..8fbe049 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2180,7 +2180,8 @@ ZlibStreamSubcmd( enum objIndices { OPT_COMPRESSION_DICTIONARY = 0, OPT_GZIP_HEADER = 1, - OPT_COMPRESSION_LEVEL = 2 + OPT_COMPRESSION_LEVEL = 2, + OPT_END = -1 }; Tcl_Obj *obj[3] = { NULL, NULL, NULL }; #define compDictObj obj[OPT_COMPRESSION_DICTIONARY] @@ -2193,19 +2194,19 @@ ZlibStreamSubcmd( static const OptDescriptor compressionOpts[] = { { "-dictionary", OPT_COMPRESSION_DICTIONARY }, { "-level", OPT_COMPRESSION_LEVEL }, - { NULL, 0 } + { NULL, OPT_END } }; static const OptDescriptor gzipOpts[] = { { "-header", OPT_GZIP_HEADER }, { "-level", OPT_COMPRESSION_LEVEL }, - { NULL, 0 } + { NULL, OPT_END } }; static const OptDescriptor expansionOpts[] = { { "-dictionary", OPT_COMPRESSION_DICTIONARY }, - { NULL, 0 } + { NULL, OPT_END } }; static const OptDescriptor gunzipOpts[] = { - { NULL, 0 } + { NULL, OPT_END } }; const OptDescriptor *desc = NULL; Tcl_ZlibStream zh; -- cgit v0.12 From 665a380e86877529932a05da6d253011e8065642 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 29 Nov 2012 13:15:36 +0000 Subject: silence compiler warning --- generic/tclCompCmdsSZ.c | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index be63e0e..9c93fb2 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1224,12 +1224,7 @@ TclCompileSwitchCmd( if (TCL_OK != TclFindElement(NULL, bytes, numBytes, &(bodyTokenArray[numWords].start), &bytes, &(bodyTokenArray[numWords].size), &literal) || !literal) { - abort: - ckfree((char *) bodyToken); - ckfree((char *) bodyTokenArray); - ckfree((char *) bodyLines); - ckfree((char *) bodyContLines); - return TCL_ERROR; + goto abort; } bodyTokenArray[numWords].type = TCL_TOKEN_TEXT; @@ -1254,7 +1249,12 @@ TclCompileSwitchCmd( numWords++; } if (numWords % 2) { - goto abort; + abort: + ckfree((char *) bodyToken); + ckfree((char *) bodyTokenArray); + ckfree((char *) bodyLines); + ckfree((char *) bodyContLines); + return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { /* -- cgit v0.12 From 8bdf6a3cdd5c1ace4435d972fd5f183ce4f3e18c Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 29 Nov 2012 14:47:12 +0000 Subject: 3588687 When detecting incompatibility during stubs initialization, the error message has always assumed a stubs-disabled 8.0 interp to be the cause. That's no longer a good assumption. More suitable error message committed. --- generic/tclStubLib.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 1ab7ff3..7bf04a0 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -47,7 +47,7 @@ HasStubSupport (interp) if (iPtr->stubTable && (iPtr->stubTable->magic == TCL_STUB_MAGIC)) { return iPtr->stubTable; } - interp->result = "This interpreter does not support stubs-enabled extensions."; + interp->result = "interpreter uses an incompatible stubs mechanism"; interp->freeProc = TCL_STATIC; return NULL; -- cgit v0.12 From c85fd541529c09d23c1091969ad8f96012bb68ec Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 30 Nov 2012 09:16:16 +0000 Subject: Inform the HTML builder about the TDBC drivers. --- pkgs/package.list.txt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/pkgs/package.list.txt b/pkgs/package.list.txt index 5020506..f12111d 100644 --- a/pkgs/package.list.txt +++ b/pkgs/package.list.txt @@ -19,3 +19,8 @@ thread Thread tdbc TDBC Tdbc TDBC TDBC TDBC +# Drivers for TDBC +tdbcmysql tdbc::mysql +tdbcodbc tdbc::odbc +tdbcpostgres tdbc::postgres +tdbcsqlite3- tdbc::sqlite3 -- cgit v0.12 From 06d38df148ae4415dd9b1ed7afff6d74a5482345 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 2 Dec 2012 14:35:03 +0000 Subject: Allow http, msgcat and tcltest to be loaded by Tcl 9 as well. I think that this should be included in tcl8.6.0: Those 3 packages are so widely used, we don't want to introduce Tcl-level incompatibilities in Tcl9 such that those packages wouldn't work any more. Moved to branch novem-support. For now, novem is a playground. The trunk is not. By all means lets track what we need for migration, but hold back committing to them until we commit more meaningfully to where we're going. --- library/http/http.tcl | 2 +- library/http/pkgIndex.tcl | 2 +- library/msgcat/msgcat.tcl | 2 +- library/msgcat/pkgIndex.tcl | 2 +- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index d57e3ce..c3290c9 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.6 +package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles package provide http 2.8.5 diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 303d3bd..828c860 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ -if {![package vsatisfies [package provide Tcl] 8.6]} {return} +if {![package vsatisfies [package provide Tcl] 8.6-]} {return} package ifneeded http 2.8.5 [list tclPkgSetup $dir http 2.8.5 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 112507a..5f8e1e9 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5 +package require Tcl 8.5- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. package provide msgcat 1.5.0 diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 832bf81..a5b6499 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ -if {![package vsatisfies [package provide Tcl] 8.5]} {return} +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} package ifneeded msgcat 1.5.0 [list source [file join $dir msgcat.tcl]] diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 0e4568d..3769155 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -8,5 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.5]} {return} +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} package ifneeded tcltest 2.3.4 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 02da62f..12692bb 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -16,7 +16,7 @@ # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. -package require Tcl 8.5 ;# -verbose line uses [info frame] +package require Tcl 8.5- ;# -verbose line uses [info frame] namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, -- cgit v0.12 From 8ef61c13e0df3175cac5b314840f726f7407b6f8 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 3 Dec 2012 14:33:17 +0000 Subject: Post-header reform (long long ago now) Tcl headers take care of their own protection from EXTERN definitions. --- unix/tclLoadShl.c | 9 --------- 1 file changed, 9 deletions(-) diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index c9e4e27..8aaefda 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -12,15 +12,6 @@ */ #include - -/* - * On some HP machines, dl.h defines EXTERN; remove that definition. - */ - -#ifdef EXTERN -# undef EXTERN -#endif - #include "tclInt.h" /* -- cgit v0.12 From b222d2f2b2dbf7666e44385dc825b59b5045b3f2 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 3 Dec 2012 19:14:32 +0000 Subject: Disable the legacy configuration setting from $::argv only when a setting call to [configure] is made. Queries should not disturb that support. Bump to tcltest 2.2.11. --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index e569fa5..eb5859e 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.3]} {return} -package ifneeded tcltest 2.2.10 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.2.11 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 4ae1480c..5d89748 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.2.10 + variable Version 2.2.11 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -601,7 +601,9 @@ namespace eval tcltest { } } proc configure args { - RemoveAutoConfigureTraces + if {[llength $args] > 1} { + RemoveAutoConfigureTraces + } set code [catch {eval Configure $args} msg] return -code $code $msg } -- cgit v0.12 From ae09e66da466ea68e269fc388798ca6ce2cd1c4c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Dec 2012 13:39:07 +0000 Subject: MODULE_SCOPE symbol names are suppoted to start with 'tcl' (data) or 'Tcl' (code) --- generic/tclParse.c | 2 +- generic/tclParse.h | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index 309e232..08615a7 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -42,7 +42,7 @@ * TYPE_BRACE - Character is a curly brace (either left or right). */ -const char charTypeTable[] = { +const char tclCharTypeTable[] = { /* * Negative character values, from -128 to -1: */ diff --git a/generic/tclParse.h b/generic/tclParse.h index be1ab15..20c609c 100644 --- a/generic/tclParse.h +++ b/generic/tclParse.h @@ -12,6 +12,6 @@ #define TYPE_CLOSE_BRACK 0x20 #define TYPE_BRACE 0x40 -#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)] +#define CHAR_TYPE(c) (tclCharTypeTable+128)[(int)(c)] -MODULE_SCOPE const char charTypeTable[]; +MODULE_SCOPE const char tclCharTypeTable[]; -- cgit v0.12 From b1e66e34704ff978d2dbacea83cc81ae8650a6d0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 5 Dec 2012 13:31:22 +0000 Subject: Fix gcc warning in cygwin build: implicitely declared function TclUnixOpenTemporaryFile. Move the function to slot 30, and define it (as 0) for win32 as well. --- generic/tclInt.decls | 19 +++++++++---------- generic/tclIntPlatDecls.h | 41 +++++++++++++++++++++++++++-------------- generic/tclStubInit.c | 8 ++++++-- 3 files changed, 42 insertions(+), 26 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 8f8b992..f215d32 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1148,9 +1148,6 @@ declare 27 win { declare 28 win { void TclWinResetInterfaces(void) } -declare 29 win { - int TclWinCPUID(unsigned int index, unsigned int *regs) -} ################################ # Unix specific functions @@ -1219,12 +1216,6 @@ declare 14 unix { const Tcl_StatBuf *statBufPtr, int dontCopyAtts) } -# Added in 8.6; core of TclpOpenTemporaryFile -declare 20 unix { - int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, - Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) -} - ################################ # Mac OS X specific functions @@ -1248,9 +1239,17 @@ declare 18 macosx { declare 19 macosx { void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) } -declare 29 unix { + +declare 29 {win unix} { int TclWinCPUID(unsigned int index, unsigned int *regs) } +# Added in 8.6; core of TclpOpenTemporaryFile +declare 30 {win unix} { + int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, + Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) +} + + # Local Variables: # mode: tcl diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index f265e7e..dcf1753 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -84,10 +84,7 @@ EXTERN int TclUnixCopyFile(const char *src, const char *dst, /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ -/* 20 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); +/* Slot 20 is reserved */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ @@ -98,6 +95,10 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, /* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +/* 30 */ +EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); #endif /* UNIX */ #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ /* 0 */ @@ -169,6 +170,10 @@ EXTERN void TclWinFlushDirtyChannels(void); EXTERN void TclWinResetInterfaces(void); /* 29 */ EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +/* 30 */ +EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ @@ -228,10 +233,7 @@ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); -/* 20 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); +/* Slot 20 is reserved */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ @@ -242,6 +244,10 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, /* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +/* 30 */ +EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); #endif /* MACOSX */ typedef struct TclIntPlatStubs { @@ -269,7 +275,7 @@ typedef struct TclIntPlatStubs { void (*reserved17)(void); void (*reserved18)(void); void (*reserved19)(void); - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 20 */ + void (*reserved20)(void); void (*reserved21)(void); void (*reserved22)(void); void (*reserved23)(void); @@ -279,6 +285,7 @@ typedef struct TclIntPlatStubs { void (*reserved27)(void); void (*reserved28)(void); int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ void (*tclWinConvertError) (DWORD errCode); /* 0 */ @@ -311,6 +318,7 @@ typedef struct TclIntPlatStubs { void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*tclWinResetInterfaces) (void); /* 28 */ int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ @@ -333,7 +341,7 @@ typedef struct TclIntPlatStubs { int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 20 */ + void (*reserved20)(void); void (*reserved21)(void); void (*reserved22)(void); void (*reserved23)(void); @@ -343,6 +351,7 @@ typedef struct TclIntPlatStubs { void (*reserved27)(void); void (*reserved28)(void); int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* MACOSX */ } TclIntPlatStubs; @@ -395,8 +404,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 20 */ +/* Slot 20 is reserved */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ @@ -407,6 +415,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ @@ -467,6 +477,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #define TclGetAndDetachPids \ @@ -508,8 +520,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 20 */ +/* Slot 20 is reserved */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ @@ -520,6 +531,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 0bede56..88ada19 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -65,6 +65,7 @@ static unsigned short TclWinNToHS(unsigned short ns) { #ifdef __WIN32__ # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 +# define TclUnixOpenTemporaryFile 0 # define TclpReaddir 0 # define TclpIsAtty 0 #elif defined(__CYGWIN__) @@ -465,7 +466,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { 0, /* 17 */ 0, /* 18 */ 0, /* 19 */ - TclUnixOpenTemporaryFile, /* 20 */ + 0, /* 20 */ 0, /* 21 */ 0, /* 22 */ 0, /* 23 */ @@ -475,6 +476,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { 0, /* 27 */ 0, /* 28 */ TclWinCPUID, /* 29 */ + TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ @@ -507,6 +509,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclWinFlushDirtyChannels, /* 27 */ TclWinResetInterfaces, /* 28 */ TclWinCPUID, /* 29 */ + TclUnixOpenTemporaryFile, /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ TclGetAndDetachPids, /* 0 */ @@ -529,7 +532,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclMacOSXCopyFileAttributes, /* 17 */ TclMacOSXMatchType, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ - TclUnixOpenTemporaryFile, /* 20 */ + 0, /* 20 */ 0, /* 21 */ 0, /* 22 */ 0, /* 23 */ @@ -539,6 +542,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { 0, /* 27 */ 0, /* 28 */ TclWinCPUID, /* 29 */ + TclUnixOpenTemporaryFile, /* 30 */ #endif /* MACOSX */ }; -- cgit v0.12 From 80f5d8964ac592076e2adbb83d4402382d01914d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 5 Dec 2012 14:42:48 +0000 Subject: use Tcl_PkgProvideEx everywhere (again, for testing purposes) --- generic/tclTest.c | 2 +- generic/tclTestProcBodyObj.c | 2 +- generic/tclZlib.c | 2 +- unix/dltest/pkga.c | 2 +- unix/dltest/pkgb.c | 4 ++-- unix/dltest/pkgc.c | 4 ++-- unix/dltest/pkgd.c | 4 ++-- unix/dltest/pkgua.c | 2 +- win/tclWinDde.c | 2 +- win/tclWinReg.c | 2 +- 10 files changed, 13 insertions(+), 13 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index a8b27fb..b112e2d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -544,7 +544,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; } diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index a3f89f6..7b33895 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -185,7 +185,7 @@ ProcBodyTestInitInternal( } } - return Tcl_PkgProvide(interp, packageName, packageVersion); + return Tcl_PkgProvideEx(interp, packageName, packageVersion, NULL); } /* diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 8fbe049..c85123b 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -3884,7 +3884,7 @@ TclZlibInit( * Formally provide the package as a Tcl built-in. */ - return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); + return Tcl_PkgProvideEx(interp, "zlib", TCL_ZLIB_VERSION, NULL); } /* diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c index 901f4c9..8d40758 100644 --- a/unix/dltest/pkga.c +++ b/unix/dltest/pkga.c @@ -134,7 +134,7 @@ Pkga_Init( if (Tcl_InitStubs(interp, "8.6-", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkga", "1.0"); + code = Tcl_PkgProvideEx(interp, "Pkga", "1.0", NULL); if (code != TCL_OK) { return code; } diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index b00d4e5..f6f7bbb 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -124,7 +124,7 @@ Pkgb_Init( if (Tcl_InitStubs(interp, "8.6-", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkgb", "2.3"); + code = Tcl_PkgProvideEx(interp, "Pkgb", "2.3", NULL); if (code != TCL_OK) { return code; } @@ -161,7 +161,7 @@ Pkgb_SafeInit( if (Tcl_InitStubs(interp, "8.6-", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkgb", "2.3"); + code = Tcl_PkgProvideEx(interp, "Pkgb", "2.3", NULL); if (code != TCL_OK) { return code; } diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c index e5678dc..a70f929 100644 --- a/unix/dltest/pkgc.c +++ b/unix/dltest/pkgc.c @@ -124,7 +124,7 @@ Pkgc_Init( if (Tcl_InitStubs(interp, "8.6-", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); + code = Tcl_PkgProvideEx(interp, "Pkgc", "1.7.2", NULL); if (code != TCL_OK) { return code; } @@ -161,7 +161,7 @@ Pkgc_SafeInit( if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); + code = Tcl_PkgProvideEx(interp, "Pkgc", "1.7.2", NULL); if (code != TCL_OK) { return code; } diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c index 877489c..e6538cd 100644 --- a/unix/dltest/pkgd.c +++ b/unix/dltest/pkgd.c @@ -124,7 +124,7 @@ Pkgd_Init( if (Tcl_InitStubs(interp, "8.6-", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkgd", "7.3"); + code = Tcl_PkgProvideEx(interp, "Pkgd", "7.3", NULL); if (code != TCL_OK) { return code; } @@ -161,7 +161,7 @@ Pkgd_SafeInit( if (Tcl_InitStubs(interp, "8.6-", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkgd", "7.3"); + code = Tcl_PkgProvideEx(interp, "Pkgd", "7.3", NULL); if (code != TCL_OK) { return code; } diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index 18a1cac..87df4a0 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -219,7 +219,7 @@ Pkgua_Init( PkguaInitTokensHashTable(); - code = Tcl_PkgProvide(interp, "Pkgua", "1.0"); + code = Tcl_PkgProvideEx(interp, "Pkgua", "1.0", NULL); if (code != TCL_OK) { return code; } diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 13e1f18..4df308b 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -170,7 +170,7 @@ Dde_Init( #endif Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); - return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION); + return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL); } /* diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 8bb14d0..8b13afb 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -172,7 +172,7 @@ Registry_Init( cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); - return Tcl_PkgProvide(interp, "registry", "1.3.0"); + return Tcl_PkgProvideEx(interp, "registry", "1.3.0", NULL); } /* -- cgit v0.12 From 6a27e83c7193e742481d954eddb39a02586b54bf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 5 Dec 2012 22:38:20 +0000 Subject: do some Tcl_EvalEx, for test-purposes, demonstrating a crash --- unix/dltest/pkgb.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index f6f7bbb..772b239 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -93,8 +93,7 @@ Pkgb_UnsafeObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1)); - return TCL_OK; + return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL); } /* -- cgit v0.12 From 92b20ad57f4d24e7d2d915c6059e0decb570276d Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Dec 2012 21:03:22 +0000 Subject: Tcl_InitStubs("8.5",1) would succeed in an "8.50" interp. Fixed. --- generic/tclStubLib.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 871d7ea..9774731 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -118,7 +118,7 @@ Tcl_InitStubs( while (*p && (*p == *q)) { p++; q++; } - if (*p) { + if (*p || isDigit(*q)) { /* Construct error message */ Tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); return NULL; -- cgit v0.12 From 99bda89c0b6500e673ecacd280527492c780b562 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 7 Dec 2012 14:53:40 +0000 Subject: Extended test of [load]ing Tcl 8 compiled extension into Tcl 9 interp. --- unix/dltest/pkgb.c | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index 02bd233..9c199ca 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -30,6 +30,8 @@ static int Pkgb_SubObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int Pkgb_UnsafeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int Pkgb_DemoObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* *---------------------------------------------------------------------- @@ -95,6 +97,17 @@ Pkgb_UnsafeObjCmd( { return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL); } + +static int +Pkgb_DemoObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *foo = Tcl_GetDefaultEncodingDir(); + return TCL_OK; +} /* *---------------------------------------------------------------------- @@ -128,8 +141,8 @@ Pkgb_Init( return code; } Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "pkgb_unsafe", Pkgb_UnsafeObjCmd, NULL, - NULL); + Tcl_CreateObjCommand(interp, "pkgb_unsafe", Pkgb_UnsafeObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "pkgb_demo", Pkgb_DemoObjCmd, NULL, NULL); return TCL_OK; } -- cgit v0.12 From fa2a03a1bf7c810f5d6fb14da98de6d4526339af Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Dec 2012 15:51:25 +0000 Subject: add proper runtime-detection to pkgb.so --- unix/dltest/pkgb.c | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index 9c199ca..1a362ef 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -98,6 +98,11 @@ Pkgb_UnsafeObjCmd( return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL); } +#if (TCL_MAJOR_VERSION > 8) +# define Tcl_GetDefaultEncodingDir ((const char *(*)(void)) \ + ((&(tclStubsPtr->tcl_PkgProvideEx))[341])) +#endif + static int Pkgb_DemoObjCmd( ClientData dummy, /* Not used. */ @@ -105,7 +110,11 @@ Pkgb_DemoObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *foo = Tcl_GetDefaultEncodingDir(); + if(!Tcl_GetDefaultEncodingDir) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("not supported", -1)); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetDefaultEncodingDir(), -1)); return TCL_OK; } -- cgit v0.12 From ef331c2b06dede42238295f9b0fbaedb83f668b2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Dec 2012 15:53:29 +0000 Subject: fix failing test --- tests/load.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/load.test b/tests/load.test index eef677f..cded85d 100644 --- a/tests/load.test +++ b/tests/load.test @@ -188,7 +188,7 @@ test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] { load [file join $testDir pkgb$ext] pkgb list [info loaded {}] [lsort [info commands pkgb_*]] -} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_sub pkgb_unsafe}] +} [list [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}] interp delete child test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \ -- cgit v0.12 From a4a99b73219c5f30bd18f6349427c834691b2c46 Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 7 Dec 2012 15:56:13 +0000 Subject: small correction in doc/NRE.3 --- doc/NRE.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/NRE.3 b/doc/NRE.3 index be2c58b..4ad78b3 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -295,7 +295,7 @@ int int result) { /* \fIdata[0] .. data[3]\fR are the four words of data - * passed to \fBTcl_NREvalObj\fR */ + * passed to \fBTcl_NRAddCallback\fR */ \fI... postprocessing ...\fR -- cgit v0.12 From cee1ce03b712770dc55c7c3b4b65c5026546d53f Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 7 Dec 2012 17:03:39 +0000 Subject: Source compat, rather than stubs compat demo. --- unix/dltest/pkgb.c | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index 1a362ef..9884a64 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -99,8 +99,19 @@ Pkgb_UnsafeObjCmd( } #if (TCL_MAJOR_VERSION > 8) -# define Tcl_GetDefaultEncodingDir ((const char *(*)(void)) \ - ((&(tclStubsPtr->tcl_PkgProvideEx))[341])) +const char *Tcl_GetDefaultEncodingDir(void) +{ + int numDirs; + Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath(); + + Tcl_ListObjLength(NULL, searchPath, &numDirs); + if (numDirs == 0) { + return NULL; + } + Tcl_ListObjIndex(NULL, searchPath, 0, &first); + + return Tcl_GetString(first); +} #endif static int @@ -110,10 +121,6 @@ Pkgb_DemoObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - if(!Tcl_GetDefaultEncodingDir) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("not supported", -1)); - return TCL_ERROR; - } Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetDefaultEncodingDir(), -1)); return TCL_OK; } -- cgit v0.12 From 6d6c732492789c16c16f822a7b3ae1421261b86d Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 7 Dec 2012 18:07:18 +0000 Subject: 3593703 Don't crash on bad input to Tcl_PkgRequire*(). --- generic/tclPkg.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index aed80c0..b3396e6 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -353,6 +353,10 @@ PkgRequireCore( char *script, *pkgVersionI; Tcl_DString command; + if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { + return NULL; + } + /* * It can take up to three passes to find the package: one pass to run the * "package unknown" script, one to run the "package ifneeded" script for -- cgit v0.12 From e76d16d3eba7f034fc003f1061736c298b03c74f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Dec 2012 21:28:49 +0000 Subject: only set tclStubsPtr if all version checks pass. Backported from tcl 8.5. --- generic/tclStubLib.c | 105 ++++++++++++++++++++++++++++++--------------------- 1 file changed, 62 insertions(+), 43 deletions(-) diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 7bf04a0..39e94c8 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -1,45 +1,26 @@ -/* +/* * tclStubLib.c -- * - * Stub object that will be statically linked into extensions that wish + * Stub object that will be statically linked into extensions that want * to access Tcl. * * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 1998 Paul Duffin. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -/* - * We need to ensure that we use the stub macros so that this file contains - * no references to any of the stub functions. This will make it possible - * to build an extension that references Tcl_InitStubs but doesn't end up - * including the rest of the stub functions. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef USE_TCL_STUBS -#define USE_TCL_STUBS -#endif -#undef USE_TCL_STUB_PROCS - #include "tclInt.h" #include "tclPort.h" -/* - * Ensure that Tcl_InitStubs is built as an exported symbol. The other stub - * functions should be built as non-exported symbols. - */ - TclStubs *tclStubsPtr = NULL; TclPlatStubs *tclPlatStubsPtr = NULL; TclIntStubs *tclIntStubsPtr = NULL; TclIntPlatStubs *tclIntPlatStubsPtr = NULL; -static TclStubs * HasStubSupport _ANSI_ARGS_((Tcl_Interp *interp)); - static TclStubs * -HasStubSupport (interp) +HasStubSupport(interp) Tcl_Interp *interp; { Interp *iPtr = (Interp *) interp; @@ -49,57 +30,87 @@ HasStubSupport (interp) } interp->result = "interpreter uses an incompatible stubs mechanism"; interp->freeProc = TCL_STATIC; - return NULL; } /* + * Use our own isdigit to avoid linking to libc on windows + */ + +static int isDigit(const int c) +{ + return (c >= '0' && c <= '9'); +} + +/* *---------------------------------------------------------------------- * * Tcl_InitStubs -- * - * Tries to initialise the stub table pointers and ensures that - * the correct version of Tcl is loaded. + * Tries to initialise the stub table pointers and ensures that the + * correct version of Tcl is loaded. * * Results: - * The actual version of Tcl that satisfies the request, or - * NULL to indicate that an error occurred. + * The actual version of Tcl that satisfies the request, or NULL to + * indicate that an error occurred. * * Side effects: * Sets the stub table pointers. * *---------------------------------------------------------------------- */ - -#ifdef Tcl_InitStubs #undef Tcl_InitStubs -#endif - CONST char * -Tcl_InitStubs (interp, version, exact) +Tcl_InitStubs(interp, version, exact) Tcl_Interp *interp; CONST char *version; int exact; { CONST char *actualVersion = NULL; - ClientData pkgData = NULL; + TclStubs *stubsPtr; /* - * We can't optimize this check by caching tclStubsPtr because - * that prevents apps from being able to load/unload Tcl dynamically - * multiple times. [Bug 615304] + * We can't optimize this check by caching tclStubsPtr because that + * prevents apps from being able to load/unload Tcl dynamically multiple + * times. [Bug 615304] */ - tclStubsPtr = HasStubSupport(interp); - if (!tclStubsPtr) { + stubsPtr = HasStubSupport(interp); + if (!stubsPtr) { return NULL; } - actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, exact, &pkgData); + actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, NULL); if (actualVersion == NULL) { return NULL; } - tclStubsPtr = (TclStubs*)pkgData; + if (exact) { + CONST char *p = version; + int count = 0; + + while (*p) { + count += !isDigit(*p++); + } + if (count == 1) { + CONST char *q = actualVersion; + + p = version; + while (*p && (*p == *q)) { + p++; q++; + } + if (*p || isDigit(*q)) { + /* Construct error message */ + stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); + return NULL; + } + } else { + actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); + if (actualVersion == NULL) { + return NULL; + } + } + } + tclStubsPtr = stubsPtr; if (tclStubsPtr->hooks) { tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; @@ -110,6 +121,14 @@ Tcl_InitStubs (interp, version, exact) tclIntStubsPtr = NULL; tclIntPlatStubsPtr = NULL; } - + return actualVersion; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ -- cgit v0.12 From 8ea32cad84602b02b1eab7b2ca01bf583bd1c9db Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Dec 2012 22:14:26 +0000 Subject: just lost one MODULE_SCOPE in the merge --- generic/tclStubLib.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 5a122dd..b8979df 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -64,7 +64,7 @@ static int isDigit(const int c) *---------------------------------------------------------------------- */ #undef Tcl_InitStubs -const char * +MODULE_SCOPE const char * Tcl_InitStubs( Tcl_Interp *interp, const char *version, -- cgit v0.12 From 5ab4d052c526754eca52cbec0aea41c6a61d7fb6 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Sat, 8 Dec 2012 17:13:03 +0000 Subject: Fix busyloop at exit under TCL_FINALIZE_ON_EXIT when there are unflushed nonblocking channels. Thanks Miguel for spotting. --- ChangeLog | 5 +++++ generic/tclIO.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 37c3e2e..c1a3ff7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-12-08 Alexandre Ferrieux + * generic/tclIO.c: Fix busyloop at exit under TCL_FINALIZE_ON_EXIT + when there are unflushed nonblocking channels. Thanks Miguel for + spotting. + 2012-12-07 Jan Nijtmans * unix/dltest/pkgb.c: Turn pkgb.so into a Tcl9 interoperability test diff --git a/generic/tclIO.c b/generic/tclIO.c index 0cb9fa9..715c1ef 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -2472,7 +2472,7 @@ FlushChannel( * it's a tty channel (dup'ed underneath) */ - if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { + if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED) && !TclInExit()) { SetFlag(statePtr, BG_FLUSH_SCHEDULED); UpdateInterest(chanPtr); } -- cgit v0.12 From ff12195b2b7d3b9d0f8f4441bd3ec0c991ba742b Mon Sep 17 00:00:00 2001 From: ferrieux Date: Sun, 9 Dec 2012 11:52:04 +0000 Subject: Clean up unwanted eofchar side-effect of chan-4.6 leading to a spurious "'" at end of chan.test under certain conditions (see [Bug 3389289] and [Bug 3389251]). --- ChangeLog | 5 +++++ tests/chan.test | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index c1a3ff7..aeb6a62 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-12-09 Alexandre Ferrieux + * tests/chan.test: Clean up unwanted eofchar side-effect of + chan-4.6 leading to a spurious "'" at end of chan.test under + certain conditions (see [Bug 3389289] and [Bug 3389251]). + 2012-12-08 Alexandre Ferrieux * generic/tclIO.c: Fix busyloop at exit under TCL_FINALIZE_ON_EXIT when there are unflushed nonblocking channels. Thanks Miguel for diff --git a/tests/chan.test b/tests/chan.test index da44ffd..d8390e2 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -61,7 +61,7 @@ test chan-4.5 {chan command: check valid inValue, invalid outValue} -body { } -returnCodes error -match glob -result {bad value for -eofchar:*} test chan-4.6 {chan command: check no inValue, valid outValue} -body { chan configure stdout -eofchar [list {} \x27] -} -returnCodes ok -result {} +} -returnCodes ok -result {} -cleanup {chan configure stdout -eofchar [list {} {}]} test chan-5.1 {chan command: copy subcommand} -body { chan copy foo -- cgit v0.12 From a68a31f4bff004ca60d9cf17cb74a9fc8b94d2ed Mon Sep 17 00:00:00 2001 From: ferrieux Date: Sun, 9 Dec 2012 19:44:57 +0000 Subject: [Bug 3594188] Clarifications about commas. --- ChangeLog | 1 + doc/expr.n | 16 ++++++++++++++-- 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index aeb6a62..9c42929 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,7 @@ * tests/chan.test: Clean up unwanted eofchar side-effect of chan-4.6 leading to a spurious "'" at end of chan.test under certain conditions (see [Bug 3389289] and [Bug 3389251]). + * doc/expr.n: [Bug 3594188] Clarifications about commas. 2012-12-08 Alexandre Ferrieux * generic/tclIO.c: Fix busyloop at exit under TCL_FINALIZE_ON_EXIT diff --git a/doc/expr.n b/doc/expr.n index 6d965fb..8698f5c 100644 --- a/doc/expr.n +++ b/doc/expr.n @@ -39,9 +39,9 @@ additional operators not found in C. .SS OPERANDS .PP A Tcl expression consists of a combination of operands, operators, -and parentheses. +parentheses and commas. White space may be used between the operands and operators and -parentheses; it is ignored by the expression's instructions. +parentheses (or commas); it is ignored by the expression's instructions. Where possible, operands are interpreted as integer values. Integer values may be specified in decimal (the normal case), in binary (if the first two characters of the operand are \fB0b\fR), in octal @@ -283,6 +283,18 @@ rules for resolving functions in namespaces. Either current]::tcl::mathfunc::sin\fR will satisfy the request, and others may as well (depending on the current \fBnamespace path\fR setting). .PP +Some mathematical functions have several arguments, separated by commas like in C. Thus: +.PP +.CS +\fBexpr\fR {hypot($x,$y)} +.CE +.PP +ends up as +.PP +.CS +tcl::mathfunc::hypot $x $y +.CE +.PP See the \fBmathfunc\fR(n) manual page for the math functions that are available by default. .SS "TYPES, OVERFLOW, AND PRECISION" -- cgit v0.12 From e595fefe85b468cabc5e2cbebb030a525b46228f Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 10 Dec 2012 14:08:59 +0000 Subject: Restore the initialization of tclStubsPtr from the "Tcl" package clientData so that we don't close off a potential avenue of future innovations. --- generic/tclStubLib.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 39e94c8..ceee8f3 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -67,6 +67,7 @@ Tcl_InitStubs(interp, version, exact) int exact; { CONST char *actualVersion = NULL; + ClientData pkgData = NULL; TclStubs *stubsPtr; /* @@ -80,7 +81,7 @@ Tcl_InitStubs(interp, version, exact) return NULL; } - actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, NULL); + actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData); if (actualVersion == NULL) { return NULL; } @@ -110,7 +111,7 @@ Tcl_InitStubs(interp, version, exact) } } } - tclStubsPtr = stubsPtr; + tclStubsPtr = (TclStubs *)pkgData; if (tclStubsPtr->hooks) { tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; -- cgit v0.12 From 005010e14da826074d8b45810962d7eee6fe8c36 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 10 Dec 2012 23:23:50 +0000 Subject: Improve the generation of HTML documentation in 8.6, allowing for contributed packages whose non-version name parts are prefixes of others. Also ensure that documentation builds are complete after distribution, and that we generate a better error message when using the wrong tclsh version to do the build. --- ChangeLog | 29 ++++++++++++++++++++--------- tools/tcltk-man2html.tcl | 22 +++++++++++++++------- unix/Makefile.in | 3 ++- 3 files changed, 37 insertions(+), 17 deletions(-) diff --git a/ChangeLog b/ChangeLog index 9c42929..9beccc7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,12 +1,23 @@ +2012-12-10 Donal K. Fellows + + * tools/tcltk-man2html.tcl (plus-pkgs): Increased robustness of + version number detection code to deal with packages whose names are + prefixes of other packages. + * unix/Makefile.in (dist): Added pkgs/package.list.txt to distribution + builds to ensure that 'make html' will work better. + 2012-12-09 Alexandre Ferrieux - * tests/chan.test: Clean up unwanted eofchar side-effect of - chan-4.6 leading to a spurious "'" at end of chan.test under - certain conditions (see [Bug 3389289] and [Bug 3389251]). - * doc/expr.n: [Bug 3594188] Clarifications about commas. + + * tests/chan.test: Clean up unwanted eofchar side-effect of chan-4.6 + leading to a spurious "'" at end of chan.test under certain conditions + (see [Bug 3389289] and [Bug 3389251]). + + * doc/expr.n: [Bug 3594188]: Clarifications about commas. 2012-12-08 Alexandre Ferrieux + * generic/tclIO.c: Fix busyloop at exit under TCL_FINALIZE_ON_EXIT - when there are unflushed nonblocking channels. Thanks Miguel for + when there are unflushed nonblocking channels. Thanks Miguel for spotting. 2012-12-07 Jan Nijtmans @@ -24,10 +35,10 @@ 2012-11-26 Reinhard Max * unix/tclUnixSock.c: Factor out creation of the -sockname and - -peername lists from TcpGetOptionProc() to TcpHostPortList(). - Make it robust against implementations of getnameinfo() that error - out if reverse mapping fails instead of falling back to the - numeric representation. + -peername lists from TcpGetOptionProc() to TcpHostPortList(). Make it + robust against implementations of getnameinfo() that error out if + reverse mapping fails instead of falling back to the numeric + representation. 2012-11-20 Donal K. Fellows diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index 665a1d4..270a774 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -1,6 +1,12 @@ #!/usr/bin/env tclsh -package require Tcl 8.6 +if {[catch {package require Tcl 8.6} msg]} { + puts stderr "ERROR: $msg" + puts stderr "If running this script from 'make html', set the\ + NATIVE_TCLSH environment\nvariable to point to an installed\ + tclsh8.6 (or the equivalent tclsh86.exe\non Windows)." + exit 1 +} # Convert Ousterhout format man pages into highly crosslinked hypertext. # @@ -16,7 +22,7 @@ package require Tcl 8.6 # Copyright (c) 1995-1997 Roger E. Critchlow Jr # Copyright (c) 2004-2010 Donal K. Fellows -regexp {\d+\.\d+} {$Revision: 1.49 $} ::Version +set ::Version "50/8.6" set ::CSSFILE "docs.css" ## @@ -454,16 +460,18 @@ proc plus-pkgs {type args} { } if {!$build_tcl} return set result {} + set pkgsdir $tcltkdir/$tcldir/pkgs foreach {dir name} $args { - set globpat $tcltkdir/$tcldir/pkgs/$dir*/doc/*.$type - if {![llength [glob -nocomplain $globpat]]} { + set globpat $pkgsdir/{$dir,$dir\[0-9\]*}/doc/*.$type + if {![llength [glob -type f -nocomplain $globpat]]} { # Fallback for manpages generated using doctools - set globpat $tcltkdir/$tcldir/pkgs/$dir*/doc/man/*.$type - if {![llength [glob -nocomplain $globpat]]} { + set globpat $pkgsdir/{$dir,$dir\[0-9\]*}/doc/man/*.$type + if {![llength [glob -type f -nocomplain $globpat]]} { continue } } - regexp "pkgs/${dir}(.*)/doc$" [glob $tcltkdir/$tcldir/pkgs/$dir*/doc] \ + regexp "pkgs/${dir}(.*)/doc$" \ + [lindex [glob -type d $pkgsdir/{$dir,$dir\[0-9\]*}/doc] 0] \ -> version switch $type { n { diff --git a/unix/Makefile.in b/unix/Makefile.in index df05759..680d4ce 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -2019,7 +2019,8 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h \ $(DISTDIR)/libtommath mkdir $(DISTDIR)/pkgs - cp $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs + cp $(TOP_DIR)/pkgs/README $(TOP_DIR)/pkgs/package.list.txt \ + $(DISTDIR)/pkgs for i in `ls $(DISTROOT)/pkgs/*.tar.gz 2> /dev/null`; do \ tar -C $(DISTDIR)/pkgs -xzf "$$i"; \ done -- cgit v0.12 From 1f1d7f55107bdc5a370bd404c4e35e171a0f2eea Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 11 Dec 2012 21:19:11 +0000 Subject: update changes --- changes | 36 +++++++++++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) diff --git a/changes b/changes index 0ced7a1..b517cec 100644 --- a/changes +++ b/changes @@ -8117,11 +8117,45 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows) --- Released 8.6b3, September 18, 2012 --- See ChangeLog for details --- +2012-09-20 (enhancement) full Unicode support (nijtmans) +=> dde 1.4.0 + +2012-09-20 (enhancement) update bundled zlib to 1.2.7 (nijtmans) + 2012-10-03 (bug fix) exit panic on stacked std channel (griffin,porter) 2012-10-14 (bug fix) [tcl::Bgerror] crash on non-dict options (nijtmans) +2012-10-16 (TIP 400) New [zlib] options to set compression dict (fellows) + +2012-10-16 (TIP 405) New commands [lmap] and [dict map] (fellows) + +2012-10-24 (enhancement) [dict unset] now bytecompiled (fellows) + +2012-11-05 (TIP 413) Revisions to default [string trim*] trimset (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2012-11-05 (enhancement) Now bytecompiled: [array exists], [array set], +[array unset], [dict create], [dict exists], [dict merge], [format], +[info commands], [info coroutine], [info level], [info object], +[namespace current], [namespace code], [namespace qualifiers], [namespace tail], +[namespace which], [regsub], [self], [string first], [string last], +[string map], [string range], [tailcall], [yield]. (fellows) + 2012-11-06 (bug fix)[3581754] avoid multiple callback on keep-alive (fellows) => http 2.8.5 ---- Released 8.6.0, ??? ??, 2012 --- See ChangeLog for details --- +2012-11-07 tzdata updated to Olson's tzdata2012i (kenny) + +2012-11-13 (bug fix)[3567063] thread fp settings from master (mistachkin) + +2012-11-14 (bug fix)[2933003] tempfile creation in $TMPDIR (fellows) + +2012-11-15 (TIP 416) New [load] options -global and -lazy (nijtmans) + +2012-11-20 (bug fix)[3033307] base64 trail whitespace (kovalenko,goth) + +2012-12-03 (bug fix) [configure] query broke init from argv (porter) +=> tcltest 2.3.5 + +--- Released 8.6.0, December 20, 2012 --- See ChangeLog for details --- -- cgit v0.12 From b8f7032b2378ad5140908f50da466efe081d0afb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Dec 2012 10:48:04 +0000 Subject: Fix Tcl_DecrRefCount macro, not to refer to its objPtr parameter twice. --- generic/tcl.h | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 36077e6..48fe062 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -810,9 +810,7 @@ typedef struct Tcl_Obj { * Note: clients should use Tcl_DecrRefCount() when they are finished using * an object, and should never call TclFreeObj() directly. TclFreeObj() is * only defined and made public in tcl.h to support Tcl_DecrRefCount's macro - * definition. Note also that Tcl_DecrRefCount() refers to the parameter - * "obj" twice. This means that you should avoid calling it with an - * expression that is expensive to compute or has side effects. + * definition. */ void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); @@ -833,7 +831,12 @@ int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); * http://c2.com/cgi/wiki?TrivialDoWhileLoop */ # define Tcl_DecrRefCount(objPtr) \ - do { if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr); } while(0) + do { \ + Tcl_Obj *obj = (objPtr); \ + if ((obj)->refCount-- < 2) { \ + TclFreeObj(obj); \ + } \ + } while(0) # define Tcl_IsShared(objPtr) \ ((objPtr)->refCount > 1) #endif -- cgit v0.12 From e30259f5920c3e4e6a6ff76d6c7d80bdbfd5ac32 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Dec 2012 12:03:51 +0000 Subject: Changelog entry, and change macro variable to not conflict with possible outside variable names --- ChangeLog | 5 +++++ generic/tcl.h | 6 +++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index ef04907..092d5f9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-12-13 Jan Nijtmans + + * generic/tcl.h: Fix Tcl_DecrRefCount macro such that it + doesn't access its objPtr parameter twice any more. + 2012-11-14 Donal K. Fellows * unix/tclUnixPipe.c (DefaultTempDir): [Bug 2933003]: Allow overriding diff --git a/generic/tcl.h b/generic/tcl.h index 48fe062..bf9b446 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -832,9 +832,9 @@ int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); */ # define Tcl_DecrRefCount(objPtr) \ do { \ - Tcl_Obj *obj = (objPtr); \ - if ((obj)->refCount-- < 2) { \ - TclFreeObj(obj); \ + Tcl_Obj *_objPtr = (objPtr); \ + if (_objPtr->refCount-- < 2) { \ + TclFreeObj(_objPtr); \ } \ } while(0) # define Tcl_IsShared(objPtr) \ -- cgit v0.12 From 86ced50657a467a7e29470be90d1d13061b84a2d Mon Sep 17 00:00:00 2001 From: mig Date: Thu, 13 Dec 2012 13:37:19 +0000 Subject: Fix for [Bug 3595576], found by andrewsh --- ChangeLog | 7 +++++++ generic/tclCmdAH.c | 3 ++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 87f0260..13fcaf8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2012-11-13 Miguel Sofer + + * generic/tclCmdAH.c (CatchObjCmdCallback): do not decrRefCount + the newValuePtr sent to Tcl_ObjSetVar2: TOSV2 is 'fire and + forget', it decrs on its own. Fix for [Bug 3595576], found by + andrewsh. + 2012-12-13 Jan Nijtmans * generic/tcl.h: Fix Tcl_DecrRefCount macro such that it diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 14951e4..133a61b 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -361,7 +361,8 @@ CatchObjCmdCallback( if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, options, TCL_LEAVE_ERR_MSG)) { - Tcl_DecrRefCount(options); + /* Do not decrRefCount 'options', it was already done by + * Tcl_ObjSetVar2 */ return TCL_ERROR; } } -- cgit v0.12 From 7cf0ac1eafc58e6473a6f2d2e2c0480628ac626c Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Dec 2012 15:59:51 +0000 Subject: 3595576 Tests/fix for mem corruption: [catch] fails to store options in a var. --- generic/tclCmdAH.c | 1 - tests/cmdAH.test | 6 ++++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 8e32389..44f08a3 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -273,7 +273,6 @@ Tcl_CatchObjCmd( Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, options, 0)) { - Tcl_DecrRefCount(options); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't save return options in variable", NULL); diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 2e94d7d..fb0fefc 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -46,6 +46,12 @@ test cmdAH-1.2 {Tcl_CatchObjCmd, errors} { test cmdAH-1.3 {Tcl_CatchObjCmd, errors} { list [catch {catch foo bar baz spaz} msg] $msg } {1 {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}} +test cmdAH-1.4 {Bug 3595576} { + catch {catch {} -> noSuchNs::var} +} 1 +test cmdAH-1.5 {Bug 3595576} { + catch {catch error -> noSuchNs::var} +} 1 test cmdAH-2.1 {Tcl_CdObjCmd} { list [catch {cd foo bar} msg] $msg -- cgit v0.12 From 990ca78bafc3a3a4363dbdaca20c2c3f78b8ee83 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Dec 2012 16:11:07 +0000 Subject: Restore clarity to macro test. --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index bf9b446..9dd6ff0 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -833,7 +833,7 @@ int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); # define Tcl_DecrRefCount(objPtr) \ do { \ Tcl_Obj *_objPtr = (objPtr); \ - if (_objPtr->refCount-- < 2) { \ + if (--(_objPtr)->refCount <= 0) { \ TclFreeObj(_objPtr); \ } \ } while(0) -- cgit v0.12 From 73eeb5f121c51edba58ed7deaa273a7381110e26 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Dec 2012 19:43:43 +0000 Subject: Simplify the [info object] and [info class] additions. --- generic/tclOOInfo.c | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index e09ee4e..3f37a6d 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -114,21 +114,15 @@ TclOOInitInfo( infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) { - Tcl_Obj *mapDict, *objectObj, *classObj; + Tcl_Obj *mapDict; Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); if (mapDict != NULL) { - objectObj = Tcl_NewStringObj("object", -1); - classObj = Tcl_NewStringObj("class", -1); - Tcl_IncrRefCount(objectObj); - Tcl_IncrRefCount(classObj); - Tcl_DictObjPut(NULL, mapDict, objectObj, + Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1), Tcl_NewStringObj("::oo::InfoObject", -1)); - Tcl_DictObjPut(NULL, mapDict, classObj, + Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1), Tcl_NewStringObj("::oo::InfoClass", -1)); - Tcl_DecrRefCount(objectObj); - Tcl_DecrRefCount(classObj); Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); } } -- cgit v0.12 From 4eaff43e124f523dca05591bc760fa9f32eb7672 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 13 Dec 2012 20:20:46 +0000 Subject: TIP 400 suffered from the same segfaulting flaw as 3595576. Segfaulting test and fix committed. --- generic/tclZlib.c | 19 +++---------------- tests/zlib.test | 14 ++++++++++++++ 2 files changed, 17 insertions(+), 16 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 8fbe049..9c1176e 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -507,7 +507,7 @@ GenerateHeader( * ExtractHeader -- * * Take the values out of a gzip header and store them in a dictionary. - * SetValue is a helper function. + * SetValue is a helper macro. * * Results: * None. @@ -518,18 +518,8 @@ GenerateHeader( *---------------------------------------------------------------------- */ -static inline void -SetValue( - Tcl_Obj *dictObj, - const char *key, - Tcl_Obj *value) -{ - Tcl_Obj *keyObj = Tcl_NewStringObj(key, -1); - - Tcl_IncrRefCount(keyObj); - Tcl_DictObjPut(NULL, dictObj, keyObj, value); - TclDecrRefCount(keyObj); -} +#define SetValue(dictObj, key, value) \ + Tcl_DictObjPut(NULL, (dictObj), Tcl_NewStringObj((key), -1), (value)) static void ExtractHeader( @@ -2119,9 +2109,6 @@ ZlibCmd( } if (headerVarObj != NULL && Tcl_ObjSetVar2(interp, headerVarObj, NULL, headerDictObj, TCL_LEAVE_ERR_MSG) == NULL) { - if (headerDictObj) { - TclDecrRefCount(headerDictObj); - } return TCL_ERROR; } return TCL_OK; diff --git a/tests/zlib.test b/tests/zlib.test index 5f1e5fc..891dba0 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -826,6 +826,20 @@ test zlib-11.2 "Bug #3390073: mis-appled gzip filtering" -setup { } -cleanup { removeFile $file } -result {1000 /foo/bar 0} +test zlib-11.3 {Bug 3595576 variant} -setup { + set file [makeFile {} test.input] +} -constraints zlib -body { + set f [open $file wb] + puts -nonewline [zlib push gzip $f -header {filename /foo/bar}] \ + [string repeat "hello" 1000] + close $f + set f [open $file rb] + set d [read $f] + close $f + zlib gunzip $d -header noSuchNs::foo +} -cleanup { + removeFile $file +} -returnCodes error -result {can't set "noSuchNs::foo": parent namespace doesn't exist} ::tcltest::cleanupTests return -- cgit v0.12 From 97482cca000b9f31593285d349c05793f79f9863 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 17 Dec 2012 14:27:44 +0000 Subject: Slim down the code a bit more; we can make more safe assumptions. --- generic/tclOOInfo.c | 20 +++++++------------- 1 file changed, 7 insertions(+), 13 deletions(-) diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 3f37a6d..5be9b01 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -100,6 +100,7 @@ TclOOInitInfo( Tcl_Interp *interp) { Tcl_Command infoCmd; + Tcl_Obj *mapDict; /* * Build the ensembles used to implement [info object] and [info class]. @@ -113,19 +114,12 @@ TclOOInitInfo( */ infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); - if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) { - Tcl_Obj *mapDict; - - Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); - if (mapDict != NULL) { - - Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1), - Tcl_NewStringObj("::oo::InfoObject", -1)); - Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1), - Tcl_NewStringObj("::oo::InfoClass", -1)); - Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); - } - } + Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); + Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1), + Tcl_NewStringObj("::oo::InfoObject", -1)); + Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1), + Tcl_NewStringObj("::oo::InfoClass", -1)); + Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); } /* -- cgit v0.12 From 71500874b393cf7e4a8528218307492dd88d18b7 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 18 Dec 2012 09:37:42 +0000 Subject: Generate better code for the common case of subst-ed variables where the variable is a simple scalar or an array with a simple literal element name. --- generic/tclCompCmdsSZ.c | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 9c93fb2..71a1dfc 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -836,6 +836,21 @@ TclSubstCompile( TclEmitPush(literal, envPtr); count++; continue; + case TCL_TOKEN_VARIABLE: + /* + * Simple variable access; can only generate TCL_OK or TCL_ERROR + * so no need to generate elaborate exception-management code. + */ + + if (tokenPtr->numComponents == 1 || (tokenPtr->numComponents == 2 + && tokenPtr[2].type == TCL_TOKEN_TEXT)) { + envPtr->line = bline; + TclCompileVarSubst(interp, tokenPtr, envPtr); + bline = envPtr->line; + count++; + continue; + } + break; } while (count > 255) { -- cgit v0.12 From ee58f2d325a281f03cf6669e8d7ae2c377a5af2d Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 18 Dec 2012 10:21:34 +0000 Subject: Better version that can handle simple composite array keys as well. As long as they are free of command substitutions, we can still safely omit the exception processor code. --- generic/tclCompCmdsSZ.c | 33 +++++++++++++++++++++++---------- 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 71a1dfc..7bead0d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -838,19 +838,32 @@ TclSubstCompile( continue; case TCL_TOKEN_VARIABLE: /* - * Simple variable access; can only generate TCL_OK or TCL_ERROR - * so no need to generate elaborate exception-management code. + * Check for simple variable access; see if we can only generate + * TCL_OK or TCL_ERROR from the substituted variable read; if so, + * there is no need to generate elaborate exception-management + * code. Note that the first component of TCL_TOKEN_VARIABLE is + * always TCL_TOKEN_TEXT... */ - if (tokenPtr->numComponents == 1 || (tokenPtr->numComponents == 2 - && tokenPtr[2].type == TCL_TOKEN_TEXT)) { - envPtr->line = bline; - TclCompileVarSubst(interp, tokenPtr, envPtr); - bline = envPtr->line; - count++; - continue; + if (tokenPtr->numComponents > 1) { + int i, foundCommand = 0; + + for (i=2 ; i<=tokenPtr->numComponents ; i++) { + if (tokenPtr[i].type == TCL_TOKEN_COMMAND) { + foundCommand = 1; + break; + } + } + if (foundCommand) { + break; + } } - break; + + envPtr->line = bline; + TclCompileVarSubst(interp, tokenPtr, envPtr); + bline = envPtr->line; + count++; + continue; } while (count > 255) { -- cgit v0.12