diff options
52 files changed, 710 insertions, 488 deletions
diff --git a/.github/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md new file mode 100644 index 0000000..22d3860 --- /dev/null +++ b/.github/ISSUE_TEMPLATE.md @@ -0,0 +1,3 @@ +Important Note +========== +Please do not file issues with Tcl on Github. They are unlikely to be noticed in a timely fashion. Tcl issues are hosted in the [tcl fossil repository on core.tcl.tk](https://core.tcl.tk/tcl/tktnew); please post them there. diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md new file mode 100644 index 0000000..da07cd2 --- /dev/null +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -0,0 +1,3 @@ +Important Note +========== +Please do not file pull requests with Tcl on Github. They are unlikely to be noticed in a timely fashion. Tcl issues (including patches) are hosted in the [tcl fossil repository on core.tcl.tk](https://core.tcl.tk/tcl/tktnew); please post them there. @@ -96,10 +96,9 @@ A null-terminated Unicode string. A null-terminated Unicode string. .AP size_t length in The length of the UTF-8 string in bytes (not UTF-8 characters). If --1, all bytes up to the first null byte are used. +(size_t)-1, all bytes up to the first null byte are used. .AP size_t uniLength in -The length of the Unicode string in characters. Must be greater than or -equal to 0. +The length of the Unicode string in characters. .AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. .AP "const char" *start in @@ -119,8 +118,8 @@ case-insensitive (1). .SH DESCRIPTION .PP -These routines convert between UTF-8 strings and Tcl_UniChars. A -Tcl_UniChar is a Unicode character represented as an unsigned, fixed-size +These routines convert between UTF-8 strings and Unicode characters. An +Unicode character represented as an unsigned, fixed-size quantity. A UTF-8 character is a Unicode character represented as a varying-length sequence of up to \fBTCL_UTF_MAX\fR bytes. A multibyte UTF-8 sequence consists of a lead byte followed by some number of trail bytes. @@ -128,9 +127,12 @@ sequence consists of a lead byte followed by some number of trail bytes. \fBTCL_UTF_MAX\fR is the maximum number of bytes that it takes to represent one Unicode character in the UTF-8 representation. .PP -\fBTcl_UniCharToUtf\fR stores the Tcl_UniChar \fIch\fR as a UTF-8 string +\fBTcl_UniCharToUtf\fR stores the character \fIch\fR as a UTF-8 string in starting at \fIbuf\fR. The return value is the number of bytes stored -in \fIbuf\fR. +in \fIbuf\fR. If ch is an upper surrogate (range U+D800 - U+DBFF), then +the return value will be 0 and nothing will be stored. If you still +want to produce UTF-8 output for it (even though knowing it's an illegal +code-point on its own), just call \fBTcl_UniCharToUtf\fR again using ch = -1. .PP \fBTcl_UtfToUniChar\fR reads one UTF-8 character starting at \fIsrc\fR and stores it as a Tcl_UniChar in \fI*chPtr\fR. The return value is the @@ -201,7 +203,7 @@ of \fIlength\fR bytes is long enough to be decoded by \fBTcl_UtfToUniChar\fR, or 0 otherwise. This function does not guarantee that the UTF-8 string is properly formed. This routine is used by procedures that are operating on a byte at a time and need to know if a -full Tcl_UniChar has been seen. +full Unicode character has been seen. .PP \fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings. It returns the number of Tcl_UniChars that are represented by the UTF-8 string @@ -209,12 +211,12 @@ returns the number of Tcl_UniChars that are represented by the UTF-8 string length is negative, all bytes up to the first null byte are used. .PP \fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings. It -returns a pointer to the first occurrence of the Tcl_UniChar \fIch\fR +returns a pointer to the first occurrence of the Unicode character \fIch\fR in the null-terminated UTF-8 string \fIsrc\fR. The null terminator is considered part of the UTF-8 string. .PP \fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings. It -returns a pointer to the last occurrence of the Tcl_UniChar \fIch\fR +returns a pointer to the last occurrence of the Unicode character \fIch\fR in the null-terminated UTF-8 string \fIsrc\fR. The null terminator is considered part of the UTF-8 string. .PP @@ -241,7 +243,7 @@ characters. \fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR characters. This is equivalent to calling -\fBTcl_UtfNext\fR \fIindex\fR times. If \fIindex\fR is -1, +\fBTcl_UtfNext\fR \fIindex\fR times. If \fIindex\fR is (size_t)-1, the return pointer points to the first character in the source string. .PP \fBTcl_UtfBackslash\fR is a utility procedure used by several of the Tcl diff --git a/generic/tcl.h b/generic/tcl.h index d1996a3..3f96d08 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -208,9 +208,6 @@ extern "C" { #if !defined(CONST86) && !defined(TCL_NO_DEPRECATED) # define CONST86 const #endif -#ifndef CONST90 -# define CONST90 const -#endif /* * Make sure EXTERN isn't defined elsewhere. @@ -967,10 +964,10 @@ typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; -typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, CONST90 void *keyPtr); -typedef int (Tcl_CompareHashKeysProc) (CONST90 void *keyPtr, Tcl_HashEntry *hPtr); +typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); +typedef int (Tcl_CompareHashKeysProc) (void *keyPtr, Tcl_HashEntry *hPtr); typedef Tcl_HashEntry * (Tcl_AllocHashEntryProc) (Tcl_HashTable *tablePtr, - CONST90 void *keyPtr); + void *keyPtr); typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *hPtr); /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 705cccb..e2f70f6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7911,18 +7911,12 @@ TclNRTailcallObjCmd( if (objc > 1) { Tcl_Obj *listPtr, *nsObjPtr; Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; /* The tailcall data is in a Tcl list: the first element is the * namespace, the rest the command to be tailcalled. */ - listPtr = Tcl_NewListObj(objc, objv); - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) - || (nsPtr != ns1Ptr)) { - Tcl_Panic("Tailcall failed to find the proper namespace"); - } + listPtr = Tcl_NewListObj(objc, objv); TclListObjSetElement(interp, listPtr, 0, nsObjPtr); iPtr->varFramePtr->tailcallPtr = listPtr; diff --git a/generic/tclBinary.c b/generic/tclBinary.c index acc8fa5..a34bd27 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2479,7 +2479,7 @@ BinaryDecodeHex( } c = *data++; - if (!isxdigit((int) c)) { + if (!isxdigit(c)) { if (strict || !isspace(c)) { goto badChar; } @@ -2513,7 +2513,7 @@ BinaryDecodeHex( badChar: TclDecrRefCount(resultObj); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid hexadecimal digit \"%c\" at position %td", + "invalid hexadecimal digit \"%c\" at position %" TCL_Z_MODIFIER "d", c, data - datastart - 1)); return TCL_ERROR; } @@ -2915,7 +2915,7 @@ BinaryDecodeUu( badUu: Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid uuencode character \"%c\" at position %td", + "invalid uuencode character \"%c\" at position %" TCL_Z_MODIFIER "d", c, data - datastart - 1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); TclDecrRefCount(resultObj); @@ -3065,7 +3065,7 @@ BinaryDecode64( bad64: Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid base64 character \"%c\" at position %td", + "invalid base64 character \"%c\" at position %" TCL_Z_MODIFIER "d", (char) c, data - datastart - 1)); TclDecrRefCount(resultObj); return TCL_ERROR; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 15fefae..b624bc0 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1447,6 +1447,9 @@ StringIndexCmd( char buf[4]; length = Tcl_UniCharToUtf(ch, buf); + if (!length) { + length = Tcl_UniCharToUtf(-1, buf); + } Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); } } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 0fe7ceb..d9f0258 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -701,7 +701,7 @@ TclCompileCatchCmd( /* Stack at this point on both branches: result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileCatchCmd: bad jump distance %td", + Tcl_Panic("TclCompileCatchCmd: bad jump distance %" TCL_Z_MODIFIER "d", (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } @@ -1863,7 +1863,7 @@ TclCompileDictUpdateCmd( TclEmitInvoke(envPtr,INST_RETURN_STK); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %td", + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d", CurrentOffset(envPtr) - jumpFixup.codeOffset); } TclStackFree(interp, keyTokenPtrs); @@ -2225,7 +2225,7 @@ TclCompileDictWithCmd( */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %td", + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d", CurrentOffset(envPtr) - jumpFixup.codeOffset); } return TCL_OK; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index df512af..38839fd 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1567,7 +1567,7 @@ TclSubstCompile( /* Start */ if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad start jump distance %td", + Tcl_Panic("TclCompileSubstCmd: bad start jump distance %" TCL_Z_MODIFIER "d", CurrentOffset(envPtr) - startFixup.codeOffset); } } @@ -1626,7 +1626,7 @@ TclSubstCompile( TclAdjustStackDepth(1, envPtr); /* BREAK destination */ if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad break jump distance %td", + Tcl_Panic("TclCompileSubstCmd: bad break jump distance %" TCL_Z_MODIFIER "d", CurrentOffset(envPtr) - breakFixup.codeOffset); } OP( POP); @@ -1642,7 +1642,7 @@ TclSubstCompile( TclAdjustStackDepth(2, envPtr); /* CONTINUE destination */ if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %td", + Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %" TCL_Z_MODIFIER "d", CurrentOffset(envPtr) - continueFixup.codeOffset); } OP( POP); @@ -1652,11 +1652,11 @@ TclSubstCompile( TclAdjustStackDepth(2, envPtr); /* RETURN + other destination */ if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad return jump distance %td", + Tcl_Panic("TclCompileSubstCmd: bad return jump distance %" TCL_Z_MODIFIER "d", CurrentOffset(envPtr) - returnFixup.codeOffset); } if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad other jump distance %td", + Tcl_Panic("TclCompileSubstCmd: bad other jump distance %" TCL_Z_MODIFIER "d", CurrentOffset(envPtr) - otherFixup.codeOffset); } @@ -1669,7 +1669,7 @@ TclSubstCompile( /* OK destination */ if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %td", + Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %" TCL_Z_MODIFIER "d", CurrentOffset(envPtr) - okFixup.codeOffset); } if (count > 1) { @@ -1679,7 +1679,7 @@ TclSubstCompile( /* CONTINUE jump to here */ if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad end jump distance %td", + Tcl_Panic("TclCompileSubstCmd: bad end jump distance %" TCL_Z_MODIFIER "d", CurrentOffset(envPtr) - endFixup.codeOffset); } bline = envPtr->line; diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 8f2ff37..29ca0bf 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -64,7 +64,7 @@ static void FreeDictInternalRep(Tcl_Obj *dictPtr); static void InvalidateDictChain(Tcl_Obj *dictObj); static int SetDictFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDict(Tcl_Obj *dictPtr); -static Tcl_HashEntry * AllocChainEntry(Tcl_HashTable *tablePtr,CONST90 void *keyPtr); +static Tcl_HashEntry * AllocChainEntry(Tcl_HashTable *tablePtr, void *keyPtr); static inline void InitChainTable(struct Dict *dict); static inline void DeleteChainTable(struct Dict *dict); static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict, @@ -227,7 +227,7 @@ typedef struct { static Tcl_HashEntry * AllocChainEntry( Tcl_HashTable *tablePtr, - CONST90 void *keyPtr) + void *keyPtr) { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; ChainEntry *cPtr; diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 77b18df..fe18119 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -894,7 +894,7 @@ PrintSourceToObj( Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ch); i += 10; } else -#elif TCL_UTF_MAX > 3 +#else /* If len == 0, this means we have a char > 0xffff, resulting in * TclUtfToUniChar producing a surrogate pair. We want to output * this pair as a single Unicode character. diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 8cc4b74..40ced17 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -723,14 +723,25 @@ TclFinalizeEnvironment(void) * strings. This may leak more memory that strictly necessary, since some * of the strings may no longer be in the environment. However, * determining which ones are ok to delete is n-squared, and is pretty - * unlikely, so we don't bother. + * unlikely, so we don't bother. However, in the case of DPURIFY, just + * free all strings in the cache. */ if (env.cache) { +#ifdef PURIFY + int i; + for (i = 0; i < env.cacheSize; i++) { + ckfree(env.cache[i]); + } +#endif ckfree(env.cache); env.cache = NULL; env.cacheSize = 0; #ifndef USE_PUTENV + if ((env.ourEnviron != NULL)) { + ckfree(env.ourEnviron); + env.ourEnviron = NULL; + } env.ourEnvironSize = 0; #endif } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5b8bc01..be4a744 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4754,7 +4754,7 @@ TEBCresume( /* Decode index value operands. */ - /* + /* assert ( toIdx != TCL_INDEX_AFTER); * * Extra safety for legacy bytecodes: @@ -5015,9 +5015,15 @@ TEBCresume( * but creating the object as a string seems to be faster in * practical use. */ - - length = (ch != -1) ? Tcl_UniCharToUtf(ch, buf) : 0; - objResultPtr = Tcl_NewStringObj(buf, length); + if (ch == -1) { + objResultPtr = Tcl_NewObj(); + } else { + length = Tcl_UniCharToUtf(ch, buf); + if (!length) { + length = Tcl_UniCharToUtf(-1, buf); + } + objResultPtr = Tcl_NewStringObj(buf, length); + } } TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); diff --git a/generic/tclHash.c b/generic/tclHash.c index dc58800..a4317e8 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -34,18 +34,18 @@ * Prototypes for the array hash key methods. */ -static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, CONST90 void *keyPtr); -static int CompareArrayKeys(CONST90 void *keyPtr, Tcl_HashEntry *hPtr); -static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, CONST90 void *keyPtr); +static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr); +static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); +static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the string hash key methods. */ static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, - CONST90 void *keyPtr); -static int CompareStringKeys(CONST90 void *keyPtr, Tcl_HashEntry *hPtr); -static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, CONST90 void *keyPtr); + void *keyPtr); +static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); +static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Function prototypes for static functions in this file: @@ -619,16 +619,16 @@ Tcl_HashStats( */ result = ckalloc((NUM_COUNTERS * 60) + 300); - sprintf(result, "%" TCL_LL_MODIFIER "d entries in table, %" TCL_LL_MODIFIER "d buckets\n", - (Tcl_WideInt)tablePtr->numEntries, (Tcl_WideInt)tablePtr->numBuckets); + sprintf(result, "%" TCL_Z_MODIFIER "u entries in table, %" TCL_Z_MODIFIER "u buckets\n", + tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); for (i = 0; i < NUM_COUNTERS; i++) { - sprintf(p, "number of buckets with %d entries: %" TCL_LL_MODIFIER "d\n", - (int)i, (Tcl_WideInt)count[i]); + sprintf(p, "number of buckets with %" TCL_Z_MODIFIER "u entries: %" TCL_Z_MODIFIER "u\n", + i, count[i]); p += strlen(p); } - sprintf(p, "number of buckets with %d or more entries: %d\n", - NUM_COUNTERS, (int)overflow); + sprintf(p, "number of buckets with %d or more entries: %" TCL_Z_MODIFIER "u\n", + NUM_COUNTERS, overflow); p += strlen(p); sprintf(p, "average search distance for entry: %.1f", average); return result; @@ -653,7 +653,7 @@ Tcl_HashStats( static Tcl_HashEntry * AllocArrayEntry( Tcl_HashTable *tablePtr, /* Hash table. */ - CONST90 void *keyPtr) /* Key to store in the hash table entry. */ + void *keyPtr) /* Key to store in the hash table entry. */ { int *array = (int *) keyPtr; register int *iPtr1, *iPtr2; @@ -697,11 +697,11 @@ AllocArrayEntry( static int CompareArrayKeys( - CONST90 void *keyPtr, /* New key to compare. */ + void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - register const int *iPtr1 = (const int *) keyPtr; - register const int *iPtr2 = (const int *) hPtr->key.words; + const int *iPtr1 = keyPtr; + const int *iPtr2 = hPtr->key.words; Tcl_HashTable *tablePtr = hPtr->tablePtr; int count; @@ -737,7 +737,7 @@ CompareArrayKeys( static TCL_HASH_TYPE HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ - CONST90 void *keyPtr) /* Key from which to compute hash value. */ + void *keyPtr) /* Key from which to compute hash value. */ { register const int *array = (const int *) keyPtr; register TCL_HASH_TYPE result; @@ -769,7 +769,7 @@ HashArrayKey( static Tcl_HashEntry * AllocStringEntry( Tcl_HashTable *tablePtr, /* Hash table. */ - CONST90 void *keyPtr) /* Key to store in the hash table entry. */ + void *keyPtr) /* Key to store in the hash table entry. */ { const char *string = (const char *) keyPtr; Tcl_HashEntry *hPtr; @@ -804,13 +804,10 @@ AllocStringEntry( static int CompareStringKeys( - CONST90 void *keyPtr, /* New key to compare. */ + void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - register const char *p1 = (const char *) keyPtr; - register const char *p2 = (const char *) hPtr->key.string; - - return !strcmp(p1, p2); + return !strcmp(keyPtr, hPtr->key.string); } /* @@ -833,7 +830,7 @@ CompareStringKeys( static TCL_HASH_TYPE HashStringKey( Tcl_HashTable *tablePtr, /* Hash table. */ - CONST90 void *keyPtr) /* Key from which to compute hash value. */ + void *keyPtr) /* Key from which to compute hash value. */ { register const char *string = keyPtr; register TCL_HASH_TYPE result; diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 24c26f6..db124fb 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -11,7 +11,7 @@ #include "tclInt.h" -#if defined(_WIN32) && defined(UNICODE) +#if defined(_WIN32) /* * On Windows, we need to do proper Unicode->UTF-8 conversion. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index ecac8d1..0ba2ee7 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4024,9 +4024,9 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, * So tclObj.c and tclDictObj.c can share these implementations. */ -MODULE_SCOPE int TclCompareObjKeys(CONST90 void *keyPtr, Tcl_HashEntry *hPtr); +MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); -MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, CONST90 void *keyPtr); +MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); diff --git a/generic/tclObj.c b/generic/tclObj.c index 3438e1a..6ad57b3 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -220,7 +220,7 @@ static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * Prototypes for the array hash key methods. */ -static Tcl_HashEntry * AllocObjEntry(Tcl_HashTable *tablePtr, CONST90 void *keyPtr); +static Tcl_HashEntry * AllocObjEntry(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the CommandName object type. @@ -3111,8 +3111,7 @@ TclGetNumberFromObj( } if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; - mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, - (int) sizeof(mp_int)); + mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, sizeof(mp_int)); UNPACK_BIGNUM(objPtr, *bigPtr); *typePtr = TCL_NUMBER_BIG; @@ -3375,7 +3374,7 @@ Tcl_InitObjHashTable( static Tcl_HashEntry * AllocObjEntry( Tcl_HashTable *tablePtr, /* Hash table. */ - CONST90 void *keyPtr) /* Key to store in the hash table entry. */ + void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; Tcl_HashEntry *hPtr = ckalloc(sizeof(Tcl_HashEntry)); @@ -3406,7 +3405,7 @@ AllocObjEntry( int TclCompareObjKeys( - CONST90 void *keyPtr, /* New key to compare. */ + void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; @@ -3496,7 +3495,7 @@ TclFreeObjEntry( TCL_HASH_TYPE TclHashObjKey( Tcl_HashTable *tablePtr, /* Hash table. */ - CONST90 void *keyPtr) /* Key from which to compute hash value. */ + void *keyPtr) /* Key from which to compute hash value. */ { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; const char *string = TclGetString(objPtr); @@ -3914,10 +3913,10 @@ Tcl_RepresentationCmd( * "1872361827361287" */ - descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d," + descObj = Tcl_ObjPrintf("value is a %s with a refcount of %" TCL_Z_MODIFIER "d," " object pointer at %p", objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", - (int) objv[1]->refCount, objv[1]); + objv[1]->refCount, objv[1]); if (objv[1]->typePtr) { if (objv[1]->typePtr == &tclDoubleType) { diff --git a/generic/tclParse.c b/generic/tclParse.c index ca10b89..4e83ae2 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -980,7 +980,12 @@ TclParseBackslash( if (readPtr != NULL) { *readPtr = count; } - return Tcl_UniCharToUtf(result, dst); + count = Tcl_UniCharToUtf(result, dst); + if (!count) { + /* Special case for handling upper surrogates. */ + count = Tcl_UniCharToUtf(-1, dst); + } + return count; } /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 4d30374..34474f1 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -536,7 +536,7 @@ Tcl_GetUniChar( return -1; } - return (int) bytes[index]; + return bytes[index]; } /* @@ -683,9 +683,6 @@ Tcl_GetRange( String *stringPtr; int length; - if (last == (size_t)-2) { - last = (size_t)-1; /* For compatibility with pre-9.0 behavior */ - } if (first == (size_t)-1) { first = 0; } @@ -698,10 +695,10 @@ Tcl_GetRange( if (TclIsPureByteArray(objPtr)) { unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); - if (last+1 >= (size_t)(unsigned int)length+1) { + if (last+2 >= (size_t)(unsigned int)length+2) { last = length - 1; } - if (last + 1 < first + 1) { + if (last + 2 < first + 2) { return Tcl_NewObj(); } return Tcl_NewByteArrayObj(bytes + first, last - first + 1); @@ -723,10 +720,10 @@ Tcl_GetRange( TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { - if (last + 1 >= stringPtr->numChars + 1) { + if (last + 2 >= stringPtr->numChars + 2) { last = stringPtr->numChars - 1; } - if (last + 1 < first + 1) { + if (last + 2 < first + 2) { return Tcl_NewObj(); } newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last-first+1); @@ -743,10 +740,10 @@ Tcl_GetRange( FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } - if (last + 1 > stringPtr->numChars + 1) { + if (last + 2 > stringPtr->numChars + 2) { last = stringPtr->numChars; } - if (last + 1 < first + 1) { + if (last + 2 < first + 2) { return Tcl_NewObj(); } #if TCL_UTF_MAX <= 4 @@ -755,7 +752,7 @@ Tcl_GetRange( && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { ++first; } - if ((last + 1 < stringPtr->numChars) + if ((last + 2 < stringPtr->numChars + 1) && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00) && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) { ++last; @@ -1995,6 +1992,10 @@ Tcl_AppendFormatToObj( goto error; } length = Tcl_UniCharToUtf(code, buf); + if (!length) { + /* Special case for handling upper surrogates. */ + length = Tcl_UniCharToUtf(-1, buf); + } segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; @@ -2124,7 +2125,7 @@ Tcl_AppendFormatToObj( const char *bytes; if (useShort) { - pure = Tcl_NewIntObj((int) s); + pure = Tcl_NewIntObj(s); #ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { pure = Tcl_NewWideIntObj(w); @@ -2255,9 +2256,9 @@ Tcl_AppendFormatToObj( numDigits = 1; } pure = Tcl_NewObj(); - Tcl_SetObjLength(pure, (int) numDigits); + Tcl_SetObjLength(pure, numDigits); bytes = TclGetString(pure); - toAppend = length = (int) numDigits; + toAppend = length = numDigits; while (numDigits--) { int digitOffset; @@ -2269,7 +2270,7 @@ Tcl_AppendFormatToObj( } shift -= numBits; } - digitOffset = (int) (bits % base); + digitOffset = bits % base; if (digitOffset > 9) { if (ch == 'X') { bytes[numDigits] = 'A' + digitOffset - 10; @@ -2561,7 +2562,7 @@ AppendPrintfToObjVA( */ q = Tcl_UtfPrev(end, bytes); - if (!Tcl_UtfCharComplete(q, (int)(end - q))) { + if (!Tcl_UtfCharComplete(q, (end - q))) { end = q; } @@ -2572,7 +2573,7 @@ AppendPrintfToObjVA( } Tcl_ListObjAppendElement(NULL, list, - Tcl_NewStringObj(bytes , (int)(end - bytes))); + Tcl_NewStringObj(bytes , (end - bytes))); break; } @@ -2622,7 +2623,7 @@ AppendPrintfToObjVA( seekingConversion = 0; break; case '*': - lastNum = (int) va_arg(argList, int); + lastNum = va_arg(argList, int); Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum)); p++; break; @@ -2630,7 +2631,7 @@ AppendPrintfToObjVA( case '5': case '6': case '7': case '8': case '9': { char *end; - lastNum = (int) strtoul(p, &end, 10); + lastNum = strtoul(p, &end, 10); p = end; break; } @@ -4210,7 +4211,7 @@ ExtendStringRepWithUnicode( copyBytes: dst = objPtr->bytes + origLength; for (i = 0; i < numChars; i++) { - dst += Tcl_UniCharToUtf((int) unicode[i], dst); + dst += Tcl_UniCharToUtf(unicode[i], dst); } *dst = '\0'; objPtr->length = dst - objPtr->bytes; diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 3a6fc43..1742eb7 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -174,7 +174,6 @@ TclThread_Init( Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL); return TCL_OK; } - /* *---------------------------------------------------------------------- @@ -1158,6 +1157,14 @@ ThreadExitProc( Tcl_MutexLock(&threadMutex); + if (self == errorThreadId) { + if (errorProcString) { /* Extra safety */ + ckfree(errorProcString); + errorProcString = NULL; + } + errorThreadId = 0; + } + if (threadEvalScript) { ckfree(threadEvalScript); threadEvalScript = NULL; diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 4cbe31c..e9aab51 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -173,6 +173,13 @@ Tcl_UniCharToUtf( buf[0] = (char) ((ch >> 18) | 0xF0); return 4; } + } else if (ch == -1) { + if (((buf[0] & 0xF8) == 0xF0) && ((buf[1] & 0xC0) == 0x80) + && ((buf[2] & 0xCF) == 0)) { + ch = 0xD7C0 + ((buf[0] & 0x07) << 8) + ((buf[1] & 0x3F) << 2) + + ((buf[2] & 0x30) >> 4); + goto three; + } } ch = 0xFFFD; @@ -212,6 +219,7 @@ Tcl_UniCharToUtfDString( const Tcl_UniChar *w, *wEnd; char *p, *string; size_t oldLength; + int len = 1; /* * UTF-8 string length in bytes will be <= Unicode string length * 4. @@ -224,9 +232,18 @@ Tcl_UniCharToUtfDString( p = string; wEnd = uniStr + uniLength; for (w = uniStr; w < wEnd; ) { - p += Tcl_UniCharToUtf(*w, p); + if (!len && ((*w & 0xFC00) != 0xDC00)) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + len = Tcl_UniCharToUtf(*w, p); + p += len; w++; } + if (!len) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); return string; @@ -899,7 +916,7 @@ Tcl_UtfToUpper( * char to dst if its size is <= the original char. */ - if (bytes < TclUtfCount(upChar)) { + if ((bytes < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -962,7 +979,7 @@ Tcl_UtfToLower( * char to dst if its size is <= the original char. */ - if (bytes < TclUtfCount(lowChar)) { + if ((bytes < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -1022,7 +1039,7 @@ Tcl_UtfToTitle( #endif titleChar = Tcl_UniCharToTitle(titleChar); - if (bytes < TclUtfCount(titleChar)) { + if ((bytes < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -1046,7 +1063,7 @@ Tcl_UtfToTitle( lowChar = Tcl_UniCharToLower(lowChar); } - if (bytes < TclUtfCount(lowChar)) { + if ((bytes < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 65dc55c..c85f33d 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1907,7 +1907,7 @@ TclTrim( */ /* The whitespace characters trimmed during [concat] operations */ -#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_TRIM_SET "") - 1) +#define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1) char * Tcl_Concat( @@ -3535,7 +3535,7 @@ GetEndOffsetFromObj( /* TODO: Handle overflow cases sensibly */ *indexPtr = endValue + (int)objPtr->internalRep.wideValue; - if ((*indexPtr < -1) && (endValue < 0)) *indexPtr = -1; + if ((*indexPtr < -1) && (endValue > 0)) *indexPtr = -1; return TCL_OK; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 3bae78f..12e3640 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -24,9 +24,9 @@ * Prototypes for the variable hash key methods. */ -static Tcl_HashEntry * AllocVarEntry(Tcl_HashTable *tablePtr, CONST90 void *keyPtr); +static Tcl_HashEntry * AllocVarEntry(Tcl_HashTable *tablePtr, void *keyPtr); static void FreeVarEntry(Tcl_HashEntry *hPtr); -static int CompareVarKeys(CONST90 void *keyPtr, Tcl_HashEntry *hPtr); +static int CompareVarKeys(void *keyPtr, Tcl_HashEntry *hPtr); static const Tcl_HashKeyType tclVarHashKeyType = { TCL_HASH_KEY_TYPE_VERSION, /* version */ @@ -6389,7 +6389,7 @@ TclInitVarHashTable( static Tcl_HashEntry * AllocVarEntry( Tcl_HashTable *tablePtr, /* Hash table. */ - CONST90 void *keyPtr) /* Key to store in the hash table entry. */ + void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; Tcl_HashEntry *hPtr; @@ -6428,7 +6428,7 @@ FreeVarEntry( static int CompareVarKeys( - CONST90 void *keyPtr, /* New key to compare. */ + void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr; diff --git a/tests/all.tcl b/tests/all.tcl index ad372db..e14bd9c 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -13,19 +13,14 @@ package prefer latest package require Tcl 8.5- package require tcltest 2.2 -namespace import tcltest::* -configure {*}$argv -testdir [file dir [info script]] +namespace import ::tcltest::* + +configure {*}$argv -testdir [file dirname [file dirname [file normalize [ + info script]/...]]] + if {[singleProcess]} { interp debug {} -frame 1 } -set testsdir [file dirname [file dirname [file normalize [info script]/...]]] -lappend auto_path $testsdir {*}[apply {{testsdir args} { - lmap x $args { - if {$x eq $testsdir} continue - lindex $x - } -}} $testsdir {*}$auto_path] - runAllTests proc exit args {} diff --git a/tests/chanio.test b/tests/chanio.test index 97e7e70..e7f51b3 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -13,16 +13,11 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. +# TODO: This test is likely worthless. Confirm and remove if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 - namespace import -force ::tcltest::* } -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -testConstraint testbytestring [llength [info commands testbytestring]] - namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -35,18 +30,16 @@ namespace eval ::tcl::test::io { variable msg variable expected - ::tcltest::loadTestedCommands + loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] - + package require tcltests + + testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] - testConstraint exec [llength [info commands exec]] testConstraint openpipe 1 - testConstraint fileevent [llength [info commands fileevent]] - testConstraint fcopy [llength [info commands fcopy]] testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] - testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # You need a *very* special environment to do some tests. In particular, # many file systems do not support large-files... diff --git a/tests/env.test b/tests/env.test index 0dd4f98..2c077b1 100644 --- a/tests/env.test +++ b/tests/env.test @@ -16,49 +16,96 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } -# Some tests require the "exec" command. -# Skip them if exec is not defined. -testConstraint exec [llength [info commands exec]] +package require tcltests + +# [exec] is required here to see the actual environment received by child +# processes. +proc getenv {} { + global printenvScript + catch {exec [interpreter] $printenvScript} out + if {$out eq "child process exited abnormally"} { + set out {} + } + return $out +} + + +proc envrestore {} { + # Restore the environment variables at the end of the test. + global env + variable env2 + + foreach name [array names env] { + unset env($name) + } + array set env $env2 + return +} + + +proc envprep {} { + # Save the current environment variables at the start of the test. + global env + variable keep + variable env2 + + set env2 [array get env] + foreach name [array names env] { + # Keep some environment variables that support operation of the tcltest + # package. + if {[string toupper $name] ni $keep} { + unset env($name) + } + } + return +} + + +proc encodingrestore {} { + variable sysenc + encoding system $sysenc + return +} + + +proc encodingswitch encoding { + variable sysenc + # Need to run [getenv] in known encoding, so save the current one here... + set sysenc [encoding system] + encoding system $encoding + return +} + + +proc setup1 {} { + global env + envprep + encodingswitch iso8859-1 +} + +proc setup2 {} { + global env + setup1 + set env(NAME1) {test string} + set env(NAME2) {new value} + set env(XYZZY) {garbage} +} + + +proc cleanup1 {} { + encodingrestore + envrestore +} -# -# These tests will run on any platform (and indeed crashed on the Mac). So put -# them before you test for the existance of exec. -# -test env-1.1 {propagation of env values to child interpreters} -setup { - catch {interp delete child} - catch {unset env(test)} -} -body { - interp create child - set env(test) garbage - child eval {set env(test)} -} -cleanup { - interp delete child - unset env(test) -} -result {garbage} -# -# This one crashed on Solaris under Tcl8.0, so we only want to make sure it -# runs. -# -test env-1.2 {lappend to env value} -setup { - catch {unset env(test)} -} -body { - set env(test) aaaaaaaaaaaaaaaa - append env(test) bbbbbbbbbbbbbb - unset env(test) +variable keep { + TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH + SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH + DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING + SECURITYSESSIONID LANG WINDIR TERM + CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432 } -test env-1.3 {reflection of env by "array names"} -setup { - catch {interp delete child} - catch {unset env(test)} -} -body { - interp create child - child eval {set env(test) garbage} - expr {"test" in [array names env]} -} -cleanup { - interp delete child - catch {unset env(test)} -} -result {1} -set printenvScript [makeFile { +variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { encoding system iso8859-1 proc lrem {listname name} { upvar $listname list @@ -70,7 +117,7 @@ set printenvScript [makeFile { } proc mangle s { regsub -all {\[|\\|\]} $s {\\&} s - regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar &]} s + regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar {&}]} s return [subst -novariables $s] } proc manglechar c { @@ -84,161 +131,154 @@ set printenvScript [makeFile { lrem names ComSpec lrem names "" } - foreach name { - TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY - SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH - DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING - __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432 - } { + foreach name @keep@ { lrem names $name } foreach p $names { - puts "[mangle $p]=[mangle $env($p)]" + puts [mangle $p]=[mangle $env($p)] } exit -} printenv] +}] printenv] -# [exec] is required here to see the actual environment received by child -# processes. -proc getenv {} { - global printenvScript tcltest - catch {exec [interpreter] $printenvScript} out - if {$out eq "child process exited abnormally"} { - set out {} - } - return $out -} -# Save the current environment variables at the start of the test. - -set env2 [array get env] -foreach name [array names env] { - # Keep some environment variables that support operation of the tcltest - # package. - if {[string toupper $name] ni { - TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH - SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH - DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING - SECURITYSESSIONID LANG WINDIR TERM - CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432 - }} { - unset env($name) - } +test env-1.1 {propagation of env values to child interpreters} -setup { + catch {interp delete child} + catch {unset env(test)} +} -body { + interp create child + set env(test) garbage + child eval {set env(test)} +} -cleanup { + interp delete child + unset env(test) +} -result {garbage} + + +# This one crashed on Solaris under Tcl8.0, so we only want to make sure it +# runs. +test env-1.2 {lappend to env value} -setup { + catch {unset env(test)} +} -body { + set env(test) aaaaaaaaaaaaaaaa + append env(test) bbbbbbbbbbbbbb + unset env(test) } -# Need to run 'getenv' in known encoding, so save the current one here... -set sysenc [encoding system] -test env-2.1 {adding environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { - getenv +test env-1.3 {reflection of env by "array names"} -setup { + catch {interp delete child} + catch {unset env(test)} +} -body { + interp create child + child eval {set env(test) garbage} + expr {"test" in [array names env]} } -cleanup { - encoding system $sysenc -} -result {} -test env-2.2 {adding environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + interp delete child + catch {unset env(test)} +} -result 1 + + +test env-2.1 { + adding environment variables +} -constraints exec -setup setup1 -body { + getenv +} -cleanup cleanup1 -result {} + + +test env-2.2 { + adding environment variables +} -constraints exec -setup setup1 -body { set env(NAME1) "test string" getenv -} -cleanup { - encoding system $sysenc -} -result {NAME1=test string} -test env-2.3 {adding environment variables} -setup { - encoding system iso8859-1 +} -cleanup cleanup1 -result {NAME1=test string} + + +test env-2.3 {adding environment variables} -constraints exec -setup { + setup1 set env(NAME1) "test string" -} -constraints {exec} -body { +} -body { set env(NAME2) "more" getenv -} -cleanup { - encoding system $sysenc -} -result {NAME1=test string +} -cleanup cleanup1 -result {NAME1=test string NAME2=more} -test env-2.4 {adding environment variables} -setup { - encoding system iso8859-1 + + +test env-2.4 { + adding environment variables +} -constraints exec -setup { + setup1 set env(NAME1) "test string" set env(NAME2) "more" -} -constraints {exec} -body { +} -body { set env(XYZZY) "garbage" getenv -} -cleanup { - encoding system $sysenc +} -cleanup { cleanup1 } -result {NAME1=test string NAME2=more XYZZY=garbage} -set env(NAME1) "test string" -set env(NAME2) "new value" -set env(XYZZY) "garbage" -test env-3.1 {changing environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + +test env-3.1 { + changing environment variables +} -constraints exec -setup setup2 -body { set result [getenv] unset env(NAME2) set result } -cleanup { - encoding system $sysenc + cleanup1 } -result {NAME1=test string NAME2=new value XYZZY=garbage} -unset -nocomplain env(NAME2) -test env-4.1 {unsetting environment variables: default} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + +test env-4.1 { + unsetting environment variables +} -constraints exec -setup setup2 -body { + unset -nocomplain env(NAME2) getenv -} -cleanup { - encoding system $sysenc -} -result {NAME1=test string +} -cleanup cleanup1 -result {NAME1=test string XYZZY=garbage} -test env-4.2 {unsetting environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { - unset env(NAME1) - getenv -} -cleanup { - unset env(XYZZY) - encoding system $sysenc -} -result {XYZZY=garbage} -unset -nocomplain env(NAME1) env(XYZZY) -test env-4.3 {setting international environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + +# env-4.2 is deleted + +test env-4.3 { + setting international environment variables +} -constraints exec -setup setup1 -body { set env(\ua7) \ub6 getenv -} -cleanup { - encoding system $sysenc -} -result {\u00a7=\u00b6} -test env-4.4 {changing international environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { +} -cleanup cleanup1 -result {\u00a7=\u00b6} + + +test env-4.4 { + changing international environment variables +} -constraints exec -setup setup1 -body { set env(\ua7) \ua7 getenv -} -cleanup { - encoding system $sysenc -} -result {\u00a7=\u00a7} -test env-4.5 {unsetting international environment variables} -setup { - encoding system iso8859-1 +} -cleanup cleanup1 -result {\u00a7=\u00a7} + + +test env-4.5 { + unsetting international environment variables +} -constraints exec -setup { + setup1 set env(\ua7) \ua7 } -body { set env(\ub6) \ua7 unset env(\ua7) getenv -} -constraints {exec} -cleanup { - unset env(\ub6) - encoding system $sysenc -} -result {\u00b6=\u00a7} +} -cleanup cleanup1 -result {\u00b6=\u00a7} -test env-5.0 {corner cases - set a value, it should exist} -body { +test env-5.0 { + corner cases - set a value, it should exist +} -setup setup1 -body { set env(temp) a set env(temp) -} -cleanup { - unset env(temp) -} -result {a} -test env-5.1 {corner cases - remove one elem at a time} -setup { - set x [array get env] -} -body { +} -cleanup cleanup1 -result a + + +test env-5.1 { + corner cases - remove one elem at a time +} -setup setup1 -body { # When no environment variables exist, the env var will contain no # entries. The "array names" call synchs up the C-level environ array with # the Tcl level env array. Make sure an empty Tcl array is created. @@ -246,9 +286,9 @@ test env-5.1 {corner cases - remove one elem at a time} -setup { unset env($e) } array size env -} -cleanup { - array set env $x -} -result {0} +} -cleanup cleanup1 -result 0 + + test env-5.2 {corner cases - unset the env array} -setup { interp create i } -body { @@ -262,42 +302,54 @@ test env-5.2 {corner cases - unset the env array} -setup { } -cleanup { interp delete i } -result {0} + + test env-5.3 {corner cases: unset the env in master should unset child} -setup { + setup1 interp create i } -body { # Variables deleted in a master interp should be deleted in child interp # too. - i eval { set env(THIS_SHOULD_EXIST) a} + i eval {set env(THIS_SHOULD_EXIST) a} set result [set env(THIS_SHOULD_EXIST)] unset env(THIS_SHOULD_EXIST) lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}] } -cleanup { + cleanup1 interp delete i } -result {a 1} + + test env-5.4 {corner cases - unset the env array} -setup { + setup1 interp create i } -body { # The info exists command should be in synch with the env array. # Know Bug: 1737 - i eval { set env(THIS_SHOULD_EXIST) a} + i eval {set env(THIS_SHOULD_EXIST) a} set result [info exists env(THIS_SHOULD_EXIST)] lappend result [set env(THIS_SHOULD_EXIST)] lappend result [info exists env(THIS_SHOULD_EXIST)] } -cleanup { + cleanup1 interp delete i } -result {1 a 1} -test env-5.5 {corner cases - cannot have null entries on Windows} -constraints win -body { + + +test env-5.5 { + corner cases - cannot have null entries on Windows +} -constraints win -body { set env() a catch {set env()} -} -result 1 +} -cleanup cleanup1 -result 1 -test env-6.1 {corner cases - add lots of env variables} -body { +test env-6.1 {corner cases - add lots of env variables} -setup setup1 -body { set size [array size env] for {set i 0} {$i < 100} {incr i} { set env(BOGUS$i) $i } expr {[array size env] - $size} -} -result 100 +} -cleanup cleanup1 -result 100 test env-7.1 {[219226]: whole env array should not be unset by read} -body { set n [array size env] @@ -310,16 +362,20 @@ test env-7.1 {[219226]: whole env array should not be unset by read} -body { return $n } -result 0 -test env-7.2 {[219226]: links to env elements should not be removed by read} -body { +test env-7.2 { + [219226]: links to env elements should not be removed by read +} -setup setup1 -body { apply {{} { set ::env(test7_2) ok upvar env(test7_2) elem set ::env(PATH) return $elem }} -} -result ok +} -cleanup cleanup1 -result ok -test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy trace} -body { +test env-7.3 { + [9b4702]: testing existence of env(some_thing) should not destroy trace +} -setup setup1 -body { apply {{} { catch {unset ::env(test7_3)} proc foo args { @@ -330,16 +386,25 @@ test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy set ::env(not_yet_existent) "Now I'm here"; return [info exists ::env(test7_3)] }} -} -result 1 +} -cleanup cleanup1 -result 1 -# Restore the environment variables at the end of the test. +test env-8.0 { + memory usage - valgrind does not report reachable memory +} -body { + set res [set env(__DUMMY__) {i'm with dummy}] + unset env(__DUMMY__) + return $res +} -result {i'm with dummy} + -foreach name [array names env] { - unset env($name) -} -array set env $env2 # cleanup +rename getenv {} +rename envrestore {} +rename envprep {} +rename encodingrestore {} +rename encodingswitch {} + removeFile $printenvScript ::tcltest::cleanupTests return diff --git a/tests/expr.test b/tests/expr.test index 695469b..0b9bd48 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -7157,6 +7157,15 @@ test expr-51.1 {test round-to-even on input} { expr 6.9294956446009195e15 } 6929495644600920.0 +test expr-52.1 { + comparison with empty string does not generate string representation +} { + set a [list one two three] + list [expr {$a eq {}}] [expr {$a < {}}] [expr {$a > {}}] [ + string match {*no string representation*} [ + ::tcl::unsupported::representation $a]] +} {0 0 1 1} + # cleanup diff --git a/tests/http11.test b/tests/http11.test index c9ded0b..2e50837 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -666,6 +666,13 @@ test http11-4.3 "normal post request, check channel query length" -setup { # ------------------------------------------------------------------------- +# Eliminate valgrind "still reachable" reports on outstanding "Detached" +# structures in the detached list which stem from PipeClose2Proc not waiting +# around for background processes to complete, meaning that previous calls to +# Tcl_ReapDetachedProcs might not have had a chance to reap all processes. +after 10 +exec [info nameofexecutable] << {} + foreach p {create_httpd httpd_read halt_httpd meta check_crc} { if {[llength [info proc $p]]} {rename $p {}} } diff --git a/tests/io.test b/tests/io.test index 20bb565..683a1b2 100644 --- a/tests/io.test +++ b/tests/io.test @@ -15,14 +15,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 - namespace import -force ::tcltest::* } -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -testConstraint testbytestring [llength [info commands testbytestring]] - namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -35,15 +29,16 @@ namespace eval ::tcl::test::io { variable msg variable expected + loadTestedCommands + catch [list package require -exact Tcltest [info patchlevel]] + package require tcltests + +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint exec [llength [info commands exec]] testConstraint openpipe 1 -testConstraint fileevent [llength [info commands fileevent]] -testConstraint fcopy [llength [info commands fcopy]] testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] -testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] testConstraint testobj [llength [info commands testobj]] # You need a *very* special environment to do some tests. In diff --git a/tests/ioCmd.test b/tests/ioCmd.test index ae58025..948671e 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -21,10 +21,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +package require tcltests + # Custom constraints used in this file -testConstraint fcopy [llength [info commands fcopy]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] #---------------------------------------------------------------------- @@ -395,7 +395,7 @@ test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode } {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} -test iocmd-11.4 {I/O to command pipelines} unixOrPc { +test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrPc} { list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode } {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}} @@ -3833,6 +3833,16 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat rename track {} # cleanup + + +# Eliminate valgrind "still reachable" reports on outstanding "Detached" +# structures in the detached list which stem from PipeClose2Proc not waiting +# around for background processes to complete, meaning that previous calls to +# Tcl_ReapDetachedProcs might not have had a chance to reap all processes. +after 10 +exec [info nameofexecutable] << {} + + foreach file [list test1 test2 test3 test4] { removeFile $file } diff --git a/tests/iogt.test b/tests/iogt.test index aa579bf..3cac2cf 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -608,7 +608,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { variable copy 1 } } -constraints {testchannel knownBug} -body { - # This test to check the validity of aquired Tcl_Channel references is not + # This test to check the validity of acquired Tcl_Channel references is not # possible because even a backgrounded fcopy will immediately start to # copy data, without waiting for the event loop. This is done only in case # of an underflow on the read size!. So stacking transforms after the diff --git a/tests/pkgIndex.tcl b/tests/pkgIndex.tcl index 48ab71b..854b943 100644 --- a/tests/pkgIndex.tcl +++ b/tests/pkgIndex.tcl @@ -1,6 +1,6 @@ #! /usr/bin/env tclsh -package ifneeded tcltests 0.1 { - source [file dirname [file dirname [file normalize [info script]/...]]]/tcltests.tcl - package provide tcltests 0.1 -} +package ifneeded tcltests 0.1 " + source [list $dir/tcltests.tcl] + package provide tcltests 0.1 +" diff --git a/tests/platform.test b/tests/platform.test index 8a68351..fa533e8 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -10,6 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 +package require tcltests namespace eval ::tcl::test::platform { namespace import ::tcltest::testConstraint @@ -67,7 +68,10 @@ test platform-3.1 {CPU ID on Windows/UNIX} \ # format of string it produces consists of two non-empty words separated by a # hyphen. package require platform -test platform-4.1 {format of platform::identify result} -match regexp -body { +test platform-4.1 {format of platform::identify result} -constraints notValgrind -match regexp -body { + # [identify] may attempt to [exec] dpkg-architecture, which may not exist, + # in which case fork will not be followed by exec, and valgrind will issue + # "still reachable" reports. platform::identify } -result {^([^-]+-)+[^-]+$} test platform-4.2 {format of platform::generic result} -match regexp -body { diff --git a/tests/tailcall.test b/tests/tailcall.test index ce506a7..9174167 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -688,6 +688,26 @@ if {[testConstraint testnrelevels]} { namespace delete testnre } +test tailcall-14.1 {in a deleted namespace} -body { + namespace eval ns { + proc p args { + tailcall [namespace current] $args + } + namespace delete [namespace current] + p + } +} -returnCodes 1 -result {namespace "::ns" not found} + +test tailcall-14.1-bc {{in a deleted namespace} {byte compiled}} -body { + namespace eval ns { + proc p args { + tailcall [namespace current] {*}$args + } + namespace delete [namespace current] + p + } +} -returnCodes 1 -result {namespace "::ns" not found} + # cleanup ::tcltest::cleanupTests diff --git a/tests/tcltest.test b/tests/tcltest.test index 286f017..5a3671f 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -909,7 +909,9 @@ removeFile load.tcl # [interpreter] test tcltest-13.1 {interpreter} { + -constraints notValgrind -setup { + #to do: Why is $::tcltest::tcltest being saved and restored here? set old $::tcltest::tcltest set ::tcltest::tcltest tcltest } @@ -921,6 +923,11 @@ test tcltest-13.1 {interpreter} { } -result {tcltest tclsh tclsh} -cleanup { + # writing ::tcltest::tcltest triggers a trace that sets up the stdio + # constraint, which involves a call to [exec] that might fail after + # "fork" and before "exec", in which case the forked process will not + # have a chance to clean itself up before exiting, which causes + # valgrind to issue numerous "still reachable" reports. set ::tcltest::tcltest $old } } diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl new file mode 100644 index 0000000..74d1b40 --- /dev/null +++ b/tests/tcltests.tcl @@ -0,0 +1,11 @@ +#! /usr/bin/env tclsh + +package require tcltest 2.2 +namespace import ::tcltest::* + +testConstraint exec [llength [info commands exec]] +testConstraint fcopy [llength [info commands fcopy]] +testConstraint fileevent [llength [info commands fileevent]] +testConstraint thread [ + expr {0 == [catch {package require Thread 2.7-}]}] +testConstraint notValgrind [expr {![testConstraint valgrind]}] diff --git a/tests/thread.test b/tests/thread.test index cc4c871..eaaaa41 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -11,25 +11,19 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.2 - namespace import -force ::tcltest::* -} + +# when thread::release is used, -wait is passed in order allow the thread to +# be fully finalized, which avoids valgrind "still reachable" reports. + +package require tcltests ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the testthread command -testConstraint testthread [expr {[info commands testthread] != {}}] - -# Some tests require the Thread package - -testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] +testConstraint testthread [expr {[info commands testthread] ne {}}] -# Some tests may not work under valgrind - -testConstraint notValgrind [expr {![testConstraint valgrind]}] set threadSuperKillScript { rename catch "" @@ -72,6 +66,17 @@ proc ThreadError {id info} { set threadSawError($id) true; # signal main thread to exit [vwait]. } +proc threadSuperKill id { + variable threadSuperKillScript + try { + thread::send $id $::threadSuperKillScript + } on error {tres topts} { + if {$tres ne {target thread died}} { + return -options $topts $tres + } + } +} + if {[testConstraint thread]} { thread::errorproc ThreadError } @@ -96,22 +101,22 @@ test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} { test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} { set serverthread [thread::create -preserved] set numthreads [llength [thread::names]] - thread::release $serverthread + thread::release -wait $serverthread set numthreads -} {2} +} 2 test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} { thread::create {set x 5} foreach try {0 1 2 4 5 6} { - # Try various ways to yield - update - after 10 - set l [llength [thread::names]] - if {$l == 1} { - break - } + # Try various ways to yield + update + after 10 + set l [llength [thread::names]] + if {$l == 1} { + break + } } set l -} {1} +} 1 test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { thread::create {{*}{}} update @@ -121,13 +126,13 @@ test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} { set serverthread [thread::create -preserved] set five [thread::send $serverthread {set x 5}] - thread::release $serverthread + thread::release -wait $serverthread set five } 5 test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} { set serverthread [thread::create -preserved {set z 5 ; thread::wait}] set five [thread::send $serverthread {set z}] - thread::release $serverthread + thread::release -wait $serverthread set five } 5 @@ -159,7 +164,7 @@ test thread-3.1 {TclThreadList} {thread} { set l2 [thread::names] set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]] foreach t $l1 { - thread::release $t + thread::release -wait $t } list $len $c } {1 0} @@ -887,7 +892,7 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread drainE # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::cancel $serverthread] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -929,7 +934,7 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::cancel $serverthread] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1029,7 +1034,7 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {interp cancel}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1071,7 +1076,7 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {interp cancel}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1111,7 +1116,7 @@ test thread-7.30 {cancel: send async thread cancel nested catch inside pure byte # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {thread::cancel [thread::id]}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1153,7 +1158,7 @@ test thread-7.31 {cancel: send async thread cancel nested catch pure inside-comm # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {thread::cancel [thread::id]}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ diff --git a/tests/utf.test b/tests/utf.test index 9dd8017..e820359 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -44,6 +44,18 @@ test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { test utf-1.7 {Tcl_UniCharToUtf: 4 byte sequences} -constraints testbytestring -body { expr {"\U014e4e" eq [testbytestring "\xf0\x94\xb9\x8e"]} } -result 1 +test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, upper surrogate} testbytestring { + expr {"\ud842" eq [testbytestring "\xed\xa1\x82"]} +} 1 +test utf-1.9 {Tcl_UniCharToUtf: 3 byte sequence, lower surrogate} testbytestring { + expr {"\udc42" eq [testbytestring "\xed\xb1\x82"]} +} 1 +test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, upper surrogate} testbytestring { + expr {[format %c 0xd842] eq [testbytestring "\xed\xa1\x82"]} +} 1 +test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, lower surrogate} testbytestring { + expr {[format %c 0xdc42] eq [testbytestring "\xed\xb1\x82"]} +} 1 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" @@ -146,6 +158,12 @@ test utf-8.3 {Tcl_UniCharAtIndex: index > 0} { test utf-8.4 {Tcl_UniCharAtIndex: index > 0} { string index \u4e4e\u25a\xff\u543 2 } "\uff" +test utf-8.5 {Tcl_UniCharAtIndex: upper surrogate} { + string index \ud842 0 +} "\ud842" +test utf-8.5 {Tcl_UniCharAtIndex: lower surrogate} { + string index \udc42 0 +} "\udc42" test utf-9.1 {Tcl_UtfAtIndex: index = 0} { string range abcd 0 2 @@ -251,6 +269,9 @@ test utf-11.4 {Tcl_UtfToUpper} { test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} { string toupper \u10d0\u1c90 } \u1c90\u1c90 +test utf-11.6 {Tcl_UtfToUpper low/high surrogate)} { + string toupper \udc24\ud824 +} \udc24\ud824 test utf-12.1 {Tcl_UtfToLower} { string tolower {} @@ -267,6 +288,9 @@ test utf-12.4 {Tcl_UtfToLower} { test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} { string tolower \u10d0\u1c90 } \u10d0\u10d0 +test utf-12.6 {Tcl_UtfToUpper low/high surrogate)} { + string tolower \udc24\ud824 +} \udc24\ud824 test utf-13.1 {Tcl_UtfToTitle} { string totitle {} @@ -286,6 +310,9 @@ test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { string totitle \u1c90\u10d0 } \u1c90\u10d0 +test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} { + string totitle \udc24\ud824 +} \udc24\ud824 test utf-14.1 {Tcl_UtfNcasecmp} { string compare -nocase a b diff --git a/tools/valgrind_suppress b/tools/valgrind_suppress new file mode 100644 index 0000000..fb7f173 --- /dev/null +++ b/tools/valgrind_suppress @@ -0,0 +1,126 @@ +{ + TclCreatesocketAddress/getaddrinfo/calloc + Memcheck:Leak + match-leak-kinds: reachable + fun:calloc + ... + fun:getaddrinfo + fun:TclCreateSocketAddress +} + +{ + TclCreatesocketAddress/getaddrinfo/malloc + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:getaddrinfo + fun:TclCreateSocketAddress +} + +{ + TclpDlopen/load + Memcheck:Leak + match-leak-kinds: reachable + fun:calloc + ... + fun:dlopen + fun:TclpDlopen +} + +{ + TclpDlopen/load + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:dlopen + fun:TclpDlopen +} + +{ + TclpGetGrNam/__nss_next2/calloc + Memcheck:Leak + match-leak-kinds: reachable + fun:calloc + ... + fun:__nss_next2 + ... + fun:TclpGetGrNam +} + +{ + TclpGetGrNam/__nss_next2/malloc + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:__nss_next2 + ... + fun:TclpGetGrNam +} + +{ + TclpGetGrNam/__nss_systemd_getfrname_r/malloc + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:_nss_systemd_getgrnam_r + ... + fun:TclpGetGrNam +} + +{ + TclpGetPwNam/getpwname_r/__nss_next2/calloc + Memcheck:Leak + match-leak-kinds: reachable + fun:calloc + ... + fun:__nss_next2 + ... + fun:TclpGetPwNam +} + +{ + TclpGetPwNam/getpwname_r/__nss_next2/malloc + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:__nss_next2 + ... + fun:TclpGetPwNam +} + +{ + TclpGetPwNam/getpwname_r/_nss_systemd_getpwnam_r/malloc + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:_nss_systemd_getpwnam_r + ... + fun:TclpGetPwNam +} + +{ + TclpThreadExit/pthread_exit/calloc + Memcheck:Leak + match-leak-kinds: reachable + fun:calloc + ... + fun:pthread_exit + fun:TclpThreadExit +} + +{ + TclpThreadExit/pthread_exit/malloc + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:pthread_exit + fun:TclpThreadExit +} + diff --git a/unix/Makefile.in b/unix/Makefile.in index 41d7e7f..a932eb1 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -262,7 +262,9 @@ GDB = gdb TRACE = strace TRACE_OPTS = VALGRIND = valgrind -VALGRINDARGS = --tool=memcheck --num-callers=8 --leak-resolution=high --leak-check=yes --show-reachable=yes -v +VALGRINDARGS = --tool=memcheck --num-callers=24 \ + --leak-resolution=high --leak-check=yes --show-reachable=yes -v \ + --suppressions=$(TOOL_DIR)/valgrind_suppress #-------------------------------------------------------------------------- # The information below should be usable as is. The configure script won't diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 45abc01..7bef7c0 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1124,7 +1124,7 @@ TcpGetHandleProc( * TcpAsyncCallback -- * * Called by the event handler that TcpConnect sets up internally for - * [socket -async] to get notified when the asyncronous connection + * [socket -async] to get notified when the asynchronous connection * attempt has succeeded or failed. * * ---------------------------------------------------------------------- @@ -1157,7 +1157,7 @@ TcpAsyncCallback( * * Remarks: * A single host name may resolve to more than one IP address, e.g. for - * an IPv4/IPv6 dual stack host. For handling asyncronously connecting + * an IPv4/IPv6 dual stack host. For handling asynchronously connecting * sockets in the background for such hosts, this function can act as a * coroutine. On the first call, it sets up the control variables for the * two nested loops over the local and remote addresses. Once the first @@ -1165,7 +1165,7 @@ TcpAsyncCallback( * event handler for that socket, and returns. When the callback occurs, * control is transferred to the "reenter" label, right after the initial * return and the loops resume as if they had never been interrupted. - * For syncronously connecting sockets, the loops work the usual way. + * For synchronously connecting sockets, the loops work the usual way. * * ---------------------------------------------------------------------- */ diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 43f0cb2..a510719 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -305,7 +305,7 @@ TclpInitUnlock(void) * in finalization; it is hidden during creation of the objects. * * This lock must be different than the initLock because the initLock is - * held during creation of syncronization objects. + * held during creation of synchronization objects. * * Results: * None. @@ -396,7 +396,7 @@ Tcl_GetAllocMutex(void) * None. * * Side effects: - * May block the current thread. The mutex is aquired when this returns. + * May block the current thread. The mutex is acquired when this returns. * Will allocate memory for a pthread_mutex_t and initialize this the * first time this Tcl_Mutex is used. * @@ -500,7 +500,7 @@ TclpFinalizeMutex( * None. * * Side effects: - * May block the current thread. The mutex is aquired when this returns. + * May block the current thread. The mutex is acquired when this returns. * Will allocate memory for a pthread_mutex_t and initialize this the * first time this Tcl_Mutex is used. * diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 92643cf..f8b67a3 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -1360,11 +1360,7 @@ TclWinOpenConsoleChannel( Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); -#ifdef UNICODE Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode"); -#else - Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding); -#endif return infoPtr->channel; } diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 8b0be8d..59e553b 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -18,15 +18,6 @@ #include <dde.h> #include <ddeml.h> -#ifndef UNICODE -# undef CP_WINUNICODE -# define CP_WINUNICODE CP_WINANSI -# undef Tcl_WinTCharToUtf -# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) -# undef Tcl_WinUtfToTChar -# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) -#endif - #if !defined(NDEBUG) /* test POKE server Implemented for debug mode only */ # undef CBF_FAIL_POKES @@ -1432,11 +1423,7 @@ DdeObjCmd( Initialize(); if (firstArg != 1) { -#ifdef UNICODE serviceName = Tcl_GetUnicodeFromObj(objv[firstArg], &length); -#else - serviceName = Tcl_GetStringFromObj(objv[firstArg], &length); -#endif } else { length = 0; } @@ -1449,11 +1436,7 @@ DdeObjCmd( } if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { -#ifdef UNICODE topicName = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 1], &length); -#else - topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length); -#endif if (length == 0) { topicName = NULL; } else { @@ -1467,11 +1450,7 @@ DdeObjCmd( serviceName = DdeSetServerName(interp, serviceName, flags, handlerPtr); if (serviceName != NULL) { -#ifdef UNICODE Tcl_SetObjResult(interp, Tcl_NewUnicodeObj((Tcl_UniChar *) serviceName, -1)); -#else - Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1)); -#endif } else { Tcl_ResetResult(interp); } @@ -1530,13 +1509,8 @@ DdeObjCmd( break; } case DDE_REQUEST: { -#ifdef UNICODE const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], &length); -#else - const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], - &length); -#endif if (length == 0) { Tcl_SetObjResult(interp, @@ -1590,13 +1564,8 @@ DdeObjCmd( break; } case DDE_POKE: { -#ifdef UNICODE const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], &length); -#else - const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], - &length); -#endif BYTE *dataString; if (length == 0) { diff --git a/win/tclWinError.c b/win/tclWinError.c index ac98cd4..7897ff7 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -391,7 +391,7 @@ tclWinDebugPanic( if (IsDebuggerPresent()) { WCHAR msgString[TCL_MAX_WARN_LEN]; - char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX]; + char buf[TCL_MAX_WARN_LEN * 3]; vsnprintf(buf, sizeof(buf), format, argList); msgString[TCL_MAX_WARN_LEN-1] = L'\0'; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 404f81a..9fb8db2 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -567,7 +567,6 @@ WinReadLinkDirectory( */ offset = 0; -#ifdef UNICODE if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == L'\\') { /* * Check whether this is a mounted volume. @@ -629,7 +628,6 @@ WinReadLinkDirectory( offset = 4; } } -#endif /* UNICODE */ Tcl_WinTCharToUtf((const TCHAR *) reparseBuffer->MountPointReparseBuffer.PathBuffer, @@ -800,7 +798,7 @@ tclWinDebugPanic( { #define TCL_MAX_WARN_LEN 1024 va_list argList; - char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX]; + char buf[TCL_MAX_WARN_LEN * 3]; WCHAR msgString[TCL_MAX_WARN_LEN]; va_start(argList, format); @@ -849,19 +847,9 @@ TclpFindExecutable( * ignore. */ { WCHAR wName[MAX_PATH]; - char name[MAX_PATH * TCL_UTF_MAX]; + char name[MAX_PATH * 3]; -#ifdef UNICODE GetModuleFileNameW(NULL, wName, MAX_PATH); -#else - GetModuleFileNameA(NULL, name, sizeof(name)); - - /* - * Convert to WCHAR to get out of ANSI codepage - */ - - MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH); -#endif WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); TclWinNoBackslash(name); TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL); @@ -1626,7 +1614,6 @@ NativeAccess( * what permissions the OS has set for a file. */ -#ifdef UNICODE { SECURITY_DESCRIPTOR *sdPtr = NULL; unsigned long size; @@ -1789,7 +1776,6 @@ NativeAccess( } } -#endif /* !UNICODE */ return 0; } diff --git a/win/tclWinInit.c b/win/tclWinInit.c index e0fc73d..a617f60 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -107,7 +107,6 @@ static ProcessGlobalValue sourceLibraryDir = {0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL}; static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib); -static int ToUtf(const WCHAR *wSrc, char *dst); /* *--------------------------------------------------------------------------- @@ -257,7 +256,7 @@ AppendEnvironment( { int pathc; WCHAR wBuf[MAX_PATH]; - char buf[MAX_PATH * TCL_UTF_MAX]; + char buf[MAX_PATH * 3]; Tcl_Obj *objPtr; Tcl_DString ds; const char **pathv; @@ -286,12 +285,8 @@ AppendEnvironment( * this is a unicode string. */ - if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) { - buf[0] = '\0'; - GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH); - } else { - ToUtf(wBuf, buf); - } + GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH); + WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL); if (buf[0] != '\0') { objPtr = Tcl_NewStringObj(buf, -1); @@ -350,14 +345,11 @@ InitializeDefaultLibraryDir( { HMODULE hModule = TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; - char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; + char name[(MAX_PATH + LIBRARY_SIZE) * 3]; char *end, *p; - if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { - GetModuleFileNameA(hModule, name, MAX_PATH); - } else { - ToUtf(wName, name); - } + GetModuleFileNameW(hModule, wName, MAX_PATH); + WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, MAX_PATH * 3, NULL, NULL); end = strrchr(name, '\\'); *end = '\0'; @@ -401,14 +393,11 @@ InitializeSourceLibraryDir( { HMODULE hModule = TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; - char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; + char name[(MAX_PATH + LIBRARY_SIZE) * 3]; char *end, *p; - if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { - GetModuleFileNameA(hModule, name, MAX_PATH); - } else { - ToUtf(wName, name); - } + GetModuleFileNameW(hModule, wName, MAX_PATH); + WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, MAX_PATH * 3, NULL, NULL); end = strrchr(name, '\\'); *end = '\0'; @@ -429,38 +418,6 @@ InitializeSourceLibraryDir( /* *--------------------------------------------------------------------------- * - * ToUtf -- - * - * Convert a char string to a UTF string. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -static int -ToUtf( - const WCHAR *wSrc, - char *dst) -{ - char *start; - - start = dst; - while (*wSrc != '\0') { - dst += Tcl_UniCharToUtf(*wSrc, dst); - wSrc++; - } - *dst = '\0'; - return (int) (dst - start); -} - -/* - *--------------------------------------------------------------------------- - * * TclpSetInitialEncodings -- * * Based on the locale, determine the encoding of the operating system @@ -646,7 +603,7 @@ TclpSetVariables( * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this routine is - * case sensitive, on Windows this matches mioxed case. + * case sensitive, on Windows this matches mixed case. * * Results: * The return value is the index in environ of an entry with the name diff --git a/win/tclWinPanic.c b/win/tclWinPanic.c index 3b9933c..52fa97e 100644 --- a/win/tclWinPanic.c +++ b/win/tclWinPanic.c @@ -35,7 +35,7 @@ Tcl_ConsolePanic( #define TCL_MAX_WARN_LEN 26000 va_list argList; WCHAR msgString[TCL_MAX_WARN_LEN]; - char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX]; + char buf[TCL_MAX_WARN_LEN * 3]; HANDLE handle = GetStdHandle(STD_ERROR_HANDLE); DWORD dummy; diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index a357412..2155a8d 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -941,7 +941,7 @@ TclpCreateProcess( PROCESS_INFORMATION procInfo; SECURITY_ATTRIBUTES secAtts; HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; - char execPath[MAX_PATH * TCL_UTF_MAX]; + char execPath[MAX_PATH * 3]; WinFile *filePtr; PipeInit(); diff --git a/win/tclWinReg.c b/win/tclWinReg.c index de48b9b..95ab499 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -22,13 +22,6 @@ #endif #include <stdlib.h> -#ifndef UNICODE -# undef Tcl_WinTCharToUtf -# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) -# undef Tcl_WinUtfToTChar -# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) -#endif /* !UNICODE */ - /* * Ensure that we can say which registry is being accessed. */ diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 7be194e..ac3ddbd 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -738,8 +738,8 @@ WaitForConnect( } /* - * A non blocking socket waiting for an asyncronous connect returns - * directly the error EWOULDBLOCK. + * A non blocking socket waiting for an asynchronous connect + * returns directly the error EWOULDBLOCK */ if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { @@ -1690,9 +1690,9 @@ TcpGetHandleProc( * * This might be called in 3 circumstances: * - By a regular socket command - * - By the event handler to continue an asynchroneous connect + * - By the event handler to continue an asynchronously connect * - By a blocking socket function (gets/puts) to terminate the - * connect synchroneously + * connect synchronously * * Results: * TCL_OK, if the socket was successfully connected or an asynchronous @@ -1704,7 +1704,7 @@ TcpGetHandleProc( * * Remarks: * A single host name may resolve to more than one IP address, e.g. for - * an IPv4/IPv6 dual stack host. For handling asyncronously connecting + * an IPv4/IPv6 dual stack host. For handling asynchronously connecting * sockets in the background for such hosts, this function can act as a * coroutine. On the first call, it sets up the control variables for the * two nested loops over the local and remote addresses. Once the first @@ -1712,7 +1712,7 @@ TcpGetHandleProc( * event handler for that socket, and returns. When the callback occurs, * control is transferred to the "reenter" label, right after the initial * return and the loops resume as if they had never been interrupted. - * For syncronously connecting sockets, the loops work the usual way. + * For synchronously connecting sockets, the loops work the usual way. * *---------------------------------------------------------------------- */ @@ -1816,7 +1816,7 @@ TcpConnect( } /* - * For asyncroneous connect set the socket in nonblocking mode + * For asynchroneous connect set the socket in nonblocking mode * and activate connect notification */ @@ -1930,8 +1930,8 @@ TcpConnect( } /* - * Clear the tsd socket list pointer if we did not wait for the - * FD_CONNECT asynchronously. + * Clear the tsd socket list pointer if we did not wait for + * the FD_CONNECT asynchroneously */ tsdPtr->pendingTcpState = NULL; @@ -2014,7 +2014,7 @@ TcpConnect( } /* - * Error message on syncroneous connect + * Error message on synchroneous connect */ if (interp != NULL) { diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 45de4de..4d6a28f 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -241,7 +241,7 @@ TclpThreadCreate( /* * The only purpose of this is to decrement the reference count so the - * OS resources will be reaquired when the thread closes. + * OS resources will be reacquired when the thread closes. */ CloseHandle(tHandle); @@ -399,7 +399,7 @@ TclpInitUnlock(void) * mutexes, condition variables, and thread local storage keys. * * This lock must be different than the initLock because the initLock is - * held during creation of syncronization objects. + * held during creation of synchronization objects. * * Results: * None. @@ -549,7 +549,7 @@ static void FinalizeConditionEvent(ClientData data); * None. * * Side effects: - * May block the current thread. The mutex is aquired when this returns. + * May block the current thread. The mutex is acquired when this returns. * *---------------------------------------------------------------------- */ @@ -649,7 +649,7 @@ TclpFinalizeMutex( * None. * * Side effects: - * May block the current thread. The mutex is aquired when this returns. + * May block the current thread. The mutex is acquired when this returns. * Will allocate memory for a HANDLE and initialize this the first time * this Tcl_Condition is used. * |