From 4884764d1d8d9cf7bd61e25622b0173c43e46114 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 13 Apr 2011 11:03:30 +0000 Subject: [3285375]: Make the crash less mysterious through the judicious use of a panic. --- ChangeLog | 27 +++++++++++++++++---------- generic/tclUtil.c | 5 +++++ 2 files changed, 22 insertions(+), 10 deletions(-) diff --git a/ChangeLog b/ChangeLog index cc68aaa..7bf374c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2011-04-13 Donal K. Fellows + + * generic/tclUtil.c (Tcl_ConcatObj): [Bug 3285375]: Make the crash + less mysterious through the judicious use of a panic. Not yet properly + fixed, but at least now clearer what the failure mode is. + 2011-04-12 Don Porter * tests/string.test: Test for [Bug 3285472]. Not buggy in trunk. @@ -8,31 +14,32 @@ 2011-04-12 Miguel Sofer - * generic/tclBasic.c: fix for [Bug 2440625], kbk's patch + * generic/tclBasic.c: Fix for [Bug 2440625], kbk's patch 2011-04-11 Miguel Sofer * generic/tclBasic.c: - * tests/coroutine.test: insure that 'coroutine eval' runs the initial - command in the proper context, [Bug 3282869] - + * tests/coroutine.test: [Bug 3282869]: Ensure that 'coroutine eval' + runs the initial command in the proper context. + 2011-04-11 Jan Nijtmans - * generic/tcl.h: fix for [Bug 3281728]: Tcl sources from 2011-04-06 do - * unix/tcl.m4: not build on GCC9 (RH9) + + * generic/tcl.h: Fix for [Bug 3281728]: Tcl sources from 2011-04-06 + * unix/tcl.m4: do not build on GCC9 (RH9) * unix/configure: 2011-04-08 Jan Nijtmans - * win/tclWinPort.h: fix for [Bug 3280043]: win2k: unresolved DLL imports - * win/configure.in + * win/tclWinPort.h: Fix for [Bug 3280043]: win2k: unresolved DLL + * win/configure.in: imports. * win/configure 2011-04-06 Miguel Sofer - * generic/tclExecute.c (TclCompileObj): earlier return if Tip280 + * generic/tclExecute.c (TclCompileObj): Earlier return if Tip280 gymnastics not needed. - * generic/tclExecute.c: fix for [Bug 3274728], making *catchTop an + * generic/tclExecute.c: Fix for [Bug 3274728]: making *catchTop an unsigned long. 2011-04-06 Jan Nijtmans diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 64aa824..46ddf85 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1110,10 +1110,15 @@ Tcl_ConcatObj( allocSize = 0; for (i = 0; i < objc; i++) { + int oldAllocSize = allocSize; + objPtr = objv[i]; element = TclGetStringFromObj(objPtr, &length); if ((element != NULL) && (length > 0)) { allocSize += (length + 1); + if (allocSize < oldAllocSize) { + Tcl_Panic("too much memory required"); + } } } if (allocSize == 0) { -- cgit v0.12 From cb46d8443010d208077152c70a8d11ea8f10ba9e Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 13 Apr 2011 13:09:19 +0000 Subject: fix for [Bug 2662380], crash caused by appending to a variable with a write trace that unsets it --- ChangeLog | 5 +++++ generic/tclVar.c | 3 ++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 1ee1018..2ff7fc6 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-04-13 Miguel Sofer + + * generic/tclVar.c: fix for [Bug 2662380], crash caused by + appending to a variable with a write trace that unsets it. + 2011-04-04 Don Porter * README: Updated README files, repairing broken URLs and diff --git a/generic/tclVar.c b/generic/tclVar.c index 3312191..a434bae 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -2699,7 +2699,8 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv) varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); - if (varValuePtr == NULL) { + if ((varValuePtr == NULL) || + (varValuePtr == ((Interp *) interp)->emptyObjPtr)) { return TCL_ERROR; } } -- cgit v0.12 From ff0738ff2d537d9c4d0d95d944bfd0a239baef8e Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 13 Apr 2011 13:19:36 +0000 Subject: fix for [Bug 2662380], crash caused by appending to a variable with a write trace that unsets it --- ChangeLog | 5 +++++ generic/tclVar.c | 7 ++++--- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index 14fb1e4..e90ee9d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-04-13 Miguel Sofer + + * generic/tclVar.c: fix for [Bug 2662380], crash caused by + appending to a variable with a write trace that unsets it. + 2011-04-12 Don Porter * generic/tclStringObj.c: Repair corruption in [string reverse] diff --git a/generic/tclVar.c b/generic/tclVar.c index 9815469..a1885b5 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -2554,13 +2554,14 @@ Tcl_AppendObjCmd( /* * Note that we do not need to increase the refCount of the Var * pointers: should a trace delete the variable, the return value - * of TclPtrSetVar will be NULL, and we will not access the - * variable again. + * of TclPtrSetVar will be NULL or emptyObjPtr, and we will not + * access the variable again. */ varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], NULL, objv[i], TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG, -1); - if (varValuePtr == NULL) { + if ((varValuePtr == NULL) || + (varValuePtr == ((Interp *) interp)->emptyObjPtr)) { return TCL_ERROR; } } -- cgit v0.12 From ef9aca4d1c097c0bb5c50d64ed819c38baef6387 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 13 Apr 2011 20:27:29 +0000 Subject: [Bug 3285375]: Rewrite Tcl_Concat*() and [string trim*]. --- ChangeLog | 11 +++ generic/tclCmdMZ.c | 127 ++++------------------------ generic/tclInt.h | 4 + generic/tclUtil.c | 239 +++++++++++++++++++++++++++++++++++++---------------- 4 files changed, 196 insertions(+), 185 deletions(-) diff --git a/ChangeLog b/ChangeLog index e90ee9d..508a72d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2011-04-13 Don Porter + + * generic/tclUtil.c: Rewrite of Tcl_Concat*() routines to + prevent segfaults on buffer overflow. Build them out of existing + primitives already coded to handle overflow properly. Uses the + new TclTrim*() routines. [Bug 3285375] + + * generic/tclCmdMZ.c: New internal utility routines TclTrimLeft() + * generic/tclInt.h: and TclTrimRight(). Refactor the + * generic/tclUtil.c: [string trim*] implementations to use them. + 2011-04-13 Miguel Sofer * generic/tclVar.c: fix for [Bug 2662380], crash caused by diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index cf74db5..7c3855c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3108,10 +3108,8 @@ StringTrimCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch, trim; - register const char *p, *end; - const char *check, *checkEnd, *string1, *string2; - int offset, length1, length2; + const char *string1, *string2; + int triml, trimr, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); @@ -3123,58 +3121,12 @@ StringTrimCmd( return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); - checkEnd = string2 + length2; - /* - * The outer loop iterates over the string. The inner loop iterates over - * the trim characters. The loops terminate as soon as a non-trim - * character is discovered and string1 is left pointing at the first - * non-trim character. - */ - - end = string1 + length1; - for (p = string1; p < end; p += offset) { - offset = TclUtfToUniChar(p, &ch); - - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - string1 += offset; - break; - } - } - } - - /* - * The outer loop iterates over the string. The inner loop iterates over - * the trim characters. The loops terminate as soon as a non-trim - * character is discovered and length1 marks the last non-trim character. - */ - - end = string1; - for (p = string1 + length1; p > end; ) { - p = Tcl_UtfPrev(p, string1); - offset = TclUtfToUniChar(p, &ch); - check = string2; - while (1) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - break; - } - } - } + triml = TclTrimLeft(string1, length1, string2, length2); + trimr = TclTrimRight(string1 + triml, length1 - triml, string2, length2); - Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(string1 + triml, length1 - triml - trimr)); return TCL_OK; } @@ -3204,10 +3156,8 @@ StringTrimLCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch, trim; - register const char *p, *end; - const char *check, *checkEnd, *string1, *string2; - int offset, length1, length2; + const char *string1, *string2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); @@ -3219,34 +3169,10 @@ StringTrimLCmd( return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); - checkEnd = string2 + length2; - - /* - * The outer loop iterates over the string. The inner loop iterates over - * the trim characters. The loops terminate as soon as a non-trim - * character is discovered and string1 is left pointing at the first - * non-trim character. - */ - - end = string1 + length1; - for (p = string1; p < end; p += offset) { - offset = TclUtfToUniChar(p, &ch); - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - string1 += offset; - break; - } - } - } + trim = TclTrimLeft(string1, length1, string2, length2); - Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(string1+trim, length1-trim)); return TCL_OK; } @@ -3276,10 +3202,8 @@ StringTrimRCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch, trim; - register const char *p, *end; - const char *check, *checkEnd, *string1, *string2; - int offset, length1, length2; + const char *string1, *string2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); @@ -3291,33 +3215,10 @@ StringTrimRCmd( return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); - checkEnd = string2 + length2; - /* - * The outer loop iterates over the string. The inner loop iterates over - * the trim characters. The loops terminate as soon as a non-trim - * character is discovered and length1 marks the last non-trim character. - */ - - end = string1; - for (p = string1 + length1; p > end; ) { - p = Tcl_UtfPrev(p, string1); - offset = TclUtfToUniChar(p, &ch); - check = string2; - while (1) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - break; - } - } - } + trim = TclTrimRight(string1, length1, string2, length2); - Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1-trim)); return TCL_OK; } diff --git a/generic/tclInt.h b/generic/tclInt.h index c966610..b8a4dfa 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2784,6 +2784,10 @@ MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int *clNextOuter, CONST char *outerScript); MODULE_SCOPE void TclTransferResult(Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp); +MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, + const char *trim, int numTrim); +MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, + const char *trim, int numTrim); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_PackageInitProc *TclpFindSymbol(Tcl_Interp *interp, diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 3565165..2f2deec 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -937,6 +937,142 @@ Tcl_Backslash( /* *---------------------------------------------------------------------- * + * TclTrimRight -- + * Takes two counted strings in the Tcl encoding which must both be + * null terminated. Conceptually trims from the right side of the + * first string all characters found in the second string. + * + * Results: + * The number of bytes to be removed from the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclTrimRight( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ +{ + const char *p = bytes + numBytes; + int pInc; + + if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { + Tcl_Panic("TclTrimRight works only on null-terminated strings"); + } + + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + /* Outer loop: iterate over string to be trimmed */ + do { + Tcl_UniChar ch1; + const char *q = trim; + int bytesLeft = numTrim; + + p = Tcl_UtfPrev(p, bytes); + pInc = TclUtfToUniChar(p, &ch1); + + /* Inner loop: scan trim string for match to current character */ + do { + Tcl_UniChar ch2; + int qInc = TclUtfToUniChar(q, &ch2); + + if (ch1 == ch2) { + break; + } + + q += qInc; + bytesLeft -= qInc; + } while (bytesLeft); + + if (bytesLeft == 0) { + /* No match; trim task done; *p is last non-trimmed char */ + break; + } + pInc = 0; + } while (p > bytes); + + return numBytes - (p - bytes) - pInc; +} + +/* + *---------------------------------------------------------------------- + * + * TclTrimLeft -- + * Takes two counted strings in the Tcl encoding which must both be + * null terminated. Conceptually trims from the left side of the + * first string all characters found in the second string. + * + * Results: + * An integer index into the first string, pointing to the first + * character not to be trimmed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclTrimLeft( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ +{ + const char *p = bytes; + + if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { + Tcl_Panic("TclTrimLeft works only on null-terminated strings"); + } + + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + /* Outer loop: iterate over string to be trimmed */ + do { + Tcl_UniChar ch1; + int pInc = TclUtfToUniChar(p, &ch1); + const char *q = trim; + int bytesLeft = numTrim; + + /* Inner loop: scan trim string for match to current character */ + do { + Tcl_UniChar ch2; + int qInc = TclUtfToUniChar(q, &ch2); + + if (ch1 == ch2) { + break; + } + + q += qInc; + bytesLeft -= qInc; + } while (bytesLeft); + + if (bytesLeft == 0) { + /* No match; trim task done; *p is first non-trimmed char */ + break; + } + + p += pInc; + numBytes -= pInc; + } while (numBytes); + + return p - bytes; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_Concat -- * * Concatenate a set of strings into a single large string. @@ -964,6 +1100,9 @@ Tcl_Concat( for (totalSize = 1, i = 0; i < argc; i++) { totalSize += strlen(argv[i]) + 1; + if (totalSize <= 0) { + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); + } } result = (char *) ckalloc((unsigned) totalSize); if (argc == 0) { @@ -1029,19 +1168,13 @@ Tcl_ConcatObj( int objc, /* Number of objects to concatenate. */ Tcl_Obj *CONST objv[]) /* Array of objects to concatenate. */ { - int allocSize, finalSize, length, elemLength, i; - char *p; - char *element; - char *concatStr; + int i, needSpace = 0; Tcl_Obj *objPtr, *resPtr; /* * Check first to see if all the items are of list type or empty. If so, * we will concat them together as lists, and return a list object. This - * is only valid when the lists have no current string representation, - * since we don't know what the original type was. An original string rep - * may have lost some whitespace info when converted which could be - * important. + * is only valid when the lists are in canonical form. */ for (i = 0; i < objc; i++) { @@ -1100,79 +1233,41 @@ Tcl_ConcatObj( * the slow way, using the string representations. */ - allocSize = 0; + TclNewObj(resPtr); for (i = 0; i < objc; i++) { + int trim, elemLength; + const char *element; + objPtr = objv[i]; - element = TclGetStringFromObj(objPtr, &length); - if ((element != NULL) && (length > 0)) { - allocSize += (length + 1); - } - } - if (allocSize == 0) { - allocSize = 1; /* enough for the NULL byte at end */ - } - - /* - * Allocate storage for the concatenated result. Note that allocSize is - * one more than the total number of characters, and so includes room for - * the terminating NULL byte. - */ - - concatStr = ckalloc((unsigned) allocSize); + element = TclGetStringFromObj(objPtr, &elemLength); - /* - * Now concatenate the elements. Clip white space off the front and back - * to generate a neater result, and ignore any empty elements. Also put a - * null byte at the end. - */ + /* Trim away the leading whitespace */ + trim = TclTrimLeft(element, elemLength, " \f\v\r\t\n", 6); + element += trim; + elemLength -= trim; - finalSize = 0; - if (objc == 0) { - *concatStr = '\0'; - } else { - p = concatStr; - for (i = 0; i < objc; i++) { - objPtr = objv[i]; - element = TclGetStringFromObj(objPtr, &elemLength); - while ((elemLength > 0) && (UCHAR(*element) < 127) - && isspace(UCHAR(*element))) { /* INTL: ISO C space. */ - element++; - elemLength--; - } + /* + * Trim away the trailing whitespace. Do not permit trimming + * to expose a final backslash character. + */ - /* - * Trim trailing white space. But, be careful not to trim a space - * character if it is preceded by a backslash: in this case it - * could be significant. - */ + trim = TclTrimRight(element, elemLength, " \f\v\r\t\n", 6); + trim -= trim && (element[elemLength - trim - 1] == '\\'); + elemLength -= trim; - while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127) - && isspace(UCHAR(element[elemLength-1])) - /* INTL: ISO C space. */ - && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { - elemLength--; - } - if (elemLength == 0) { - continue; /* nothing left of this element */ - } - memcpy(p, element, (size_t) elemLength); - p += elemLength; - *p = ' '; - p++; - finalSize += (elemLength + 1); + /* If we're left with empty element after trimming, do nothing */ + if (elemLength == 0) { + continue; } - if (p != concatStr) { - p[-1] = 0; - finalSize -= 1; /* we overwrote the final ' ' */ - } else { - *p = 0; + + /* Append to the result with space if needed */ + if (needSpace) { + Tcl_AppendToObj(resPtr, " ", 1); } + Tcl_AppendToObj(resPtr, element, elemLength); + needSpace = 1; } - - TclNewObj(objPtr); - objPtr->bytes = concatStr; - objPtr->length = finalSize; - return objPtr; + return resPtr; } /* -- cgit v0.12 From 341459596f22fe7e76ab600503bd3c826b7832e4 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 14 Apr 2011 15:33:40 +0000 Subject: More Tcl_Concat* and TclTrim* improvements. --- generic/tclUtil.c | 126 ++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 79 insertions(+), 47 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 2f2deec..44a24f8 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -994,12 +994,12 @@ TclTrimRight( if (bytesLeft == 0) { /* No match; trim task done; *p is last non-trimmed char */ + p += pInc; break; } - pInc = 0; } while (p > bytes); - return numBytes - (p - bytes) - pInc; + return numBytes - (p - bytes); } /* @@ -1011,8 +1011,7 @@ TclTrimRight( * first string all characters found in the second string. * * Results: - * An integer index into the first string, pointing to the first - * character not to be trimmed. + * The number of bytes to be removed from the start of the string. * * Side effects: * None. @@ -1089,59 +1088,77 @@ TclTrimLeft( *---------------------------------------------------------------------- */ +/* The whitespace characters trimmed during [concat] operations */ +#define CONCAT_WS " \f\v\r\t\n" +#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_WS "") - 1) + char * Tcl_Concat( int argc, /* Number of strings to concatenate. */ CONST char * CONST *argv) /* Array of strings to concatenate. */ { - int totalSize, i; - char *p; - char *result; + int i, needSpace = 0, bytesNeeded = 0; + char *result, *p; - for (totalSize = 1, i = 0; i < argc; i++) { - totalSize += strlen(argv[i]) + 1; - if (totalSize <= 0) { - Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); - } - } - result = (char *) ckalloc((unsigned) totalSize); + /* Dispose of the empty result corner case first to simplify later code */ if (argc == 0) { - *result = '\0'; + result = (char *) ckalloc(1); + result[0] = '\0'; return result; } - for (p = result, i = 0; i < argc; i++) { - CONST char *element; - int length; + /* First allocate the result buffer at the size required */ + for (i = 0; i < argc; i++) { + bytesNeeded += strlen(argv[i]); + if (bytesNeeded < 0) { + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); + } + } + if (bytesNeeded + argc - 1 < 0) { /* - * Clip white space off the front and back of the string to generate a - * neater result, and ignore any empty elements. + * Panic test could be tighter, but not going to bother for + * this legacy routine. */ + Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); + } + /* All element bytes + (argc - 1) spaces + 1 terminating NULL */ + result = (char *) ckalloc((unsigned) (bytesNeeded + argc)); + for (p = result, i = 0; i < argc; i++) { + int trim, elemLength; + const char *element; + element = argv[i]; - while (isspace(UCHAR(*element))) { /* INTL: ISO space. */ - element++; - } - for (length = strlen(element); - (length > 0) - && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ - && ((length < 2) || (element[length-2] != '\\')); - length--) { - /* Null loop body. */ - } - if (length == 0) { + elemLength = strlen(argv[i]); + + /* Trim away the leading whitespace */ + trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + element += trim; + elemLength -= trim; + + /* + * Trim away the trailing whitespace. Do not permit trimming + * to expose a final backslash character. + */ + + trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim -= trim && (element[elemLength - trim - 1] == '\\'); + elemLength -= trim; + + /* If we're left with empty element after trimming, do nothing */ + if (elemLength == 0) { continue; } - memcpy(p, element, (size_t) length); - p += length; - *p = ' '; - p++; - } - if (p != result) { - p[-1] = 0; - } else { - *p = 0; + + /* Append to the result with space if needed */ + if (needSpace) { + *p++ = ' '; + } + memcpy(p, element, (size_t) elemLength); + p += elemLength; + needSpace = 1; } + *p = '\0'; return result; } @@ -1168,7 +1185,8 @@ Tcl_ConcatObj( int objc, /* Number of objects to concatenate. */ Tcl_Obj *CONST objv[]) /* Array of objects to concatenate. */ { - int i, needSpace = 0; + int i, elemLength, needSpace = 0, bytesNeeded = 0; + const char *element; Tcl_Obj *objPtr, *resPtr; /* @@ -1233,16 +1251,30 @@ Tcl_ConcatObj( * the slow way, using the string representations. */ + /* First try to pre-allocate the size required */ + for (i = 0; i < objc; i++) { + element = TclGetStringFromObj(objv[i], &elemLength); + bytesNeeded += elemLength; + if (bytesNeeded < 0) { + break; + } + } + /* + * Does not matter if this fails, will simply try later to build up + * the string with each Append reallocating as needed with the usual + * string append algorithm. When that fails it will report the error. + */ TclNewObj(resPtr); + Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); + Tcl_SetObjLength(resPtr, 0); + for (i = 0; i < objc; i++) { - int trim, elemLength; - const char *element; + int trim; - objPtr = objv[i]; - element = TclGetStringFromObj(objPtr, &elemLength); + element = TclGetStringFromObj(objv[i], &elemLength); /* Trim away the leading whitespace */ - trim = TclTrimLeft(element, elemLength, " \f\v\r\t\n", 6); + trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); element += trim; elemLength -= trim; @@ -1251,7 +1283,7 @@ Tcl_ConcatObj( * to expose a final backslash character. */ - trim = TclTrimRight(element, elemLength, " \f\v\r\t\n", 6); + trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; -- cgit v0.12 From 915f2744b9947b03a54a56f1bcedbe611452ba56 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 16 Apr 2011 11:35:17 +0000 Subject: Added code to try to tame the [file attributes] guts, while trying to simplify things enough that I can puzzle out AK's TclVFS problems. I suspect this is not a real fix though; just an attempt to make the problem tractable. --- ChangeLog | 31 +++++++++++++++++++------------ generic/tclFCmd.c | 21 ++++++++++++--------- 2 files changed, 31 insertions(+), 21 deletions(-) diff --git a/ChangeLog b/ChangeLog index 508a72d..1297137 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,9 +1,16 @@ +2011-04-16 Donal K. Fellows + + * generic/tclFCmd.c (TclFileAttrsCmd): Tidied up the memory management + a bit to try to ensure that the dynamic and static cases don't get + confused while still promoting caching where possible. Added a panic + to trap problems in the case where an extension is misusing the API. + 2011-04-13 Don Porter - * generic/tclUtil.c: Rewrite of Tcl_Concat*() routines to - prevent segfaults on buffer overflow. Build them out of existing - primitives already coded to handle overflow properly. Uses the - new TclTrim*() routines. [Bug 3285375] + * generic/tclUtil.c: [Bug 3285375]: Rewrite of Tcl_Concat*() + routines to prevent segfaults on buffer overflow. Build them out of + existing primitives already coded to handle overflow properly. Uses + the new TclTrim*() routines. * generic/tclCmdMZ.c: New internal utility routines TclTrimLeft() * generic/tclInt.h: and TclTrimRight(). Refactor the @@ -11,14 +18,14 @@ 2011-04-13 Miguel Sofer - * generic/tclVar.c: fix for [Bug 2662380], crash caused by - appending to a variable with a write trace that unsets it. + * generic/tclVar.c: [Bug 2662380]: Fix crash caused by appending to a + variable with a write trace that unsets it. 2011-04-12 Don Porter - * generic/tclStringObj.c: Repair corruption in [string reverse] - * tests/string.test: when string rep invalidation failed to also - reset the bytes allocated for string rep to zero [Bug 3285472]. + * generic/tclStringObj.c: [Bug 3285472]: Repair corruption in + * tests/string.test: [string reverse] when string rep invalidation + failed to also reset the bytes allocated for string rep to zero. 2011-04-12 Venkat Iyer @@ -26,7 +33,7 @@ 2011-04-06 Miguel Sofer - * generic/tclExecute.c (TclCompEvalObj): earlier return if Tip280 + * generic/tclExecute.c (TclCompEvalObj): Earlier return if Tip280 gymnastics not needed. 2011-04-05 Venkat Iyer @@ -47,8 +54,8 @@ 2011-04-02 Kevin B. Kenny - * generic/tclStrToD.c (QuickConversion): Replaced another couple - of 'double' declarations with 'volatile double' to work around + * generic/tclStrToD.c (QuickConversion): Replaced another couple of + 'double' declarations with 'volatile double' to work around misrounding issues in mingw-gcc 3.4.5. 2011-03-24 Donal K. Fellows diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 53f955f..5850846 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -950,7 +950,7 @@ TclFileAttrsCmd( int result; CONST char ** attributeStrings; Tcl_Obj* objStrings = NULL; - int numObjStrings = -1; + int numObjStrings = -1, didAlloc = 0; Tcl_Obj *filePtr; if (objc < 3) { @@ -983,9 +983,8 @@ TclFileAttrsCmd( Tcl_AppendResult(interp, "could not read \"", TclGetString(filePtr), "\": ", Tcl_PosixError(interp), NULL); - return TCL_ERROR; } - goto end; + return TCL_ERROR; } /* @@ -1003,12 +1002,16 @@ TclFileAttrsCmd( } attributeStrings = (CONST char **) TclStackAlloc(interp, (1+numObjStrings) * sizeof(char*)); + didAlloc = 1; for (index = 0; index < numObjStrings; index++) { Tcl_ListObjIndex(interp, objStrings, index, &objPtr); attributeStrings[index] = TclGetString(objPtr); } attributeStrings[index] = NULL; + } else if (objStrings != NULL) { + Tcl_Panic("must not update objPtrRef's variable and return non-NULL"); } + if (objc == 0) { /* * Get all attributes. @@ -1069,7 +1072,7 @@ TclFileAttrsCmd( "option", 0, &index) != TCL_OK) { goto end; } - if (numObjStrings != -1) { + if (didAlloc) { TclFreeIntRep(objv[0]); } if (Tcl_FSFileAttrsGet(interp, index, filePtr, @@ -1096,7 +1099,7 @@ TclFileAttrsCmd( "option", 0, &index) != TCL_OK) { goto end; } - if (numObjStrings != -1) { + if (didAlloc) { TclFreeIntRep(objv[i]); } if (i + 1 == objc) { @@ -1113,20 +1116,20 @@ TclFileAttrsCmd( result = TCL_OK; end: - if (numObjStrings != -1) { + if (didAlloc) { /* * Free up the array we allocated. */ TclStackFree(interp, (void *)attributeStrings); + } + if (objStrings != NULL) { /* * We don't need this object that was passed to us any more. */ - if (objStrings != NULL) { - Tcl_DecrRefCount(objStrings); - } + Tcl_DecrRefCount(objStrings); } return result; } -- cgit v0.12 From f1724b7ab36f74c7fc8f9f4c58e79be1864f14d5 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 16 Apr 2011 11:51:35 +0000 Subject: Added comments to try to tame the file attributes guts, while trying to simplify things enough that I can puzzle out AK's TclVFS problems. I suspect this is not a real fix though; just an attempt to make the problem tractable. --- ChangeLog | 18 ++++++++++++------ generic/tclFCmd.c | 36 ++++++++++++++++++++++-------------- 2 files changed, 34 insertions(+), 20 deletions(-) diff --git a/ChangeLog b/ChangeLog index d04c05e..13aa14a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,9 +1,15 @@ +2011-04-16 Donal K. Fellows + + * generic/tclFCmd.c (TclFileAttrsCmd): Add comments to make this code + easier to understand. Added a panic to handle the case where the VFS + layer does something odd. + 2011-04-13 Don Porter - * generic/tclUtil.c: Rewrite of Tcl_Concat*() routines to - prevent segfaults on buffer overflow. Build them out of existing - primitives already coded to handle overflow properly. Uses the - new TclTrim*() routines. [Bug 3285375] + * generic/tclUtil.c: [Bug 3285375]: Rewrite of Tcl_Concat*() + routines to prevent segfaults on buffer overflow. Build them out of + existing primitives already coded to handle overflow properly. Uses + the new TclTrim*() routines. * generic/tclCmdMZ.c: New internal utility routines TclTrimLeft() * generic/tclInt.h: and TclTrimRight(). Refactor the @@ -11,8 +17,8 @@ 2011-04-13 Miguel Sofer - * generic/tclVar.c: fix for [Bug 2662380], crash caused by - appending to a variable with a write trace that unsets it. + * generic/tclVar.c: [Bug 2662380]: Fix crash caused by appending to a + variable with a write trace that unsets it. 2011-04-13 Donal K. Fellows diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index e9176ca..048fa57 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -966,6 +966,10 @@ TclFileAttrsCmd( result = TCL_ERROR; Tcl_SetErrno(0); + /* + * Get the set of attribute names from the filesystem. + */ + attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings); if (attributeStrings == NULL) { int index; @@ -980,9 +984,8 @@ TclFileAttrsCmd( Tcl_AppendResult(interp, "could not read \"", TclGetString(filePtr), "\": ", Tcl_PosixError(interp), NULL); - return TCL_ERROR; } - goto end; + return TCL_ERROR; } /* @@ -1006,7 +1009,16 @@ TclFileAttrsCmd( } attributeStringsAllocated[index] = NULL; attributeStrings = attributeStringsAllocated; + } else if (objStrings != NULL) { + Tcl_Panic("must not update objPtrRef's variable and return non-NULL"); } + + /* + * Process the attributes to produce a list of all of them, the value of a + * particular attribute, or to set one or more attributes (depending on + * the number of arguments). + */ + if (objc == 0) { /* * Get all attributes. @@ -1114,21 +1126,17 @@ TclFileAttrsCmd( } result = TCL_OK; + /* + * Free up the array we allocated and drop our reference to any list of + * attribute names issued by the filesystem. + */ + end: if (attributeStringsAllocated != NULL) { - /* - * Free up the array we allocated. - */ - TclStackFree(interp, (void *) attributeStringsAllocated); - - /* - * We don't need this object that was passed to us any more. - */ - - if (objStrings != NULL) { - Tcl_DecrRefCount(objStrings); - } + } + if (objStrings != NULL) { + Tcl_DecrRefCount(objStrings); } return result; } -- cgit v0.12 From a6a5cd0c448ed7eab1edf7e9812853b9111593d5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Apr 2011 07:10:34 +0000 Subject: fix for [Bug 3288345]: Wrong Tcl_StatBuf used on MinGW. --- ChangeLog | 5 +++++ generic/tcl.h | 19 +++++++------------ 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2ff7fc6..87720e0 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-04-18 Jan Nijtmans + + * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf + used on MinGW. + 2011-04-13 Miguel Sofer * generic/tclVar.c: fix for [Bug 2662380], crash caused by diff --git a/generic/tcl.h b/generic/tcl.h index 245293e..a98b685 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -372,24 +372,14 @@ typedef long LONG; */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(__GNUC__) -# define TCL_WIDE_INT_TYPE long long -# if defined(__WIN32__) && !defined(__CYGWIN__) -# define TCL_LL_MODIFIER "I64" -# define TCL_LL_MODIFIER_SIZE 3 -# else -# define TCL_LL_MODIFIER "ll" -# define TCL_LL_MODIFIER_SIZE 2 -# endif -typedef struct stat Tcl_StatBuf; -# elif defined(__WIN32__) +# if defined(__WIN32__) # define TCL_WIDE_INT_TYPE __int64 # ifdef __BORLANDC__ typedef struct stati64 Tcl_StatBuf; # define TCL_LL_MODIFIER "L" # define TCL_LL_MODIFIER_SIZE 1 # else /* __BORLANDC__ */ -# if _MSC_VER < 1400 || !defined(_M_IX86) +# if (defined(_MSC_VER) && (_MSC_VER < 1400)) || !defined(_M_IX86) typedef struct _stati64 Tcl_StatBuf; # else typedef struct _stat64 Tcl_StatBuf; @@ -397,6 +387,11 @@ typedef struct _stat64 Tcl_StatBuf; # define TCL_LL_MODIFIER "I64" # define TCL_LL_MODIFIER_SIZE 3 # endif /* __BORLANDC__ */ +# elif defined(__GNUC__) +# define TCL_WIDE_INT_TYPE long long +# define TCL_LL_MODIFIER "ll" +# define TCL_LL_MODIFIER_SIZE 2 +typedef struct stat Tcl_StatBuf; # else /* __WIN32__ */ /* * Don't know what platform it is and configure hasn't discovered what -- cgit v0.12 From 76259f2d58dc67f1a0095a1891696b69167c3902 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 18 Apr 2011 10:19:13 +0000 Subject: [Bug 3288696]: Command summary was confusingly wrong when it came to [dict filter] with a 'value' filter. --- ChangeLog | 8 ++++++-- doc/dict.n | 2 +- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index 670038a..ca5e989 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,11 @@ +2011-04-18 Donal K. Fellows + + * doc/dict.n: [Bug 3288696]: Command summary was confusingly wrong + when it came to [dict filter] with a 'value' filter. + 2011-04-18 Jan Nijtmans - * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf - used on MinGW. + * generic/tcl.h: [Bug 3288345]: Fix wrong Tcl_StatBuf used on MinGW. 2011-04-16 Donal K. Fellows diff --git a/doc/dict.n b/doc/dict.n index c14a06f..561d418 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -67,7 +67,7 @@ dictionary, and a condition of \fBTCL_CONTINUE\fR is equivalent to a false result. The key/value pairs are tested in the order in which the keys were inserted into the dictionary. .TP -\fBdict filter \fIdictionaryValue \fBvalue \fIglobPattern\fR +\fBdict filter \fIdictionaryValue \fBvalue \fIglobPattern ...\fR .VS 8.6 The value rule only matches those key/value pairs whose values match any of the given patterns (in the style of \fBstring match\fR.) -- cgit v0.12 From 50920cb27bda1113bd1e4edf637f4a6d03c8d63a Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 18 Apr 2011 18:31:18 +0000 Subject: Define and use macros that test whether a Tcl list value is canonical. --- ChangeLog | 6 ++++ generic/tclBasic.c | 85 +++++++++++++++++++++++------------------------------- generic/tclInt.h | 6 ++++ generic/tclUtil.c | 17 ++++------- 4 files changed, 54 insertions(+), 60 deletions(-) diff --git a/ChangeLog b/ChangeLog index c28b0d1..d9e54e2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2011-04-18 Don Porter + + * generic/tclInt.h: Define and use macros that test whether + * generic/tclBasic.c: a Tcl list value is canonical. + * generic/tclUtil.c: + 2011-04-18 Jan Nijtmans * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 596254d..71bd45c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4900,8 +4900,7 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) * up by the caller. It knows better than us. */ - if ((!obj->bytes) || ((obj->typePtr == &tclListType) && - ((List *)obj->internalRep.twoPtrValue.ptr1)->canonicalFlag)) { + if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { return; } @@ -5083,61 +5082,50 @@ TclEvalObjEx( * internal rep). */ - if (objPtr->typePtr == &tclListType) { /* is a list... */ - List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1; - - if (objPtr->bytes == NULL || /* ...without a string rep */ - listRepPtr->canonicalFlag) {/* ...or that is canonical */ - /* - * TIP #280 Structures for tracking lines. As we know that this is - * dynamic execution we ignore the invoker, even if known. - */ + if (TclListObjIsCanonical(objPtr)) { + /* + * TIP #280 Structures for tracking lines. As we know that this is + * dynamic execution we ignore the invoker, even if known. + */ - int nelements; - Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr); - CmdFrame *eoFramePtr = (CmdFrame *) + int nelements; + Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr); + CmdFrame *eoFramePtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); - eoFramePtr->type = TCL_LOCATION_EVAL_LIST; - eoFramePtr->level = (iPtr->cmdFramePtr == NULL? - 1 : iPtr->cmdFramePtr->level + 1); - eoFramePtr->framePtr = iPtr->framePtr; - eoFramePtr->nextPtr = iPtr->cmdFramePtr; - - eoFramePtr->nline = 0; - eoFramePtr->line = NULL; + eoFramePtr->type = TCL_LOCATION_EVAL_LIST; + eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 + : iPtr->cmdFramePtr->level + 1); + eoFramePtr->framePtr = iPtr->framePtr; + eoFramePtr->nextPtr = iPtr->cmdFramePtr; - eoFramePtr->cmd.listPtr = objPtr; - Tcl_IncrRefCount(eoFramePtr->cmd.listPtr); - eoFramePtr->data.eval.path = NULL; + eoFramePtr->nline = 0; + eoFramePtr->line = NULL; - /* - * TIP #280 We do _not_ compute all the line numbers for the words - * in the command. For the eval of a pure list the most sensible - * choice is to put all words on line 1. Given that we neither - * need memory for them nor compute anything. 'line' is left - * NULL. The two places using this information (TclInfoFrame, and - * TclInitCompileEnv), are special-cased to use the proper line - * number directly instead of accessing the 'line' array. - */ + eoFramePtr->cmd.listPtr = objPtr; + Tcl_IncrRefCount(eoFramePtr->cmd.listPtr); + eoFramePtr->data.eval.path = NULL; - Tcl_ListObjGetElements(NULL, copyPtr, - &nelements, &elements); + /* + * TIP #280 We do _not_ compute all the line numbers for the words + * in the command. For the eval of a pure list the most sensible + * choice is to put all words on line 1. Given that we neither + * need memory for them nor compute anything. 'line' is left + * NULL. The two places using this information (TclInfoFrame, and + * TclInitCompileEnv), are special-cased to use the proper line + * number directly instead of accessing the 'line' array. + */ - iPtr->cmdFramePtr = eoFramePtr; - result = Tcl_EvalObjv(interp, nelements, elements, - flags); + Tcl_ListObjGetElements(NULL, copyPtr, &nelements, &elements); - Tcl_DecrRefCount(copyPtr); - iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; - Tcl_DecrRefCount(eoFramePtr->cmd.listPtr); - TclStackFree(interp, eoFramePtr); + iPtr->cmdFramePtr = eoFramePtr; + result = Tcl_EvalObjv(interp, nelements, elements, flags); - goto done; - } - } - - if (flags & TCL_EVAL_DIRECT) { + Tcl_DecrRefCount(copyPtr); + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + Tcl_DecrRefCount(eoFramePtr->cmd.listPtr); + TclStackFree(interp, eoFramePtr); + } else if (flags & TCL_EVAL_DIRECT) { /* * We're not supposed to use the compiler or byte-code interpreter. * Let Tcl_EvalEx evaluate the command directly (and probably more @@ -5297,7 +5285,6 @@ TclEvalObjEx( iPtr->varFramePtr = savedVarFramePtr; } - done: TclDecrRefCount(objPtr); return result; } diff --git a/generic/tclInt.h b/generic/tclInt.h index b8a4dfa..ca565dd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2207,6 +2207,9 @@ typedef struct List { #define ListObjLength(listPtr, len) \ ((len) = ListRepPtr(listPtr)->elemCount) +#define ListObjIsCanonical(listPtr) \ + (((listPtr)->bytes == NULL) || ListRepPtr(listPtr)->canonicalFlag) + #define TclListObjGetElements(interp, listPtr, objcPtr, objvPtr) \ (((listPtr)->typePtr == &tclListType) \ ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\ @@ -2217,6 +2220,9 @@ typedef struct List { ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\ : Tcl_ListObjLength((interp), (listPtr), (lenPtr))) +#define TclListObjIsCanonical(listPtr) \ + (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0) + /* * Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere, * Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints. diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 44a24f8..b3e1e08 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1196,19 +1196,14 @@ Tcl_ConcatObj( */ for (i = 0; i < objc; i++) { - List *listRepPtr; + int length; objPtr = objv[i]; - if (objPtr->typePtr != &tclListType) { - TclGetString(objPtr); - if (objPtr->length) { - break; - } else { - continue; - } + if (TclListObjIsCanonical(objPtr)) { + continue; } - listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; - if (objPtr->bytes != NULL && !listRepPtr->canonicalFlag) { + Tcl_GetStringFromObj(objPtr, &length); + if (length > 0) { break; } } @@ -1228,7 +1223,7 @@ Tcl_ConcatObj( */ objPtr = objv[i]; - if (objPtr->bytes && !objPtr->length) { + if (objPtr->bytes && objPtr->length == 0) { continue; } TclListObjGetElements(NULL, objPtr, &listc, &listv); -- cgit v0.12 From 34bda55e3628476458e63d4495350e14672d01af Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 18 Apr 2011 21:24:55 +0000 Subject: Use ListRepPtr(.) and other cleanup. --- ChangeLog | 4 ++++ generic/tclCmdIL.c | 34 +++++++++++----------------------- generic/tclConfig.c | 3 +-- generic/tclListObj.c | 18 +++++++++--------- 4 files changed, 25 insertions(+), 34 deletions(-) diff --git a/ChangeLog b/ChangeLog index d9e54e2..d55c35e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,9 @@ 2011-04-18 Don Porter + * generic/tclCmdIL.c: Use ListRepPtr(.) and other cleanup. + * generic/tclConfig.c: + * generic/tclListObj.c: + * generic/tclInt.h: Define and use macros that test whether * generic/tclBasic.c: a Tcl list value is canonical. * generic/tclUtil.c: diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 87c5435..25fd078 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1540,7 +1540,6 @@ InfoLoadedCmd( Tcl_Obj *CONST objv[]) /* Argument objects. */ { char *interpName; - int result; if ((objc != 1) && (objc != 2)) { Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); @@ -1552,8 +1551,7 @@ InfoLoadedCmd( } else { /* Get pkgs just in specified interp. */ interpName = TclGetString(objv[1]); } - result = TclGetLoadedPackages(interp, interpName); - return result; + return TclGetLoadedPackages(interp, interpName); } /* @@ -2403,7 +2401,7 @@ Tcl_LrepeatObjCmd( register Tcl_Obj *CONST objv[]) /* The argument objects. */ { - int elementCount, i, result, totalElems; + int elementCount, i, totalElems; Tcl_Obj *listPtr, **dataArray; List *listRepPtr; @@ -2416,8 +2414,7 @@ Tcl_LrepeatObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "positiveCount value ?value ...?"); return TCL_ERROR; } - result = TclGetIntFromObj(interp, objv[1], &elementCount); - if (result == TCL_ERROR) { + if (TCL_ERROR == TclGetIntFromObj(interp, objv[1], &elementCount)) { return TCL_ERROR; } if (elementCount < 1) { @@ -2454,7 +2451,7 @@ Tcl_LrepeatObjCmd( */ listPtr = Tcl_NewListObj(totalElems, NULL); - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); listRepPtr->elemCount = elementCount*objc; dataArray = &listRepPtr->elements; @@ -2639,15 +2636,15 @@ Tcl_LreverseObjCmd( return TCL_OK; } - if (Tcl_IsShared(objv[1])) { + if (Tcl_IsShared(objv[1]) + || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */ Tcl_Obj *resultObj, **dataArray; - List *listPtr; + List *listRepPtr; - makeNewReversedList: resultObj = Tcl_NewListObj(elemc, NULL); - listPtr = (List *) resultObj->internalRep.twoPtrValue.ptr1; - listPtr->elemCount = elemc; - dataArray = &listPtr->elements; + listRepPtr = ListRepPtr(resultObj); + listRepPtr->elemCount = elemc; + dataArray = &listRepPtr->elements; for (i=0,j=elemc-1 ; iinternalRep.twoPtrValue.ptr1)->refCount > 1) { - goto makeNewReversedList; - } /* * Not shared, so swap "in place". This relies on Tcl_LOGE above @@ -3763,7 +3751,7 @@ Tcl_LsortObjCmd( int i; resultPtr = Tcl_NewListObj(sortInfo.numElements, NULL); - listRepPtr = (List *) resultPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(resultPtr); newArray = &listRepPtr->elements; if (indices) { for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){ diff --git a/generic/tclConfig.c b/generic/tclConfig.c index c91ee64..2ba1bd2 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -273,8 +273,7 @@ QueryConfigObjCmd( } if (n) { - List *listRepPtr = (List *) - listPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = ListRepPtr(listPtr); Tcl_DictSearch s; Tcl_Obj *key, **vals; int done, i = 0; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index b2a951e..9544337 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -447,7 +447,7 @@ Tcl_ListObjGetElements( return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; @@ -565,7 +565,7 @@ Tcl_ListObjAppendElement( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; @@ -676,7 +676,7 @@ Tcl_ListObjIndex( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { @@ -731,7 +731,7 @@ Tcl_ListObjLength( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); *intPtr = listRepPtr->elemCount; return TCL_OK; } @@ -818,7 +818,7 @@ Tcl_ListObjReplace( * Resist any temptation to optimize this case. */ - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; @@ -1502,7 +1502,7 @@ TclListObjSetElement( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; elemPtrs = &listRepPtr->elements; @@ -1587,7 +1587,7 @@ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { - register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + register List *listRepPtr = ListRepPtr(listPtr); register Tcl_Obj **elemPtrs = &listRepPtr->elements; register Tcl_Obj *objPtr; int numElems = listRepPtr->elemCount; @@ -1627,7 +1627,7 @@ DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *listRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = ListRepPtr(srcPtr); listRepPtr->refCount++; copyPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; @@ -1843,7 +1843,7 @@ UpdateStringOfList( { # define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr; - List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = ListRepPtr(listPtr); int numElems = listRepPtr->elemCount; register int i; char *elem, *dst; -- cgit v0.12 From 1ba0761f8a75067fc5f6f597b7a80bd8ab395587 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 19 Apr 2011 08:04:22 +0000 Subject: This time, I'll try to get it right! --- doc/dict.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/dict.n b/doc/dict.n index 561d418..b8386f2 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -67,7 +67,7 @@ dictionary, and a condition of \fBTCL_CONTINUE\fR is equivalent to a false result. The key/value pairs are tested in the order in which the keys were inserted into the dictionary. .TP -\fBdict filter \fIdictionaryValue \fBvalue \fIglobPattern ...\fR +\fBdict filter \fIdictionaryValue \fBvalue \fR?\fIglobPattern ...\fR? .VS 8.6 The value rule only matches those key/value pairs whose values match any of the given patterns (in the style of \fBstring match\fR.) -- cgit v0.12 From bb5c4230ac4a9acd532eae83581c1c64a2137dd1 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 19 Apr 2011 16:38:15 +0000 Subject: Reduce internals access in the implementation of [::pkgconfig list]. --- ChangeLog | 5 +++++ generic/tclConfig.c | 11 +++-------- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/ChangeLog b/ChangeLog index d55c35e..ddb6690 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-04-19 Don Porter + + * generic/tclConfig.c: Reduce internals access in the implementation + of [::pkgconfig list]. + 2011-04-18 Don Porter * generic/tclCmdIL.c: Use ListRepPtr(.) and other cleanup. diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 2ba1bd2..251868e 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -273,18 +273,13 @@ QueryConfigObjCmd( } if (n) { - List *listRepPtr = ListRepPtr(listPtr); Tcl_DictSearch s; - Tcl_Obj *key, **vals; - int done, i = 0; - - listRepPtr->elemCount = n; - vals = &listRepPtr->elements; + Tcl_Obj *key; + int done; for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); !done; Tcl_DictObjNext(&s, &key, NULL, &done)) { - vals[i++] = key; - Tcl_IncrRefCount(key); + Tcl_ListObjAppendElement(NULL, listPtr, key); } } -- cgit v0.12 From b99b0b6866dfddd102e496aa634c4b940ace19d7 Mon Sep 17 00:00:00 2001 From: jan Date: Wed, 20 Apr 2011 00:01:54 +0000 Subject: fix for [Bug 3288345]: Wrong Tcl_StatBuf used on MinGW. Follow-up: get it right for cygwin and WIN64 as well. --- ChangeLog | 5 +++++ generic/tcl.h | 8 +++++--- generic/tclIOUtil.c | 2 +- generic/tclInt.h | 2 +- win/tclWinFile.c | 5 +++-- 5 files changed, 15 insertions(+), 7 deletions(-) diff --git a/ChangeLog b/ChangeLog index 87720e0..b0046a4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,6 +1,11 @@ 2011-04-18 Jan Nijtmans * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf + used on MinGW. Follow-up: get it right for cygwin and WIN64 + +2011-04-18 Jan Nijtmans + + * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf used on MinGW. 2011-04-13 Miguel Sofer diff --git a/generic/tcl.h b/generic/tcl.h index a98b685..264363d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -372,17 +372,19 @@ typedef long LONG; */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(__WIN32__) +# if defined(__WIN32__) && !defined(__CYGWIN__) # define TCL_WIDE_INT_TYPE __int64 # ifdef __BORLANDC__ typedef struct stati64 Tcl_StatBuf; # define TCL_LL_MODIFIER "L" # define TCL_LL_MODIFIER_SIZE 1 # else /* __BORLANDC__ */ -# if (defined(_MSC_VER) && (_MSC_VER < 1400)) || !defined(_M_IX86) +# if defined(_WIN64) +typedef struct _stat64 Tcl_StatBuf; +# elif (defined(_MSC_VER) && (_MSC_VER < 1400)) typedef struct _stati64 Tcl_StatBuf; # else -typedef struct _stat64 Tcl_StatBuf; +typedef struct _stat32i64 Tcl_StatBuf; # endif /* _MSC_VER < 1400 */ # define TCL_LL_MODIFIER "I64" # define TCL_LL_MODIFIER_SIZE 3 diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 256cd60..32658a8 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1910,7 +1910,7 @@ Tcl_FSStat(pathPtr, buf) { Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS - struct stat oldStyleStatBuffer; + Tcl_StatBuf oldStyleStatBuffer; int retVal = -1; /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 607dc80..b080fef 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1795,7 +1795,7 @@ typedef struct TclpTime_t_ *CONST TclpTime_t_CONST; *---------------------------------------------------------------- */ -typedef int (TclStatProc_) _ANSI_ARGS_((CONST char *path, struct stat *buf)); +typedef int (TclStatProc_) _ANSI_ARGS_((CONST char *path, Tcl_StatBuf *buf)); typedef int (TclAccessProc_) _ANSI_ARGS_((CONST char *path, int mode)); typedef Tcl_Channel (TclOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp, CONST char *fileName, CONST char *modeString, diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 5f88cb2..99dfc2f 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -12,8 +12,9 @@ * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -//#define _WIN32_WINNT 0x0500 - +#ifndef _WIN64 +# define _USE_32BIT_TIME_T +#endif #include "tclWinInt.h" #include #include -- cgit v0.12 From 42efbb470ac6bda9d075bc0aee9cf14bcc143fb2 Mon Sep 17 00:00:00 2001 From: jan Date: Wed, 20 Apr 2011 00:02:20 +0000 Subject: (no comment) --- ChangeLog | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index b0046a4..57f519b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,9 @@ 2011-04-18 Jan Nijtmans - * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf - used on MinGW. Follow-up: get it right for cygwin and WIN64 + * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf + * generic/tclInt.h: used on MinGW. Follow-up: get it right + * generic/tclIOUtil.c: for cygwin and WIN64 as well. + * win/tclWinFile.c: 2011-04-18 Jan Nijtmans -- cgit v0.12 From be4982a04a7e508f516fc9e761a15472c6b3eb8d Mon Sep 17 00:00:00 2001 From: jan Date: Wed, 20 Apr 2011 00:05:00 +0000 Subject: wrong date --- ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 57f519b..9db76d4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,4 @@ -2011-04-18 Jan Nijtmans +2011-04-20 Jan Nijtmans * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf * generic/tclInt.h: used on MinGW. Follow-up: get it right -- cgit v0.12 From e3995f82768b5b9212f3a643a51e50fd3dcbef2b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 20 Apr 2011 12:54:34 +0000 Subject: Silence unused variable warning --- generic/tclHash.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclHash.c b/generic/tclHash.c index b5baf22..e7ee344 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -1147,7 +1147,6 @@ RebuildTable(tablePtr) register Tcl_HashEntry **oldChainPtr, **newChainPtr; register Tcl_HashEntry *hPtr; Tcl_HashKeyType *typePtr; - VOID *key; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; @@ -1201,7 +1200,7 @@ RebuildTable(tablePtr) hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; #else - key = (VOID *) Tcl_GetHashKey (tablePtr, hPtr); + VOID *key = (VOID *) Tcl_GetHashKey (tablePtr, hPtr); if (typePtr->hashKeyProc) { unsigned int hash; hash = typePtr->hashKeyProc (tablePtr, (VOID *) key); -- cgit v0.12 From aed831f6a1a96de6e8f56e5600f4e9584fefd224 Mon Sep 17 00:00:00 2001 From: andreask Date: Wed, 20 Apr 2011 17:48:57 +0000 Subject: Fixed the shift in line numbers used for testing 'info frame' introduced by checkin [79367df0f0] (Mar 2, 2011). --- ChangeLog | 6 ++++++ tests/info.test | 2 ++ 2 files changed, 8 insertions(+) diff --git a/ChangeLog b/ChangeLog index 9db76d4..6b499c1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2011-04-20 Andreas Kupries + + * tests/info.test: Fixed the shift in line numbers used for + testing 'info frame' introduced by checkin [79367df0f0] + (Mar 2, 2011). + 2011-04-20 Jan Nijtmans * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf diff --git a/tests/info.test b/tests/info.test index 11e475f..5816da3 100644 --- a/tests/info.test +++ b/tests/info.test @@ -12,6 +12,8 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# DO NOT DELETE THIS LINE. Keep line numbers correct for testing 'info frame'. if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 -- cgit v0.12 From 8556b1aba054954e5f7f386dc1833ca08fdb5e9f Mon Sep 17 00:00:00 2001 From: andreask Date: Wed, 20 Apr 2011 17:51:02 +0000 Subject: (TclFileAttrsCmd): Added commands to reset the typePtr of the Tcl_Obj* whose int-rep was just purged. Required to prevent a dangling IndexRep* to reused, smashing the heap. See also the entries at 2011-04-16 and 2011-03-24 for the history of the problem. Note also bug 2857044. This is the original report and fix of such issues for HEAD. --- ChangeLog | 8 ++++++++ generic/tclFCmd.c | 2 ++ 2 files changed, 10 insertions(+) diff --git a/ChangeLog b/ChangeLog index ddb6690..b2a324d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2011-04-20 Andreas Kupries + + * generic/tclFCmd.c (TclFileAttrsCmd): Added commands to reset the + typePtr of the Tcl_Obj* whose int-rep was just purged. Required to + prevent a dangling IndexRep* to reused, smashing the heap. See + also the entries at 2011-04-16 and 2011-03-24 for the history of + the problem. + 2011-04-19 Don Porter * generic/tclConfig.c: Reduce internals access in the implementation diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 5850846..2b4977b 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1074,6 +1074,7 @@ TclFileAttrsCmd( } if (didAlloc) { TclFreeIntRep(objv[0]); + objv[0]->typePtr = NULL; } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { @@ -1101,6 +1102,7 @@ TclFileAttrsCmd( } if (didAlloc) { TclFreeIntRep(objv[i]); + objv[i]->typePtr = NULL; } if (i + 1 == objc) { Tcl_AppendResult(interp, "value for \"", -- cgit v0.12 From 7f792b880aa3a8d14f800a2f2bf5af2df9fe36da Mon Sep 17 00:00:00 2001 From: patthoyts Date: Wed, 20 Apr 2011 22:05:10 +0000 Subject: Support cross-compilation to x64 from ix86 hosts when using NMAKE. Part of the build uses tclsh to generate files. Ensure we can specify a runnable executable using TCLSH_NATIVE when cross-compiling. This patch also gets smarter about finding the compiler version, the compiler target architecture and the native architecture. Signed-off-by: Pat Thoyts --- win/makefile.vc | 13 +++++++-- win/rules.vc | 87 +++++++++++++++++++++++++++++---------------------------- 2 files changed, 56 insertions(+), 44 deletions(-) diff --git a/win/makefile.vc b/win/makefile.vc index 35aef18..7dc96b7 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -208,6 +208,15 @@ TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe CAT32 = $(OUT_DIR)\cat32.exe +# Can we run what we build? IX86 runs on all architectures. +!ifndef TCLSH_NATIVE +!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" +TCLSH_NATIVE = $(TCLSH) +!else +!error You must explicitly set TCLSH_NATIVE for cross-compilation +!endif +!endif + ### Make sure we use backslash only. LIB_INSTALL_DIR = $(_INSTALLDIR)\lib BIN_INSTALL_DIR = $(_INSTALLDIR)\bin @@ -1015,13 +1024,13 @@ install-libraries: tclConfig install-msgs install-tzdata install-tzdata: @echo Installing time zone data @set TCL_LIBRARY=$(ROOT)/library - @$(TCLSH) "$(ROOT)/tools/installData.tcl" \ + @$(TCLSH_NATIVE) "$(ROOT)/tools/installData.tcl" \ "$(ROOT)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" install-msgs: @echo Installing message catalogs @set TCL_LIBRARY=$(ROOT)/library - @$(TCLSH) "$(ROOT)/tools/installData.tcl" \ + @$(TCLSH_NATIVE) "$(ROOT)/tools/installData.tcl" \ "$(ROOT)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" #--------------------------------------------------------------------- diff --git a/win/rules.vc b/win/rules.vc index 865b10d..e18dca9 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -27,18 +27,6 @@ _INSTALLDIR = C:\Program Files\Tcl _INSTALLDIR = $(INSTALLDIR:/=\) !endif -!ifndef MACHINE -!if "$(CPU)" == "" || "$(CPU)" == "i386" -MACHINE = IX86 -!else -MACHINE = $(CPU) -!endif -!endif - -!ifndef CFG_ENCODING -CFG_ENCODING = \"cp1252\" -!endif - #---------------------------------------------------------- # Set the proper copy method to avoid overwrite questions # to the user when copying files and selecting the right @@ -64,6 +52,50 @@ ERRNULL = >NUL # Win9x shell cannot redirect stderr !endif MKDIR = mkdir +#------------------------------------------------------------------------------ +# Determine the host and target architectures and compiler version. +#------------------------------------------------------------------------------ + +_HASH=^# +_VC_MANIFEST_EMBED_EXE= +_VC_MANIFEST_EMBED_DLL= +VCVER=0 +!if ![echo VCVERSION=_MSC_VER > vercl.x] \ + && ![echo $(_HASH)if defined(_M_IX86) >> vercl.x] \ + && ![echo ARCH=IX86 >> vercl.x] \ + && ![echo $(_HASH)elif defined(_M_AMD64) >> vercl.x] \ + && ![echo ARCH=AMD64 >> vercl.x] \ + && ![echo $(_HASH)endif >> vercl.x] \ + && ![cl -nologo -TC -P vercl.x $(ERRNULL)] +!include vercl.i +!if ![echo VCVER= ^\> vercl.vc] \ + && ![set /a $(VCVERSION) / 100 - 6 >> vercl.vc] +!include vercl.vc +!endif +!endif +!if ![del $(ERRNUL) /q/f vercl.x vercl.i vercl.vc] +!endif + +!if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i x86] +NATIVE_ARCH=IX86 +!else +NATIVE_ARCH=AMD64 +!endif + +# Since MSVC8 we must deal with manifest resources. +!if $(VCVERSION) >= 1400 +_VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 +_VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 +!endif + +!ifndef MACHINE +MACHINE=$(ARCH) +!endif + +!ifndef CFG_ENCODING +CFG_ENCODING = \"cp1252\" +!endif + !message =============================================================================== #---------------------------------------------------------- @@ -176,36 +208,6 @@ LINKERFLAGS =-ltcg !endif #---------------------------------------------------------- -# MSVC8 (ships with Visual Studio 2005) generates a manifest -# file that we should link into the binaries. This is how. -#---------------------------------------------------------- - -_VC_MANIFEST_EMBED_EXE= -_VC_MANIFEST_EMBED_DLL= -VCVER=0 -!if ![echo VCVERSION=_MSC_VER > vercl.x] \ - && ![cl -nologo -TC -P vercl.x $(ERRNULL)] -!include vercl.i -!if $(VCVERSION) >= 1600 -VCVER=10 -!elseif $(VCVERSION) >= 1500 -VCVER=9 -!elseif $(VCVERSION) >= 1400 -VCVER=8 -!elseif $(VCVERSION) >= 1300 -VCVER=7 -!elseif $(VCVERSION) >= 1200 -VCVER=6 -!endif -!endif - -# Since MSVC8 we must deal with manifest resources. -!if $(VCVERSION) >= 1400 -_VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 -_VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 -!endif - -#---------------------------------------------------------- # Decode the options requested. #---------------------------------------------------------- @@ -667,6 +669,7 @@ TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib" !message *** Suffix for binaries will be '$(SUFX)' !message *** Optional defines are '$(OPTDEFINES)' !message *** Compiler version $(VCVER). Target machine is $(MACHINE) +!message *** Host architecture is $(NATIVE_ARCH) !message *** Compiler options '$(COMPILERFLAGS) $(OPTIMIZATIONS) $(DEBUGFLAGS) $(WARNINGS)' !message *** Link options '$(LINKERFLAGS)' -- cgit v0.12 From 81582f76e6fa7e328f9ae6c92cf756e569565818 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Apr 2011 08:08:36 +0000 Subject: fix for [Bug 3288345]: Wrong Tcl_StatBufused on MinGW. Make sure that all _WIN32 compilers use exactly the same layout for Tcl_StatBuf - the one used by MSVC6 - in all situations. --- ChangeLog | 21 ++++++------- win/configure | 95 ++++++++++++++++++++++++++++++++++++++++---------------- win/configure.in | 19 ++++++++++++ win/tclWinPort.h | 19 ++++++++++++ 4 files changed, 115 insertions(+), 39 deletions(-) diff --git a/ChangeLog b/ChangeLog index 6b499c1..4572003 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,21 +1,18 @@ +2011-04-21 Jan Nijtmans + + * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf + * generic/tclInt.h: used on MinGW. Make sure that all _WIN32 + * generic/tclIOUtil.c: compilers use exactly the same layout + * win/tclWinFile.c: for Tcl_StatBuf - the one used by MSVC6 - + * win/configure.in: in all situations. + * win/configure: + 2011-04-20 Andreas Kupries * tests/info.test: Fixed the shift in line numbers used for testing 'info frame' introduced by checkin [79367df0f0] (Mar 2, 2011). -2011-04-20 Jan Nijtmans - - * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf - * generic/tclInt.h: used on MinGW. Follow-up: get it right - * generic/tclIOUtil.c: for cygwin and WIN64 as well. - * win/tclWinFile.c: - -2011-04-18 Jan Nijtmans - - * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf - used on MinGW. - 2011-04-13 Miguel Sofer * generic/tclVar.c: fix for [Bug 2662380], crash caused by diff --git a/win/configure b/win/configure index f7da2f0..ac2284a 100755 --- a/win/configure +++ b/win/configure @@ -1263,19 +1263,60 @@ EOF fi +# Check to see if struct _stat32i64 exists in mingw's sys/stat.h + +echo $ac_n "checking struct _stat32i64""... $ac_c" 1>&6 +echo "configure:1270: checking struct _stat32i64" >&5 +if eval "test \"`echo '$''{'tcl_struct_stat32i64'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include + +int main() { + + struct _stat32i64 foo; + +; return 0; } +EOF +if { (eval echo configure:1287: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + tcl_struct_stat32i64=yes +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + tcl_struct_stat32i64=no +fi +rm -f conftest* + +fi + +echo "$ac_t""$tcl_struct_stat32i64" 1>&6 +if test "$tcl_struct_stat32i64" = "yes" ; then + cat >> confdefs.h <<\EOF +#define HAVE_STRUCT_STAT32I64 1 +EOF + +fi + #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- echo $ac_n "checking for object suffix""... $ac_c" 1>&6 -echo "configure:1273: checking for object suffix" >&5 +echo "configure:1314: checking for object suffix" >&5 if eval "test \"`echo '$''{'ac_cv_objext'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else rm -f conftest* echo 'int i = 1;' > conftest.$ac_ext -if { (eval echo configure:1279: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:1320: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then for ac_file in conftest.*; do case $ac_file in *.c) ;; @@ -1293,19 +1334,19 @@ OBJEXT=$ac_cv_objext ac_objext=$ac_cv_objext echo $ac_n "checking for mingw32 environment""... $ac_c" 1>&6 -echo "configure:1297: checking for mingw32 environment" >&5 +echo "configure:1338: checking for mingw32 environment" >&5 if eval "test \"`echo '$''{'ac_cv_mingw32'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:1350: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_mingw32=yes else @@ -1324,7 +1365,7 @@ test "$ac_cv_mingw32" = yes && MINGW32=yes echo $ac_n "checking for executable suffix""... $ac_c" 1>&6 -echo "configure:1328: checking for executable suffix" >&5 +echo "configure:1369: checking for executable suffix" >&5 if eval "test \"`echo '$''{'ac_cv_exeext'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -1334,7 +1375,7 @@ else rm -f conftest* echo 'int main () { return 0; }' > conftest.$ac_ext ac_cv_exeext= - if { (eval echo configure:1338: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then + if { (eval echo configure:1379: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then for file in conftest.*; do case $file in *.c | *.o | *.obj) ;; @@ -1361,7 +1402,7 @@ ac_exeext=$EXEEXT echo $ac_n "checking for building with threads""... $ac_c" 1>&6 -echo "configure:1365: checking for building with threads" >&5 +echo "configure:1406: checking for building with threads" >&5 # Check whether --enable-threads or --disable-threads was given. if test "${enable_threads+set}" = set; then enableval="$enable_threads" @@ -1398,7 +1439,7 @@ EOF echo $ac_n "checking how to build libraries""... $ac_c" 1>&6 -echo "configure:1402: checking how to build libraries" >&5 +echo "configure:1443: checking how to build libraries" >&5 # Check whether --enable-shared or --disable-shared was given. if test "${enable_shared+set}" = set; then enableval="$enable_shared" @@ -1439,7 +1480,7 @@ EOF # Step 0: Enable 64 bit support? echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6 -echo "configure:1443: checking if 64bit support is requested" >&5 +echo "configure:1484: checking if 64bit support is requested" >&5 # Check whether --enable-64bit or --disable-64bit was given. if test "${enable_64bit+set}" = set; then enableval="$enable_64bit" @@ -1453,7 +1494,7 @@ fi # Cross-compiling options for Windows/CE builds echo $ac_n "checking if Windows/CE build is requested""... $ac_c" 1>&6 -echo "configure:1457: checking if Windows/CE build is requested" >&5 +echo "configure:1498: checking if Windows/CE build is requested" >&5 # Check whether --enable-wince or --disable-wince was given. if test "${enable_wince+set}" = set; then enableval="$enable_wince" @@ -1465,7 +1506,7 @@ fi echo "$ac_t""$doWince" 1>&6 echo $ac_n "checking for Windows/CE celib directory""... $ac_c" 1>&6 -echo "configure:1469: checking for Windows/CE celib directory" >&5 +echo "configure:1510: checking for Windows/CE celib directory" >&5 # Check whether --with-celib or --without-celib was given. if test "${with_celib+set}" = set; then withval="$with_celib" @@ -1482,7 +1523,7 @@ fi # Extract the first word of "cygpath", so it can be a program name with args. set dummy cygpath; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1486: checking for $ac_word" >&5 +echo "configure:1527: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_prog_CYGPATH'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -1530,9 +1571,9 @@ fi echo "END" >> $conftest echo $ac_n "checking for Windows native path bug in windres""... $ac_c" 1>&6 -echo "configure:1534: checking for Windows native path bug in windres" >&5 +echo "configure:1575: checking for Windows native path bug in windres" >&5 cyg_conftest=`$CYGPATH $conftest` - if { ac_try='$RC -o conftest.res.o $cyg_conftest'; { (eval echo configure:1536: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } ; then + if { ac_try='$RC -o conftest.res.o $cyg_conftest'; { (eval echo configure:1577: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } ; then echo "$ac_t""no" 1>&6 else echo "$ac_t""yes" 1>&6 @@ -1551,7 +1592,7 @@ echo "configure:1534: checking for Windows native path bug in windres" >&5 # set various compiler flags depending on whether we are using gcc or cl echo $ac_n "checking compiler flags""... $ac_c" 1>&6 -echo "configure:1555: checking compiler flags" >&5 +echo "configure:1596: checking compiler flags" >&5 if test "${GCC}" = "yes" ; then SHLIB_LD="" SHLIB_LD_LIBS="" @@ -1899,7 +1940,7 @@ EOF echo $ac_n "checking for build with symbols""... $ac_c" 1>&6 -echo "configure:1903: checking for build with symbols" >&5 +echo "configure:1944: checking for build with symbols" >&5 # Check whether --enable-symbols or --disable-symbols was given. if test "${enable_symbols+set}" = set; then enableval="$enable_symbols" @@ -1959,7 +2000,7 @@ TCL_DBGX=${DBGX} #-------------------------------------------------------------------- echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 -echo "configure:1963: checking how to run the C preprocessor" >&5 +echo "configure:2004: checking how to run the C preprocessor" >&5 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= @@ -1974,13 +2015,13 @@ else # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1984: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2025: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then : @@ -1991,13 +2032,13 @@ else rm -rf conftest* CPP="${CC-cc} -E -traditional-cpp" cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2001: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2042: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then : @@ -2008,13 +2049,13 @@ else rm -rf conftest* CPP="${CC-cc} -nologo -E" cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2018: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2059: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then : @@ -2040,17 +2081,17 @@ echo "$ac_t""$CPP" 1>&6 ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for errno.h""... $ac_c" 1>&6 -echo "configure:2044: checking for errno.h" >&5 +echo "configure:2085: checking for errno.h" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2054: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2095: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then rm -rf conftest* diff --git a/win/configure.in b/win/configure.in index 1b6a843..3e6561e 100644 --- a/win/configure.in +++ b/win/configure.in @@ -240,6 +240,25 @@ if test "$tcl_cv_cast_to_union" = "yes"; then [Defined when compiler supports casting to union type.]) fi +# Check to see if struct _stat32i64 exists in mingw's sys/stat.h + +AC_CACHE_CHECK(struct _stat32i64, + tcl_struct_stat32i64, +AC_TRY_COMPILE([ +#include +#include +], +[ + struct _stat32i64 foo; +], + tcl_struct_stat32i64=yes, + tcl_struct_stat32i64=no) +) +if test "$tcl_struct_stat32i64" = "yes" ; then + AC_DEFINE(HAVE_STRUCT_STAT32I64, 1, + [Defined when sys/stat.h has struct_stat32i64]) +fi + #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 6e8dcfb..5115dab 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -95,6 +95,25 @@ #endif /* + * Not all mingw32 versions have this struct. + */ +#if !defined(__BORLANDC__) && !defined(_MSC_VER) && !defined(_WIN64) && !defined(HAVE_STRUCT_STAT32I64) + struct _stat32i64 { + _dev_t st_dev; + _ino_t st_ino; + unsigned short st_mode; + short st_nlink; + short st_uid; + short st_gid; + _dev_t st_rdev; + __int64 st_size; + long st_atime; + long st_mtime; + long st_ctime; + }; +#endif + +/* * The following defines redefine the Windows Socket errors as * BSD errors so Tcl_PosixError can do the right thing. */ -- cgit v0.12 From 445fd51fa9afc1afece5244fbaa88454f3d310c5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Apr 2011 12:05:13 +0000 Subject: fix warnings in tclTest.c --- generic/tclTest.c | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index f2a357a..9acbc5e 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -327,13 +327,13 @@ static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy, static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int PretendTclpStat _ANSI_ARGS_((CONST char *path, - struct stat *buf)); + Tcl_StatBuf *buf)); static int TestStatProc1 _ANSI_ARGS_((CONST char *path, - struct stat *buf)); + Tcl_StatBuf *buf)); static int TestStatProc2 _ANSI_ARGS_((CONST char *path, - struct stat *buf)); + Tcl_StatBuf *buf)); static int TestStatProc3 _ANSI_ARGS_((CONST char *path, - struct stat *buf)); + Tcl_StatBuf *buf)); static int TeststatprocCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy, @@ -4699,7 +4699,7 @@ TeststatprocCmd (dummy, interp, argc, argv) static int PretendTclpStat(path, buf) CONST char *path; - struct stat *buf; + Tcl_StatBuf *buf; { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); @@ -4793,9 +4793,9 @@ static int PretendTclpStat(path, buf) static int TestStatProc1(path, buf) CONST char *path; - struct stat *buf; + Tcl_StatBuf *buf; { - memset(buf, 0, sizeof(struct stat)); + memset(buf, 0, sizeof(Tcl_StatBuf)); buf->st_size = 1234; return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0); } @@ -4804,9 +4804,9 @@ TestStatProc1(path, buf) static int TestStatProc2(path, buf) CONST char *path; - struct stat *buf; + Tcl_StatBuf *buf; { - memset(buf, 0, sizeof(struct stat)); + memset(buf, 0, sizeof(Tcl_StatBuf)); buf->st_size = 2345; return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0); } @@ -4815,9 +4815,9 @@ TestStatProc2(path, buf) static int TestStatProc3(path, buf) CONST char *path; - struct stat *buf; + Tcl_StatBuf *buf; { - memset(buf, 0, sizeof(struct stat)); + memset(buf, 0, sizeof(Tcl_StatBuf)); buf->st_size = 3456; return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0); } -- cgit v0.12 From 3dee0582a464245f4ebfb6cc887e198566d3f035 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 21 Apr 2011 12:58:31 +0000 Subject: Make sure SetFooFromAny routines react reasonably when passed a NULL interp. --- ChangeLog | 7 +++++++ generic/tclCompile.c | 7 +++++-- generic/tclIndexObj.c | 2 ++ generic/tclNamesp.c | 4 ++++ generic/tclObj.c | 4 ++++ 5 files changed, 22 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4572003..c88efd1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2011-04-21 Don Porter + + * generic/tclCompile.c: Make sure SetFooFromAny routines react + * generic/tclIndexObj.c: reasonably when passed a NULL interp. + * generic/tclNamesp.c: + * generic/tclObj.c: + 2011-04-21 Jan Nijtmans * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 660a1f2..0b1a3ff 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -333,12 +333,12 @@ Tcl_ObjType tclByteCodeType = { * compiling its string representation. This function also takes * a hook procedure that will be invoked to perform any needed post * processing on the compilation results before generating byte - * codes. + * codes. interp is compilation context and may not be NULL. * * Results: * The return value is a standard Tcl object result. If an error occurs * during compilation, an error message is left in the interpreter's - * result unless "interp" is NULL. + * result. * * Side effects: * Frees the old internal representation. If no error occurs, then the @@ -515,6 +515,9 @@ SetByteCodeFromAny(interp, objPtr) * being compiled. Must not be NULL. */ Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ { + if (interp == NULL) { + return TCL_ERROR; + } return TclSetByteCodeFromAny(interp, objPtr, (CompileHookProc *) NULL, (ClientData) NULL); } diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 9d8679c..79fc262 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -308,9 +308,11 @@ SetIndexFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { + if (interp) { Tcl_AppendToObj(Tcl_GetObjResult(interp), "can't convert value to index except via Tcl_GetIndexFromObj API", -1); + } return TCL_ERROR; } diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 4130c66..77352a1 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -3913,6 +3913,10 @@ SetNsNameFromAny(interp, objPtr) Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; + if (interp == NULL) { + return TCL_ERROR; + } + /* * Get the string representation. Make it up-to-date if necessary. */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 43f0d2e..7b9bb61 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3597,6 +3597,10 @@ SetCmdNameFromAny(interp, objPtr) Namespace *currNsPtr; register ResolvedCmdName *resPtr; + if (interp == NULL) { + return TCL_ERROR; + } + /* * Get "objPtr"s string representation. Make it up-to-date if necessary. */ -- cgit v0.12 From fb1e4a18589dcd6dcf8bab488503e3ce89873098 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 21 Apr 2011 16:53:44 +0000 Subject: Limits on list length were too strict. Revised panics to errors where possible. --- ChangeLog | 4 ++ generic/tclCmdIL.c | 17 +++---- generic/tclInt.h | 3 ++ generic/tclListObj.c | 125 +++++++++++++++++++++++++++++++++------------------ 4 files changed, 93 insertions(+), 56 deletions(-) diff --git a/ChangeLog b/ChangeLog index bce5d58..e593b99 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,9 @@ 2011-04-21 Don Porter + * generic/tclCmdIL.c: Limits on list length were too strict. + * generic/tclInt.h: Revised panics to errors where possible. + * generic/tclListObj.c: + * generic/tclCompile.c: Make sure SetFooFromAny routines react * generic/tclIO.c: reasonably when passed a NULL interp. * generic/tclIndexObj.c: diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 25fd078..13db6d5 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2429,21 +2429,14 @@ Tcl_LrepeatObjCmd( objc -= 2; objv += 2; - /* - * Final sanity check. Total number of elements must fit in a signed - * integer. We also limit the number of elements to 512M-1 so allocations - * on 32-bit machines are guaranteed to be less than 2GB! [Bug 2130992] - */ + /* Final sanity check. Do not exceed limits on max list length. */ - totalElems = objc * elementCount; - if (totalElems/objc != elementCount || totalElems/elementCount != objc) { - Tcl_AppendResult(interp, "too many elements in result list", NULL); - return TCL_ERROR; - } - if (totalElems >= 0x20000000) { - Tcl_AppendResult(interp, "too many elements in result list", NULL); + if (objc > LIST_MAX/elementCount) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); return TCL_ERROR; } + totalElems = objc * elementCount; /* * Get an empty list object that is allocated large enough to hold each diff --git a/generic/tclInt.h b/generic/tclInt.h index ca565dd..e410a1d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2193,6 +2193,9 @@ typedef struct List { * accomodate all elements. */ } List; +#define LIST_MAX \ + (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *))) + /* * Macro used to get the elements of a list object. */ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 751cc13..730b94d 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -17,7 +17,9 @@ * Prototypes for functions defined later in this file: */ -static List * NewListIntRep(int objc, Tcl_Obj *CONST objv[]); +static List * AttemptNewList(Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); +static List * NewListIntRep(int objc, Tcl_Obj *CONST objv[], int p); static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -49,16 +51,16 @@ Tcl_ObjType tclListType = { * * NewListIntRep -- * - * If objc>0 and objv!=NULL, this function creates a list internal rep - * with objc elements given in the array objv. If objc>0 and objv==NULL - * it creates the list internal rep of a list with 0 elements, where - * enough space has been preallocated to store objc elements. If objc<=0, - * it returns NULL. + * Creates a list internal rep with space for objc elements. objc + * must be > 0. If objv!=NULL, initializes with the first objc values + * in that array. If objv==NULL, initalize list internal rep to have + * 0 elements, with space to add objc more. Flag value "p" indicates + * how to behave on failure. * * Results: - * A new List struct is returned. If objc<=0 or if the allocation fails - * for lack of memory, NULL is returned. The list returned has refCount - * 0. + * A new List struct with refCount 0 is returned. If some failure + * prevents this then if p=0, NULL is returned and otherwise the + * routine panics. * * Side effects: * The ref counts of the elements in objv are incremented since the @@ -70,12 +72,13 @@ Tcl_ObjType tclListType = { static List * NewListIntRep( int objc, - Tcl_Obj *CONST objv[]) + Tcl_Obj *CONST objv[], + int p) { List *listRepPtr; if (objc <= 0) { - return NULL; + Tcl_Panic("NewListIntRep: expects postive element count"); } /* @@ -85,13 +88,21 @@ NewListIntRep( * requires API changes to fix. See [Bug 219196] for a discussion. */ - if ((size_t)objc > INT_MAX/sizeof(Tcl_Obj *)) { + if ((size_t)objc > LIST_MAX) { + if (p) { + Tcl_Panic("max length of a Tcl list (%d elements) exceeded", + LIST_MAX); + } return NULL; } listRepPtr = (List *) attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))); if (listRepPtr == NULL) { + if (p) { + Tcl_Panic("list creation failed: unable to alloc %u bytes", + sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))); + } return NULL; } @@ -118,6 +129,50 @@ NewListIntRep( /* *---------------------------------------------------------------------- * + * AttemptNewList -- + * + * Creates a list internal rep with space for objc elements. objc + * must be > 0. If objv!=NULL, initializes with the first objc values + * in that array. If objv==NULL, initalize list internal rep to have + * 0 elements, with space to add objc more. + * + * Results: + * A new List struct with refCount 0 is returned. If some failure + * prevents this then NULL is returned, and an error message is left + * in the interp result, unless interp is NULL. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. + * + *---------------------------------------------------------------------- + */ + +static List * +AttemptNewList( + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST objv[]) +{ + List *listRepPtr = NewListIntRep(objc, objv, 0); + + if (interp != NULL && listRepPtr == NULL) { + if (objc > LIST_MAX) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", + LIST_MAX)); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "list creation failed: unable to alloc %u bytes", + sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *)))); + } + } + return listRepPtr; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_NewListObj -- * * This function is normally called when not debugging: i.e., when @@ -172,10 +227,7 @@ Tcl_NewListObj( * Create the internal rep. */ - listRepPtr = NewListIntRep(objc, objv); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); - } + listRepPtr = NewListIntRep(objc, objv, 1); /* * Now create the object. @@ -244,10 +296,7 @@ Tcl_DbNewListObj( * Create the internal rep. */ - listRepPtr = NewListIntRep(objc, objv); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); - } + listRepPtr = NewListIntRep(objc, objv, 1); /* * Now create the object. @@ -326,10 +375,7 @@ Tcl_SetListObj( */ if (objc > 0) { - listRepPtr = NewListIntRep(objc, objv); - if (!listRepPtr) { - Tcl_Panic("Cannot allocate enough memory for Tcl_SetListObj"); - } + listRepPtr = NewListIntRep(objc, objv, 1); objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclListType; @@ -587,9 +633,9 @@ Tcl_ListObjAppendElement( List *oldListRepPtr = listRepPtr; Tcl_Obj **oldElems; - listRepPtr = NewListIntRep(newMax, NULL); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); + listRepPtr = AttemptNewList(interp, newMax, NULL); + if (listRepPtr == NULL) { + return TCL_ERROR; } oldElems = &oldListRepPtr->elements; elemPtrs = &listRepPtr->elements; @@ -884,9 +930,9 @@ Tcl_ListObjReplace( newMax = listRepPtr->maxElemCount; } - listRepPtr = NewListIntRep(newMax, NULL); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); + listRepPtr = AttemptNewList(interp, newMax, NULL); + if (listRepPtr == NULL) { + return TCL_ERROR; } listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; @@ -1527,9 +1573,9 @@ TclListObjSetElement( Tcl_Obj **oldElemPtrs = elemPtrs; int i; - listRepPtr = NewListIntRep(listRepPtr->maxElemCount, NULL); + listRepPtr = AttemptNewList(interp, listRepPtr->maxElemCount, NULL); if (listRepPtr == NULL) { - Tcl_Panic("Not enough memory to allocate list"); + return TCL_ERROR; } listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag; elemPtrs = &listRepPtr->elements; @@ -1691,13 +1737,8 @@ SetListFromAny( */ Tcl_DictObjSize(NULL, objPtr, &size); - listRepPtr = NewListIntRep(size > 0 ? 2*size : 1, NULL); + listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL); if (!listRepPtr) { - if (interp) { - Tcl_SetResult(interp, - "insufficient memory to allocate list working space", - TCL_STATIC); - } return TCL_ERROR; } listRepPtr->elemCount = 2 * size; @@ -1753,12 +1794,8 @@ SetListFromAny( * strings. */ - listRepPtr = NewListIntRep(estCount, NULL); - if (!listRepPtr) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "Not enough memory to allocate the list internal rep", -1)); - } + listRepPtr = AttemptNewList(interp, estCount, NULL); + if (listRepPtr == NULL) { return TCL_ERROR; } elemPtrs = &listRepPtr->elements; -- cgit v0.12 From 8bcda731ae34f234a8894fe1f2de0d06ce951b72 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 21 Apr 2011 18:44:38 +0000 Subject: Use macro to set List intreps --- ChangeLog | 3 +++ generic/tclInt.h | 6 ++++++ generic/tclListObj.c | 26 +++++--------------------- 3 files changed, 14 insertions(+), 21 deletions(-) diff --git a/ChangeLog b/ChangeLog index e593b99..79bc9f9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,8 @@ 2011-04-21 Don Porter + * generic/tclInt.h: Use macro to set List intreps. + * generic/tclListObj.c: + * generic/tclCmdIL.c: Limits on list length were too strict. * generic/tclInt.h: Revised panics to errors where possible. * generic/tclListObj.c: diff --git a/generic/tclInt.h b/generic/tclInt.h index e410a1d..0705492 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2203,6 +2203,12 @@ typedef struct List { #define ListRepPtr(listPtr) \ ((List *) (listPtr)->internalRep.twoPtrValue.ptr1) +#define ListSetIntRep(objPtr, listRepPtr) \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \ + (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \ + (listRepPtr)->refCount++, \ + (objPtr)->typePtr = &tclListType + #define ListObjGetElements(listPtr, objc, objv) \ ((objv) = &(ListRepPtr(listPtr)->elements), \ (objc) = ListRepPtr(listPtr)->elemCount) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 730b94d..b269607 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -234,11 +234,7 @@ Tcl_NewListObj( */ Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; - listRepPtr->refCount++; - + ListSetIntRep(listPtr, listRepPtr); return listPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -303,10 +299,7 @@ Tcl_DbNewListObj( */ Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; - listRepPtr->refCount++; + ListSetIntRep(listPtr, listRepPtr); return listPtr; } @@ -376,10 +369,7 @@ Tcl_SetListObj( if (objc > 0) { listRepPtr = NewListIntRep(objc, objv, 1); - objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclListType; - listRepPtr->refCount++; + ListSetIntRep(objPtr, listRepPtr); } else { objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; @@ -1675,10 +1665,7 @@ DupListInternalRep( { List *listRepPtr = ListRepPtr(srcPtr); - listRepPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclListType; + ListSetIntRep(copyPtr, listRepPtr); } /* @@ -1849,11 +1836,8 @@ SetListFromAny( */ commitRepresentation: - listRepPtr->refCount++; TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclListType; + ListSetIntRep(objPtr, listRepPtr); return TCL_OK; } -- cgit v0.12 From c43268cbb41ef01e1a47b494dc8e1e3af6d9e147 Mon Sep 17 00:00:00 2001 From: jan Date: Thu, 21 Apr 2011 21:09:05 +0000 Subject: [Bug 3288345]: Bring cygwin Tcl_StatBuf a little closer to reality --- win/tclWinPort.h | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 5115dab..f228a22 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -99,17 +99,23 @@ */ #if !defined(__BORLANDC__) && !defined(_MSC_VER) && !defined(_WIN64) && !defined(HAVE_STRUCT_STAT32I64) struct _stat32i64 { - _dev_t st_dev; - _ino_t st_ino; + dev_t st_dev; + ino_t st_ino; unsigned short st_mode; short st_nlink; short st_uid; short st_gid; - _dev_t st_rdev; + dev_t st_rdev; __int64 st_size; +#ifdef __CYGWIN__ + struct {long tv_sec;} st_atim; + struct {long tv_sec;} st_mtim; + struct {long tv_sec;} st_ctim; +#else long st_atime; long st_mtime; long st_ctime; +#endif }; #endif -- cgit v0.12