From bfca9ca68773d9a3dbc609448891363b52107ef9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 May 2024 10:18:23 +0000 Subject: Possible fix for [3fc3287497]: TclGetProcessGlobalValue encodes information twice on Windows --- generic/tclUtil.c | 16 ++++++++++++---- win/tclWinSock.c | 25 +++++++++++-------------- 2 files changed, 23 insertions(+), 18 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 9cf594f..0c2f305 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4212,6 +4212,7 @@ TclSetProcessGlobalValue( Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; int dummy; + Tcl_DString ds; Tcl_MutexLock(&pgvPtr->mutex); @@ -4226,8 +4227,11 @@ TclSetProcessGlobalValue( Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } bytes = TclGetStringFromObj(newValue, &pgvPtr->numBytes); + Tcl_UtfToExternalDString(encoding, bytes, pgvPtr->numBytes, &ds); + pgvPtr->numBytes = Tcl_DStringLength(&ds); pgvPtr->value = (char *)ckalloc(pgvPtr->numBytes + 1); - memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1); + memcpy(pgvPtr->value, Tcl_DStringValue(&ds), pgvPtr->numBytes + 1); + Tcl_DStringFree(&ds); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); } @@ -4269,6 +4273,7 @@ TclGetProcessGlobalValue( Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; int epoch = pgvPtr->epoch; + Tcl_DString newValue; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); @@ -4280,7 +4285,7 @@ TclGetProcessGlobalValue( * system encoding. */ - Tcl_DString native, newValue; + Tcl_DString native; Tcl_MutexLock(&pgvPtr->mutex); epoch = ++pgvPtr->epoch; @@ -4330,10 +4335,13 @@ TclGetProcessGlobalValue( } /* - * Store a copy of the shared value in our epoch-indexed cache. + * Store a copy of the shared value (but then in utf-8) + * in our epoch-indexed cache. */ - value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); + Tcl_ExternalToUtfDString(NULL, pgvPtr->value, pgvPtr->numBytes, &newValue); + value = Tcl_NewStringObj(Tcl_DStringValue(&newValue), Tcl_DStringLength(&newValue)); + Tcl_DStringFree(&newValue); hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); diff --git a/win/tclWinSock.c b/win/tclWinSock.c index df81c46..e077186 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -367,11 +367,14 @@ InitializeHostName( if (GetComputerNameExW(ComputerNamePhysicalDnsFullyQualified, wbuf, &length) != 0) { /* - * Convert string from native to UTF then change to lowercase. + * Convert string from WCHAR to utf-8, then change to lowercase, + * then to system encoding. */ + Tcl_DString inDs; - Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *)wbuf, -1, &ds)); - + Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *)wbuf, -1, &inDs)); + Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&inDs), -1, &ds); + Tcl_DStringFree(&inDs); } else { Tcl_DStringInit(&ds); if (TclpHasSockets(NULL) == TCL_OK) { @@ -380,20 +383,14 @@ InitializeHostName( * documents gethostname() as being always adequate. */ - Tcl_DString inDs; - - Tcl_DStringInit(&inDs); - Tcl_DStringSetLength(&inDs, 256); - if (gethostname(Tcl_DStringValue(&inDs), - Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), - -1, &ds); - } - Tcl_DStringFree(&inDs); + Tcl_DStringInit(&ds); + Tcl_DStringSetLength(&ds, 256); + gethostname(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); + Tcl_DStringSetLength(&ds, strlen(Tcl_DStringValue(&ds))); } } - *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); + *encodingPtr = Tcl_GetEncoding(NULL, NULL); *lengthPtr = Tcl_DStringLength(&ds); *valuePtr = (char *)ckalloc(*lengthPtr + 1); memcpy(*valuePtr, Tcl_DStringValue(&ds), *lengthPtr + 1); -- cgit v0.12 From d707e1395bbbeba874f52e6aa30c013b12e88eaa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 May 2024 11:52:04 +0000 Subject: Fix 2 warnings on Win32 (Thanks, Harald). Some more code cleanup, backported from 8.7) --- generic/tclIO.c | 16 +++---- generic/tclStringObj.c | 125 ++++++++++++++++++++++++------------------------- 2 files changed, 67 insertions(+), 74 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 165a07e..55f3642 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -477,7 +477,7 @@ ChanSeek( if ((offset >= LONG_MIN) && (offset <= LONG_MAX)) { return Tcl_ChannelSeekProc(chanPtr->typePtr)(chanPtr->instanceData, - offset, mode, errnoPtr); + (long)offset, mode, errnoPtr); } *errnoPtr = EOVERFLOW; return -1; @@ -6143,7 +6143,7 @@ ReadChars( if (dstLimit <= 0) { dstLimit = INT_MAX; /* avoid overflow */ } - (void) TclGetStringFromObj(objPtr, &numBytes); + (void)TclGetStringFromObj(objPtr, &numBytes); TclAppendUtfToUtf(objPtr, NULL, dstLimit); if (toRead == srcLen) { unsigned int size; @@ -8140,8 +8140,7 @@ Tcl_SetChannelOption( } else if (HaveOpt(2, "-eofchar")) { if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; - } - if (argc == 0) { + } else if (argc == 0) { statePtr->inEofChar = 0; statePtr->outEofChar = 0; } else if (argc == 1 || argc == 2) { @@ -9832,8 +9831,8 @@ CopyData( } /* - * Make the callback or return the number of bytes transferred. The - * local total is used because StopCopy frees csPtr. + * Make the callback or return the number of bytes transferred. The local + * total is used because StopCopy frees csPtr. */ total = csPtr->total; @@ -10662,8 +10661,7 @@ Tcl_ChannelVersion( * Side effects: * None. * - *---------------------------------------------------------------------- - */ + *---------------------------------------------------------------------- */ Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc( @@ -11063,7 +11061,7 @@ Tcl_SetChannelError( Tcl_Channel chan, /* Channel to store the data into. */ Tcl_Obj *msg) /* Error message to store. */ { - ChannelState *statePtr = ((Channel *) chan)->state; + ChannelState *statePtr = ((Channel *)chan)->state; if (statePtr->chanMsg != NULL) { TclDecrRefCount(statePtr->chanMsg); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index dcff811..55315f2 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1,34 +1,32 @@ /* * tclStringObj.c -- * - * This file contains functions that implement string operations on Tcl - * objects. Some string operations work with UTF strings and others - * require Unicode format. Functions that require knowledge of the width - * of each character, such as indexing, operate on Unicode data. - * - * A Unicode string is an internationalized string. Conceptually, a - * Unicode string is an array of 16-bit quantities organized as a - * sequence of properly formed UTF-8 characters. There is a one-to-one - * map between Unicode and UTF characters. Because Unicode characters - * have a fixed width, operations such as indexing operate on Unicode - * data. The String object is optimized for the case where each UTF char + * This file contains functions that implement string operations on Tcl + * objects. Some string operations work with UTF-8 encoding forms. + * Functions that require knowledge of the width of each character, + * such as indexing, operate on fixed width encoding forms such as UTF-16. + * + * Conceptually, a string is a sequence of Unicode code points. Internally + * it may be stored in an encoding form such as a modified version of + * UTF-8 or UTF-16. + * + * The String object is optimized for the case where each UTF char * in a string is only one byte. In this case, we store the value of - * numChars, but we don't store the Unicode data (unless Tcl_GetUnicode - * is explicitly called). + * numChars, but we don't store the fixed form encoding (unless + * Tcl_GetUnicode is explicitly called). * - * The String object type stores one or both formats. The default - * behavior is to store UTF. Once Unicode is calculated by a function, it - * is stored in the internal rep for future access (without an additional - * O(n) cost). + * The String object type stores one or both formats. The default + * behavior is to store UTF-8. Once UTF-16/UTF32 is calculated, it is + * stored in the internal rep for future access (without an additional + * O(n) cost). * * To allow many appends to be done to an object without constantly - * reallocating the space for the string or Unicode representation, we - * allocate double the space for the string or Unicode and use the + * reallocating space, we allocate double the space and use the * internal representation to keep track of how much space is used vs. * allocated. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 1999 by Scriptics Corporation. + * Copyright (c) 1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -121,8 +119,8 @@ const Tcl_ObjType tclStringType = { static void GrowStringBuffer( Tcl_Obj *objPtr, - int needed, - int flag) + int needed, /* Not including terminating nul */ + int flag) /* If 0, try to overallocate */ { /* * Preconditions: @@ -238,7 +236,7 @@ GrowUnicodeBuffer( * * Side effects: * The new object's internal string representation will be set to a copy - * of the length bytes starting at "bytes". If "length" is negative, use + * of the length bytes starting at "bytes". If "length" is -1, use * bytes up to the first NUL byte; i.e., assume "bytes" points to a * C-style NUL-terminated string. The object's type is set to NULL. An * extra NUL is added to the end of the new object's byte array. @@ -252,9 +250,9 @@ Tcl_Obj * Tcl_NewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ - int length) /* The number of bytes to copy from "bytes" + int length) /* The number of bytes to copy from "bytes" * when initializing the new object. If - * negative, use bytes up to the first NUL + * -1, use bytes up to the first NUL * byte. */ { return Tcl_DbNewStringObj(bytes, length, "unknown", 0); @@ -265,7 +263,7 @@ Tcl_NewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ int length) /* The number of bytes to copy from "bytes" - * when initializing the new object. If negative, + * when initializing the new object. If -1, * use bytes up to the first NUL byte. */ { Tcl_Obj *objPtr; @@ -299,7 +297,7 @@ Tcl_NewStringObj( * * Side effects: * The new object's internal string representation will be set to a copy - * of the length bytes starting at "bytes". If "length" is negative, use + * of the length bytes starting at "bytes". If "length" is -1, use * bytes up to the first NUL byte; i.e., assume "bytes" points to a * C-style NUL-terminated string. The object's type is set to NULL. An * extra NUL is added to the end of the new object's byte array. @@ -313,7 +311,7 @@ Tcl_DbNewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ int length, /* The number of bytes to copy from "bytes" - * when initializing the new object. If negative, + * when initializing the new object. If -1, * use bytes up to the first NUL byte. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -334,10 +332,9 @@ Tcl_Obj * Tcl_DbNewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ - int length, /* The number of bytes to copy from "bytes" - * when initializing the new object. If - * negative, use bytes up to the first NUL - * byte. */ + int length, /* The number of bytes to copy from "bytes" + * when initializing the new object. If -1, + * use bytes up to the first NUL byte. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for @@ -415,7 +412,7 @@ Tcl_GetCharLength( } /* - * Optimize the case where we're really dealing with a ByteArray object; + * Optimize the case where we're really dealing with a bytearray object; * we don't need to convert to a string to perform the get-length operation. * * NOTE that we do not need the ByteArray to be "pure". A ByteArray value @@ -468,7 +465,7 @@ Tcl_GetCharLength( *---------------------------------------------------------------------- */ int -TclCheckEmptyString ( +TclCheckEmptyString( Tcl_Obj *objPtr) { int length = -1; @@ -723,9 +720,9 @@ Tcl_GetUnicodeFromObj( * * Create a Tcl Object that contains the chars between first and last of * the object indicated by "objPtr". If the object is not already a - * String object, convert it to one. If first is negative, the + * String object, convert it to one. If first is -1, the * returned string start at the beginning of objPtr. If last is - * negative, the returned string ends at the end of objPtr. + * -1, the returned string ends at the end of objPtr. * * Results: * Returns a new Tcl Object of the String type. @@ -751,7 +748,7 @@ Tcl_GetRange( } /* - * Optimize the case where we're really dealing with a ByteArray object + * Optimize the case where we're really dealing with a bytearray object * we don't need to convert to a string to perform the substring operation. */ @@ -805,7 +802,6 @@ Tcl_GetRange( FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } - if (last < 0 || last >= stringPtr->numChars) { last = stringPtr->numChars - 1; } @@ -841,7 +837,7 @@ Tcl_GetRange( * * Side effects: * The object's string representation will be set to a copy of the - * "length" bytes starting at "bytes". If "length" is negative, use bytes + * "length" bytes starting at "bytes". If "length" is -1, use bytes * up to the first NUL byte; i.e., assume "bytes" points to a C-style * NUL-terminated string. The object's old string and internal * representations are freed and the object's type is set NULL. @@ -854,8 +850,8 @@ Tcl_SetStringObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ const char *bytes, /* Points to the first of the length bytes * used to initialize the object. */ - int length) /* The number of bytes to copy from "bytes" - * when initializing the object. If negative, + int length) /* The number of bytes to copy from "bytes" + * when initializing the object. If -1, * use bytes up to the first NUL byte.*/ { if (Tcl_IsShared(objPtr)) { @@ -891,12 +887,11 @@ Tcl_SetStringObj( * None. * * Side effects: - * If the size of objPtr's string representation is greater than length, - * then it is reduced to length and a new terminating null byte is stored - * in the strength. If the length of the string representation is greater - * than length, the storage space is reallocated to the given length; a - * null byte is stored at the end, but other bytes past the end of the - * original string representation are undefined. + * If the size of objPtr's string representation is greater than length, a + * new terminating null byte is stored in objPtr->bytes at length, and + * bytes at positions past length have no meaning. If the length of the + * string representation is greater than length, the storage space is + * reallocated to length+1. * * The object's internal representation is changed to &tclStringType. * @@ -907,7 +902,7 @@ void Tcl_SetObjLength( Tcl_Obj *objPtr, /* Pointer to object. This object must not * currently be shared. */ - int length) /* Number of bytes desired for string + int length) /* Number of bytes desired for string * representation of object, not including * terminating null byte. */ { @@ -1007,7 +1002,7 @@ int Tcl_AttemptSetObjLength( Tcl_Obj *objPtr, /* Pointer to object. This object must not * currently be shared. */ - int length) /* Number of bytes desired for string + int length) /* Number of bytes desired for string * representation of object, not including * terminating null byte. */ { @@ -1195,10 +1190,10 @@ Tcl_AppendLimitedToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const char *bytes, /* Points to the bytes to append to the * object. */ - int length, /* The number of bytes available to be - * appended from "bytes". If < 0, then all - * bytes up to a NUL byte are available. */ - int limit, /* The maximum number of bytes to append to + int length, /* The number of bytes available to be + * appended from "bytes". If -1, then + * all bytes up to a NUL byte are available. */ + int limit, /* The maximum number of bytes to append to * the object. */ const char *ellipsis) /* Ellipsis marker string, appended to the * object to indicate not all available bytes @@ -1507,7 +1502,7 @@ static void AppendUnicodeToUnicodeRep( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* String to append. */ - int appendNumChars) /* Number of chars of "unicode" to append. */ + int appendNumChars) /* Number of chars of "unicode" to append. */ { String *stringPtr; int numChars; @@ -1596,7 +1591,7 @@ static void AppendUnicodeToUtfRep( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* String to convert to UTF. */ - int numChars) /* Number of chars of unicode to convert. */ + int numChars) /* Number of chars of Unicode to convert. */ { String *stringPtr = GET_STRING(objPtr); @@ -1876,7 +1871,7 @@ Tcl_AppendFormatToObj( if (Tcl_IsShared(appendObj)) { Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj"); } - TclGetStringFromObj(appendObj, &originalLength); + (void)TclGetStringFromObj(appendObj, &originalLength); limit = INT_MAX - originalLength; /* @@ -2347,7 +2342,7 @@ Tcl_AppendFormatToObj( uw /= base; } #endif - } else if (useBig && big.used) { + } else if (useBig && !mp_iszero(&big)) { int leftover = (big.used * MP_DIGIT_BIT) % numBits; mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover); @@ -2380,13 +2375,13 @@ Tcl_AppendFormatToObj( numDigits = 1; } TclNewObj(pure); - Tcl_SetObjLength(pure, numDigits); + Tcl_SetObjLength(pure, (int)numDigits); bytes = TclGetString(pure); toAppend = length = numDigits; while (numDigits--) { int digitOffset; - if (useBig && big.used) { + if (useBig && !mp_iszero(&big)) { if (index < big.used && (size_t) shift < CHAR_BIT*sizeof(Tcl_WideUInt) - MP_DIGIT_BIT) { bits |= ((Tcl_WideUInt) big.dp[index++]) << shift; @@ -2535,7 +2530,7 @@ Tcl_AppendFormatToObj( } } - TclGetStringFromObj(segment, &segmentNumBytes); + (void)TclGetStringFromObj(segment, &segmentNumBytes); if (segmentNumBytes > limit) { if (allocSegment) { Tcl_DecrRefCount(segment); @@ -2878,9 +2873,9 @@ TclGetStringStorage( * Implements the [string reverse] operation. * * Results: - * An unshared Tcl value which is the [string reverse] of the argument - * supplied. When sharing rules permit, the returned value might be the - * argument with modifications done in place. + * A Tcl value which is the [string reverse] of the argument supplied. + * When sharing rules permit and the caller requests, the returned value + * might be the argument with modifications done in place. * * Side effects: * May allocate a new Tcl_Obj. @@ -2892,7 +2887,7 @@ static void ReverseBytes( unsigned char *to, /* Copy bytes into here... */ unsigned char *from, /* ...from here... */ - int count) /* Until this many are copied, */ + int count) /* Until this many are copied, */ /* reversing as you go. */ { unsigned char *src = from + count; @@ -3109,7 +3104,7 @@ ExtendUnicodeRepWithString( } else { numAppendChars = 0; } - for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { + for (dst = stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { bytes += TclUtfToUniChar(bytes, &unichar); *dst = unichar; } -- cgit v0.12 From 102df76131e3c743231e9e29605725011eabf2a7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 May 2024 07:03:46 +0000 Subject: Code optimization: no need for encoding = Tcl_GetEncoding(NULL, NULL). Use TclDStringToObj where possible --- generic/tclUtil.c | 3 +-- unix/tclUnixFile.c | 50 ++++++++++++++++++++++++-------------------------- 2 files changed, 25 insertions(+), 28 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 0c2f305..dab5c3a 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4340,8 +4340,7 @@ TclGetProcessGlobalValue( */ Tcl_ExternalToUtfDString(NULL, pgvPtr->value, pgvPtr->numBytes, &newValue); - value = Tcl_NewStringObj(Tcl_DStringValue(&newValue), Tcl_DStringLength(&newValue)); - Tcl_DStringFree(&newValue); + value = TclDStringToObj(&newValue); hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 1d1d729..5f9f9b3 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -54,10 +54,10 @@ TclpFindExecutable( TclSetObjNameOfExecutable( Tcl_NewStringObj(name, length), NULL); #else - Tcl_Encoding encoding; const char *name, *p; Tcl_StatBuf statBuf; Tcl_DString buffer, nameString, cwd, utfName; + Tcl_Obj *obj; if (argv0 == NULL) { return; @@ -125,15 +125,16 @@ TclpFindExecutable( && S_ISREG(statBuf.st_mode)) { goto gotName; } - if (*p == '\0') { + if (p[0] == '\0') { break; - } else if (*(p+1) == 0) { + } else if (p[1] == 0) { p = "./"; } else { p++; } } - TclSetObjNameOfExecutable(Tcl_NewObj(), NULL); + TclNewObj(obj); + TclSetObjNameOfExecutable(obj, NULL); goto done; /* @@ -147,16 +148,16 @@ TclpFindExecutable( if (name[0] == '/') #endif { - encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, name, -1, &utfName); + Tcl_ExternalToUtfDString(NULL, name, -1, &utfName); TclSetObjNameOfExecutable( - Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); + Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), NULL); Tcl_DStringFree(&utfName); goto done; } if (TclpGetCwd(NULL, &cwd) == NULL) { - TclSetObjNameOfExecutable(Tcl_NewObj(), NULL); + TclNewObj(obj); + TclSetObjNameOfExecutable(obj, NULL); goto done; } @@ -183,11 +184,9 @@ TclpFindExecutable( TclDStringAppendDString(&buffer, &nameString); Tcl_DStringFree(&nameString); - encoding = Tcl_GetEncoding(NULL, NULL); - Tcl_ExternalToUtfDString(encoding, Tcl_DStringValue(&buffer), -1, - &utfName); + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buffer), -1, &utfName); TclSetObjNameOfExecutable( - Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding); + Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), NULL); Tcl_DStringFree(&utfName); done: @@ -269,7 +268,7 @@ TclpMatchInDirectory( Tcl_DString dsOrig; /* utf-8 encoding of dir */ Tcl_DStringInit(&dsOrig); - dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength); + dirName = TclGetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); /* @@ -363,8 +362,7 @@ TclpMatchInDirectory( * and pattern. If so, add the file to the result. */ - utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, - &utfDs); + utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &utfDs); if (Tcl_StringCaseMatch(utfname, pattern, 0)) { int typeOk = 1; @@ -621,7 +619,7 @@ TclpObjAccess( Tcl_Obj *pathPtr, /* Path of file to access */ int mode) /* Permission setting. */ { - const char *path = Tcl_FSGetNativePath(pathPtr); + const char *path = (const char *)Tcl_FSGetNativePath(pathPtr); if (path == NULL) { return -1; @@ -702,9 +700,9 @@ TclpObjLstat( *---------------------------------------------------------------------- */ -ClientData +void * TclpGetNativeCwd( - ClientData clientData) + void *clientData) { char buffer[MAXPATHLEN+1]; @@ -719,7 +717,7 @@ TclpGetNativeCwd( #endif /* USEGETWD */ if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) { - char *newCd = (char*)ckalloc(strlen(buffer) + 1); + char *newCd = (char *)ckalloc(strlen(buffer) + 1); strcpy(newCd, buffer); return newCd; @@ -937,9 +935,9 @@ TclpObjLink( */ if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { - int targetLen; Tcl_DString ds; Tcl_Obj *transPtr; + int length; /* * Now we don't want to link to the absolute, normalized path. @@ -951,8 +949,8 @@ TclpObjLink( if (transPtr == NULL) { return NULL; } - target = Tcl_GetStringFromObj(transPtr, &targetLen); - target = Tcl_UtfToExternalDString(NULL, target, targetLen, &ds); + target = Tcl_GetStringFromObj(transPtr, &length); + target = Tcl_UtfToExternalDString(NULL, target, length, &ds); Tcl_DecrRefCount(transPtr); if (symlink(target, src) != 0) { @@ -1048,7 +1046,7 @@ TclpFilesystemPathType( Tcl_Obj * TclpNativeToNormalized( - ClientData clientData) + void *clientData) { Tcl_DString ds; @@ -1072,7 +1070,7 @@ TclpNativeToNormalized( *--------------------------------------------------------------------------- */ -ClientData +void * TclNativeCreateNativeRep( Tcl_Obj *pathPtr) { @@ -1139,9 +1137,9 @@ TclNativeCreateNativeRep( *--------------------------------------------------------------------------- */ -ClientData +void * TclNativeDupInternalRep( - ClientData clientData) + void *clientData) { char *copy; size_t len; -- cgit v0.12 From 1c5176a55d3ebaf47f1324716990387e82831813 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 24 May 2024 15:31:28 +0000 Subject: Backport test for bug [e589d9bdab] --- tests/socket.test | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/tests/socket.test b/tests/socket.test index 7251bfa..31d41ba 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1079,6 +1079,25 @@ test socket_$af-7.5 {testing socket specific options} -setup { close $s close $s1 } -result [list $localhost 1 3] +test socket_$af-7.6 {testing socket specific options - bug e589d9bdab} -setup { + set timer [after 10000 "set x timed_out"] + set l "" +} -constraints [list socket supported_$af unixOrWin] -body { + set s [socket -server accept 0] + proc accept {s a p} { + global x + set x [fconfigure $s -sockname] + close $s + } + set listen [lindex [fconfigure $s -sockname] 2] + set s1 [socket $localhost $listen] + vwait x + lsort [dict keys [fconfigure $s1]] +} -cleanup { + after cancel $timer + close $s + close $s1 +} -result {-blocking -buffering -buffersize -encoding -eofchar -peername -sockname -translation} test socket_$af-8.1 {testing -async flag on sockets} -constraints [list socket supported_$af] -body { # NOTE: This test may fail on some Solaris 2.4 systems. If it does, check -- cgit v0.12 From 0201d4b3ee5ec24ea7bb96ef5acb9d52fc65b9e7 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 24 May 2024 19:36:08 +0000 Subject: Use TclDStringToObj a bit more --- generic/tclPkg.c | 6 +----- unix/tclUnixFCmd.c | 6 ++---- unix/tclUnixFile.c | 8 ++------ win/tclWinFCmd.c | 2 +- 4 files changed, 6 insertions(+), 16 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 5e7f614..7e8db0e 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -414,11 +414,7 @@ PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { AddRequirementsToDString(&command, reqc, reqv); Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - Tcl_NREvalObj(interp, - Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), - TCL_EVAL_GLOBAL - ); - Tcl_DStringFree(&command); + Tcl_NREvalObj(interp, TclDStringToObj(&command), TCL_EVAL_GLOBAL); } return TCL_OK; } else { diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 26429df..3d44124 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -789,8 +789,7 @@ TclpObjCopyDirectory( Tcl_DStringFree(&dstString); if (ret != TCL_OK) { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); - Tcl_DStringFree(&ds); + *errorPtr = TclDStringToObj(&ds); Tcl_IncrRefCount(*errorPtr); } return ret; @@ -843,8 +842,7 @@ TclpObjRemoveDirectory( Tcl_DStringFree(&pathString); if (ret != TCL_OK) { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); - Tcl_DStringFree(&ds); + *errorPtr = TclDStringToObj(&ds); Tcl_IncrRefCount(*errorPtr); } return ret; diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 5f9f9b3..c39e7b6 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -149,9 +149,7 @@ TclpFindExecutable( #endif { Tcl_ExternalToUtfDString(NULL, name, -1, &utfName); - TclSetObjNameOfExecutable( - Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), NULL); - Tcl_DStringFree(&utfName); + TclSetObjNameOfExecutable(TclDStringToObj(&utfName), NULL); goto done; } @@ -185,9 +183,7 @@ TclpFindExecutable( Tcl_DStringFree(&nameString); Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buffer), -1, &utfName); - TclSetObjNameOfExecutable( - Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), NULL); - Tcl_DStringFree(&utfName); + TclSetObjNameOfExecutable(TclDStringToObj(&utfName), NULL); done: Tcl_DStringFree(&buffer); diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 65c6441..0bf21dd 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -925,7 +925,7 @@ TclpObjCopyDirectory( } else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) { *errorPtr = destPathPtr; } else { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + *errorPtr = TclDStringToObj(&ds); } Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); -- cgit v0.12 From d0f4560014d2fd2def1e2860ec52259ef80495f1 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 May 2024 09:13:47 +0000 Subject: Add some more C functions for working with dicts [656fe3c816] --- generic/tclDictObj.c | 114 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 6 +++ 2 files changed, 120 insertions(+) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index de3547e..b44e437 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -1440,6 +1440,120 @@ Tcl_DbNewDictObj( #endif } +/***** START OF FUNCTIONS ACTING AS HELPERS *****/ + +/* + *---------------------------------------------------------------------- + * + * TclDictGet -- + * + * Given a key, get its value from the dictionary (or NULL if key is not + * found in dictionary.) + * + * Results: + * A standard Tcl result. The variable pointed to by valuePtrPtr is + * updated with the value for the key. Note that it is not an error for + * the key to have no mapping in the dictionary. + * + * Side effects: + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one. + * + *---------------------------------------------------------------------- + */ +int +TclDictGet( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + const char *key, /* The key in a C string. */ + Tcl_Obj **valuePtrPtr) /* Where to write the value. */ +{ + Tcl_Obj *keyPtr = Tcl_NewStringObj(key, -1); + int code; + + Tcl_IncrRefCount(keyPtr); + code = Tcl_DictObjGet(interp, dictPtr, keyPtr, valuePtrPtr); + Tcl_DecrRefCount(keyPtr); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclDictPut -- + * + * Add a key,value pair to a dictionary, or update the value for a key if + * that key already has a mapping in the dictionary. + * + * If valuePtr is a zero-count object and is not written into the + * dictionary because of an error, it is freed by this routine. The caller + * does NOT need to do reference count management. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one, and any string representation that it has is + * invalidated. + * + *---------------------------------------------------------------------- + */ +int +TclDictPut( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + const char *key, /* The key in a C string. */ + Tcl_Obj *valuePtr) /* The value to write in. */ +{ + Tcl_Obj *keyPtr = Tcl_NewStringObj(key, -1); + int code; + + Tcl_IncrRefCount(keyPtr); + Tcl_IncrRefCount(valuePtr); + code = Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr); + Tcl_DecrRefCount(keyPtr); + Tcl_DecrRefCount(valuePtr); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclDictPutString -- + * + * Add a key,value pair to a dictionary, or update the value for a key if + * that key already has a mapping in the dictionary. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one, and any string representation that it has is + * invalidated. + * + *---------------------------------------------------------------------- + */ +int +TclDictPutString( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + const char *key, /* The key in a C string. */ + const char *value) /* The value in a C string. */ +{ + Tcl_Obj *keyPtr = Tcl_NewStringObj(key, -1); + Tcl_Obj *valuePtr = Tcl_NewStringObj(value, -1); + int code; + + Tcl_IncrRefCount(keyPtr); + Tcl_IncrRefCount(valuePtr); + code = Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr); + Tcl_DecrRefCount(keyPtr); + Tcl_DecrRefCount(valuePtr); + return code; +} + /***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/ /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 5890bcb..a3761e5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2918,6 +2918,12 @@ MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *literalPtr); +MODULE_SCOPE int TclDictGet(Tcl_Interp *interp, Tcl_Obj *dictPtr, + const char *key, Tcl_Obj **valuePtrPtr); +MODULE_SCOPE int TclDictPut(Tcl_Interp *interp, Tcl_Obj *dictPtr, + const char *key, Tcl_Obj *valuePtr); +MODULE_SCOPE int TclDictPutString(Tcl_Interp *interp, Tcl_Obj *dictPtr, + const char *key, const char *value); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, -- cgit v0.12 From 872c04a64adaa412f6b8684bb024d000d11a1650 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 May 2024 11:31:34 +0000 Subject: Use the new operations --- generic/tclCmdMZ.c | 6 ++---- generic/tclCompCmds.c | 15 ++++++--------- generic/tclCompCmdsSZ.c | 5 ++--- generic/tclConfig.c | 2 +- generic/tclDictObj.c | 33 ++++++++++++++++++++++++++++++++ generic/tclDisassemble.c | 50 ++++++++++++++++++++---------------------------- generic/tclEncoding.c | 11 ++++------- generic/tclEnsemble.c | 5 ++--- generic/tclEvent.c | 30 +++++++---------------------- generic/tclIOCmd.c | 3 +-- generic/tclInt.h | 2 ++ generic/tclInterp.c | 41 ++++++++++++++++----------------------- generic/tclMain.c | 8 ++------ generic/tclOOInfo.c | 6 ++---- generic/tclZlib.c | 48 ++++++++++++++++------------------------------ 15 files changed, 117 insertions(+), 148 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 41782b0..a6e9ffd 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -5115,12 +5115,10 @@ TryPostBody( */ if (code == TCL_ERROR) { - Tcl_Obj *errorCodeName, *errcode, **bits1, **bits2; + Tcl_Obj *errcode, **bits1, **bits2; int len1, len2, j; - TclNewLiteralStringObj(errorCodeName, "-errorcode"); - Tcl_DictObjGet(NULL, options, errorCodeName, &errcode); - Tcl_DecrRefCount(errorCodeName); + TclDictGet(NULL, options, "-errorcode", &errcode); TclListObjGetElements(NULL, info[2], &len1, &bits1); if (TclListObjGetElements(NULL, errcode, &len2, &bits2) != TCL_OK) { diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index bafcb13..a422072 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2293,8 +2293,7 @@ DisassembleDictUpdateInfo( Tcl_ListObjAppendElement(NULL, variables, Tcl_NewIntObj(duiPtr->varIndices[i])); } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1), - variables); + TclDictPut(NULL, dictObj, "variables", variables); } /* @@ -3035,14 +3034,13 @@ DisassembleForeachInfo( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewIntObj(infoPtr->firstValueTemp + i)); } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr); + TclDictPut(NULL, dictObj, "data", objPtr); /* * Loop counter. */ - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1), - Tcl_NewIntObj(infoPtr->loopCtTemp)); + TclDictPut(NULL, dictObj, "loop", Tcl_NewIntObj(infoPtr->loopCtTemp)); /* * Assignment targets. @@ -3058,7 +3056,7 @@ DisassembleForeachInfo( } Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); + TclDictPut(NULL, dictObj, "assign", objPtr); } static void @@ -3077,8 +3075,7 @@ DisassembleNewForeachInfo( * Jump offset. */ - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1), - Tcl_NewIntObj(infoPtr->loopCtTemp)); + TclDictPut(NULL, dictObj, "jumpOffset", Tcl_NewIntObj(infoPtr->loopCtTemp)); /* * Assignment targets. @@ -3094,7 +3091,7 @@ DisassembleNewForeachInfo( } Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); + TclDictPut(NULL, dictObj, "assign", objPtr); } /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index a7db705..4f2ee70 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2574,10 +2574,9 @@ DisassembleJumptableInfo( for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr); offset = PTR2INT(Tcl_GetHashValue(hPtr)); - Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1), - Tcl_NewIntObj(offset)); + TclDictPut(NULL, mapping, keyPtr, Tcl_NewIntObj(offset)); } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping); + TclDictPut(NULL, dictObj, "mapping", mapping); } /* diff --git a/generic/tclConfig.c b/generic/tclConfig.c index a1a53bc..8fe8fc9 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -128,7 +128,7 @@ Tcl_RegisterConfig( */ for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) { - Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1), + TclDictPut(interp, pkgDict, cfg->key, Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value))); } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index b44e437..3cd9f43 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -1554,6 +1554,39 @@ TclDictPutString( return code; } +/* + *---------------------------------------------------------------------- + * + * TclDictRemove -- + * + * Remove the key,value pair with the given key from the dictionary; the + * key does not need to be present in the dictionary. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The object pointed to by dictPtr is converted to a dictionary if it is + * not already one, and any string representation that it has is + * invalidated. + * + *---------------------------------------------------------------------- + */ +int +TclDictRemove( + Tcl_Interp *interp, + Tcl_Obj *dictPtr, + const char *key) /* The key in a C string. */ +{ + Tcl_Obj *keyPtr = Tcl_NewStringObj(key, -1); + int code; + + Tcl_IncrRefCount(keyPtr); + code = Tcl_DictObjRemove(interp, dictPtr, keyPtr); + Tcl_DecrRefCount(keyPtr); + return code; +} + /***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/ /* diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 9597beb..a66b6a9 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -1113,7 +1113,7 @@ DisassembleByteCodeAsDicts( Tcl_Obj *desc; TclNewObj(desc); - Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc); + TclDictPut(NULL, desc, "name", auxDesc); auxDesc = desc; auxData->type->disassembleProc(auxData->clientData, auxDesc, codePtr, 0); @@ -1180,23 +1180,21 @@ DisassembleByteCodeAsDicts( sourceOffset += Decode(srcOffPtr); sourceLength = Decode(srcLenPtr); TclNewObj(cmd); - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1), - Tcl_NewIntObj(codeOffset)); - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1), - Tcl_NewIntObj(codeOffset + codeLength - 1)); + TclDictPut(NULL, cmd, "codefrom", Tcl_NewIntObj(codeOffset)); + TclDictPut(NULL, cmd, "codeto", Tcl_NewIntObj( + codeOffset + codeLength - 1)); /* * Convert byte offsets to character offsets; important if multibyte * characters are present in the source! */ - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1), - Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, - sourceOffset))); - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1), - Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, + TclDictPut(NULL, cmd, "scriptfrom", Tcl_NewIntObj( + Tcl_NumUtfChars(codePtr->source, sourceOffset))); + TclDictPut(NULL, cmd, "scriptto", Tcl_NewIntObj( + Tcl_NumUtfChars(codePtr->source, sourceOffset + sourceLength - 1))); - Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1), + TclDictPut(NULL, cmd, "script", Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength)); Tcl_ListObjAppendElement(NULL, commands, cmd); } @@ -1215,32 +1213,26 @@ DisassembleByteCodeAsDicts( */ TclNewObj(description); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1), - literals); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1), - variables); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exception", -1), exn); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1), - instructions); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", -1), - commands); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", -1), + TclDictPut(NULL, description, "literals", literals); + TclDictPut(NULL, description, "variables", variables); + TclDictPut(NULL, description, "exception", exn); + TclDictPut(NULL, description, "instructions", instructions); + TclDictPut(NULL, description, "auxiliary", aux); + TclDictPut(NULL, description, "commands", commands); + TclDictPut(NULL, description, "script", Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes)); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1), + TclDictPut(NULL, description, "namespace", Tcl_NewStringObj(codePtr->nsPtr->fullName, -1)); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1), + TclDictPut(NULL, description, "stackdepth", Tcl_NewIntObj(codePtr->maxStackDepth)); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1), + TclDictPut(NULL, description, "exceptdepth", Tcl_NewIntObj(codePtr->maxExceptDepth)); if (line > -1) { - Tcl_DictObjPut(NULL, description, - Tcl_NewStringObj("initiallinenumber", -1), + TclDictPut(NULL, description, "initiallinenumber", Tcl_NewIntObj(line)); } if (file) { - Tcl_DictObjPut(NULL, description, - Tcl_NewStringObj("sourcefile", -1), file); + TclDictPut(NULL, description, "sourcefile", file); } return description; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index ba9f811..bbcaeb9 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1494,8 +1494,7 @@ OpenEncodingFileChannel( const char *name) /* The name of the encoding file on disk and * also the name for new encoding. */ { - Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1); - Tcl_Obj *fileNameObj = Tcl_DuplicateObj(nameObj); + Tcl_Obj *fileNameObj = Tcl_NewStringObj(name, -1); Tcl_Obj *searchPath = Tcl_DuplicateObj(Tcl_GetEncodingSearchPath()); Tcl_Obj *map = TclGetProcessGlobalValue(&encodingFileMap); Tcl_Obj **dir, *path, *directory = NULL; @@ -1503,10 +1502,9 @@ OpenEncodingFileChannel( int i, numDirs; TclListObjGetElements(NULL, searchPath, &numDirs, &dir); - Tcl_IncrRefCount(nameObj); Tcl_AppendToObj(fileNameObj, ".enc", -1); Tcl_IncrRefCount(fileNameObj); - Tcl_DictObjGet(NULL, map, nameObj, &directory); + TclDictGet(NULL, map, name, &directory); /* * Check that any cached directory is still on the encoding search path. @@ -1535,7 +1533,7 @@ OpenEncodingFileChannel( */ map = Tcl_DuplicateObj(map); - Tcl_DictObjRemove(NULL, map, nameObj); + TclDictRemove(NULL, map, name); TclSetProcessGlobalValue(&encodingFileMap, map, NULL); directory = NULL; } @@ -1569,7 +1567,7 @@ OpenEncodingFileChannel( */ map = Tcl_DuplicateObj(TclGetProcessGlobalValue(&encodingFileMap)); - Tcl_DictObjPut(NULL, map, nameObj, dir[i]); + TclDictPut(NULL, map, name, dir[i]); TclSetProcessGlobalValue(&encodingFileMap, map, NULL); } } @@ -1580,7 +1578,6 @@ OpenEncodingFileChannel( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL); } Tcl_DecrRefCount(fileNameObj); - Tcl_DecrRefCount(nameObj); Tcl_DecrRefCount(searchPath); return chan; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index f1d7134..dea3bed 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1586,17 +1586,16 @@ TclMakeEnsemble( */ if (ensemble != NULL) { - Tcl_Obj *mapDict, *fromObj, *toObj; + Tcl_Obj *mapDict, *toObj; Command *cmdPtr; TclDStringAppendLiteral(&buf, "::"); TclNewObj(mapDict); for (i=0 ; map[i].name != NULL ; i++) { - fromObj = Tcl_NewStringObj(map[i].name, -1); TclNewStringObj(toObj, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); Tcl_AppendToObj(toObj, map[i].name, -1); - Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); + TclDictPut(NULL, mapDict, map[i].name, toObj); if (map[i].proc || map[i].nreProc) { /* diff --git a/generic/tclEvent.c b/generic/tclEvent.c index c2e71ec..49880b6 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -263,13 +263,9 @@ HandleBgErrors( if (errChannel != NULL) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); - Tcl_Obj *keyPtr, *valuePtr = NULL; - - TclNewLiteralStringObj(keyPtr, "-errorinfo"); - Tcl_IncrRefCount(keyPtr); - Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); + Tcl_Obj *valuePtr = NULL; + TclDictGet(NULL, options, "-errorinfo", &valuePtr); Tcl_WriteChars(errChannel, "error in background error handler:\n", -1); if (valuePtr) { @@ -313,7 +309,7 @@ TclDefaultBgErrorHandlerObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *keyPtr, *valuePtr; + Tcl_Obj *valuePtr; Tcl_Obj *tempObjv[2]; int result, code, level; Tcl_InterpState saved; @@ -327,10 +323,7 @@ TclDefaultBgErrorHandlerObjCmd( * Check for a valid return options dictionary. */ - TclNewLiteralStringObj(keyPtr, "-level"); - Tcl_IncrRefCount(keyPtr); - result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); + result = TclDictGet(NULL, objv[2], "-level", &valuePtr); if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-level\"", -1)); @@ -340,10 +333,7 @@ TclDefaultBgErrorHandlerObjCmd( if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) { return TCL_ERROR; } - TclNewLiteralStringObj(keyPtr, "-code"); - Tcl_IncrRefCount(keyPtr); - result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); + result = TclDictGet(NULL, objv[2], "-code", &valuePtr); if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-code\"", -1)); @@ -405,18 +395,12 @@ TclDefaultBgErrorHandlerObjCmd( Tcl_SetObjResult(interp, tempObjv[1]); } - TclNewLiteralStringObj(keyPtr, "-errorcode"); - Tcl_IncrRefCount(keyPtr); - result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); + result = TclDictGet(NULL, objv[2], "-errorcode", &valuePtr); if (result == TCL_OK && valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } - TclNewLiteralStringObj(keyPtr, "-errorinfo"); - Tcl_IncrRefCount(keyPtr); - result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); + result = TclDictGet(NULL, objv[2], "-errorinfo", &valuePtr); if (result == TCL_OK && valuePtr != NULL) { Tcl_AppendObjToErrorInfo(interp, valuePtr); } diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 5127b99..cdcef10 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -2005,8 +2005,7 @@ TclInitChanCmd( * Can assume that reference counts are all incremented. */ - Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj(extras[i], -1), - Tcl_NewStringObj(extras[i+1], -1)); + TclDictPutString(NULL, mapObj, extras[i], extras[i + 1]); } Tcl_SetEnsembleMappingDict(interp, ensemble, mapObj); return ensemble; diff --git a/generic/tclInt.h b/generic/tclInt.h index a3761e5..df3d7c8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2924,6 +2924,8 @@ MODULE_SCOPE int TclDictPut(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key, Tcl_Obj *valuePtr); MODULE_SCOPE int TclDictPutString(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key, const char *value); +MODULE_SCOPE int TclDictRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr, + const char *key); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, diff --git a/generic/tclInterp.c b/generic/tclInterp.c index b0f6207..ad06293 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -4428,8 +4428,7 @@ ChildCommandLimitCmd( if (hPtr != NULL) { limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), - limitCBPtr->scriptObj); + TclDictPut(NULL, dictPtr, options[0], limitCBPtr->scriptObj); } else { goto putEmptyCommandInDict; } @@ -4438,22 +4437,19 @@ ChildCommandLimitCmd( putEmptyCommandInDict: TclNewObj(empty); - Tcl_DictObjPut(NULL, dictPtr, - Tcl_NewStringObj(options[0], -1), empty); + TclDictPut(NULL, dictPtr, options[0], empty); } - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewIntObj(Tcl_LimitGetGranularity(childInterp, - TCL_LIMIT_COMMANDS))); + TclDictPut(NULL, dictPtr, options[1], Tcl_NewIntObj( + Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS))); if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) { - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewIntObj(Tcl_LimitGetCommands(childInterp))); + TclDictPut(NULL, dictPtr, options[2], Tcl_NewIntObj( + Tcl_LimitGetCommands(childInterp))); } else { Tcl_Obj *empty; TclNewObj(empty); - Tcl_DictObjPut(NULL, dictPtr, - Tcl_NewStringObj(options[2], -1), empty); + TclDictPut(NULL, dictPtr, options[2], empty); } Tcl_SetObjResult(interp, dictPtr); return TCL_OK; @@ -4616,8 +4612,7 @@ ChildTimeLimitCmd( if (hPtr != NULL) { limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), - limitCBPtr->scriptObj); + TclDictPut(NULL, dictPtr, options[0], limitCBPtr->scriptObj); } else { goto putEmptyCommandInDict; } @@ -4625,29 +4620,25 @@ ChildTimeLimitCmd( Tcl_Obj *empty; putEmptyCommandInDict: TclNewObj(empty); - Tcl_DictObjPut(NULL, dictPtr, - Tcl_NewStringObj(options[0], -1), empty); + TclDictPut(NULL, dictPtr, options[0], empty); } - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewIntObj(Tcl_LimitGetGranularity(childInterp, - TCL_LIMIT_TIME))); + TclDictPut(NULL, dictPtr, options[1], Tcl_NewIntObj( + Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME))); if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) { Tcl_Time limitMoment; Tcl_LimitGetTime(childInterp, &limitMoment); - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewLongObj(limitMoment.usec/1000)); - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1), + TclDictPut(NULL, dictPtr, options[2], + Tcl_NewLongObj(limitMoment.usec / 1000)); + TclDictPut(NULL, dictPtr, options[3], Tcl_NewLongObj(limitMoment.sec)); } else { Tcl_Obj *empty; TclNewObj(empty); - Tcl_DictObjPut(NULL, dictPtr, - Tcl_NewStringObj(options[2], -1), empty); - Tcl_DictObjPut(NULL, dictPtr, - Tcl_NewStringObj(options[3], -1), empty); + TclDictPut(NULL, dictPtr, options[2], empty); + TclDictPut(NULL, dictPtr, options[3], empty); } Tcl_SetObjResult(interp, dictPtr); return TCL_OK; diff --git a/generic/tclMain.c b/generic/tclMain.c index 4f31924..d2ab04a 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -405,13 +405,9 @@ Tcl_MainEx( chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); - Tcl_Obj *keyPtr, *valuePtr; - - TclNewLiteralStringObj(keyPtr, "-errorinfo"); - Tcl_IncrRefCount(keyPtr); - Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); + Tcl_Obj *valuePtr = NULL; + TclDictGet(NULL, options, "-errorinfo", &valuePtr); if (valuePtr) { Tcl_WriteObj(chan, valuePtr); } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 081dd5b..8f544e1 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -116,10 +116,8 @@ TclOOInitInfo( infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); if (infoCmd) { Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); - Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1), - Tcl_NewStringObj("::oo::InfoObject", -1)); - Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1), - Tcl_NewStringObj("::oo::InfoClass", -1)); + TclDictPutString(NULL, mapDict, "object", "::oo::InfoObject"); + TclDictPutString(NULL, mapDict, "class", "::oo::InfoClass"); Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); } } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 4b0332b..e043212 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -385,7 +385,7 @@ ConvertErrorToList( * GenerateHeader -- * * Function for creating a gzip header from the contents of a dictionary - * (as described in the documentation). GetValue is a helper function. + * (as described in the documentation). * * Results: * A Tcl result code. @@ -398,20 +398,6 @@ ConvertErrorToList( *---------------------------------------------------------------------- */ -static inline int -GetValue( - Tcl_Interp *interp, - Tcl_Obj *dictObj, - const char *nameStr, - Tcl_Obj **valuePtrPtr) -{ - Tcl_Obj *name = Tcl_NewStringObj(nameStr, -1); - int result = Tcl_DictObjGet(interp, dictObj, name, valuePtrPtr); - - TclDecrRefCount(name); - return result; -} - static int GenerateHeader( Tcl_Interp *interp, /* Where to put error messages. */ @@ -438,7 +424,7 @@ GenerateHeader( Tcl_Panic("no latin-1 encoding"); } - if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) { + if (TclDictGet(interp, dictObj, "comment", &value) != TCL_OK) { goto error; } else if (value != NULL) { Tcl_EncodingState state; @@ -465,14 +451,14 @@ GenerateHeader( } } - if (GetValue(interp, dictObj, "crc", &value) != TCL_OK) { + if (TclDictGet(interp, dictObj, "crc", &value) != TCL_OK) { goto error; } else if (value != NULL && Tcl_GetBooleanFromObj(interp, value, &headerPtr->header.hcrc)) { goto error; } - if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) { + if (TclDictGet(interp, dictObj, "filename", &value) != TCL_OK) { goto error; } else if (value != NULL) { Tcl_EncodingState state; @@ -499,7 +485,7 @@ GenerateHeader( } } - if (GetValue(interp, dictObj, "os", &value) != TCL_OK) { + if (TclDictGet(interp, dictObj, "os", &value) != TCL_OK) { goto error; } else if (value != NULL && Tcl_GetIntFromObj(interp, value, &headerPtr->header.os) != TCL_OK) { @@ -511,14 +497,14 @@ GenerateHeader( * input data. */ - if (GetValue(interp, dictObj, "time", &value) != TCL_OK) { + if (TclDictGet(interp, dictObj, "time", &value) != TCL_OK) { goto error; } else if (value != NULL && Tcl_GetLongFromObj(interp, value, (long *) &headerPtr->header.time) != TCL_OK) { goto error; } - if (GetValue(interp, dictObj, "type", &value) != TCL_OK) { + if (TclDictGet(interp, dictObj, "type", &value) != TCL_OK) { goto error; } else if (value != NULL && Tcl_GetIndexFromObj(interp, value, types, "type", TCL_EXACT, &headerPtr->header.text) != TCL_OK) { @@ -548,9 +534,6 @@ GenerateHeader( *---------------------------------------------------------------------- */ -#define SetValue(dictObj, key, value) \ - Tcl_DictObjPut(NULL, (dictObj), Tcl_NewStringObj((key), -1), (value)) - static void ExtractHeader( gz_header *headerPtr, /* The gzip header to extract from. */ @@ -573,9 +556,9 @@ ExtractHeader( Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1, &tmp); - SetValue(dictObj, "comment", TclDStringToObj(&tmp)); + TclDictPut(NULL, dictObj, "comment", TclDStringToObj(&tmp)); } - SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc)); + TclDictPut(NULL, dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc)); if (headerPtr->name != Z_NULL) { if (latin1enc == NULL) { /* @@ -590,17 +573,18 @@ ExtractHeader( Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1, &tmp); - SetValue(dictObj, "filename", TclDStringToObj(&tmp)); + TclDictPut(NULL, dictObj, "filename", TclDStringToObj(&tmp)); } if (headerPtr->os != 255) { - SetValue(dictObj, "os", Tcl_NewIntObj(headerPtr->os)); + TclDictPut(NULL, dictObj, "os", Tcl_NewIntObj(headerPtr->os)); } if (headerPtr->time != 0 /* magic - no time */) { - SetValue(dictObj, "time", Tcl_NewLongObj((long) headerPtr->time)); + TclDictPut(NULL, dictObj, "time", + Tcl_NewLongObj((long) headerPtr->time)); } if (headerPtr->text != Z_UNKNOWN) { - SetValue(dictObj, "type", - Tcl_NewStringObj(headerPtr->text ? "text" : "binary", -1)); + TclDictPutString(NULL, dictObj, "type", + headerPtr->text ? "text" : "binary"); } if (latin1enc != NULL) { @@ -1889,7 +1873,7 @@ Tcl_ZlibInflate( Tcl_SetByteArrayLength(obj, stream.total_out); if (headerPtr != NULL) { ExtractHeader(&header, gzipHeaderDictObj); - SetValue(gzipHeaderDictObj, "size", + TclDictPut(NULL, gzipHeaderDictObj, "size", Tcl_NewLongObj(stream.total_out)); ckfree(nameBuf); ckfree(commentBuf); -- cgit v0.12 From 1a46ae83e5dcdceccd87a20aa607b9919340efb4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 May 2024 13:53:52 +0000 Subject: Test to demonstrate [9ee9f4d7be]. Not fixed. --- tests/zlib.test | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/tests/zlib.test b/tests/zlib.test index 5312d2b..61bddd9 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -1117,6 +1117,40 @@ if {$zlibbinf ne ""} { unset zlibbinf rename _zlibbinf {} +test zlib-14.1 {Bug 9ee9f4d7be: compression header added to source channel} -setup { + set data hello + set src [file tempfile] + puts -nonewline $src $data + flush $src + chan configure $src -translation binary + set dst [file tempfile] + chan configure $dst -translation binary + set result {} +} -constraints knownBug -body { + for {set i 0} {$i < 3} {incr i} { + # Determine size of src channel + seek $src 0 end + set size [chan tell $src] + seek $src 0 start + # Determine size of content in src channel + set data [read $src] + set size2 [string length $data] + seek $src 0 start + # Copy src over to dst, keep dst empty + zlib push deflate $src -level 6 + chan truncate $dst 0 + chan copy $src $dst + set size3 [chan tell $dst] + chan pop $src + # Show sizes + lappend result $size $size2 ->$size3 + } + return $result +} -cleanup { + chan close $src + chan close $dst +} -result {5 5 ->5 5 5 ->5 5 5 ->5} + ::tcltest::cleanupTests return -- cgit v0.12 From a5d90257c2e0558387e24753ee7bfb86cbf4f353 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 25 May 2024 15:18:54 +0000 Subject: Check limits immediately when we do [interp eval]. [e3f4a8b78d] --- generic/tclInterp.c | 13 +++++++++++++ tests/interp.test | 18 ++++++++++++++++-- 2 files changed, 29 insertions(+), 2 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index b0f6207..ddca212 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2795,6 +2795,18 @@ ChildEval( Tcl_Preserve(childInterp); Tcl_AllowExceptions(childInterp); + /* + * If we're transferring to another interpreter, check it's limits first. + * It's much more reliable to do that now rather than waiting for the + * intermittent checks done during running; the slight performance hit for + * a cross-interp call is not a big problem. [Bug e3f4a8b78d] + */ + + if (interp != childInterp && Tcl_LimitCheck(childInterp) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (objc == 1) { /* * TIP #280: Make actual argument location available to eval'd script. @@ -2813,6 +2825,7 @@ ChildEval( result = Tcl_EvalObjEx(childInterp, objPtr, 0); Tcl_DecrRefCount(objPtr); } + done: Tcl_TransferResult(childInterp, result, interp); Tcl_Release(childInterp); diff --git a/tests/interp.test b/tests/interp.test index d742484..31c27ac 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -3326,13 +3326,13 @@ test interp-34.9 {time limits trigger in blocking after} { test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { set i [interp create] # Assume someone hasn't set the clock to early 1970! - $i limit time -seconds 1 -granularity 4 + $i limit time -seconds [expr {[clock seconds] + 1}] -granularity 4 interp alias $i log {} lappend result set result {} catch { $i eval { log 1 - after 100 + after 1000 log 2 } } msg @@ -3409,6 +3409,20 @@ test interp-34.13 {time limit granularity and vwait: Bug 2891362} -setup { } -cleanup { interp delete $i } -returnCodes error -result {limit exceeded} +test interp-34.14 {[Bug e3f4a8b78d]: interp limit and interp eval} -setup { + set i [interp create] + set result {} +} -body { + $i limit command -value [$i eval {info cmdcount}] + catch {$i eval [list expr 1+3]} msg + lappend result $msg + catch {$i eval [list expr 1+3]} msg + lappend result $msg + catch {interp eval $i [list expr 1+3]} msg + lappend result $msg +} -cleanup { + interp delete $i +} -result {{command count limit exceeded} {command count limit exceeded} {command count limit exceeded}} test interp-35.1 {interp limit syntax} -body { interp limit -- cgit v0.12 From 3a0060b46224a9c6b8c7ad630558ca441ca778ef Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 27 May 2024 19:26:46 +0000 Subject: fix for [e3f4a8b78dec4bdb]: don't swallow limit errors in further invocations of EvalObjvCore (e. g. direct invocation or NRE, Tcl_EvalObjv, Tcl_EvalObjEx, TclNREvalObjEx, etc); partially reverts [b740e2abbd44c7d0] --- generic/tclBasic.c | 4 ++++ generic/tclInterp.c | 13 ------------- 2 files changed, 4 insertions(+), 13 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c462278..b66c1cc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4330,6 +4330,10 @@ EvalObjvCore( } if (TclLimitExceeded(iPtr->limit)) { + /* generate error message if not yet already logged at this stage */ + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_LimitCheck(interp); + } return TCL_ERROR; } diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 2c0035c..ad06293 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2795,18 +2795,6 @@ ChildEval( Tcl_Preserve(childInterp); Tcl_AllowExceptions(childInterp); - /* - * If we're transferring to another interpreter, check it's limits first. - * It's much more reliable to do that now rather than waiting for the - * intermittent checks done during running; the slight performance hit for - * a cross-interp call is not a big problem. [Bug e3f4a8b78d] - */ - - if (interp != childInterp && Tcl_LimitCheck(childInterp) != TCL_OK) { - result = TCL_ERROR; - goto done; - } - if (objc == 1) { /* * TIP #280: Make actual argument location available to eval'd script. @@ -2825,7 +2813,6 @@ ChildEval( result = Tcl_EvalObjEx(childInterp, objPtr, 0); Tcl_DecrRefCount(objPtr); } - done: Tcl_TransferResult(childInterp, result, interp); Tcl_Release(childInterp); -- cgit v0.12 From 15ebf19a871e197a6f6a17427e865b4ecd785eb3 Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 27 May 2024 20:09:13 +0000 Subject: speedup interp.test a bit: switch to 50ms-based time limits (instead of 1sec); more tests for interp-34.14 covering [e3f4a8b78d] (direct/NRE) --- tests/interp.test | 76 ++++++++++++++++++++++++++++++------------------------- 1 file changed, 41 insertions(+), 35 deletions(-) diff --git a/tests/interp.test b/tests/interp.test index 31c27ac..24ffb1b 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -22,6 +22,12 @@ testConstraint testinterpdelete [llength [info commands testinterpdelete]] set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} +proc _ms_limit_args {ms {t0 {}}} { + if {$t0 eq {}} { set t0 [clock milliseconds] } + incr t0 $ms + list -seconds [expr {$t0 / 1000}] -milliseconds [expr {$t0 % 1000}] +} + foreach i [interp children] { interp delete $i } @@ -3155,7 +3161,7 @@ test interp-34.3 {basic test of limits - pure bytecode loop} -body { } } # We use a time limit here; command limits don't trap this case - $i limit time -seconds [expr {[clock seconds]+2}] + $i limit time {*}[_ms_limit_args 50] $i eval foobar } -returnCodes error -result {time limit exceeded} -cleanup { interp delete $i @@ -3171,7 +3177,7 @@ test interp-34.3.1 {basic test of limits - pure inside-command loop} -body { } } # We use a time limit here; command limits don't trap this case - $i limit time -seconds [expr {[clock seconds] + 2}] + $i limit time {*}[_ms_limit_args 50] $i eval foobar } -returnCodes error -result {time limit exceeded} -cleanup { interp delete $i @@ -3304,7 +3310,7 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { # Bug 1085023 test interp-34.8 {time limits trigger in vwaits} -body { set i [interp create] - interp limit $i time -seconds [expr {[clock seconds] + 1}] -granularity 1 + interp limit $i time {*}[_ms_limit_args 50] -granularity 1 $i eval { set x {} vwait x @@ -3314,25 +3320,24 @@ test interp-34.8 {time limits trigger in vwaits} -body { } -returnCodes error -result {limit exceeded} test interp-34.9 {time limits trigger in blocking after} { set i [interp create] - set t0 [clock seconds] - interp limit $i time -seconds [expr {$t0 + 1}] -granularity 1 + set t0 [clock milliseconds] + interp limit $i time {*}[_ms_limit_args 50 $t0] -granularity 1 set code [catch { $i eval {after 10000} } msg] - set t1 [clock seconds] + set t1 [clock milliseconds] interp delete $i - list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] + list $code $msg [expr {($t1-$t0) < 1000 ? "OK" : $t1-$t0}] } {1 {time limit exceeded} OK} test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { set i [interp create] - # Assume someone hasn't set the clock to early 1970! - $i limit time -seconds [expr {[clock seconds] + 1}] -granularity 4 interp alias $i log {} lappend result set result {} + $i limit time {*}[_ms_limit_args 50] -granularity 4 catch { $i eval { log 1 - after 1000 + after 100 log 2 } } msg @@ -3340,10 +3345,10 @@ test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { lappend result $msg } -result {1 {time limit exceeded}} test interp-34.11 {time limit extension in callbacks} -setup { - proc cb1 {i t} { + proc cb1 {i args} { global result lappend result cb1 - $i limit time -seconds $t -command cb2 + $i limit time {*}[_ms_limit_args {*}$args] -command cb2 } proc cb2 {} { global result @@ -3351,9 +3356,9 @@ test interp-34.11 {time limit extension in callbacks} -setup { } } -body { set i [interp create] - set t0 [clock seconds] - $i limit time -seconds [expr {$t0 + 1}] -granularity 1 \ - -command "cb1 $i [expr {$t0 + 2}]" + set t0 [clock milliseconds] + $i limit time {*}[_ms_limit_args 50 $t0] \ + -command "cb1 $i 100 $t0" set ::result {} lappend ::result [catch { $i eval { @@ -3362,8 +3367,8 @@ test interp-34.11 {time limit extension in callbacks} -setup { } } } msg] $msg - set t1 [clock seconds] - lappend ::result [expr {$t1-$t0>=2 ? "ok" : "$t0,$t1"}] + set t1 [clock milliseconds] + lappend ::result [expr {$t1-$t0>=100 ? "ok" : "$t0,$t1"}] interp delete $i return $::result } -result {cb1 cb2 1 {time limit exceeded} ok} -cleanup { @@ -3371,27 +3376,27 @@ test interp-34.11 {time limit extension in callbacks} -setup { rename cb2 {} } test interp-34.12 {time limit extension in callbacks} -setup { - proc cb1 {i} { + proc cb1 {i t0} { global result times lappend result cb1 set times [lassign $times t] - $i limit time -seconds $t + $i limit time {*}[_ms_limit_args $t $t0] } } -body { set i [interp create] - set t0 [clock seconds] - set ::times "[expr {$t0 + 2}] [expr {$t0 + 100}]" - $i limit time -seconds [expr {$t0 + 1}] -granularity 1 -command "cb1 $i" + set t0 [clock milliseconds] + set ::times {100 10000} + $i limit time {*}[_ms_limit_args 50] -granularity 1 -command "cb1 $i $t0" set ::result {} lappend ::result [catch { $i eval { - for {set i 0} {$i<30} {incr i} { - after 100 + for {set i 0} {$i<5} {incr i} { + after 50 } } } msg] $msg - set t1 [clock seconds] - lappend ::result [expr {$t1-$t0>=2 ? "ok" : "$t0,$t1"}] + set t1 [clock milliseconds] + lappend ::result [expr {$t1-$t0>=100 ? "ok" : "$t0,$t1"}] interp delete $i return $::result } -result {cb1 cb1 0 {} ok} -cleanup { @@ -3400,7 +3405,7 @@ test interp-34.12 {time limit extension in callbacks} -setup { test interp-34.13 {time limit granularity and vwait: Bug 2891362} -setup { set i [interp create -safe] } -body { - $i limit time -seconds [clock add [clock seconds] 1 second] + $i limit time {*}[_ms_limit_args 50] $i eval { after 2000 set x timeout vwait x @@ -3413,16 +3418,16 @@ test interp-34.14 {[Bug e3f4a8b78d]: interp limit and interp eval} -setup { set i [interp create] set result {} } -body { - $i limit command -value [$i eval {info cmdcount}] - catch {$i eval [list expr 1+3]} msg - lappend result $msg - catch {$i eval [list expr 1+3]} msg - lappend result $msg - catch {interp eval $i [list expr 1+3]} msg - lappend result $msg + $i limit command -value [$i eval {info cmdcount}] -granularity 1 + lappend result [catch {$i eval [list expr 1+3]} msg] $msg + lappend result [catch {$i eval [list expr 1+3]} msg] $msg + lappend result [catch {$i eval {set cmd expr; $cmd 1+3}} msg] $msg + lappend result [catch {$i eval {expr 1+3}} msg] $msg + lappend result [catch {$i eval expr 1+3} msg] $msg + lappend result [catch {interp eval $i [list expr 1+3]} msg] $msg } -cleanup { interp delete $i -} -result {{command count limit exceeded} {command count limit exceeded} {command count limit exceeded}} +} -result [lrepeat 6 1 {command count limit exceeded}] test interp-35.1 {interp limit syntax} -body { interp limit @@ -3684,6 +3689,7 @@ unset -nocomplain hidden_cmds foreach i [interp children] { interp delete $i } +rename _ms_limit_args {} ::tcltest::cleanupTests return -- cgit v0.12 From 1f059c4f281d63894b3daf5e67a0b5166ed2e491 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 27 May 2024 20:23:37 +0000 Subject: Eliminate TclPrintByteCodeObj()'s 'interp' argument, which is not used --- generic/tclAssembly.c | 66 +++++++++++++++++++---------------------- generic/tclCompile.c | 16 ++-------- generic/tclCompile.h | 5 ++-- generic/tclDisassemble.c | 76 +++++++++++++++++++++++------------------------- generic/tclExecute.c | 57 +++++++++++++++++------------------- 5 files changed, 99 insertions(+), 121 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index fa59db0..a871f05 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -6,8 +6,8 @@ * This file contains the procedures that convert Tcl Assembly Language (TAL) * to a sequence of bytecode instructions for the Tcl execution engine. * - * Copyright (c) 2010 by Ozgur Dogan Ugurlu. - * Copyright (c) 2010 by Kevin B. Kenny. + * Copyright (c) 2010 Ozgur Dogan Ugurlu. + * Copyright (c) 2010 Kevin B. Kenny. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -271,15 +271,14 @@ static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, const TalInstDesc*); static int DefineLabel(AssemblyEnv* envPtr, const char* label); static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); -static void DupAssembleCodeInternalRep(Tcl_Obj* src, - Tcl_Obj* dest); +static Tcl_DupInternalRepProc DupAssembleCodeInternalRep; static void FillInJumpOffsets(AssemblyEnv*); static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable); static int FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr); static int FinishAssembly(AssemblyEnv*); -static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr); +static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep; static void FreeAssemblyEnv(AssemblyEnv*); static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); @@ -759,7 +758,7 @@ BBEmitInst1or4( int Tcl_AssembleObjCmd( - ClientData dummy, /* Not used. */ + void *clientData, /* clientData */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -769,12 +768,12 @@ Tcl_AssembleObjCmd( * because there needs to be one in place to execute bytecode. */ - return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, dummy, objc, objv); + return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, clientData, objc, objv); } int TclNRAssembleObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -912,12 +911,7 @@ CompileAssembleObj( * Report on what the assembler did. */ -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ + TclDebugPrintByteCodeObj(objPtr); return codePtr; } @@ -1257,7 +1251,7 @@ AssembleOneLine( Tcl_Obj* instNameObj; /* Name of the instruction */ int tblIdx; /* Index in TalInstructionTable of the * instruction */ - enum TalInstType instType; /* Type of the instruction */ + TalInstType instType; /* Type of the instruction */ Tcl_Obj* operand1Obj = NULL; /* First operand to the instruction */ const char* operand1; /* String rep of the operand */ @@ -1377,7 +1371,7 @@ AssembleOneLine( if (opnd < 0 || opnd > 3) { Tcl_SetObjResult(interp, Tcl_NewStringObj("operand must be [0..3]", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", (char *)NULL); goto cleanup; } BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd); @@ -1617,7 +1611,7 @@ AssembleOneLine( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj("operand must be >=2", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", (char *)NULL); } goto cleanup; } @@ -1983,7 +1977,7 @@ CreateMirrorJumpTable( Tcl_SetObjResult(interp, Tcl_NewStringObj( "jump table must have an even number of list elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", (char *)NULL); } return TCL_ERROR; } @@ -2011,7 +2005,7 @@ CreateMirrorJumpTable( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "duplicate entry in jump table for \"%s\"", TclGetString(objv[i]))); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY", (char *)NULL); DeleteMirrorJumpTable(jtPtr); return TCL_ERROR; } @@ -2096,7 +2090,7 @@ GetNextOperand( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "assembly code may not contain substitutions", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", (char *)NULL); } return TCL_ERROR; } @@ -2319,7 +2313,7 @@ FindLocalVar( Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use this instruction to create a variable" " in a non-proc context", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", (char *)NULL); } return -1; } @@ -2354,7 +2348,7 @@ CheckNamespaceQualifiers( if ((*p == ':') && (p[1] == ':')) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "variable \"%s\" is not local", name)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, (char *)NULL); return TCL_ERROR; } } @@ -2390,7 +2384,7 @@ CheckOneByte( if (value < 0 || value > 0xFF) { result = Tcl_NewStringObj("operand does not fit in one byte", -1); Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", (char *)NULL); return TCL_ERROR; } return TCL_OK; @@ -2425,7 +2419,7 @@ CheckSignedOneByte( if (value > 0x7F || value < -0x80) { result = Tcl_NewStringObj("operand does not fit in one byte", -1); Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", (char *)NULL); return TCL_ERROR; } return TCL_OK; @@ -2458,7 +2452,7 @@ CheckNonNegative( if (value < 0) { result = Tcl_NewStringObj("operand must be nonnegative", -1); Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", (char *)NULL); return TCL_ERROR; } return TCL_OK; @@ -2491,7 +2485,7 @@ CheckStrictlyPositive( if (value <= 0) { result = Tcl_NewStringObj("operand must be positive", -1); Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", (char *)NULL); return TCL_ERROR; } return TCL_OK; @@ -2543,7 +2537,7 @@ DefineLabel( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "duplicate definition of label \"%s\"", labelName)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName, - NULL); + (char *)NULL); } return TCL_ERROR; } @@ -2944,7 +2938,7 @@ ReportUndefinedLabel( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "undefined label \"%s\"", TclGetString(jumpTarget))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", - TclGetString(jumpTarget), NULL); + TclGetString(jumpTarget), (char *)NULL); Tcl_SetErrorLine(interp, bbPtr->jumpLine); } } @@ -3229,7 +3223,7 @@ CheckNonThrowingBlock( "a context where an exception has been " "caught and not disposed of.", tclInstructionTable[opcode].name)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", (char *)NULL); AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); } return TCL_ERROR; @@ -3409,7 +3403,7 @@ StackCheckBasicBlock( */ Tcl_SetErrorLine(interp, blockPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (char *)NULL); } return TCL_ERROR; } @@ -3432,7 +3426,7 @@ StackCheckBasicBlock( if (initialStackDepth + blockPtr->minStackDepth < 0) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (char *)NULL); AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); Tcl_SetErrorLine(interp, blockPtr->startLine); } @@ -3451,7 +3445,7 @@ StackCheckBasicBlock( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "code pops stack below level of enclosing catch", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", (char *)NULL); AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); Tcl_SetErrorLine(interp, blockPtr->startLine); } @@ -3579,7 +3573,7 @@ StackCheckExit( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "stack is unbalanced on exit from the code (depth=%d)", depth)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (char *)NULL); } return TCL_ERROR; } @@ -3724,7 +3718,7 @@ ProcessCatchesInBasicBlock( "execution reaches an instruction in inconsistent " "exception contexts", -1)); Tcl_SetErrorLine(interp, bbPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", (char *)NULL); } return TCL_ERROR; } @@ -3783,7 +3777,7 @@ ProcessCatchesInBasicBlock( Tcl_SetObjResult(interp, Tcl_NewStringObj( "endCatch without a corresponding beginCatch", -1)); Tcl_SetErrorLine(interp, bbPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", (char *)NULL); } return TCL_ERROR; } @@ -3859,7 +3853,7 @@ CheckForUnclosedCatches( "catch still active on exit from assembly code", -1)); Tcl_SetErrorLine(interp, assemEnvPtr->curr_bb->enclosingCatch->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", (char *)NULL); } return TCL_ERROR; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 76e0efb..3813077 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -872,12 +872,7 @@ TclSetByteCodeFromAny( if (result == TCL_OK) { TclInitByteCodeObj(objPtr, &compEnv); -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ + TclDebugPrintByteCodeObj(objPtr); } TclFreeCompileEnv(&compEnv); @@ -1322,12 +1317,7 @@ CompileSubstObj( codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ + TclDebugPrintByteCodeObj(objPtr); } return codePtr; } @@ -2137,7 +2127,7 @@ TclCompileScript( if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "too many nested compilations (infinite loop?)", -1)); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", (char *)NULL); TclCompileSyntaxError(interp, envPtr); return; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index f262b37..44c89bc 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1148,8 +1148,9 @@ MODULE_SCOPE int TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG -MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); +MODULE_SCOPE void TclDebugPrintByteCodeObj(Tcl_Obj *objPtr); +#else +#define TclDebugPrintByteCodeObj(objPtr) (void)(objPtr) #endif MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr, const unsigned char *pc); diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index a66b6a9..51e281b 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -5,7 +5,7 @@ * human-readable or Tcl-processable forms. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2001 Kevin B. Kenny. All rights reserved. * Copyright (c) 2013-2016 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of @@ -21,10 +21,8 @@ * Prototypes for procedures defined later in this file: */ -static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Interp *interp, - Tcl_Obj *objPtr); -static Tcl_Obj * DisassembleByteCodeObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); +static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Obj *objPtr); +static Tcl_Obj * DisassembleByteCodeObj(Tcl_Obj *objPtr); static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); static void GetLocationInformation(Proc *procPtr, @@ -107,7 +105,7 @@ GetLocationInformation( /* *---------------------------------------------------------------------- * - * TclPrintByteCodeObj -- + * TclDebugPrintByteCodeObj -- * * This procedure prints ("disassembles") the instructions of a bytecode * object to stdout. @@ -122,14 +120,16 @@ GetLocationInformation( */ void -TclPrintByteCodeObj( - Tcl_Interp *interp, /* Used only for getting location info. */ +TclDebugPrintByteCodeObj( Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - Tcl_Obj *bufPtr = DisassembleByteCodeObj(interp, objPtr); + if (tclTraceCompile == 2) { + Tcl_Obj *bufPtr = DisassembleByteCodeObj(objPtr); - fprintf(stdout, "\n%s", TclGetString(bufPtr)); - Tcl_DecrRefCount(bufPtr); + fprintf(stdout, "\n%s", TclGetString(bufPtr)); + Tcl_DecrRefCount(bufPtr); + fflush(stdout); + } } /* @@ -191,7 +191,7 @@ TclPrintObject( char *bytes; int length; - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } @@ -242,14 +242,14 @@ TclPrintSource( static Tcl_Obj * DisassembleByteCodeObj( - Tcl_Interp *interp, Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { ByteCode *codePtr = BYTECODE(objPtr); unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; - int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line; + int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, line; + int i; Interp *iPtr = (Interp *) *codePtr->interpHandle; Tcl_Obj *bufferObj, *fileObj; char ptrBuf1[20], ptrBuf2[20]; @@ -277,9 +277,9 @@ DisassembleByteCodeObj( PrintSourceToObj(bufferObj, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); GetLocationInformation(codePtr->procPtr, &fileObj, &line); - if (line > -1 && fileObj != NULL) { + if (line >= 0 && fileObj != NULL) { Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", - Tcl_GetString(fileObj), line); + TclGetString(fileObj), line); } Tcl_AppendPrintfToObj(bufferObj, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", @@ -648,7 +648,7 @@ FormatInstruction( int length; Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); + bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length); PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); } else if (suffixBuffer[0]) { Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); @@ -683,7 +683,7 @@ TclGetInnerContext( const unsigned char *pc, Tcl_Obj **tosPtr) { - int objc = 0, off = 0; + int objc = 0; Tcl_Obj *result; Interp *iPtr = (Interp *) interp; @@ -766,7 +766,7 @@ TclGetInnerContext( for (; objc>0 ; objc--) { Tcl_Obj *objPtr; - objPtr = tosPtr[1 - objc + off]; + objPtr = tosPtr[1 - objc]; if (!objPtr) { Tcl_Panic("InnerContext: bad tos -- appending null object"); } @@ -929,8 +929,6 @@ PrintSourceToObj( static Tcl_Obj * DisassembleByteCodeAsDicts( - Tcl_Interp *interp, /* Used for looking up the CmdFrame for the - * procedure, if one exists. */ Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ { ByteCode *codePtr = BYTECODE(objPtr); @@ -1221,7 +1219,7 @@ DisassembleByteCodeAsDicts( TclDictPut(NULL, description, "commands", commands); TclDictPut(NULL, description, "script", Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes)); - TclDictPut(NULL, description, "namespace", + TclDictPut(NULL, description, "namespace", Tcl_NewStringObj(codePtr->nsPtr->fullName, -1)); TclDictPut(NULL, description, "stackdepth", Tcl_NewIntObj(codePtr->maxStackDepth)); @@ -1252,7 +1250,7 @@ DisassembleByteCodeAsDicts( int Tcl_DisassembleObjCmd( - ClientData clientData, /* What type of operation. */ + void *clientData, /* What type of operation. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1335,7 +1333,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't a procedure", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (char *)NULL); return TCL_ERROR; } @@ -1384,7 +1382,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (char *)NULL); return TCL_ERROR; } @@ -1394,7 +1392,7 @@ Tcl_DisassembleObjCmd( "\"%s\" has no defined constructor", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "CONSRUCTOR", NULL); + "CONSRUCTOR", (char *)NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(methodPtr); @@ -1402,7 +1400,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "body not available for this kind of constructor", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); + "METHODTYPE", (char *)NULL); return TCL_ERROR; } @@ -1449,7 +1447,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (char *)NULL); return TCL_ERROR; } @@ -1459,7 +1457,7 @@ Tcl_DisassembleObjCmd( "\"%s\" has no defined destructor", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "DESRUCTOR", NULL); + "DESRUCTOR", (char *)NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(methodPtr); @@ -1467,7 +1465,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "body not available for this kind of destructor", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); + "METHODTYPE", (char *)NULL); return TCL_ERROR; } @@ -1514,11 +1512,11 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); + TclGetString(objv[2]), (char *)NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *) objv[3]); + (char *)objv[3]); goto methodBody; case DISAS_OBJECT_METHOD: if (objc != 4) { @@ -1537,7 +1535,7 @@ Tcl_DisassembleObjCmd( if (oPtr->methodsPtr == NULL) { goto unknownMethod; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *)objv[3]); /* * Compile (if necessary) and disassemble a method body. @@ -1549,7 +1547,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[3]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[3]), NULL); + TclGetString(objv[3]), (char *)NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr)); @@ -1557,7 +1555,7 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "body not available for this kind of method", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); + "METHODTYPE", (char *)NULL); return TCL_ERROR; } if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { @@ -1592,15 +1590,15 @@ Tcl_DisassembleObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not disassemble prebuilt bytecode", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "BYTECODE", NULL); + "BYTECODE", (char *)NULL); return TCL_ERROR; } - if (PTR2INT(clientData)) { + if (clientData) { Tcl_SetObjResult(interp, - DisassembleByteCodeAsDicts(interp, codeObjPtr)); + DisassembleByteCodeAsDicts(codeObjPtr)); } else { Tcl_SetObjResult(interp, - DisassembleByteCodeObj(interp, codeObjPtr)); + DisassembleByteCodeObj(codeObjPtr)); } return TCL_OK; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4072781..bdc3785 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1582,12 +1582,7 @@ CompileExprObj( codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile == 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ + TclDebugPrintByteCodeObj(objPtr); } return codePtr; } @@ -2519,7 +2514,7 @@ TEBCresume( "yield can only be called in a coroutine", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", - NULL); + (char *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -2550,7 +2545,7 @@ TEBCresume( "yieldto can only be called in a coroutine", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", - NULL); + (char *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -2561,7 +2556,7 @@ TEBCresume( "yieldto called in deleted namespace", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", - NULL); + (char *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -2622,7 +2617,7 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_NewStringObj( "tailcall can only be called from a proc or lambda", -1)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (char *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4408,7 +4403,7 @@ TEBCresume( TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", "variable isn't array", opnd); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (char *)NULL); CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; @@ -4757,7 +4752,7 @@ TEBCresume( TRACE_ERROR(interp); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", - TclGetString(OBJ_AT_TOS), NULL); + TclGetString(OBJ_AT_TOS), (char *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4785,7 +4780,7 @@ TEBCresume( "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS))); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(OBJ_AT_TOS), NULL); + TclGetString(OBJ_AT_TOS), (char *)NULL); CACHE_STACK_INFO(); TRACE_APPEND(("ERROR: not command\n")); goto gotError; @@ -4820,7 +4815,7 @@ TEBCresume( "self may only be called from inside a method", -1)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4848,7 +4843,7 @@ TEBCresume( "nextto may only be called from inside a method", -1)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4869,7 +4864,7 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(valuePtr))); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", (char *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4921,7 +4916,7 @@ TEBCresume( methodType, TclGetString(valuePtr))); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", - NULL); + (char *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4929,7 +4924,7 @@ TEBCresume( "%s has no non-filter implementation by \"%s\"", methodType, TclGetString(valuePtr))); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", (char *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4947,7 +4942,7 @@ TEBCresume( "next may only be called from inside a method", -1)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL); CACHE_STACK_INFO(); goto gotError; } @@ -4976,7 +4971,7 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no next %s implementation", methodType)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", (char *)NULL); CACHE_STACK_INFO(); goto gotError; #ifdef TCL_COMPILE_DEBUG @@ -6300,7 +6295,7 @@ TEBCresume( DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", - NULL); + (char *)NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; @@ -6349,7 +6344,7 @@ TEBCresume( DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", - NULL); + (char *)NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; @@ -6371,7 +6366,7 @@ TEBCresume( #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", NULL); + "integer value too large to represent", (char *)NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; @@ -7325,7 +7320,7 @@ TEBCresume( TclGetString(OBJ_AT_TOS))); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); + TclGetString(OBJ_AT_TOS), (char *)NULL); CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; @@ -8012,7 +8007,7 @@ TEBCresume( divideByZero: Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", (char *)NULL); CACHE_STACK_INFO(); goto gotError; @@ -8026,7 +8021,7 @@ TEBCresume( "exponentiation of zero by negative power", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "exponentiation of zero by negative power", NULL); + "exponentiation of zero by negative power", (char *)NULL); CACHE_STACK_INFO(); /* @@ -9779,7 +9774,7 @@ IllegalExprOperandType( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use %s as operand of \"%s\"", description, op)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, (char *)NULL); } /* @@ -10156,23 +10151,23 @@ TclExprFloatError( if ((errno == EDOM) || TclIsNaN(value)) { s = "domain error: argument not in valid range"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *)NULL); } else if ((errno == ERANGE) || TclIsInfinite(value)) { if (value == 0.0) { s = "floating-point value too small to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *)NULL); } else { s = "floating-point value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *)NULL); } } else { Tcl_Obj *objPtr = Tcl_ObjPrintf( "unknown floating-point error, errno = %d", errno); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", - Tcl_GetString(objPtr), NULL); + Tcl_GetString(objPtr), (char *)NULL); Tcl_SetObjResult(interp, objPtr); } } -- cgit v0.12 From 7d54d1c504996494afe53a0d900d64e0e4aecafa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 28 May 2024 12:38:44 +0000 Subject: Make TclGlob() a static function. Sentinel/indenting/comment improvements (all backported from 8.7) --- generic/tclBasic.c | 657 ++++++++++++++++++++++++------------------------- generic/tclBinary.c | 109 ++++---- generic/tclClock.c | 20 +- generic/tclCmdAH.c | 2 +- generic/tclDate.c | 2 +- generic/tclExecute.c | 80 +++--- generic/tclFileName.c | 114 ++++----- generic/tclGetDate.y | 2 +- generic/tclIO.c | 10 +- generic/tclIOUtil.c | 11 +- generic/tclInt.h | 3 - generic/tclLink.c | 10 +- generic/tclObj.c | 28 +-- generic/tclPipe.c | 26 +- generic/tclStrToD.c | 16 +- generic/tclStringObj.c | 16 +- generic/tclTest.c | 6 +- generic/tclTestObj.c | 4 +- generic/tclZlib.c | 6 +- unix/tclUnixTime.c | 2 +- win/tclWinFile.c | 12 +- win/tclWinTime.c | 14 +- 22 files changed, 574 insertions(+), 576 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b66c1cc..be4e56a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -45,17 +45,17 @@ void * TclGetCStackPtr(void) { #if defined( __GNUC__ ) || __has_builtin(__builtin_frame_address) - return __builtin_frame_address(0); + return __builtin_frame_address(0); #elif defined(_MSC_VER) && defined(HAVE_INTRIN_H) - return _AddressOfReturnAddress(); + return _AddressOfReturnAddress(); #else - size_t unused = 0; - /* - * LLVM recommends using volatile: - * https://github.com/llvm/llvm-project/blob/llvmorg-10.0.0-rc1/clang/lib/Basic/Stack.cpp#L31 - */ - size_t *volatile stackLevel = &unused; - return (void *)stackLevel; + size_t unused = 0; + /* + * LLVM recommends using volatile: + * https://github.com/llvm/llvm-project/blob/llvmorg-10.0.0-rc1/clang/lib/Basic/Stack.cpp#L31 + */ + size_t *volatile stackLevel = &unused; + return (void *)stackLevel; #endif } @@ -220,9 +220,9 @@ typedef struct { int flags; /* Various flag bits, as defined below. */ } CmdInfo; -#define CMD_IS_SAFE 1 /* Whether this command is part of the set of - * commands present by default in a safe - * interpreter. */ +#define CMD_IS_SAFE 1 /* Whether this command is part of the set of + * commands present by default in a safe + * interpreter. */ /* CMD_COMPILES_EXPANDED - Whether the compiler for this command can handle * expansion for itself rather than needing the generic layer to take care of * it for it. Defined in tclInt.h. */ @@ -652,7 +652,7 @@ Tcl_CreateInterp(void) iPtr->flags |= INTERP_DEBUG_FRAME; #else if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) { - iPtr->flags |= INTERP_DEBUG_FRAME; + iPtr->flags |= INTERP_DEBUG_FRAME; } #endif @@ -820,9 +820,9 @@ Tcl_CreateInterp(void) cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; cmdPtr->flags = 0; - if (cmdInfoPtr->flags & CMD_COMPILES_EXPANDED) { - cmdPtr->flags |= CMD_COMPILES_EXPANDED; - } + if (cmdInfoPtr->flags & CMD_COMPILES_EXPANDED) { + cmdPtr->flags |= CMD_COMPILES_EXPANDED; + } cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; cmdPtr->nreProc = cmdInfoPtr->nreProc; @@ -881,15 +881,15 @@ Tcl_CreateInterp(void) /* Adding the bytecode assembler command */ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, - "::tcl::unsupported::assemble", Tcl_AssembleObjCmd, - TclNRAssembleObjCmd, NULL, NULL); + "::tcl::unsupported::assemble", Tcl_AssembleObjCmd, + TclNRAssembleObjCmd, NULL, NULL); cmdPtr->compileProc = &TclCompileAssembleCmd; /* Coroutine monkeybusiness */ Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, NRCoroInjectObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype", - CoroTypeObjCmd, NULL, NULL); + CoroTypeObjCmd, NULL, NULL); /* Create an unsupported command for timerate */ Tcl_CreateObjCommand(interp, "::tcl::unsupported::timerate", @@ -901,7 +901,6 @@ Tcl_CreateInterp(void) Tcl_Export(interp, nsPtr, "*", 1); } - #ifdef USE_DTRACE /* * Register the tcl::dtrace command. @@ -922,7 +921,7 @@ Tcl_CreateInterp(void) memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN); for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL; builtinFuncPtr++) { - strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name); + strcpy(mathFuncName + MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name); Tcl_CreateObjCommand(interp, mathFuncName, builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL); Tcl_Export(interp, nsPtr, builtinFuncPtr->name, 0); @@ -986,11 +985,11 @@ Tcl_CreateInterp(void) TCL_GLOBAL_ONLY); Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize", - Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY); + Tcl_NewLongObj((long)sizeof(long)), TCL_GLOBAL_ONLY); /* TIP #291 */ Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize", - Tcl_NewLongObj((long) sizeof(void *)), TCL_GLOBAL_ONLY); + Tcl_NewLongObj((long)sizeof(void *)), TCL_GLOBAL_ONLY); /* * Set up other variables such as tcl_version and tcl_library @@ -1118,8 +1117,8 @@ Tcl_CallWhenDeleted( { Interp *iPtr = (Interp *) interp; static Tcl_ThreadDataKey assocDataCounterKey; - int *assocDataCounterPtr = - (int *)Tcl_GetThreadData(&assocDataCounterKey, sizeof(int)); + int *assocDataCounterPtr = (int *) + Tcl_GetThreadData(&assocDataCounterKey, sizeof(int)); int isNew; char buffer[32 + TCL_INTEGER_SPACE]; AssocData *dPtr = (AssocData *)ckalloc(sizeof(AssocData)); @@ -1461,7 +1460,7 @@ DeleteInterpProc( */ Tcl_MutexLock(&cancelLock); - hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr); + hPtr = Tcl_FindHashEntry(&cancelTable, (char *)iPtr); if (hPtr != NULL) { CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr); @@ -1662,7 +1661,7 @@ DeleteInterpProc( if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eclPtr->path); } - for (i=0; i< eclPtr->nuloc; i++) { + for (i=0; inuloc; i++) { ckfree(eclPtr->loc[i].line); } @@ -1693,7 +1692,7 @@ DeleteInterpProc( } Tcl_DeleteHashTable(iPtr->lineLAPtr); - ckfree((char *) iPtr->lineLAPtr); + ckfree((char *)iPtr->lineLAPtr); iPtr->lineLAPtr = NULL; if (iPtr->lineLABCPtr->numEntries && !TclInExit()) { @@ -1786,7 +1785,7 @@ Tcl_HideCommand( Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use namespace qualifiers in hidden command" " token (rename)", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", (char *)NULL); return TCL_ERROR; } @@ -1809,9 +1808,9 @@ Tcl_HideCommand( if (cmdPtr->nsPtr != iPtr->globalNsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only hide global namespace commands (use rename then hide)", - -1)); - Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", (char *)NULL); + "can only hide global namespace commands (use rename then hide)", + -1)); + Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", (char *)NULL); return TCL_ERROR; } @@ -1835,9 +1834,9 @@ Tcl_HideCommand( hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &isNew); if (!isNew) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "hidden command named \"%s\" already exists", - hiddenCmdToken)); - Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", (char *)NULL); + "hidden command named \"%s\" already exists", + hiddenCmdToken)); + Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", (char *)NULL); return TCL_ERROR; } @@ -1939,9 +1938,9 @@ Tcl_ExposeCommand( if (strstr(cmdName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot expose to a namespace (use expose to toplevel, then rename)", - -1)); - Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", (char *)NULL); + "cannot expose to a namespace (use expose to toplevel, then rename)", + -1)); + Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", (char *)NULL); return TCL_ERROR; } @@ -1956,9 +1955,9 @@ Tcl_ExposeCommand( } if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown hidden command \"%s\"", hiddenCmdToken)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", - hiddenCmdToken, (char *)NULL); + "unknown hidden command \"%s\"", hiddenCmdToken)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", + hiddenCmdToken, (char *)NULL); return TCL_ERROR; } cmdPtr = (Command *)Tcl_GetHashValue(hPtr); @@ -1995,8 +1994,8 @@ Tcl_ExposeCommand( hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); if (!isNew) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "exposed command \"%s\" already exists", cmdName)); - Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", (char *)NULL); + "exposed command \"%s\" already exists", cmdName)); + Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", (char *)NULL); return TCL_ERROR; } @@ -2124,26 +2123,26 @@ Tcl_CreateCommand( */ while (1) { - /* - * Determine where the command should reside. If its name contains - * namespace qualifiers, we put it in the specified namespace; + /* + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; * otherwise, we always put it in the global namespace. - */ + */ - if (strstr(cmdName, "::") != NULL) { + if (strstr(cmdName, "::") != NULL) { Namespace *dummy1, *dummy2; TclGetNamespaceForQualName(interp, cmdName, NULL, TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if ((nsPtr == NULL) || (tail == NULL)) { - return (Tcl_Command) NULL; + return (Tcl_Command) NULL; } - } else { + } else { nsPtr = iPtr->globalNsPtr; tail = cmdName; - } + } - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); if (isNew || deleted) { /* @@ -2154,8 +2153,8 @@ Tcl_CreateCommand( } /* - * An existing command conflicts. Try to delete it... - */ + * An existing command conflicts. Try to delete it... + */ cmdPtr = (Command *)Tcl_GetHashValue(hPtr); @@ -2293,10 +2292,9 @@ Tcl_CreateObjCommand( * name. */ ClientData clientData, /* Arbitrary value to pass to object * function. */ - Tcl_CmdDeleteProc *deleteProc + Tcl_CmdDeleteProc *deleteProc) /* If not NULL, gives a function to call when * this command is deleted. */ -) { Interp *iPtr = (Interp *) interp; Namespace *nsPtr; @@ -2337,8 +2335,8 @@ Tcl_Command TclCreateObjCommandInNs( Tcl_Interp *interp, const char *cmdName, /* Name of command, without any namespace - * components. */ - Tcl_Namespace *namesp, /* The namespace to create the command in */ + * components. */ + Tcl_Namespace *namesp, /* The namespace to create the command in */ Tcl_ObjCmdProc *proc, /* Object-based function to associate with * name. */ ClientData clientData, /* Arbitrary value to pass to object @@ -2373,8 +2371,8 @@ TclCreateObjCommandInNs( } /* - * An existing command conflicts. Try to delete it... - */ + * An existing command conflicts. Try to delete it... + */ cmdPtr = (Command *)Tcl_GetHashValue(hPtr); @@ -2392,7 +2390,7 @@ TclCreateObjCommandInNs( && cmdPtr->deleteProc == deleteProc) { cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; - return (Tcl_Command) cmdPtr; + return (Tcl_Command)cmdPtr; } /* @@ -2408,14 +2406,14 @@ TclCreateObjCommandInNs( } /* - * Make sure namespace doesn't get deallocated. - */ + * Make sure namespace doesn't get deallocated. + */ cmdPtr->nsPtr->refCount++; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); nsPtr = (Namespace *) TclEnsureNamespace(interp, - (Tcl_Namespace *) cmdPtr->nsPtr); + (Tcl_Namespace *) cmdPtr->nsPtr); TclNsDecrRefCount(cmdPtr->nsPtr); if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { @@ -2484,6 +2482,7 @@ TclCreateObjCommandInNs( cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { Command *refCmdPtr = oldRefPtr->importedCmdPtr; + dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; @@ -2535,7 +2534,7 @@ TclInvokeStringCommand( TclStackAlloc(interp, (objc + 1) * sizeof(char *)); for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); + argv[i] = TclGetString(objv[i]); } argv[objc] = 0; @@ -2670,10 +2669,10 @@ TclRenameCommand( cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't %s \"%s\": command doesn't exist", - ((newName == NULL)||(*newName == '\0'))? "delete":"rename", + "can't %s \"%s\": command doesn't exist", + ((newName == NULL) || (*newName == '\0')) ? "delete" : "rename", oldName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, (char *)NULL); return TCL_ERROR; } @@ -2703,16 +2702,16 @@ TclRenameCommand( if ((newNsPtr == NULL) || (newTail == NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't rename to \"%s\": bad command name", newName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (char *)NULL); + "can't rename to \"%s\": bad command name", newName)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (char *)NULL); result = TCL_ERROR; goto done; } if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't rename to \"%s\": command already exists", newName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME", - "TARGET_EXISTS", (char *)NULL); + "can't rename to \"%s\": command already exists", newName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME", + "TARGET_EXISTS", (char *)NULL); result = TCL_ERROR; goto done; } @@ -2789,7 +2788,7 @@ TclRenameCommand( } Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; - CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName), + CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName), Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); Tcl_DStringFree(&newFullName); @@ -2897,7 +2896,7 @@ Tcl_SetCommandInfoFromToken( * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. */ - cmdPtr = (Command *) cmd; + cmdPtr = (Command *)cmd; cmdPtr->proc = infoPtr->proc; cmdPtr->clientData = infoPtr->clientData; if (infoPtr->objProc == NULL) { @@ -2992,7 +2991,6 @@ Tcl_GetCommandInfoFromToken( infoPtr->deleteProc = cmdPtr->deleteProc; infoPtr->deleteData = cmdPtr->deleteData; infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; - return 1; } @@ -3664,7 +3662,7 @@ OldMathFuncProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", -1)); - TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); + TclCheckBadOctal(interp, TclGetString(valuePtr)); ckfree(args); return TCL_ERROR; } @@ -3820,8 +3818,8 @@ Tcl_GetMathFuncInfo( */ if (cmdPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown math function \"%s\"", name)); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown math function \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, (char *)NULL); *numArgsPtr = -1; *argTypesPtr = NULL; @@ -3962,7 +3960,7 @@ TclInterpReady( * probably because of an infinite loop somewhere. */ - if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) { + if (iPtr->numLevels <= iPtr->maxNestingDepth) { return TCL_OK; } @@ -4045,7 +4043,7 @@ Tcl_Canceled( */ if (!TclCanceled(iPtr)) { - return TCL_OK; + return TCL_OK; } /* @@ -4066,7 +4064,7 @@ Tcl_Canceled( */ if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) { - return TCL_OK; + return TCL_OK; } /* @@ -4075,34 +4073,34 @@ Tcl_Canceled( */ if (flags & TCL_LEAVE_ERR_MSG) { - const char *id, *message = NULL; - int length; + const char *id, *message = NULL; + int length; - /* - * Setup errorCode variables so that we can differentiate between - * being canceled and unwound. - */ + /* + * Setup errorCode variables so that we can differentiate between + * being canceled and unwound. + */ - if (iPtr->asyncCancelMsg != NULL) { - message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); - } else { - length = 0; - } + if (iPtr->asyncCancelMsg != NULL) { + message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length); + } else { + length = 0; + } - if (iPtr->flags & TCL_CANCEL_UNWIND) { - id = "IUNWIND"; - if (length == 0) { - message = "eval unwound"; - } - } else { - id = "ICANCEL"; - if (length == 0) { - message = "eval canceled"; - } - } + if (iPtr->flags & TCL_CANCEL_UNWIND) { + id = "IUNWIND"; + if (length == 0) { + message = "eval unwound"; + } + } else { + id = "ICANCEL"; + if (length == 0) { + message = "eval canceled"; + } + } - Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1)); - Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, (char *)NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1)); + Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, (char *)NULL); } /* @@ -4164,7 +4162,7 @@ Tcl_CancelEval( goto done; } - hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp); + hPtr = Tcl_FindHashEntry(&cancelTable, (char *)interp); if (hPtr == NULL) { /* * No CancelInfo record for this interpreter. @@ -4183,8 +4181,8 @@ Tcl_CancelEval( */ if (resultObjPtr != NULL) { - result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length); - cancelInfo->result = (char *)ckrealloc(cancelInfo->result,cancelInfo->length); + result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length); + cancelInfo->result = (char *)ckrealloc(cancelInfo->result, cancelInfo->length); memcpy(cancelInfo->result, result, cancelInfo->length); TclDecrRefCount(resultObjPtr); /* Discard their result object. */ } else { @@ -4287,9 +4285,9 @@ TclNREvalObjv( */ if (iPtr->deferredCallbacks) { - iPtr->deferredCallbacks = NULL; + iPtr->deferredCallbacks = NULL; } else { - TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, (char *)NULL); + TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); } iPtr->numLevels++; @@ -4379,13 +4377,13 @@ EvalObjvCore( assert(cmdPtr == NULL); if (preCmdPtr) { /* - * Caller gave it to us. - */ + * Caller gave it to us. + */ if (!(preCmdPtr->flags & CMD_DEAD)) { /* - * So long as it exists, use it. - */ + * So long as it exists, use it. + */ cmdPtr = preCmdPtr; } else if (flags & TCL_EVAL_NORESOLVE) { @@ -4410,7 +4408,7 @@ EvalObjvCore( if (enterTracesDone || iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { Tcl_Obj *commandPtr = TclGetSourceFromFrame( - flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, objc, objv); Tcl_IncrRefCount(commandPtr); @@ -4453,7 +4451,7 @@ EvalObjvCore( cmdPtr->refCount++; TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); + commandPtr, cmdPtr, objv); } TclNRAddCallback(interp, Dispatch, @@ -4536,8 +4534,8 @@ TclNRRunCallbacks( */ while (TOP_CB(interp) != rootPtr) { - NRE_callback *callbackPtr = TOP_CB(interp); - Tcl_NRPostProc *procPtr = callbackPtr->procPtr; + NRE_callback *callbackPtr = TOP_CB(interp); + Tcl_NRPostProc *procPtr = callbackPtr->procPtr; TOP_CB(interp) = callbackPtr->nextPtr; result = procPtr(callbackPtr->data, interp, result); @@ -4556,12 +4554,12 @@ NRCommand( iPtr->numLevels--; - /* - * If there is a tailcall, schedule it next - */ + /* + * If there is a tailcall, schedule it next + */ if (data[1] && (data[1] != INT2PTR(1))) { - TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL); + TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL); } /* OPT ?? @@ -4706,7 +4704,7 @@ TEOV_Error( */ listPtr = Tcl_NewListObj(objc, objv); - cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); + cmdString = TclGetStringFromObj(listPtr, &cmdLen); Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); Tcl_DecrRefCount(listPtr); } @@ -4770,7 +4768,7 @@ TEOV_NotFound( newObjv[i] = handlerObjv[i]; Tcl_IncrRefCount(newObjv[i]); } - memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * objc); + memcpy(newObjv + handlerObjc, objv, sizeof(Tcl_Obj *) * objc); /* * Look up and invoke the handler (by recursive call to this function). If @@ -4785,9 +4783,9 @@ TEOV_NotFound( cmdPtr = TEOV_LookupCmdFromObj(interp, newObjv[0], lookupNsPtr); if (cmdPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid command name \"%s\"", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(objv[0]), (char *)NULL); + "invalid command name \"%s\"", TclGetString(objv[0]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", + TclGetString(objv[0]), (char *)NULL); /* * Release any resources we locked and allocated during the handler @@ -4850,9 +4848,9 @@ TEOV_RunEnterTraces( { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; - int length, traceCode = TCL_OK; - const char *command = Tcl_GetStringFromObj(commandPtr, &length); + int length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int traceCode = TCL_OK; + const char *command = TclGetStringFromObj(commandPtr, &length); /* * Call trace functions. @@ -4904,7 +4902,7 @@ TEOV_RunLeaveTraces( Command *cmdPtr = (Command *)data[2]; Tcl_Obj **objv = (Tcl_Obj **)data[3]; int length; - const char *command = Tcl_GetStringFromObj(commandPtr, &length); + const char *command = TclGetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { @@ -5275,7 +5273,7 @@ TclEvalEx( iPtr->cmdFramePtr = eeFramePtr->nextPtr; for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr; objectsUsed < numWords; - objectsUsed++, tokenPtr += tokenPtr->numComponents+1) { + objectsUsed++, tokenPtr += tokenPtr->numComponents + 1) { /* * TIP #280. Track lines to current word. Save the information * on a per-word basis, signaling dynamic words as needed. @@ -5296,7 +5294,7 @@ TclEvalEx( iPtr->evalFlags |= TCL_EVAL_FILE; } - code = TclSubstTokens(interp, tokenPtr+1, + code = TclSubstTokens(interp, tokenPtr + 1, tokenPtr->numComponents, NULL, wordLine, wordCLNext, outerScript); @@ -5351,8 +5349,7 @@ TclEvalEx( int objIdx = objectsNeeded - 1; if ((numWords > minObjs) || (objectsNeeded > minObjs)) { - objv = objvSpace = - (Tcl_Obj **)ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); + objv = objvSpace = (Tcl_Obj **)ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); lines = lineSpace = (int *)ckalloc(objectsNeeded * sizeof(int)); } @@ -5377,7 +5374,7 @@ TclEvalEx( objectsUsed++; } } - objv += objIdx+1; + objv += objIdx + 1; if (copy != stackObjArray) { ckfree(copy); @@ -5651,7 +5648,8 @@ TclArgumentEnter( CmdFrame *cfPtr) { Interp *iPtr = (Interp *) interp; - int isNew, i; + int isNew; + int i; Tcl_HashEntry *hPtr; CFWord *cfwPtr; @@ -5722,8 +5720,7 @@ TclArgumentRelease( for (i = 1; i < objc; i++) { CFWord *cfwPtr; - Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]); + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *)objv[i]); if (!hPtr) { continue; @@ -5774,8 +5771,7 @@ TclArgumentBCEnter( ECL *ePtr; CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hePtr = - Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); + Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, (char *)codePtr); if (!hePtr) { return; @@ -5797,7 +5793,7 @@ TclArgumentBCEnter( */ if (ePtr->nline != objc) { - return; + return; } /* @@ -5815,7 +5811,7 @@ TclArgumentBCEnter( if (ePtr->line[word] >= 0) { int isNew; Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, - objv[word], &isNew); + objv[word], &isNew); CFWordBC *cfwPtr = (CFWordBC *)ckalloc(sizeof(CFWordBC)); cfwPtr->framePtr = cfPtr; @@ -5881,7 +5877,7 @@ TclArgumentBCRelease( while (cfwPtr) { CFWordBC *nextPtr = cfwPtr->nextPtr; Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj); + Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *)cfwPtr->obj); CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); if (xPtr != cfwPtr) { @@ -5946,7 +5942,7 @@ TclArgumentGet( * stack. That is nearest. */ - hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj); + hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *)obj); if (hPtr) { CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr); @@ -5960,12 +5956,12 @@ TclArgumentGet( * that stack. */ - hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj); + hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *)obj); if (hPtr) { CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); framePtr = cfwPtr->framePtr; - framePtr->data.tebc.pc = (char *) (((ByteCode *) + framePtr->data.tebc.pc = (char *)(((ByteCode *) framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc); *cfPtrPtr = cfwPtr->framePtr; *wordPtr = cfwPtr->word; @@ -6010,7 +6006,7 @@ Tcl_Eval( * string result (some callers may expect it there). */ - (void) Tcl_GetStringResult(interp); + (void)Tcl_GetStringResult(interp); return code; } @@ -6080,7 +6076,7 @@ int Tcl_EvalObjEx( Tcl_Interp *interp, /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ - Tcl_Obj *objPtr, /* Pointer to object containing commands to + Tcl_Obj *objPtr, /* Pointer to object containing commands to * execute. */ int flags) /* Collection of OR-ed bits that control the * evaluation of the script. Supported values @@ -6093,7 +6089,7 @@ int TclEvalObjEx( Tcl_Interp *interp, /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ - Tcl_Obj *objPtr, /* Pointer to object containing commands to + Tcl_Obj *objPtr, /* Pointer to object containing commands to * execute. */ int flags, /* Collection of OR-ed bits that control the * evaluation of the script. Supported values @@ -6112,7 +6108,7 @@ int TclNREvalObjEx( Tcl_Interp *interp, /* Token for command interpreter (returned by * a previous call to Tcl_CreateInterp). */ - Tcl_Obj *objPtr, /* Pointer to object containing commands to + Tcl_Obj *objPtr, /* Pointer to object containing commands to * execute. */ int flags, /* Collection of OR-ed bits that control the * evaluation of the script. Supported values @@ -6197,7 +6193,7 @@ TclNREvalObjEx( } TclMarkTailcall(interp); - TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, + TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, objPtr, NULL); ListObjGetElements(listPtr, objc, objv); @@ -6218,9 +6214,9 @@ TclNREvalObjEx( * iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ - if (TclInterpReady(interp) != TCL_OK) { - return TCL_ERROR; - } + if (TclInterpReady(interp) != TCL_OK) { + return TCL_ERROR; + } if (flags & TCL_EVAL_GLOBAL) { savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = iPtr->rootFramePtr; @@ -6230,7 +6226,7 @@ TclNREvalObjEx( TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr, objPtr, INT2PTR(allowExceptions), NULL); - return TclNRExecuteByteCode(interp, codePtr); + return TclNRExecuteByteCode(interp, codePtr); } { @@ -6268,7 +6264,7 @@ TclNREvalObjEx( Tcl_IncrRefCount(objPtr); - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + script = TclGetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); TclDecrRefCount(objPtr); @@ -6299,7 +6295,7 @@ TEOEx_ByteCodeCallback( ProcessUnexpectedResult(interp, result); result = TCL_ERROR; - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + script = TclGetStringFromObj(objPtr, &numSrcBytes); Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } @@ -6389,7 +6385,7 @@ ProcessUnexpectedResult( "command returned bad code: %d", returnCode)); } snprintf(buf, sizeof(buf), "%d", returnCode); - Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, NULL); + Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, (char *)NULL); } /* @@ -6707,7 +6703,7 @@ TclObjInvoke( } if ((objc < 1) || (objv == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "illegal argument vector", -1)); + "illegal argument vector", -1)); return TCL_ERROR; } if ((flags & TCL_INVOKE_HIDDEN) == 0) { @@ -6736,9 +6732,9 @@ TclNRInvoke( } if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid hidden command name \"%s\"", cmdName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName, - NULL); + "invalid hidden command name \"%s\"", cmdName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName, + (char *)NULL); return TCL_ERROR; } cmdPtr = (Command *)Tcl_GetHashValue(hPtr); @@ -6961,7 +6957,7 @@ Tcl_AddObjErrorInfo( } /* - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- * * Tcl_VarEvalVA -- * @@ -6970,12 +6966,12 @@ Tcl_AddObjErrorInfo( * * Results: * A standard Tcl return result. An error message or other result may be - * left in the interp's result. + * left in the interp. * * Side effects: * Depends on what was done by the command. * - *--------------------------------------------------------------------------- + *---------------------------------------------------------------------- */ int @@ -7017,13 +7013,14 @@ Tcl_VarEvalVA( * * Results: * A standard Tcl return result. An error message or other result may be - * left in interp->result. + * left in the interp. * * Side effects: * Depends on what was done by the command. * *---------------------------------------------------------------------- */ + int Tcl_VarEval( Tcl_Interp *interp, @@ -7322,7 +7319,7 @@ ExprIsqrtFunc( if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { return TCL_ERROR; } - if (big.sign) { + if (mp_isneg(&big)) { mp_clear(&big); goto negarg; } @@ -7347,7 +7344,7 @@ ExprIsqrtFunc( } if (exact) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d))); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)sqrt(d))); } else { mp_int root; @@ -7360,7 +7357,7 @@ ExprIsqrtFunc( negarg: Tcl_SetObjResult(interp, Tcl_NewStringObj( - "square root of negative argument", -1)); + "square root of negative argument", -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", (char *)NULL); return TCL_ERROR; @@ -7581,7 +7578,7 @@ ExprAbsFunc( if (type == TCL_NUMBER_WIDE) { Tcl_WideInt w = *((const Tcl_WideInt *) ptr); - if (w >= (Tcl_WideInt)0) { + if (w >= 0) { goto unChanged; } if (w == LLONG_MIN) { @@ -7594,7 +7591,7 @@ ExprAbsFunc( #endif if (type == TCL_NUMBER_BIG) { - if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { + if (mp_isneg((const mp_int *)ptr)) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: (void)mp_neg(&big, &big); @@ -7697,7 +7694,7 @@ ExprEntierFunc( return TCL_OK; #ifndef TCL_WIDE_INT_IS_LONG } else if ((d < (double)LLONG_MAX) && (d > (double)LLONG_MIN)) { - Tcl_WideInt result = (Tcl_WideInt) d; + Tcl_WideInt result = (Tcl_WideInt)d; Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); return TCL_OK; @@ -7823,7 +7820,7 @@ ExprRandFunc( * take into consideration the thread this interp is running in. */ - iPtr->randSeed = TclpGetClicks() + PTR2UINT(Tcl_GetCurrentThread())*4093U; + iPtr->randSeed = TclpGetClicks() + PTR2UINT(Tcl_GetCurrentThread()) * 4093U; /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. @@ -8045,13 +8042,13 @@ MathFuncWrongNumArgs( int found, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { - const char *name = Tcl_GetString(objv[0]); + const char *name = TclGetString(objv[0]); const char *tail = name + strlen(name); - while (tail > name+1) { + while (tail > name + 1) { tail--; if (*tail == ':' && tail[-1] == ':') { - name = tail+1; + name = tail + 1; break; } } @@ -8287,7 +8284,8 @@ Tcl_NRCreateCommand( * this command is deleted. */ { Command *cmdPtr = (Command *) - Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); + Tcl_CreateObjCommand(interp, cmdName, proc, clientData, + deleteProc); cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; @@ -8304,7 +8302,8 @@ TclNRCreateCommandInNs( Tcl_CmdDeleteProc *deleteProc) { Command *cmdPtr = (Command *) - TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc); + TclCreateObjCommandInNs(interp, cmdName, nsPtr, proc, clientData, + deleteProc); cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; @@ -8368,14 +8367,14 @@ Tcl_NRCmdSwap( * will execute. There are functions whose purpose is to help define the * precise spot: * TclMarkTailcall: if the NEXT command to be pushed tailcalls, execution - * should continue right here + * should continue right here * TclSkipTailcall: if the NEXT command to be pushed tailcalls, execution - * should continue after the CURRENT command is fully returned ("skip - * the next command: we are redirecting to it, tailcalls should run - * after WE return") + * should continue after the CURRENT command is fully returned ("skip + * the next command: we are redirecting to it, tailcalls should run + * after WE return") * TclPushTailcallPoint: the search for a tailcalling spot cannot traverse - * this point. This is special for OO, as some of the oo constructs - * that behave like commands may not push an NRCommand callback. + * this point. This is special for OO, as some of the oo constructs + * that behave like commands may not push an NRCommand callback. */ void @@ -8386,8 +8385,8 @@ TclMarkTailcall( if (iPtr->deferredCallbacks == NULL) { TclNRAddCallback(interp, NRCommand, NULL, NULL, - NULL, NULL); - iPtr->deferredCallbacks = TOP_CB(interp); + NULL, NULL); + iPtr->deferredCallbacks = TOP_CB(interp); } } @@ -8434,12 +8433,12 @@ TclSetTailcall( NRE_callback *runPtr; for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { - if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { - break; - } + if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { + break; + } } if (!runPtr) { - Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!"); + Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!"); } runPtr->data[1] = listPtr; } @@ -8475,9 +8474,9 @@ TclNRTailcallObjCmd( } if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "tailcall can only be called from a proc, lambda or method", -1)); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (char *)NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "tailcall can only be called from a proc, lambda or method", -1)); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (char *)NULL); return TCL_ERROR; } @@ -8487,8 +8486,8 @@ TclNRTailcallObjCmd( */ if (iPtr->varFramePtr->tailcallPtr) { - Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); - iPtr->varFramePtr->tailcallPtr = NULL; + Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); + iPtr->varFramePtr->tailcallPtr = NULL; } /* @@ -8498,19 +8497,19 @@ TclNRTailcallObjCmd( */ if (objc > 1) { - Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + Tcl_Obj *listPtr, *nsObjPtr; + Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - /* - * The tailcall data is in a Tcl list: the first element is the - * namespace, the rest the command to be tailcalled. - */ + /* + * The tailcall data is in a Tcl list: the first element is the + * namespace, the rest the command to be tailcalled. + */ - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - listPtr = Tcl_NewListObj(objc, objv); + nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); + listPtr = Tcl_NewListObj(objc, objv); TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - iPtr->varFramePtr->tailcallPtr = listPtr; + iPtr->varFramePtr->tailcallPtr = listPtr; } return TCL_RETURN; } @@ -8545,13 +8544,13 @@ TclNRTailcallEval( } if (result != TCL_OK) { - /* - * Tailcall execution was preempted, eg by an intervening catch or by - * a now-gone namespace: cleanup and return. - */ + /* + * Tailcall execution was preempted, eg by an intervening catch or by + * a now-gone namespace: cleanup and return. + */ Tcl_DecrRefCount(listPtr); - return result; + return result; } /* @@ -8561,7 +8560,7 @@ TclNRTailcallEval( TclMarkTailcall(interp); TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); iPtr->lookupNsPtr = (Namespace *) nsPtr; - return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL); + return TclNREvalObjv(interp, objc - 1, objv + 1, 0, NULL); } int @@ -8638,7 +8637,7 @@ TclNRYieldObjCmd( if (!corPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yield can only be called in a coroutine", -1)); + "yield can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (char *)NULL); return TCL_ERROR; } @@ -8649,7 +8648,7 @@ TclNRYieldObjCmd( NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - clientData, NULL, NULL); + clientData, NULL, NULL); return TCL_OK; } @@ -8671,17 +8670,17 @@ TclNRYieldToObjCmd( if (!corPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto can only be called in a coroutine", -1)); + "yieldto can only be called in a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (char *)NULL); return TCL_ERROR; } if (((Namespace *) nsPtr)->flags & NS_DYING) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto called in deleted namespace", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", (char *)NULL); - return TCL_ERROR; + return TCL_ERROR; } /* @@ -8844,14 +8843,14 @@ NRCoroutineExitCallback( * * TclNRCoroutineActivateCallback -- * - * This is the workhorse for coroutines: it implements both yield and - * resume. + * This is the workhorse for coroutines: it implements both yield and + * resume. * - * It is important that both be implemented in the same callback: the - * detection of the impossibility to suspend due to a busy C-stack relies - * on the precise position of a local variable in the stack. We do not - * want the compiler to play tricks on us, either by moving things around - * or inlining. + * It is important that both be implemented in the same callback: the + * detection of the impossibility to suspend due to a busy C-stack relies + * on the precise position of a local variable in the stack. We do not + * want the compiler to play tricks on us, either by moving things around + * or inlining. * *---------------------------------------------------------------------- */ @@ -8868,57 +8867,57 @@ TclNRCoroutineActivateCallback( void *stackLevel = TclGetCStackPtr(); if (!corPtr->stackLevel) { - /* - * -- Coroutine is suspended -- - * Push the callback to restore the caller's context on yield or - * return. - */ - - TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, - NULL, NULL, NULL); - - /* - * Record the stackLevel at which the resume is happening, then swap - * the interp's environment to make it suitable to run this coroutine. - */ - - corPtr->stackLevel = stackLevel; - numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = iPtr->numLevels; - - SAVE_CONTEXT(corPtr->caller); - corPtr->callerEEPtr = iPtr->execEnvPtr; - RESTORE_CONTEXT(corPtr->running); - iPtr->execEnvPtr = corPtr->eePtr; - iPtr->numLevels += numLevels; + /* + * -- Coroutine is suspended -- + * Push the callback to restore the caller's context on yield or + * return. + */ + + TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, + NULL, NULL, NULL); + + /* + * Record the stackLevel at which the resume is happening, then swap + * the interp's environment to make it suitable to run this coroutine. + */ + + corPtr->stackLevel = stackLevel; + numLevels = corPtr->auxNumLevels; + corPtr->auxNumLevels = iPtr->numLevels; + + SAVE_CONTEXT(corPtr->caller); + corPtr->callerEEPtr = iPtr->execEnvPtr; + RESTORE_CONTEXT(corPtr->running); + iPtr->execEnvPtr = corPtr->eePtr; + iPtr->numLevels += numLevels; } else { - /* - * Coroutine is active: yield - */ + /* + * Coroutine is active: yield + */ - if (corPtr->stackLevel != stackLevel) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot yield: C stack busy", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", - (char *)NULL); - return TCL_ERROR; - } + if (corPtr->stackLevel != stackLevel) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot yield: C stack busy", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", + (char *)NULL); + return TCL_ERROR; + } - if (type == CORO_ACTIVATE_YIELD) { - corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; - } else if (type == CORO_ACTIVATE_YIELDM) { - corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY; - } else { - Tcl_Panic("Yield received an option which is not implemented"); - } + if (type == CORO_ACTIVATE_YIELD) { + corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; + } else if (type == CORO_ACTIVATE_YIELDM) { + corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY; + } else { + Tcl_Panic("Yield received an option which is not implemented"); + } - corPtr->stackLevel = NULL; + corPtr->stackLevel = NULL; - numLevels = iPtr->numLevels; - iPtr->numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; + numLevels = iPtr->numLevels; + iPtr->numLevels = corPtr->auxNumLevels; + corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; - iPtr->execEnvPtr = corPtr->callerEEPtr; + iPtr->execEnvPtr = corPtr->callerEEPtr; } return TCL_OK; @@ -8929,7 +8928,7 @@ TclNRCoroutineActivateCallback( * * TclNREvalList -- * - * Callback to invoke command as list, used in order to delayed + * Callback to invoke command as list, used in order to delayed * processing of canonical list command in sane environment. * *---------------------------------------------------------------------- @@ -8958,7 +8957,7 @@ TclNREvalList( * * CoroTypeObjCmd -- * - * Implementation of [::tcl::unsupported::corotype] command. + * Implementation of [::tcl::unsupported::corotype] command. * *---------------------------------------------------------------------- */ @@ -8984,11 +8983,11 @@ CoroTypeObjCmd( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only get coroutine type of a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objv[1]), NULL); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only get coroutine type of a coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", + TclGetString(objv[1]), (char *)NULL); + return TCL_ERROR; } /* @@ -8998,8 +8997,8 @@ CoroTypeObjCmd( corPtr = (CoroutineData *)cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1)); - return TCL_OK; + Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1)); + return TCL_OK; } /* @@ -9009,16 +9008,16 @@ CoroTypeObjCmd( switch (corPtr->nargs) { case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: - Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1)); - return TCL_OK; + Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1)); + return TCL_OK; case COROUTINE_ARGUMENTS_ARBITRARY: - Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1)); - return TCL_OK; + Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1)); + return TCL_OK; default: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unknown coroutine type", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", (char *)NULL); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unknown coroutine type", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", (char *)NULL); + return TCL_ERROR; } } @@ -9055,19 +9054,19 @@ NRCoroInjectObjCmd( cmdPtr = (Command *)Tcl_GetCommandFromObj(interp, objv[1]); if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objv[1]), (char *)NULL); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", + TclGetString(objv[1]), (char *)NULL); + return TCL_ERROR; } corPtr = (CoroutineData *)cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a suspended coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (char *)NULL); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a command into a suspended coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (char *)NULL); + return TCL_ERROR; } /* @@ -9076,8 +9075,8 @@ NRCoroInjectObjCmd( */ iPtr->execEnvPtr = corPtr->eePtr; - TclNRAddCallback(interp, TclNREvalList, Tcl_NewListObj(objc-2, objv+2), - NULL, NULL, NULL); + TclNRAddCallback(interp, TclNREvalList, Tcl_NewListObj(objc - 2, objv + 2), + NULL, NULL, NULL); iPtr->execEnvPtr = savedEEPtr; return TCL_OK; @@ -9094,8 +9093,8 @@ TclNRInterpCoroutine( if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "coroutine \"%s\" is already running", - Tcl_GetString(objv[0]))); + "coroutine \"%s\" is already running", + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", (char *)NULL); return TCL_ERROR; } @@ -9108,31 +9107,31 @@ TclNRInterpCoroutine( switch (corPtr->nargs) { case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: - if (objc == 2) { - Tcl_SetObjResult(interp, objv[1]); - } else if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?arg?"); - return TCL_ERROR; - } - break; + if (objc == 2) { + Tcl_SetObjResult(interp, objv[1]); + } else if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?arg?"); + return TCL_ERROR; + } + break; default: - if (corPtr->nargs != objc-1) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("wrong coro nargs; how did we get here? " - "not implemented!", -1)); - Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL); - return TCL_ERROR; - } - /* fallthrough */ + if (corPtr->nargs + 1 != objc) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("wrong coro nargs; how did we get here? " + "not implemented!", -1)); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL); + return TCL_ERROR; + } + /* fallthrough */ case COROUTINE_ARGUMENTS_ARBITRARY: - if (objc > 1) { - Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, objv+1)); - } - break; + if (objc > 1) { + Tcl_SetObjResult(interp, Tcl_NewListObj(objc - 1, objv + 1)); + } + break; } TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - NULL, NULL, NULL); + NULL, NULL, NULL); return TCL_OK; } @@ -9141,8 +9140,8 @@ TclNRInterpCoroutine( * * TclNRCoroutineObjCmd -- * - * Implementation of [coroutine] command; see documentation for - * description of what this does. + * Implementation of [coroutine] command; see documentation for + * description of what this does. * *---------------------------------------------------------------------- */ @@ -9172,16 +9171,16 @@ TclNRCoroutineObjCmd( if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\": unknown namespace", - procName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", (char *)NULL); + "can't create procedure \"%s\": unknown namespace", + procName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", (char *)NULL); return TCL_ERROR; } if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\": bad procedure name", - procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, (char *)NULL); + "can't create procedure \"%s\": bad procedure name", + procName)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, (char *)NULL); return TCL_ERROR; } @@ -9272,7 +9271,7 @@ TclNRCoroutineObjCmd( */ TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - NULL, NULL, NULL); + NULL, NULL, NULL); return TCL_OK; } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 9836d02..8971334 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -4,8 +4,8 @@ * This file contains the implementation of the "binary" Tcl built-in * command and the Tcl binary data object. * - * Copyright (c) 1997 by Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -185,7 +185,7 @@ typedef struct ByteArray { * of the following "bytes" field. */ unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this - * field depends on the 'allocated' field + * field is stored in the 'allocated' field * above. */ } ByteArray; @@ -206,7 +206,7 @@ typedef struct ByteArray { * from the given array of bytes. * * Results: - * The newly create object is returned. This object will have no initial + * The newly created object is returned. This object has no initial * string representation. The returned object has a ref count of 0. * * Side effects: @@ -221,16 +221,16 @@ Tcl_Obj * Tcl_NewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - int length) /* Length of the array of bytes, which must be - * >= 0. */ + int numBytes) /* Number of bytes in the array, + * must be >= 0. */ { #ifdef TCL_MEM_DEBUG - return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0); + return Tcl_DbNewByteArrayObj(bytes, numBytes, "unknown", 0); #else /* if not TCL_MEM_DEBUG */ Tcl_Obj *objPtr; TclNewObj(objPtr); - Tcl_SetByteArrayObj(objPtr, bytes, length); + Tcl_SetByteArrayObj(objPtr, bytes, numBytes); return objPtr; #endif /* TCL_MEM_DEBUG */ } @@ -251,7 +251,7 @@ Tcl_NewByteArrayObj( * result of calling Tcl_NewByteArrayObj. * * Results: - * The newly create object is returned. This object will have no initial + * The newly created object is returned. This object has no initial * string representation. The returned object has a ref count of 0. * * Side effects: @@ -264,8 +264,8 @@ Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - int length, /* Length of the array of bytes, which must be - * >= 0. */ + int numBytes, /* Number of bytes in the array, + * must be >= 0. */ const char *file, /* The name of the source file calling this * procedure; used for debugging. */ int line) /* Line number in the source file; used for @@ -275,10 +275,10 @@ Tcl_DbNewByteArrayObj( Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - Tcl_SetByteArrayObj(objPtr, bytes, length); + Tcl_SetByteArrayObj(objPtr, bytes, numBytes); return objPtr; #else /* if not TCL_MEM_DEBUG */ - return Tcl_NewByteArrayObj(bytes, length); + return Tcl_NewByteArrayObj(bytes, numBytes); #endif /* TCL_MEM_DEBUG */ } @@ -304,9 +304,9 @@ void Tcl_SetByteArrayObj( Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */ const unsigned char *bytes, /* The array of bytes to use as the new value. - * May be NULL even if length > 0. */ - int length) /* Length of the array of bytes, which must - * be >= 0. */ + * May be NULL even if numBytes > 0. */ + int numBytes) /* Number of bytes in the array, + * must be >= 0 */ { ByteArray *byteArrayPtr; @@ -316,15 +316,15 @@ Tcl_SetByteArrayObj( TclFreeIntRep(objPtr); TclInvalidateStringRep(objPtr); - if (length < 0) { - length = 0; + if (numBytes < 0) { + numBytes = 0; } - byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); - byteArrayPtr->used = length; - byteArrayPtr->allocated = length; + byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(numBytes)); + byteArrayPtr->used = numBytes; + byteArrayPtr->allocated = numBytes; - if ((bytes != NULL) && (length > 0)) { - memcpy(byteArrayPtr->bytes, bytes, length); + if ((bytes != NULL) && (numBytes > 0)) { + memcpy(byteArrayPtr->bytes, bytes, numBytes); } objPtr->typePtr = &tclByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); @@ -351,8 +351,8 @@ Tcl_SetByteArrayObj( unsigned char * Tcl_GetByteArrayFromObj( Tcl_Obj *objPtr, /* The ByteArray object. */ - int *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + int *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { ByteArray *baPtr; @@ -361,10 +361,10 @@ Tcl_GetByteArrayFromObj( } baPtr = GET_BYTEARRAY(objPtr); - if (lengthPtr != NULL) { - *lengthPtr = baPtr->used; + if (numBytesPtr != NULL) { + *numBytesPtr = baPtr->used; } - return (unsigned char *) baPtr->bytes; + return (unsigned char *)baPtr->bytes; } /* @@ -392,7 +392,7 @@ Tcl_GetByteArrayFromObj( unsigned char * Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ - int length) /* New length for internal byte array. */ + int numBytes) /* Number of bytes in resized array */ { ByteArray *byteArrayPtr; @@ -402,17 +402,17 @@ Tcl_SetByteArrayLength( if (objPtr->typePtr != &tclByteArrayType) { SetByteArrayFromAny(NULL, objPtr); } - if (length < 0) { - length = 0; + if (numBytes < 0) { + numBytes = 0; } byteArrayPtr = GET_BYTEARRAY(objPtr); - if ((unsigned int)length > byteArrayPtr->allocated) { - byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length)); - byteArrayPtr->allocated = length; + if ((unsigned int)numBytes > byteArrayPtr->allocated) { + byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(numBytes)); + byteArrayPtr->allocated = numBytes; SET_BYTEARRAY(objPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - byteArrayPtr->used = length; + byteArrayPtr->used = numBytes; return byteArrayPtr->bytes; } @@ -865,7 +865,6 @@ BinaryFormatCmd( &listv) != TCL_OK) { return TCL_ERROR; } - arg++; if (count == BINARY_ALL) { count = listc; @@ -875,6 +874,7 @@ BinaryFormatCmd( -1)); return TCL_ERROR; } + arg++; } offset += count*size; break; @@ -1260,9 +1260,8 @@ BinaryScanCmd( unsigned char *buffer; /* Start of result buffer. */ const char *errorString; const char *str; - int offset, size, length; + int offset, size, length, i; - int i; Tcl_Obj *valuePtr, *elementPtr; Tcl_HashTable numberCacheHash; Tcl_HashTable *numberCachePtr; @@ -1489,7 +1488,7 @@ BinaryScanCmd( goto badIndex; } if (count == BINARY_NOCOUNT) { - if ((length - offset) < size) { + if (length < (size + offset)) { goto done; } valuePtr = ScanNumber(buffer+offset, cmd, flags, @@ -2198,7 +2197,7 @@ ScanNumber( bigObj = Tcl_NewBignumObj(&big); return bigObj; } - return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue); + return Tcl_NewWideIntObj((Tcl_WideInt)uwvalue); /* * Do not cache double values; they are already too large to use as @@ -2359,7 +2358,8 @@ BinaryDecodeHex( Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor, c; - int i, index, value, size, pure, count = 0, cut = 0, strict = 0; + int i, index, value, pure, strict = 0; + int size, cut = 0, count = 0; Tcl_UniChar ch = 0; enum {OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; @@ -2482,7 +2482,8 @@ BinaryEncode64( int maxlen = 0; const char *wrapchar = "\n"; int wrapcharlen = 1; - int offset, i, index, size, outindex = 0, count = 0, purewrap = 1; + int index, purewrap = 1; + int i, offset, size, outindex = 0, count = 0; enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; @@ -2505,7 +2506,7 @@ BinaryEncode64( Tcl_SetObjResult(interp, Tcl_NewStringObj( "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "LINE_LENGTH", NULL); + "LINE_LENGTH", (char *)NULL); return TCL_ERROR; } break; @@ -2515,7 +2516,7 @@ BinaryEncode64( wrapchar = (const char *) Tcl_GetByteArrayFromObj( objv[i + 1], &wrapcharlen); } else { - wrapchar = Tcl_GetStringFromObj(objv[i + 1], &wrapcharlen); + wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen); } break; } @@ -2602,12 +2603,12 @@ BinaryEncodeUu( { Tcl_Obj *resultObj; unsigned char *data, *start, *cursor; - int offset, count, rawLength, i, j, bits, index; + int i, bits, index; unsigned int n; int lineLength = 61; const unsigned char SingleNewline[] = { UCHAR('\n') }; const unsigned char *wrapchar = SingleNewline; - int wrapcharlen = sizeof(SingleNewline); + int j, rawLength, offset, count, wrapcharlen = sizeof(SingleNewline); enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; @@ -2631,7 +2632,7 @@ BinaryEncodeUu( Tcl_SetObjResult(interp, Tcl_NewStringObj( "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "LINE_LENGTH", NULL); + "LINE_LENGTH", (char *)NULL); return TCL_ERROR; } lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */ @@ -2660,7 +2661,7 @@ BinaryEncodeUu( "invalid wrapchar; will defeat decoding", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", - "ENCODE", "WRAPCHAR", NULL); + "ENCODE", "WRAPCHAR", (char *)NULL); return TCL_ERROR; } } @@ -2752,7 +2753,8 @@ BinaryDecodeUu( Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor; - int i, index, size, pure, count = 0, strict = 0, lineLen; + int i, index, pure, strict = 0, lineLen; + int size, count = 0; unsigned char c; Tcl_UniChar ch = 0; enum { OPT_STRICT }; @@ -2878,7 +2880,7 @@ BinaryDecodeUu( shortUu: Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data")); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", (char *)NULL); TclDecrRefCount(resultObj); return TCL_ERROR; @@ -2891,7 +2893,7 @@ BinaryDecodeUu( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid uuencode character \"%c\" at position %d", ch, (int) (data - datastart - 1))); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (char *)NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } @@ -2924,7 +2926,8 @@ BinaryDecode64( unsigned char *begin = NULL; unsigned char *cursor = NULL; int pure, strict = 0; - int i, index, size, cut = 0, count = 0; + int i, index, cut = 0; + int size, count = 0; Tcl_UniChar ch = 0; enum { OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; @@ -3063,7 +3066,7 @@ BinaryDecode64( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid base64 character \"%c\" at position %d", ch, (int) (data - datastart - 1))); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (char *)NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } diff --git a/generic/tclClock.c b/generic/tclClock.c index 7d54edd..071f533 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -29,7 +29,7 @@ #define JULIAN_DAY_POSIX_EPOCH 2440588 #define SECONDS_PER_DAY 86400 -#define JULIAN_SEC_POSIX_EPOCH (((Tcl_WideInt) JULIAN_DAY_POSIX_EPOCH) \ +#define JULIAN_SEC_POSIX_EPOCH (((Tcl_WideInt)JULIAN_DAY_POSIX_EPOCH) \ * SECONDS_PER_DAY) #define FOUR_CENTURIES 146097 /* days */ #define JDAY_1_JAN_1_CE_JULIAN 1721424 @@ -912,7 +912,7 @@ ConvertLocalToUTCUsingC( TzsetIfNecessary(); Tcl_MutexLock(&clockMutex); errno = 0; - fields->seconds = (Tcl_WideInt) mktime(&timeVal); + fields->seconds = (Tcl_WideInt)mktime(&timeVal); localErrno = (fields->seconds == -1) ? errno : 0; Tcl_MutexUnlock(&clockMutex); @@ -1061,7 +1061,7 @@ ConvertUTCToLocalUsingC( */ tock = (time_t) fields->seconds; - if ((Tcl_WideInt) tock != fields->seconds) { + if ((Tcl_WideInt)tock != fields->seconds) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "number too large to represent as a Posix time", -1)); Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL); @@ -1091,7 +1091,7 @@ ConvertUTCToLocalUsingC( * Convert that value to seconds. */ - fields->localSeconds = (((fields->julianDay * (Tcl_WideInt) 24 + fields->localSeconds = (((fields->julianDay * (Tcl_WideInt)24 + timeVal->tm_hour) * 60 + timeVal->tm_min) * 60 + timeVal->tm_sec) - JULIAN_SEC_POSIX_EPOCH; @@ -1783,13 +1783,13 @@ ClockClicksObjCmd( switch (index) { case CLICKS_MILLIS: Tcl_GetTime(&now); - clicks = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000; + clicks = (Tcl_WideInt)now.sec * 1000 + now.usec / 1000; break; case CLICKS_NATIVE: #ifdef TCL_WIDE_CLICKS clicks = TclpGetWideClicks(); #else - clicks = (Tcl_WideInt) TclpGetClicks(); + clicks = TclpGetClicks(); #endif break; case CLICKS_MICROS: @@ -1834,8 +1834,8 @@ ClockMillisecondsObjCmd( return TCL_ERROR; } Tcl_GetTime(&now); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) - now.sec * 1000 + now.usec / 1000)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( + (Tcl_WideInt)now.sec * 1000 + now.usec / 1000)); return TCL_OK; } @@ -1940,7 +1940,7 @@ ClockParseformatargsObjCmd( if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &optionIndex) != TCL_OK) { Tcl_SetErrorCode(interp, "CLOCK", "badOption", - Tcl_GetString(objv[i]), NULL); + TclGetString(objv[i]), (char *)NULL); return TCL_ERROR; } switch (optionIndex) { @@ -2024,7 +2024,7 @@ ClockSecondsObjCmd( return TCL_ERROR; } Tcl_GetTime(&now); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) now.sec)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(now.sec)); return TCL_OK; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 51d90ed..a26254c 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1622,7 +1622,7 @@ FileAttrSizeCmd( if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(buf.st_size)); return TCL_OK; } diff --git a/generic/tclDate.c b/generic/tclDate.c index 900b538..d3b6947 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2758,7 +2758,7 @@ TclClockOldscanObjCmd( return TCL_ERROR; } - yyInput = Tcl_GetString( objv[1] ); + yyInput = TclGetString(objv[1]); dateInfo.dateStart = yyInput; yyHaveDate = 0; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index bdc3785..1c8f667 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1907,8 +1907,8 @@ TclIncrObj( } #ifndef TCL_WIDE_INT_IS_LONG { - Tcl_WideInt w1 = (Tcl_WideInt) augend; - Tcl_WideInt w2 = (Tcl_WideInt) addend; + Tcl_WideInt w1 = (Tcl_WideInt)augend; + Tcl_WideInt w2 = (Tcl_WideInt)addend; /* * We know the sum value is outside the long range, so we use the @@ -2526,7 +2526,7 @@ TEBCresume( } else { fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n", iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), - Tcl_GetString(OBJ_AT_TOS)); + TclGetString(OBJ_AT_TOS)); } fflush(stdout); } @@ -2569,7 +2569,7 @@ TEBCresume( /* FIXME: What is the right thing to trace? */ fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), - Tcl_GetString(valuePtr)); + TclGetString(valuePtr)); } fflush(stdout); } @@ -4034,7 +4034,7 @@ TEBCresume( arrayPtr = NULL; part1Ptr = part2Ptr = NULL; cleanup = 0; - TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr))); + TRACE(("%u %s => ", opnd, TclGetString(incrPtr))); doIncrVar: if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { @@ -6500,8 +6500,8 @@ TEBCresume( switch (*pc) { case INST_ADD: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; + w1 = (Tcl_WideInt)l1; + w2 = (Tcl_WideInt)l2; wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2); #ifdef TCL_WIDE_INT_IS_LONG /* @@ -6515,8 +6515,8 @@ TEBCresume( goto wideResultOfArithmetic; case INST_SUB: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; + w1 = (Tcl_WideInt)l1; + w2 = (Tcl_WideInt)l2; wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 - (Tcl_WideUInt)w2); #ifdef TCL_WIDE_INT_IS_LONG /* @@ -7881,20 +7881,20 @@ TEBCresume( #ifdef TCL_WIDE_CLICKS wval = TclpGetWideClicks(); #else - wval = (Tcl_WideInt) TclpGetClicks(); + wval = TclpGetClicks(); #endif break; case 1: /* microseconds */ Tcl_GetTime(&now); - wval = (Tcl_WideInt) now.sec * 1000000 + now.usec; + wval = (Tcl_WideInt)now.sec * 1000000 + now.usec; break; case 2: /* milliseconds */ Tcl_GetTime(&now); - wval = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000; + wval = (Tcl_WideInt)now.sec * 1000 + now.usec / 1000; break; case 3: /* seconds */ Tcl_GetTime(&now); - wval = (Tcl_WideInt) now.sec; + wval = now.sec; break; default: Tcl_Panic("clockRead instruction with unknown clock#"); @@ -8533,12 +8533,12 @@ ExecuteExtendedBinaryMathOp( * TODO: examine for logic simplification */ - if (((wQuotient < (Tcl_WideInt) 0) - || ((wQuotient == (Tcl_WideInt) 0) - && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0) - || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0)))) + if (((wQuotient < 0) + || ((wQuotient == 0) + && ((w1 < 0 && w2 > 0) + || (w1 > 0 && w2 < 0)))) && (wQuotient * w2 != w1)) { - wQuotient -= (Tcl_WideInt) 1; + wQuotient--; } wRemainder = (Tcl_WideInt)((Tcl_WideUInt)w1 - (Tcl_WideUInt)w2*(Tcl_WideUInt)wQuotient); @@ -8547,8 +8547,7 @@ ExecuteExtendedBinaryMathOp( Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - /* TODO: internals intrusion */ - if ((w1 > ((Tcl_WideInt) 0)) ^ !mp_isneg(&big2)) { + if ((w1 > 0) ^ !mp_isneg(&big2)) { /* * Arguments are opposite sign; remainder is sum. */ @@ -8572,7 +8571,7 @@ ExecuteExtendedBinaryMathOp( mp_init(&bigResult); mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); - if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { + if (!mp_iszero(&bigRemainder) && (mp_isneg(&bigRemainder) != mp_isneg(&big2))) { /* * Convert to Tcl's integer division rules. */ @@ -8598,12 +8597,12 @@ ExecuteExtendedBinaryMathOp( break; #ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: - invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); + invalid = (*((const Tcl_WideInt *)ptr2) < 0); break; #endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - invalid = (mp_cmp_d(&big2, 0) == MP_LT); + invalid = mp_isneg(&big2); mp_clear(&big2); break; default: @@ -8682,7 +8681,7 @@ ExecuteExtendedBinaryMathOp( break; #ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: - zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); + zero = (*(const Tcl_WideInt *)ptr1 > 0); break; #endif case TCL_NUMBER_BIG: @@ -8709,7 +8708,7 @@ ExecuteExtendedBinaryMathOp( if (type1 == TCL_NUMBER_WIDE) { w1 = *(const Tcl_WideInt *)ptr1; if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { - if (w1 >= (Tcl_WideInt)0) { + if (w1 >= 0) { return constants[0]; } LONG_RESULT(-1); @@ -8853,7 +8852,7 @@ ExecuteExtendedBinaryMathOp( #endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); + negativeExponent = mp_isneg(&big2); mp_mod_2d(&big2, 1, &big2); oddExponent = !mp_iszero(&big2); mp_clear(&big2); @@ -8947,7 +8946,7 @@ ExecuteExtendedBinaryMathOp( } #if !defined(TCL_WIDE_INT_IS_LONG) if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(((Tcl_WideInt) 1) << l2); + WIDE_RESULT(((Tcl_WideInt)1) << l2); } #endif goto overflowExpon; @@ -8964,7 +8963,7 @@ ExecuteExtendedBinaryMathOp( } #if !defined(TCL_WIDE_INT_IS_LONG) if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ - WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2)); + WIDE_RESULT(signum * (((Tcl_WideInt)1) << l2)); } #endif goto overflowExpon; @@ -9250,9 +9249,8 @@ ExecuteExtendedBinaryMathOp( } mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); - /* TODO: internals intrusion */ if (!mp_iszero(&bigRemainder) - && (bigRemainder.sign != big2.sign)) { + && (mp_isneg(&bigRemainder) != mp_isneg(&big2))) { /* * Convert to Tcl's integer division rules. */ @@ -9303,7 +9301,7 @@ ExecuteExtendedUnaryMathOp( case TCL_NUMBER_DOUBLE: DOUBLE_RESULT(-(*((const double *) ptr))); case TCL_NUMBER_LONG: - w = (Tcl_WideInt) (*((const long *) ptr)); + w = (Tcl_WideInt)(*((const long *) ptr)); if (w != LLONG_MIN) { WIDE_RESULT(-w); } @@ -9419,7 +9417,7 @@ TclCompareTwoNumbers( goto longCompare; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { + if (mp_isneg(&big2)) { compare = MP_GT; } else { compare = MP_LT; @@ -9445,7 +9443,7 @@ TclCompareTwoNumbers( d2 = *((const double *)ptr2); d1 = (double) w1; if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { + || w1 == (Tcl_WideInt)d1 || modf(d2, &tmp) != 0.0) { goto doubleCompare; } if (d2 < (double)LLONG_MIN) { @@ -9454,7 +9452,7 @@ TclCompareTwoNumbers( if (d2 > (double)LLONG_MAX) { return MP_LT; } - w2 = (Tcl_WideInt) d2; + w2 = (Tcl_WideInt)d2; goto wideCompare; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); @@ -9496,7 +9494,7 @@ TclCompareTwoNumbers( w2 = *((const Tcl_WideInt *)ptr2); d2 = (double) w2; if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) { + || w2 == (Tcl_WideInt)d2 || modf(d1, &tmp) != 0.0) { goto doubleCompare; } if (d1 < (double)LLONG_MIN) { @@ -9505,7 +9503,7 @@ TclCompareTwoNumbers( if (d1 > (double)LLONG_MAX) { return MP_GT; } - w1 = (Tcl_WideInt) d1; + w1 = (Tcl_WideInt)d1; goto wideCompare; #endif case TCL_NUMBER_BIG: @@ -9704,7 +9702,7 @@ ValidatePcAndStackTop( TclNewLiteralStringObj(message, "\n executing "); Tcl_IncrRefCount(message); Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL); - fprintf(stderr,"%s\n", Tcl_GetString(message)); + fprintf(stderr,"%s\n", TclGetString(message)); Tcl_DecrRefCount(message); } else { fprintf(stderr, "\n"); @@ -9754,7 +9752,7 @@ IllegalExprOperandType( if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { int numBytes; - const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); + const char *bytes = TclGetStringFromObj(opndPtr, &numBytes); if (numBytes == 0) { description = "empty string"; @@ -10167,7 +10165,7 @@ TclExprFloatError( "unknown floating-point error, errno = %d", errno); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", - Tcl_GetString(objPtr), (char *)NULL); + TclGetString(objPtr), (char *)NULL); Tcl_SetObjResult(interp, objPtr); } } @@ -10383,7 +10381,7 @@ EvalStatsCmd( if (entryPtr->objPtr->typePtr == &tclByteCodeType) { numByteCodeLits++; } - (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); + (void)TclGetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); strBytesIfUnshared += (entryPtr->refCount * (length+1)); @@ -10605,7 +10603,7 @@ EvalStatsCmd( Tcl_SetObjResult(interp, objPtr); } else { Tcl_Channel outChan; - char *str = Tcl_GetStringFromObj(objv[1], &length); + char *str = TclGetStringFromObj(objv[1], &length); if (length) { if (strcmp(str, "stdout") == 0) { diff --git a/generic/tclFileName.c b/generic/tclFileName.c index d6dac9c..7e24552 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -37,6 +37,9 @@ static Tcl_Obj * SplitUnixPath(const char *path); static int DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr, const char *separators, Tcl_Obj *pathPtr, int flags, char *pattern, Tcl_GlobTypeData *types); +static int TclGlob(Tcl_Interp *interp, char *pattern, + Tcl_Obj *pathPrefix, int globFlags, + Tcl_GlobTypeData *types); /* * When there is no support for getting the block size of a file in a stat() @@ -387,7 +390,7 @@ TclpGetNativePathType( { Tcl_PathType type = TCL_PATH_ABSOLUTE; int pathLen; - const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = TclGetStringFromObj(pathPtr, &pathLen); if (path[0] == '~') { /* @@ -493,11 +496,11 @@ TclpNativeSplitPath( switch (tclPlatform) { case TCL_PLATFORM_UNIX: - resultPtr = SplitUnixPath(Tcl_GetString(pathPtr)); + resultPtr = SplitUnixPath(TclGetString(pathPtr)); break; case TCL_PLATFORM_WINDOWS: - resultPtr = SplitWinPath(Tcl_GetString(pathPtr)); + resultPtr = SplitWinPath(TclGetString(pathPtr)); break; } @@ -567,7 +570,7 @@ Tcl_SplitPath( size = 1; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - Tcl_GetStringFromObj(eltPtr, &len); + TclGetStringFromObj(eltPtr, &len); size += len + 1; } @@ -587,7 +590,7 @@ Tcl_SplitPath( p = (char *) &(*argvPtr)[(*argcPtr) + 1]; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - str = Tcl_GetStringFromObj(eltPtr, &len); + str = TclGetStringFromObj(eltPtr, &len); memcpy(p, str, len + 1); p += len+1; } @@ -838,7 +841,7 @@ TclpNativeJoinPath( const char *p; const char *start; - start = Tcl_GetStringFromObj(prefix, &length); + start = TclGetStringFromObj(prefix, &length); /* * Remove the ./ from tilde prefixed elements, and drive-letter prefixed @@ -866,7 +869,7 @@ TclpNativeJoinPath( if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - Tcl_GetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -876,7 +879,7 @@ TclpNativeJoinPath( Tcl_SetObjLength(prefix, length + (int) strlen(p)); - dest = Tcl_GetString(prefix) + length; + dest = TclGetString(prefix) + length; for (; *p != '\0'; p++) { if (*p == '/') { while (p[1] == '/') { @@ -890,7 +893,7 @@ TclpNativeJoinPath( needsSep = 1; } } - length = dest - Tcl_GetString(prefix); + length = dest - TclGetString(prefix); Tcl_SetObjLength(prefix, length); break; @@ -902,7 +905,7 @@ TclpNativeJoinPath( if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - Tcl_GetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -911,7 +914,7 @@ TclpNativeJoinPath( */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); - dest = Tcl_GetString(prefix) + length; + dest = TclGetString(prefix) + length; for (; *p != '\0'; p++) { if ((*p == '/') || (*p == '\\')) { while ((p[1] == '/') || (p[1] == '\\')) { @@ -925,7 +928,7 @@ TclpNativeJoinPath( needsSep = 1; } } - length = dest - Tcl_GetString(prefix); + length = dest - TclGetString(prefix); Tcl_SetObjLength(prefix, length); break; } @@ -985,7 +988,7 @@ Tcl_JoinPath( * Store the result. */ - resultStr = Tcl_GetStringFromObj(resultObj, &len); + resultStr = TclGetStringFromObj(resultObj, &len); Tcl_DStringAppend(resultPtr, resultStr, len); Tcl_DecrRefCount(resultObj); @@ -1164,7 +1167,7 @@ DoTildeSubst( Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't find HOME environment " "variable to expand path", -1)); - Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", NULL); + Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", (char *)NULL); } return NULL; } @@ -1175,7 +1178,7 @@ DoTildeSubst( Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "user \"%s\" doesn't exist", user)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, (char *)NULL); } return NULL; } @@ -1231,7 +1234,7 @@ Tcl_GlobObjCmd( for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - string = Tcl_GetStringFromObj(objv[i], &length); + string = TclGetStringFromObj(objv[i], &length); if (string[0] == '-') { /* * It looks like the command contains an option so signal an @@ -1258,7 +1261,7 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-directory\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL); return TCL_ERROR; } if (dir != PATH_NONE) { @@ -1268,7 +1271,7 @@ Tcl_GlobObjCmd( : "\"-directory\" cannot be used with \"-path\"", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", - "BADOPTIONCOMBINATION", NULL); + "BADOPTIONCOMBINATION", (char *)NULL); return TCL_ERROR; } dir = PATH_DIR; @@ -1286,7 +1289,7 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-path\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL); return TCL_ERROR; } if (dir != PATH_NONE) { @@ -1296,7 +1299,7 @@ Tcl_GlobObjCmd( : "\"-path\" cannot be used with \"-dictionary\"", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", - "BADOPTIONCOMBINATION", NULL); + "BADOPTIONCOMBINATION", (char *)NULL); return TCL_ERROR; } dir = PATH_GENERAL; @@ -1307,7 +1310,7 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-types\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL); return TCL_ERROR; } typePtr = objv[i+1]; @@ -1328,7 +1331,7 @@ Tcl_GlobObjCmd( "\"-tails\" must be used with either " "\"-directory\" or \"-path\"", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", - "BADOPTIONCOMBINATION", NULL); + "BADOPTIONCOMBINATION", (char *)NULL); return TCL_ERROR; } @@ -1345,7 +1348,7 @@ Tcl_GlobObjCmd( if (dir == PATH_GENERAL) { int pathlength; const char *last; - const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); + const char *first = TclGetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path @@ -1395,7 +1398,7 @@ Tcl_GlobObjCmd( * there are none presently in the prefix. */ - if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) { + if (strpbrk(TclGetString(pathOrDir), "\\/") == NULL) { Tcl_AppendToObj(pathOrDir, last-1, 1); } } @@ -1448,7 +1451,7 @@ Tcl_GlobObjCmd( const char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); - str = Tcl_GetStringFromObj(look, &len); + str = TclGetStringFromObj(look, &len); if (strcmp("readonly", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_RONLY; } else if (strcmp("hidden", str) == 0) { @@ -1506,9 +1509,9 @@ Tcl_GlobObjCmd( if ((TclListObjLength(NULL, look, &len) == TCL_OK) && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); - if (!strcmp("macintosh", Tcl_GetString(item))) { + if (!strcmp("macintosh", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); - if (!strcmp("type", Tcl_GetString(item))) { + if (!strcmp("type", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 2, &item); if (globTypes->macType != NULL) { goto badMacTypesArg; @@ -1516,7 +1519,7 @@ Tcl_GlobObjCmd( globTypes->macType = item; Tcl_IncrRefCount(item); continue; - } else if (!strcmp("creator", Tcl_GetString(item))) { + } else if (!strcmp("creator", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 2, &item); if (globTypes->macCreator != NULL) { goto badMacTypesArg; @@ -1536,8 +1539,8 @@ Tcl_GlobObjCmd( badTypesArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument to \"-types\": %s", - Tcl_GetString(look))); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); + TclGetString(look))); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (char *)NULL); result = TCL_ERROR; join = 0; goto endOfGlob; @@ -1547,7 +1550,7 @@ Tcl_GlobObjCmd( "only one MacOS type or creator argument" " to \"-types\" allowed", -1)); result = TCL_ERROR; - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (char *)NULL); join = 0; goto endOfGlob; } @@ -1600,7 +1603,7 @@ Tcl_GlobObjCmd( Tcl_DStringFree(&str); } else { for (i = 0; i < objc; i++) { - string = Tcl_GetString(objv[i]); + string = TclGetString(objv[i]); if (TclGlob(interp, string, pathOrDir, globFlags, globTypes) != TCL_OK) { result = TCL_ERROR; @@ -1632,14 +1635,14 @@ Tcl_GlobObjCmd( for (i = 0; i < objc; i++) { Tcl_AppendPrintfToObj(errorMsg, "%s%s", - sep, Tcl_GetString(objv[i])); + sep, TclGetString(objv[i])); sep = " "; } } Tcl_AppendToObj(errorMsg, "\"", -1); Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH", - NULL); + (char *)NULL); result = TCL_ERROR; } } @@ -1692,7 +1695,7 @@ Tcl_GlobObjCmd( *---------------------------------------------------------------------- */ -int +static int TclGlob( Tcl_Interp *interp, /* Interpreter for returning error message or * appending list of matching file names. */ @@ -1766,7 +1769,6 @@ TclGlob( if (c != '\0') { tail++; } - Tcl_DStringFree(&buffer); } else { tail = pattern; } @@ -1833,7 +1835,7 @@ TclGlob( Tcl_DecrRefCount(temp); return TCL_ERROR; } - pathPrefix = Tcl_NewStringObj(Tcl_GetString(cwd), 3); + pathPrefix = Tcl_NewStringObj(TclGetString(cwd), 3); Tcl_DecrRefCount(cwd); if (tail[0] == '/') { tail++; @@ -1982,7 +1984,7 @@ TclGlob( Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL"); } - pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); + pre = TclGetStringFromObj(pathPrefix, &prefixLen); if (prefixLen > 0 && (strchr(separators, pre[prefixLen-1]) == NULL)) { /* @@ -2000,7 +2002,7 @@ TclGlob( TclListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { int len; - const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); + const char *oldStr = TclGetStringFromObj(objv[i], &len); Tcl_Obj *elem; if (len == prefixLen) { @@ -2209,14 +2211,14 @@ DoGlob( Tcl_SetObjResult(interp, Tcl_NewStringObj( "unmatched open-brace in file name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", - NULL); + (char *)NULL); return TCL_ERROR; } else if (*p == '}') { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unmatched close-brace in file name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", - NULL); + (char *)NULL); return TCL_ERROR; } } @@ -2329,7 +2331,7 @@ DoGlob( for (i=0; result==TCL_OK && i 0) && (strchr(separators, joined[len-1]) == NULL)) { Tcl_AppendToObj(joinedPtr, "/", 1); @@ -2471,7 +2473,7 @@ DoGlob( */ int len; - const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + const char *joined = TclGetStringFromObj(joinedPtr,&len); if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { @@ -2536,21 +2538,21 @@ unsigned Tcl_GetFSDeviceFromStat( const Tcl_StatBuf *statPtr) { - return (unsigned) statPtr->st_dev; + return (unsigned)statPtr->st_dev; } unsigned Tcl_GetFSInodeFromStat( const Tcl_StatBuf *statPtr) { - return (unsigned) statPtr->st_ino; + return (unsigned)statPtr->st_ino; } unsigned Tcl_GetModeFromStat( const Tcl_StatBuf *statPtr) { - return (unsigned) statPtr->st_mode; + return (unsigned)statPtr->st_mode; } int @@ -2564,7 +2566,7 @@ int Tcl_GetUserIdFromStat( const Tcl_StatBuf *statPtr) { - return (int) statPtr->st_uid; + return (int)statPtr->st_uid; } int @@ -2585,28 +2587,28 @@ Tcl_WideInt Tcl_GetAccessTimeFromStat( const Tcl_StatBuf *statPtr) { - return (Tcl_WideInt) statPtr->st_atime; + return statPtr->st_atime; } Tcl_WideInt Tcl_GetModificationTimeFromStat( const Tcl_StatBuf *statPtr) { - return (Tcl_WideInt) statPtr->st_mtime; + return statPtr->st_mtime; } Tcl_WideInt Tcl_GetChangeTimeFromStat( const Tcl_StatBuf *statPtr) { - return (Tcl_WideInt) statPtr->st_ctime; + return statPtr->st_ctime; } Tcl_WideUInt Tcl_GetSizeFromStat( const Tcl_StatBuf *statPtr) { - return (Tcl_WideUInt) statPtr->st_size; + return (Tcl_WideUInt)statPtr->st_size; } Tcl_WideUInt @@ -2614,11 +2616,11 @@ Tcl_GetBlocksFromStat( const Tcl_StatBuf *statPtr) { #ifdef HAVE_STRUCT_STAT_ST_BLOCKS - return (Tcl_WideUInt) statPtr->st_blocks; + return (Tcl_WideUInt)statPtr->st_blocks; #else unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr); - return ((Tcl_WideUInt) statPtr->st_size + blksize - 1) / blksize; + return ((Tcl_WideUInt)statPtr->st_size + blksize - 1) / blksize; #endif } diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index a8b9801..f73f9ce 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -979,7 +979,7 @@ TclClockOldscanObjCmd( return TCL_ERROR; } - yyInput = Tcl_GetString( objv[1] ); + yyInput = TclGetString(objv[1]); dateInfo.dateStart = yyInput; yyHaveDate = 0; diff --git a/generic/tclIO.c b/generic/tclIO.c index b800171..1cb3bbd 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -9193,7 +9193,7 @@ TclCopyChannelOld( int toRead, /* Amount of data to copy, or -1 for all. */ Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */ { - return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead, + return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr); } @@ -9287,7 +9287,7 @@ TclCopyChannel( csPtr->readFlags = readFlags; csPtr->writeFlags = writeFlags; csPtr->toRead = toRead; - csPtr->total = (Tcl_WideInt) 0; + csPtr->total = 0; csPtr->interp = interp; if (cmdPtr) { Tcl_IncrRefCount(cmdPtr); @@ -9612,7 +9612,7 @@ CopyData( Tcl_IncrRefCount(bufObj); } - while (csPtr->toRead != (Tcl_WideInt) 0) { + while (csPtr->toRead != 0) { /* * Check for unreported background errors. */ @@ -9643,8 +9643,8 @@ CopyData( * Read up to bufSize bytes. */ - if ((csPtr->toRead == (Tcl_WideInt) -1) - || (csPtr->toRead > (Tcl_WideInt) csPtr->bufSize)) { + if ((csPtr->toRead == -1) + || (csPtr->toRead > (Tcl_WideInt)csPtr->bufSize)) { sizeb = csPtr->bufSize; } else { sizeb = (int) csPtr->toRead; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 8b87a51..e630702 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -290,10 +290,10 @@ Tcl_Stat( * Tcl_WideInt. */ - tmp1 = (Tcl_WideInt) buf.st_ino; - tmp2 = (Tcl_WideInt) buf.st_size; + tmp1 = buf.st_ino; + tmp2 = buf.st_size; #ifdef HAVE_STRUCT_STAT_ST_BLOCKS - tmp3 = (Tcl_WideInt) buf.st_blocks; + tmp3 = buf.st_blocks; #endif if (OUT_OF_URANGE(tmp1) || OUT_OF_RANGE(tmp2) || OUT_OF_RANGE(tmp3)) { @@ -2267,8 +2267,7 @@ Tcl_FSOpenFileChannel( * Apply appropriate flags parsed out above. */ - if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END) - < (Tcl_WideInt) 0) { + if (seekFlag && (Tcl_Seek(retVal, 0, SEEK_END) < 0)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not seek to end of file while opening \"%s\": %s", @@ -3304,7 +3303,7 @@ Tcl_LoadFile( * Tcl_Read takes an int: check that file size isn't wide. */ - if (size != (Tcl_WideInt) statBuf.st_size) { + if (size != (Tcl_WideInt)statBuf.st_size) { goto mustCopyToTempAnyway; } data = Tcl_FSOpenFileChannel(interp, pathPtr, "rb", 0666); diff --git a/generic/tclInt.h b/generic/tclInt.h index df3d7c8..f8e665b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3002,9 +3002,6 @@ MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, unsigned int *sizePtr); -MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, - Tcl_Obj *unquotedPrefix, int globFlags, - Tcl_GlobTypeData *types); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, diff --git a/generic/tclLink.c b/generic/tclLink.c index d93e4cb..6c5d0d2 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -513,7 +513,7 @@ LinkTraceProc( case TCL_LINK_ULONG: if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) - || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) { + || valueWide < 0 || (Tcl_WideUInt)valueWide > ULONG_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned long value"; @@ -612,13 +612,13 @@ ObjValue( return Tcl_NewIntObj(linkPtr->lastValue.us); case TCL_LINK_UINT: linkPtr->lastValue.ui = LinkedVar(unsigned int); - return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui); + return Tcl_NewWideIntObj(linkPtr->lastValue.ui); case TCL_LINK_LONG: linkPtr->lastValue.l = LinkedVar(long); - return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l); + return Tcl_NewWideIntObj(linkPtr->lastValue.l); case TCL_LINK_ULONG: linkPtr->lastValue.ul = LinkedVar(unsigned long); - return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); + return Tcl_NewWideIntObj(linkPtr->lastValue.ul); case TCL_LINK_FLOAT: linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); @@ -627,7 +627,7 @@ ObjValue( /* * FIXME: represent as a bignum. */ - return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); + return Tcl_NewWideIntObj(linkPtr->lastValue.uw); case TCL_LINK_STRING: p = LinkedVar(char *); if (p == NULL) { diff --git a/generic/tclObj.c b/generic/tclObj.c index f7196c3..284a431 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -187,7 +187,7 @@ static Tcl_ThreadDataKey pendingObjDataKey; mp_shrink(&(bignum)); \ } \ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(bignum).dp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR((mp_isneg(&(bignum)) << 30) \ | ((bignum).alloc << 15) | ((bignum).used)); \ } @@ -2823,10 +2823,10 @@ Tcl_GetLongFromObj( while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } - if (big.sign) { - *longPtr = (long) (-value); + if (mp_isneg(&big)) { + *longPtr = (long)(-value); } else { - *longPtr = (long) value; + *longPtr = (long)value; } return TCL_OK; } @@ -3041,8 +3041,8 @@ Tcl_SetWideIntObj( } #ifndef TCL_WIDE_INT_IS_LONG - if ((wideValue < (Tcl_WideInt) LONG_MIN) - || (wideValue > (Tcl_WideInt) LONG_MAX)) { + if ((wideValue < (Tcl_WideInt)LONG_MIN) + || (wideValue > (Tcl_WideInt)LONG_MAX)) { TclSetWideIntObj(objPtr, wideValue); } else #endif @@ -3085,7 +3085,7 @@ Tcl_GetWideIntFromObj( } #endif if (objPtr->typePtr == &tclIntType) { - *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; + *wideIntPtr = (Tcl_WideInt)objPtr->internalRep.longValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { @@ -3117,10 +3117,10 @@ Tcl_GetWideIntFromObj( while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } - if (big.sign) { - *wideIntPtr = (Tcl_WideInt) (-value); + if (mp_isneg(&big)) { + *wideIntPtr = (Tcl_WideInt)(-value); } else { - *wideIntPtr = (Tcl_WideInt) value; + *wideIntPtr = (Tcl_WideInt)value; } return TCL_OK; } @@ -3545,10 +3545,10 @@ Tcl_SetBignumObj( while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } - if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) { + if (value > (((~(unsigned long)0) >> 1) + mp_isneg(bignumValue))) { goto tooLargeForLong; } - if (bignumValue->sign) { + if (mp_isneg(bignumValue)) { TclSetLongObj(objPtr, (long)(-value)); } else { TclSetLongObj(objPtr, (long)value); @@ -3571,10 +3571,10 @@ Tcl_SetBignumObj( while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } - if (value > ((UWIDE_MAX >> 1) + bignumValue->sign)) { + if (value > ((UWIDE_MAX >> 1) + mp_isneg(bignumValue))) { goto tooLargeForWide; } - if (bignumValue->sign) { + if (mp_isneg(bignumValue)) { TclSetWideIntObj(objPtr, (Tcl_WideInt)(-value)); } else { TclSetWideIntObj(objPtr, (Tcl_WideInt)value); diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 31e1143..2c6f99b 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -4,7 +4,7 @@ * This file contains the generic portion of the command channel driver * as well as various utility routines used in managing subprocesses. * - * Copyright (c) 1997 by Sun Microsystems, Inc. + * Copyright (c) 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -111,7 +111,7 @@ FileForRedirect( Tcl_GetChannelName(chan), ((writing) ? "writing" : "reading"))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "BADCHAN", NULL); + "BADCHAN", (char *)NULL); } return NULL; } @@ -155,7 +155,7 @@ FileForRedirect( badLastArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't specify \"%s\" as last word in command", arg)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", (char *)NULL); return NULL; } @@ -188,7 +188,7 @@ Tcl_DetachPids( Tcl_MutexLock(&pipeMutex); for (i = 0; i < numPids; i++) { - detPtr = ckalloc(sizeof(Detached)); + detPtr = (Detached *)ckalloc(sizeof(Detached)); detPtr->pid = pidPtr[i]; detPtr->nextPtr = detList; detList = detPtr; @@ -370,7 +370,7 @@ TclCleanupChildren( int count; Tcl_Obj *objPtr; - Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET); + Tcl_Seek(errorChan, 0, SEEK_SET); TclNewObj(objPtr); count = Tcl_ReadChars(errorChan, objPtr, -1, 0); if (count < 0) { @@ -550,7 +550,7 @@ TclCreatePipeline( Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal use of | or |& in command", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "PIPESYNTAX", NULL); + "PIPESYNTAX", (char *)NULL); goto error; } } @@ -579,7 +579,7 @@ TclCreatePipeline( "can't specify \"%s\" as last word in command", argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "PIPESYNTAX", NULL); + "PIPESYNTAX", (char *)NULL); goto error; } skip = 2; @@ -696,7 +696,7 @@ TclCreatePipeline( "must specify \"%s\" as last word in command", argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "PIPESYNTAX", NULL); + "PIPESYNTAX", (char *)NULL); goto error; } errorFile = outputFile; @@ -738,7 +738,7 @@ TclCreatePipeline( Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal use of | or |& in command", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", - NULL); + (char *)NULL); goto error; } @@ -861,7 +861,7 @@ TclCreatePipeline( */ Tcl_ReapDetachedProcs(); - pidPtr = ckalloc(cmdCount * sizeof(Tcl_Pid)); + pidPtr = (Tcl_Pid *)ckalloc(cmdCount * sizeof(Tcl_Pid)); curInFile = inputFile; @@ -1091,7 +1091,7 @@ Tcl_OpenCommandChannel( "can't read output from command:" " standard output was redirected", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "BADREDIRECT", NULL); + "BADREDIRECT", (char *)NULL); goto error; } if ((flags & TCL_STDIN) && (inPipe == NULL)) { @@ -1099,7 +1099,7 @@ Tcl_OpenCommandChannel( "can't write input to command:" " standard input was redirected", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "BADREDIRECT", NULL); + "BADREDIRECT", (char *)NULL); goto error; } } @@ -1110,7 +1110,7 @@ Tcl_OpenCommandChannel( if (channel == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "pipe for command could not be created", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", (char *)NULL); goto error; } return channel; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 12fe4ee..a5d9ad1 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1311,10 +1311,10 @@ TclParseNumber( objPtr->typePtr = &tclWideIntType; if (signum) { objPtr->internalRep.wideValue = - (Tcl_WideInt) (-octalSignificandWide); + (Tcl_WideInt)(-octalSignificandWide); } else { objPtr->internalRep.wideValue = - (Tcl_WideInt) octalSignificandWide; + (Tcl_WideInt)octalSignificandWide; } break; } @@ -1358,10 +1358,10 @@ TclParseNumber( objPtr->typePtr = &tclWideIntType; if (signum) { objPtr->internalRep.wideValue = - (Tcl_WideInt) (-significandWide); + (Tcl_WideInt)(-significandWide); } else { objPtr->internalRep.wideValue = - (Tcl_WideInt) significandWide; + (Tcl_WideInt)significandWide; } break; } @@ -2067,7 +2067,7 @@ RefineApproximation( */ if (roundToEven) { rteSignificand = frexp(approxResult, &rteExponent); - rteSigWide = (Tcl_WideInt) ldexp(rteSignificand, FP_PRECISION); + rteSigWide = ldexp(rteSignificand, FP_PRECISION); if ((rteSigWide & 1) == 0) { mp_clear(&twoMd); mp_clear(&twoMv); @@ -4703,7 +4703,7 @@ Tcl_InitBignumFromDouble( mp_init(b); mp_zero(b); } else { - Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits); + Tcl_WideInt w = ldexp(fract, mantBits); int shift = expt - mantBits; TclBNInitBignumFromWideInt(b, w); @@ -4852,7 +4852,7 @@ TclCeil( mp_int b; mp_init(&b); - if (mp_cmp_d(a, 0) == MP_LT) { + if (mp_isneg(a)) { mp_neg(a, &b); r = -TclFloor(&b); } else { @@ -4909,7 +4909,7 @@ TclFloor( mp_int b; mp_init(&b); - if (mp_cmp_d(a, 0) == MP_LT) { + if (mp_isneg(a)) { mp_neg(a, &b); r = -TclCeil(&b); } else { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 55315f2..c7812b6 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2159,7 +2159,7 @@ Tcl_AppendFormatToObj( if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { goto error; } - isNegative = (mp_cmp_d(&big, 0) == MP_LT); + isNegative = mp_isneg(&big); #ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { @@ -2174,7 +2174,7 @@ Tcl_AppendFormatToObj( Tcl_GetWideIntFromObj(NULL, objPtr, &w); Tcl_DecrRefCount(objPtr); } - isNegative = (w < (Tcl_WideInt) 0); + isNegative = (w < 0); #endif } else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) { if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { @@ -2327,14 +2327,14 @@ Tcl_AppendFormatToObj( if (useShort) { unsigned short us = (unsigned short) s; - bits = (Tcl_WideUInt) us; + bits = (Tcl_WideUInt)us; while (us) { numDigits++; us /= base; } #ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { - Tcl_WideUInt uw = (Tcl_WideUInt) w; + Tcl_WideUInt uw = (Tcl_WideUInt)w; bits = uw; while (uw) { @@ -2347,7 +2347,7 @@ Tcl_AppendFormatToObj( mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover); numDigits = 1 + - (((Tcl_WideInt) big.used * MP_DIGIT_BIT) / numBits); + (((Tcl_WideInt)big.used * MP_DIGIT_BIT) / numBits); while ((mask & big.dp[big.used-1]) == 0) { numDigits--; mask >>= numBits; @@ -2360,7 +2360,7 @@ Tcl_AppendFormatToObj( } else if (!useBig) { unsigned long ul = (unsigned long) l; - bits = (Tcl_WideUInt) ul; + bits = (Tcl_WideUInt)ul; while (ul) { numDigits++; ul /= base; @@ -2384,7 +2384,7 @@ Tcl_AppendFormatToObj( if (useBig && !mp_iszero(&big)) { if (index < big.used && (size_t) shift < CHAR_BIT*sizeof(Tcl_WideUInt) - MP_DIGIT_BIT) { - bits |= ((Tcl_WideUInt) big.dp[index++]) << shift; + bits |= ((Tcl_WideUInt)big.dp[index++]) << shift; shift += MP_DIGIT_BIT; } shift -= numBits; @@ -2635,7 +2635,7 @@ NewLongObj( mp_init_u64(&bignumValue, (unsigned long)value); return Tcl_NewBignumObj(&bignumValue); #else - return Tcl_NewWideIntObj((unsigned long)value | ~(unsigned long)LONG_MAX); + return Tcl_NewWideIntObj((unsigned long)value); #endif } return Tcl_NewLongObj(value); diff --git a/generic/tclTest.c b/generic/tclTest.c index 21c6d65..2fd6714 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3295,7 +3295,7 @@ TestlinkCmd( return TCL_ERROR; } Tcl_DecrRefCount(tmp); - uwideVar = (Tcl_WideUInt) w; + uwideVar = (Tcl_WideUInt)w; } } else if (strcmp(argv[1], "update") == 0) { int v; @@ -3412,7 +3412,7 @@ TestlinkCmd( return TCL_ERROR; } Tcl_DecrRefCount(tmp); - uwideVar = (Tcl_WideUInt) w; + uwideVar = (Tcl_WideUInt)w; Tcl_UpdateLinkedVar(interp, "uwide"); } } else { @@ -5983,7 +5983,7 @@ TestChannelCmd( } Tcl_SetObjResult(interp, Tcl_NewWideIntObj( - (Tcl_WideInt) (size_t) Tcl_GetChannelThread(chan))); + (Tcl_WideInt)(size_t)Tcl_GetChannelThread(chan))); return TCL_OK; } diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 914c6f0..4d89a7e 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -290,9 +290,9 @@ TestbignumobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], mp_iszero(&bignumValue)); + Tcl_SetBooleanObj(varPtr[varIndex], mp_iszero(&bignumValue)); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iszero(&bignumValue))); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(mp_iszero(&bignumValue))); } mp_clear(&bignumValue); break; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index e043212..0ecc0cf 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1980,7 +1980,7 @@ ZlibCmd( start = Tcl_ZlibAdler32(0, NULL, 0); } data = Tcl_GetByteArrayFromObj(objv[2], &dlen); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (uLong) Tcl_ZlibAdler32(start, data, dlen))); return TCL_OK; case CMD_CRC: /* crc32 str ?startvalue? @@ -1997,7 +1997,7 @@ ZlibCmd( start = Tcl_ZlibCRC32(0, NULL, 0); } data = Tcl_GetByteArrayFromObj(objv[2], &dlen); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (uLong) Tcl_ZlibCRC32(start, data, dlen))); return TCL_OK; case CMD_DEFLATE: /* deflate data ?level? @@ -2643,7 +2643,7 @@ ZlibStreamCmd( Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (uLong) Tcl_ZlibStreamChecksum(zstream))); return TCL_OK; case zs_reset: /* $strm reset */ diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 85a31e1..c6a24d1 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -187,7 +187,7 @@ TclpGetWideClicks(void) now = ((Tcl_WideInt)time.sec)*1000000 + time.usec; } else { #ifdef MAC_OSX_TCL - now = (Tcl_WideInt) (mach_absolute_time() & INT64_MAX); + now = (Tcl_WideInt)(mach_absolute_time() & INT64_MAX); #else #error Wide high-resolution clicks not implemented on this platform #endif diff --git a/win/tclWinFile.c b/win/tclWinFile.c index d0ff73e..38c6504 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -29,7 +29,7 @@ */ #define POSIX_EPOCH_AS_FILETIME \ - ((Tcl_WideInt) 116444736 * (Tcl_WideInt) 1000000000) + ((Tcl_WideInt)116444736 * (Tcl_WideInt)1000000000) /* * Declarations for 'link' related information. This information should come @@ -2094,8 +2094,8 @@ NativeStat( statPtr->st_ctime = ToCTime(data.ftCreationTime); } attr = data.dwFileAttributes; - statPtr->st_size = ((Tcl_WideInt) data.nFileSizeLow) | - (((Tcl_WideInt) data.nFileSizeHigh) << 32); + statPtr->st_size = ((Tcl_WideInt)data.nFileSizeLow) | + (((Tcl_WideInt)data.nFileSizeHigh) << 32); /* * On Unix, for directories, nlink apparently depends on the number of @@ -2142,8 +2142,8 @@ NativeStat( attr = data.dwFileAttributes; - statPtr->st_size = ((Tcl_WideInt) data.nFileSizeLow) | - (((Tcl_WideInt) data.nFileSizeHigh) << 32); + statPtr->st_size = ((Tcl_WideInt)data.nFileSizeLow) | + (((Tcl_WideInt)data.nFileSizeHigh) << 32); statPtr->st_atime = ToCTime(data.ftLastAccessTime); statPtr->st_mtime = ToCTime(data.ftLastWriteTime); statPtr->st_ctime = ToCTime(data.ftCreationTime); @@ -2303,7 +2303,7 @@ ToCTime( convertedTime.HighPart = (LONG) fileTime.dwHighDateTime; return (time_t) ((convertedTime.QuadPart - - (Tcl_WideInt) POSIX_EPOCH_AS_FILETIME) / (Tcl_WideInt) 10000000); + (Tcl_WideInt)POSIX_EPOCH_AS_FILETIME) / (Tcl_WideInt)10000000); } /* diff --git a/win/tclWinTime.c b/win/tclWinTime.c index b46c101..6d04550 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -97,11 +97,11 @@ static TimeInfo timeInfo = { (HANDLE) NULL, (HANDLE) NULL, #ifdef HAVE_CAST_TO_UNION - (LARGE_INTEGER) (Tcl_WideInt) 0, - (ULARGE_INTEGER) (DWORDLONG) 0, - (LARGE_INTEGER) (Tcl_WideInt) 0, - (LARGE_INTEGER) (Tcl_WideInt) 0, - (LARGE_INTEGER) (Tcl_WideInt) 0, + (LARGE_INTEGER) (Tcl_WideInt)0, + (ULARGE_INTEGER) (DWORDLONG)0, + (LARGE_INTEGER) (Tcl_WideInt)0, + (LARGE_INTEGER) (Tcl_WideInt)0, + (LARGE_INTEGER) (Tcl_WideInt)0, #else {{0, 0}}, {{0, 0}}, @@ -506,7 +506,7 @@ NativeGetMicroseconds(void) * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)1193182 * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)3579545 */ - && timeInfo.nominalFreq.QuadPart > (Tcl_WideInt) 15000000){ + && timeInfo.nominalFreq.QuadPart > 15000000){ /* * As an exception, if every logical processor on the system * is on the same chip, we use the performance counter anyway, @@ -1318,7 +1318,7 @@ AccumulateSample( estFreq = 10000000 * (perfCounter - workPCSample) / (fileTime - workFTSample); timeInfo.perfCounterSample[timeInfo.sampleNo] = perfCounter; - timeInfo.fileTimeSample[timeInfo.sampleNo] = (Tcl_WideInt) fileTime; + timeInfo.fileTimeSample[timeInfo.sampleNo] = fileTime; /* * Advance the sample number. -- cgit v0.12 From 561857f79ddc37df783119ffaa0beb5354379f3b Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 28 May 2024 12:52:09 +0000 Subject: ioTrans.test: removed constraint definition - notValgrind is already part of tcltest --- tests/ioTrans.test | 2 -- 1 file changed, 2 deletions(-) diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 4eafb6b..47006aa 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -2096,8 +2096,6 @@ test iortrans.tf-11.0 {origin thread of moved transform gone} -setup { thread::release $tidb } -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} -testConstraint notValgrind [expr {![testConstraint valgrind]}] - test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -setup { #puts <<$tcltest::mainThread>>main set tida [thread::create -preserved]; #puts <<$tida>> -- cgit v0.12 From 01ba0865d8ceaa19c915e6c65d14928d67e0e32d Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 28 May 2024 13:03:33 +0000 Subject: cmdMZ.test: more precise and fast _nrt_sleep, no failures with valgrind --- tests/cmdMZ.test | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index ff6efaa..cf63b9f 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -324,11 +324,15 @@ test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { # todo: rewrite this if monotonic clock is provided resp. command "after" # gets microsecond accuracy (RFE [fdfbd5e10] gets merged): proc _nrt_sleep {msec} { - set usec [expr {$msec * 1000}] set stime [clock microseconds] - while {abs([clock microseconds] - $stime) < $usec} { - # don't use after 0 unless it's NRT-capable, so yes - busy-wait (but it's more precise): - # after 0 + set usec [expr {$msec * 1000}] + set etime [expr {$stime + $usec}] + while {[set tm [clock microseconds]] < $etime} { + # don't use after 0 unless it's NRT-capable, so yes - busy-wait (but it's more precise): + # after 0 + if {$tm < $stime} { # avoid too long delays by backwards time jumps, simply skip test + tcltest::Skip "time-jump?" + } } } _nrt_sleep 0; # warm up (clock, compile, etc) @@ -408,6 +412,9 @@ test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} { test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measurement} -body { set m1 [timerate {_nrt_sleep 0.01} 50] set m2 [timerate {_nrt_sleep 1.00} 50] + if {[testConstraint valgrind] && ([lindex $m1 0] >= 100 || [lindex $m1 2] <= 500)} { + tcltest::Skip "too-slow-by-valgrind" + } list [list \ [expr {[lindex $m1 0] < [lindex $m2 0]}] \ [expr {[lindex $m1 0] < 100}] \ -- cgit v0.12 From 4675e3f16b23202f92aed5a60aafe5c334d5f844 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 29 May 2024 19:14:34 +0000 Subject: Another round of sentinel fixes for 8.6, NULL -> (char *)NULL --- generic/tclBinary.c | 2 +- generic/tclClock.c | 8 +++---- generic/tclCmdAH.c | 8 +++---- generic/tclCmdMZ.c | 2 +- generic/tclCompExpr.c | 2 +- generic/tclConfig.c | 6 +++--- generic/tclDate.c | 16 +++++++------- generic/tclDictObj.c | 12 +++++------ generic/tclEncoding.c | 4 ++-- generic/tclEvent.c | 6 +++--- generic/tclFCmd.c | 6 +++--- generic/tclFileName.c | 2 +- generic/tclGetDate.y | 16 +++++++------- generic/tclIOCmd.c | 4 ++-- generic/tclInterp.c | 2 +- generic/tclListObj.c | 10 ++++----- generic/tclLoad.c | 26 +++++++++++------------ generic/tclOO.c | 18 ++++++++-------- generic/tclOOBasic.c | 42 ++++++++++++++++++------------------- generic/tclOOMethod.c | 6 +++--- generic/tclObj.c | 22 +++++++++---------- generic/tclPathObj.c | 6 +++--- generic/tclPipe.c | 8 +++---- generic/tclPkg.c | 28 ++++++++++++------------- generic/tclProc.c | 30 +++++++++++++------------- generic/tclRegexp.c | 2 +- generic/tclResult.c | 14 ++++++------- generic/tclScan.c | 2 +- generic/tclStrToD.c | 4 ++-- generic/tclTest.c | 32 ++++++++++++++-------------- generic/tclThreadTest.c | 2 +- generic/tclTimer.c | 4 ++-- generic/tclTrace.c | 8 +++---- generic/tclUtil.c | 18 ++++++++-------- generic/tclVar.c | 56 ++++++++++++++++++++++++------------------------- 35 files changed, 217 insertions(+), 217 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 8971334..cbcb4a1 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2437,7 +2437,7 @@ BinaryDecodeHex( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid hexadecimal digit \"%c\" at position %d", ch, (int) (data - datastart - 1))); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (char *)NULL); return TCL_ERROR; } diff --git a/generic/tclClock.c b/generic/tclClock.c index 071f533..5d39de4 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1064,7 +1064,7 @@ ConvertUTCToLocalUsingC( if ((Tcl_WideInt)tock != fields->seconds) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "number too large to represent as a Posix time", -1)); - Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL); + Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", (char *)NULL); return TCL_ERROR; } TzsetIfNecessary(); @@ -1073,7 +1073,7 @@ ConvertUTCToLocalUsingC( Tcl_SetObjResult(interp, Tcl_NewStringObj( "localtime failed (clock value may be too " "large/small to represent)", -1)); - Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL); + Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", (char *)NULL); return TCL_ERROR; } @@ -1925,7 +1925,7 @@ ClockParseformatargsObjCmd( Tcl_WrongNumArgs(interp, 0, objv, "clock format clockval ?-format string? " "?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"); - Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", NULL); + Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", (char *)NULL); return TCL_ERROR; } @@ -1972,7 +1972,7 @@ ClockParseformatargsObjCmd( if ((saw & (1 << CLOCK_FORMAT_GMT)) && (saw & (1 << CLOCK_FORMAT_TIMEZONE))) { Tcl_SetObjResult(interp, litPtr[LIT_CANNOT_USE_GMT_AND_TIMEZONE]); - Tcl_SetErrorCode(interp, "CLOCK", "gmtWithTimezone", NULL); + Tcl_SetErrorCode(interp, "CLOCK", "gmtWithTimezone", (char *)NULL); return TCL_ERROR; } if (gmtFlag) { diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index a26254c..adbe9a6 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2063,7 +2063,7 @@ PathFilesystemCmd( if (fsInfo == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", - TclGetString(objv[1]), NULL); + TclGetString(objv[1]), (char *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, fsInfo); @@ -2213,7 +2213,7 @@ PathSplitCmd( "could not read \"%s\": no such file or directory", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH", - NULL); + (char *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, res); @@ -2315,7 +2315,7 @@ FilesystemSeparatorCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "unrecognised path", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM", - TclGetString(objv[1]), NULL); + TclGetString(objv[1]), (char *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, separatorObj); @@ -2681,7 +2681,7 @@ TclNRForIterCallback( Tcl_ResetResult(interp); TclNewObj(boolObj); TclNRAddCallback(interp, ForCondCallback, iterPtr, boolObj, NULL, - NULL); + (char *)NULL); return Tcl_NRExprObj(interp, iterPtr->cond, boolObj); case TCL_BREAK: result = TCL_OK; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index a6e9ffd..cfccd5e 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1863,7 +1863,7 @@ StringMapCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\": must be -nocase", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string, NULL); + string, (char *)NULL); return TCL_ERROR; } } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 989ca79..313c51f 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1439,7 +1439,7 @@ ParseExpr( parsePtr->string, (numBytes < limit) ? "" : "...")); if (errCode) { Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode, - subErrCode, NULL); + subErrCode, (char *)NULL); } } diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 8fe8fc9..f00a568 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -230,7 +230,7 @@ QueryConfigObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", - Tcl_GetString(pkgName), NULL); + Tcl_GetString(pkgName), (char *)NULL); return TCL_ERROR; } @@ -245,7 +245,7 @@ QueryConfigObjCmd( || val == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", - Tcl_GetString(objv[2]), NULL); + Tcl_GetString(objv[2]), (char *)NULL); return TCL_ERROR; } @@ -278,7 +278,7 @@ QueryConfigObjCmd( if (!listPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "insufficient memory to create list", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); return TCL_ERROR; } diff --git a/generic/tclDate.c b/generic/tclDate.c index d3b6947..7e2aded 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2792,12 +2792,12 @@ TclClockOldscanObjCmd( if (status == 1) { Tcl_SetObjResult(interp, dateInfo.messages); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", (char *)NULL); return TCL_ERROR; } else if (status == 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1)); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); return TCL_ERROR; } else if (status != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned " @@ -2805,7 +2805,7 @@ TclClockOldscanObjCmd( "report this error as a " "bug in Tcl.", -1)); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "BUG", NULL); + Tcl_SetErrorCode(interp, "TCL", "BUG", (char *)NULL); return TCL_ERROR; } Tcl_DecrRefCount(dateInfo.messages); @@ -2813,31 +2813,31 @@ TclClockOldscanObjCmd( if (yyHaveDate > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one date in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL); return TCL_ERROR; } if (yyHaveTime > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time of day in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL); return TCL_ERROR; } if (yyHaveZone > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time zone in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL); return TCL_ERROR; } if (yyHaveDay > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one weekday in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL); return TCL_ERROR; } if (yyHaveOrdinalMonth > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one ordinal month in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL); return TCL_ERROR; } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 3cd9f43..d67de7c 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -720,7 +720,7 @@ SetDictFromAny( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing value to go with key", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", (char *)NULL); } errorInFindDictElement: DeleteChainTable(dict); @@ -796,7 +796,7 @@ TclTraceDictPath( "key \"%s\" not known in dictionary", TclGetString(keyv[i]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(keyv[i]), NULL); + TclGetString(keyv[i]), (char *)NULL); } return NULL; } @@ -1725,7 +1725,7 @@ DictGetCmd( "key \"%s\" not known in dictionary", TclGetString(objv[objc-1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(objv[objc-1]), NULL); + TclGetString(objv[objc-1]), (char *)NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, valuePtr); @@ -2517,7 +2517,7 @@ DictForNRCmd( if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); - Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", (char *)NULL); return TCL_ERROR; } searchPtr = (Tcl_DictSearch *)TclStackAlloc(interp, sizeof(Tcl_DictSearch)); @@ -2712,7 +2712,7 @@ DictMapNRCmd( if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); - Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", (char *)NULL); return TCL_ERROR; } storagePtr = (DictMapStorage *)TclStackAlloc(interp, sizeof(DictMapStorage)); @@ -3151,7 +3151,7 @@ DictFilterCmd( if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); - Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", NULL); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", (char *)NULL); return TCL_ERROR; } keyVarObj = varv[0]; diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index bbcaeb9..e1f2536 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1575,7 +1575,7 @@ OpenEncodingFileChannel( if ((NULL == chan) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown encoding \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (char *)NULL); } Tcl_DecrRefCount(fileNameObj); Tcl_DecrRefCount(searchPath); @@ -1649,7 +1649,7 @@ LoadEncodingFile( if ((encoding == NULL) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid encoding file \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (char *)NULL); } Tcl_Close(NULL, chan); diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 49880b6..99d5e0a 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -327,7 +327,7 @@ TclDefaultBgErrorHandlerObjCmd( if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-level\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) { @@ -337,7 +337,7 @@ TclDefaultBgErrorHandlerObjCmd( if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-code\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) { @@ -1425,7 +1425,7 @@ Tcl_VwaitObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't wait for variable \"%s\": would wait forever", nameString)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL); + Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", (char *)NULL); return TCL_ERROR; } if (!done) { diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 56445b6..e550882 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1080,7 +1080,7 @@ TclFileAttrsCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); + Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", (char *)NULL); goto end; } @@ -1107,7 +1107,7 @@ TclFileAttrsCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); + Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", (char *)NULL); goto end; } @@ -1123,7 +1123,7 @@ TclFileAttrsCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR", - "NOVALUE", NULL); + "NOVALUE", (char *)NULL); goto end; } if (Tcl_FSFileAttrsSet(interp, index, filePtr, diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 7e24552..1fc89dc 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1539,7 +1539,7 @@ Tcl_GlobObjCmd( badTypesArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument to \"-types\": %s", - TclGetString(look))); + Tcl_GetString(look))); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (char *)NULL); result = TCL_ERROR; join = 0; diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index f73f9ce..3a55b8e 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -1013,12 +1013,12 @@ TclClockOldscanObjCmd( if (status == 1) { Tcl_SetObjResult(interp, dateInfo.messages); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", (char *)NULL); return TCL_ERROR; } else if (status == 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1)); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); return TCL_ERROR; } else if (status != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned " @@ -1026,7 +1026,7 @@ TclClockOldscanObjCmd( "report this error as a " "bug in Tcl.", -1)); Tcl_DecrRefCount(dateInfo.messages); - Tcl_SetErrorCode(interp, "TCL", "BUG", NULL); + Tcl_SetErrorCode(interp, "TCL", "BUG", (char *)NULL); return TCL_ERROR; } Tcl_DecrRefCount(dateInfo.messages); @@ -1034,31 +1034,31 @@ TclClockOldscanObjCmd( if (yyHaveDate > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one date in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL); return TCL_ERROR; } if (yyHaveTime > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time of day in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL); return TCL_ERROR; } if (yyHaveZone > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time zone in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL); return TCL_ERROR; } if (yyHaveDay > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one weekday in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL); return TCL_ERROR; } if (yyHaveOrdinalMonth > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one ordinal month in string", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL); return TCL_ERROR; } diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index cdcef10..0c8af09 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -450,7 +450,7 @@ Tcl_ReadObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected non-negative integer but got \"%s\"", TclGetString(objv[i]))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (char *)NULL); return TCL_ERROR; } newline = 1; @@ -1386,7 +1386,7 @@ AcceptCallbackProc( Tcl_RegisterChannel(NULL, chan); result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), - " ", address, " ", portBuf, NULL); + " ", address, " ", portBuf, (char *)NULL); if (result != TCL_OK) { Tcl_BackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ad06293..c34cbbf 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3118,7 +3118,7 @@ ChildMarkTrusted( "permission denied: safe interpreter cannot mark trusted", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", - NULL); + (char *)NULL); return TCL_ERROR; } ((Interp *) childInterp)->flags &= ~SAFE_INTERP; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index b2d6228..f063599 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -168,7 +168,7 @@ AttemptNewList( "list creation failed: unable to alloc %u bytes", LIST_SIZE(objc))); } - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return listRepPtr; } @@ -582,7 +582,7 @@ Tcl_ListObjAppendElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return TCL_ERROR; } @@ -1447,7 +1447,7 @@ TclLsetFlat( Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", - "BADINDEX", NULL); + "BADINDEX", (char *)NULL); } result = TCL_ERROR; break; @@ -1637,7 +1637,7 @@ TclListObjSetElement( Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", - "BADINDEX", NULL); + "BADINDEX", (char *)NULL); } return TCL_ERROR; } @@ -1659,7 +1659,7 @@ TclListObjSetElement( Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX", - NULL); + (char *)NULL); } return TCL_ERROR; } diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 28117f5..df9ef7d 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -185,7 +185,7 @@ Tcl_LoadObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "must specify either file name or package name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", - NULL); + (char *)NULL); code = TCL_ERROR; goto done; } @@ -253,7 +253,7 @@ Tcl_LoadObjCmd( "file \"%s\" is already loaded for package \"%s\"", fullFileName, pkgPtr->packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "SPLITPERSONALITY", NULL); + "SPLITPERSONALITY", (char *)NULL); code = TCL_ERROR; Tcl_MutexUnlock(&packageMutex); goto done; @@ -290,7 +290,7 @@ Tcl_LoadObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "package \"%s\" isn't loaded statically", packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", - NULL); + (char *)NULL); code = TCL_ERROR; goto done; } @@ -349,7 +349,7 @@ Tcl_LoadObjCmd( "couldn't figure out package name for %s", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "WHATPACKAGE", NULL); + "WHATPACKAGE", (char *)NULL); code = TCL_ERROR; goto done; } @@ -446,7 +446,7 @@ Tcl_LoadObjCmd( "can't use package in a safe interpreter: no" " %s_SafeInit procedure", pkgPtr->packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", - NULL); + (char *)NULL); code = TCL_ERROR; goto done; } @@ -457,7 +457,7 @@ Tcl_LoadObjCmd( "can't attach package to interpreter: no %s_Init procedure", pkgPtr->packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", - NULL); + (char *)NULL); code = TCL_ERROR; goto done; } @@ -608,7 +608,7 @@ Tcl_UnloadObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj( "must specify either file name or package name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", - NULL); + (char *)NULL); code = TCL_ERROR; goto done; } @@ -682,7 +682,7 @@ Tcl_UnloadObjCmd( "package \"%s\" is loaded statically and cannot be unloaded", packageName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", - NULL); + (char *)NULL); code = TCL_ERROR; goto done; } @@ -694,7 +694,7 @@ Tcl_UnloadObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "file \"%s\" has never been loaded", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", - NULL); + (char *)NULL); code = TCL_ERROR; goto done; } @@ -724,7 +724,7 @@ Tcl_UnloadObjCmd( "file \"%s\" has never been loaded in this interpreter", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", - NULL); + (char *)NULL); code = TCL_ERROR; goto done; } @@ -741,7 +741,7 @@ Tcl_UnloadObjCmd( "file \"%s\" cannot be unloaded under a safe interpreter", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - NULL); + (char *)NULL); code = TCL_ERROR; goto done; } @@ -752,7 +752,7 @@ Tcl_UnloadObjCmd( "file \"%s\" cannot be unloaded under a trusted interpreter", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - NULL); + (char *)NULL); code = TCL_ERROR; goto done; } @@ -893,7 +893,7 @@ Tcl_UnloadObjCmd( "file \"%s\" cannot be unloaded: unloading disabled", fullFileName)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED", - NULL); + (char *)NULL); code = TCL_ERROR; #endif } diff --git a/generic/tclOO.c b/generic/tclOO.c index 86c4087..a7aeeeb 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1773,7 +1773,7 @@ TclNewObjectInstanceCommon( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create object \"%s\": command already exists with" " that name", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", (char *)NULL); return NULL; } } @@ -1827,7 +1827,7 @@ FinalizeAlloc( if (result != TCL_ERROR && Destructing(oPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "object deleted in constructor", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", (char *)NULL); result = TCL_ERROR; } if (result != TCL_OK) { @@ -1896,7 +1896,7 @@ Tcl_CopyObjectInstance( if (IsRootClass(oPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not clone the class of classes", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", (char *)NULL); return NULL; } @@ -2587,7 +2587,7 @@ TclOOObjectCmdCore( "impossible to invoke method \"%s\": no defined method or" " unknown method", TclGetString(methodNamePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED", - TclGetString(methodNamePtr), NULL); + TclGetString(methodNamePtr), (char *)NULL); return TCL_ERROR; } } else { @@ -2603,7 +2603,7 @@ TclOOObjectCmdCore( "impossible to invoke method \"%s\": no defined method or" " unknown method", TclGetString(methodNamePtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(methodNamePtr), NULL); + TclGetString(methodNamePtr), (char *)NULL); return TCL_ERROR; } } @@ -2630,7 +2630,7 @@ TclOOObjectCmdCore( Tcl_SetObjResult(interp, Tcl_NewStringObj( "no valid method implementation", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(methodNamePtr), NULL); + TclGetString(methodNamePtr), (char *)NULL); TclOODeleteContext(contextPtr); return TCL_ERROR; } @@ -2711,7 +2711,7 @@ Tcl_ObjectContextInvokeNext( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no next %s implementation", methodType)); - Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", (char *)NULL); return TCL_ERROR; } @@ -2780,7 +2780,7 @@ TclNRObjectContextInvokeNext( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no next %s implementation", methodType)); - Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", (char *)NULL); return TCL_ERROR; } @@ -2859,7 +2859,7 @@ Tcl_GetObjectFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s does not refer to an object", TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr), - NULL); + (char *)NULL); return NULL; } diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index e746b64..40a70c2 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -169,7 +169,7 @@ TclOO_Class_Create( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "object \"%s\" is not a class", TclGetString(cmdnameObj))); - Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (char *)NULL); return TCL_ERROR; } @@ -187,7 +187,7 @@ TclOO_Class_Create( if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "object name must not be empty", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL); return TCL_ERROR; } @@ -234,7 +234,7 @@ TclOO_Class_CreateNs( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "object \"%s\" is not a class", TclGetString(cmdnameObj))); - Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (char *)NULL); return TCL_ERROR; } @@ -252,7 +252,7 @@ TclOO_Class_CreateNs( if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "object name must not be empty", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL); return TCL_ERROR; } nsName = Tcl_GetStringFromObj( @@ -260,7 +260,7 @@ TclOO_Class_CreateNs( if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "namespace name must not be empty", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL); return TCL_ERROR; } @@ -305,7 +305,7 @@ TclOO_Class_New( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "object \"%s\" is not a class", TclGetString(cmdnameObj))); - Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (char *)NULL); return TCL_ERROR; } @@ -538,7 +538,7 @@ TclOO_Object_Unknown( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "object \"%s\" has no %s", TclGetString(tmpBuf), piece)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[skip]), NULL); + TclGetString(objv[skip]), (char *)NULL); return TCL_ERROR; } @@ -557,7 +557,7 @@ TclOO_Object_Unknown( ckfree(methodNames); Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[skip]), NULL); + TclGetString(objv[skip]), (char *)NULL); return TCL_ERROR; } @@ -614,7 +614,7 @@ TclOO_Object_LinkVar( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "variable name \"%s\" illegal: must not contain namespace" " separator", varName)); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", (char *)NULL); return TCL_ERROR; } @@ -643,7 +643,7 @@ TclOO_Object_LinkVar( TclVarErrMsg(interp, varName, NULL, "define", "name refers to an element in an array"); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", (char *)NULL); return TCL_ERROR; } @@ -718,7 +718,7 @@ TclOO_Object_VarName( TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar); Tcl_DecrRefCount(varNamePtr); if (varPtr == NULL) { - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (char *)NULL); return TCL_ERROR; } @@ -789,7 +789,7 @@ TclOONextObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s may only be called from inside a method", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL); return TCL_ERROR; } context = framePtr->clientData; @@ -829,7 +829,7 @@ TclOONextToObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s may only be called from inside a method", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL); return TCL_ERROR; } contextPtr = framePtr->clientData; @@ -850,7 +850,7 @@ TclOONextToObjCmd( if (classPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not a class", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", (char *)NULL); return TCL_ERROR; } @@ -899,14 +899,14 @@ TclOONextToObjCmd( "%s implementation by \"%s\" not reachable from here", methodType, TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", - NULL); + (char *)NULL); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s has no non-filter implementation by \"%s\"", methodType, TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", (char *)NULL); return TCL_ERROR; } @@ -969,7 +969,7 @@ TclOOSelfObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s may only be called from inside a method", TclGetString(objv[0]))); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL); return TCL_ERROR; } @@ -1004,7 +1004,7 @@ TclOOSelfObjCmd( if (clsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "method not defined by a class", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL); return TCL_ERROR; } @@ -1025,7 +1025,7 @@ TclOOSelfObjCmd( if (!CurrentlyInvoked(contextPtr).isFilter) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "not inside a filtering context", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL); return TCL_ERROR; } else { struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr); @@ -1051,7 +1051,7 @@ TclOOSelfObjCmd( !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){ Tcl_SetObjResult(interp, Tcl_NewStringObj( "caller is not an object", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL); return TCL_ERROR; } else { CallContext *callerPtr = framePtr->callerVarPtr->clientData; @@ -1119,7 +1119,7 @@ TclOOSelfObjCmd( if (!CurrentlyInvoked(contextPtr).isFilter) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "not inside a filtering context", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL); return TCL_ERROR; } else { Method *mPtr; diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 5cff201..5633130 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -845,7 +845,7 @@ PushMethodCallFrame( pmPtr->procPtr->cmdPtr = &pmPtr->cmd; if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { - ByteCode *codePtr = + ByteCode *codePtr = (ByteCode *) pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; codePtr->nsPtr = nsPtr; @@ -1356,7 +1356,7 @@ TclOONewForwardInstanceMethod( if (prefixLen < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "method forward prefix must be non-empty", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", (char *)NULL); return NULL; } @@ -1395,7 +1395,7 @@ TclOONewForwardMethod( if (prefixLen < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "method forward prefix must be non-empty", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", (char *)NULL); return NULL; } diff --git a/generic/tclObj.c b/generic/tclObj.c index 284a431..35c62c3 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -976,7 +976,7 @@ Tcl_ConvertToType( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't convert value to type %s", typePtr->name)); - Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", NULL); + Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", (char *)NULL); } return TCL_ERROR; } @@ -1996,7 +1996,7 @@ TclSetBooleanFromAny( Tcl_AppendLimitedToObj(msg, str, length, 50, ""); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", (char *)NULL); } return TCL_ERROR; } @@ -2285,7 +2285,7 @@ Tcl_GetDoubleFromObj( Tcl_SetObjResult(interp, Tcl_NewStringObj( "floating point value is Not a Number", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", - NULL); + (char *)NULL); } return TCL_ERROR; } @@ -2508,7 +2508,7 @@ Tcl_GetIntFromObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", Tcl_GetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL); } return TCL_ERROR; } @@ -2518,7 +2518,7 @@ Tcl_GetIntFromObj( const char *s = "integer value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL); } return TCL_ERROR; } @@ -2797,7 +2797,7 @@ Tcl_GetLongFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL); } return TCL_ERROR; } @@ -2839,7 +2839,7 @@ Tcl_GetLongFromObj( Tcl_Obj *msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL); } return TCL_ERROR; } @@ -3093,7 +3093,7 @@ Tcl_GetWideIntFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL); } return TCL_ERROR; } @@ -3130,7 +3130,7 @@ Tcl_GetWideIntFromObj( Tcl_Obj *msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL); } return TCL_ERROR; } @@ -3398,7 +3398,7 @@ GetBignumFromObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "insufficient memory to unpack bignum", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return TCL_ERROR; } @@ -3429,7 +3429,7 @@ GetBignumFromObj( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL); } return TCL_ERROR; } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index f5571e2..a17c343 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1523,7 +1523,7 @@ MakePathFromNormalized( Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't find object string representation", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", - NULL); + (char *)NULL); } return TCL_ERROR; } @@ -2397,7 +2397,7 @@ SetFsPathFromAny( "couldn't find HOME environment variable to" " expand path", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", - "HOMELESS", NULL); + "HOMELESS", (char *)NULL); } return TCL_ERROR; } @@ -2422,7 +2422,7 @@ SetFsPathFromAny( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "user \"%s\" doesn't exist", expandedUser)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", - NULL); + (char *)NULL); } Tcl_DStringFree(&userName); Tcl_DStringFree(&temp); diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 2c6f99b..676ee3a 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -327,7 +327,7 @@ TclCleanupChildren( if (WIFEXITED(waitStatus)) { if (interp != NULL) { snprintf(msg2, sizeof(msg2), "%u", WEXITSTATUS(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL); + Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, (char *)NULL); } abnormalExit = 1; } else if (interp != NULL) { @@ -336,20 +336,20 @@ TclCleanupChildren( if (WIFSIGNALED(waitStatus)) { p = Tcl_SignalMsg(WTERMSIG(waitStatus)); Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, - Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); + Tcl_SignalId(WTERMSIG(waitStatus)), p, (char *)NULL); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "child killed: %s\n", p)); } else if (WIFSTOPPED(waitStatus)) { p = Tcl_SignalMsg(WSTOPSIG(waitStatus)); Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, - Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL); + Tcl_SignalId(WSTOPSIG(waitStatus)), p, (char *)NULL); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "child suspended: %s\n", p)); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj( "child wait status didn't make sense\n", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "ODDWAITRESULT", msg1, NULL); + "ODDWAITRESULT", msg1, (char *)NULL); } } } diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 7e8db0e..8bce8b5 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -174,7 +174,7 @@ Tcl_PkgProvideEx( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "conflicting versions provided for package \"%s\": %s, then %s", name, TclGetString(pkgPtr->version), version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", (char *)NULL); return TCL_ERROR; } @@ -306,7 +306,7 @@ Tcl_PkgRequireEx( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Cannot load package \"%s\" in standalone executable:" " This package is not compiled with stub support", name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", (char *)NULL); return NULL; } @@ -326,7 +326,7 @@ Tcl_PkgRequireEx( } ov = Tcl_NewStringObj(version, -1); if (exact) { - Tcl_AppendStringsToObj(ov, "-", version, NULL); + Tcl_AppendStringsToObj(ov, "-", version, (char *)NULL); } Tcl_IncrRefCount(ov); if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { @@ -432,7 +432,7 @@ PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { if ((result != TCL_OK) && (result != TCL_ERROR)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad return code: %d", result)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", (char *)NULL); result = TCL_ERROR; } if (result == TCL_ERROR) { @@ -458,7 +458,7 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", (char *)NULL); AddRequirementsToResult(interp, reqc, reqv); return TCL_ERROR; } @@ -479,7 +479,7 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { "version conflict for package \"%s\": have %s, need", name, TclGetString(reqPtr->pkgPtr->version))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", - NULL); + (char *)NULL); AddRequirementsToResult(interp, reqc, reqv); return TCL_ERROR; } @@ -525,7 +525,7 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { " attempt to provide %s %s requires %s", name, (char *) pkgPtr->clientData, name)); AddRequirementsToResult(interp, reqc, reqv); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", (char *)NULL); return TCL_ERROR; } @@ -685,7 +685,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { " no version of package %s provided", name, versionToProvide, name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", - NULL); + (char *)NULL); } else { char *pvi, *vi; @@ -709,7 +709,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { name, versionToProvide, name, TclGetString(reqPtr->pkgPtr->version))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", NULL); + "WRONGPROVIDE", (char *)NULL); } } } @@ -721,7 +721,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { "attempt to provide package %s %s failed:" " bad return code: %s", name, versionToProvide, TclGetString(codePtr))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", (char *)NULL); TclDecrRefCount(codePtr); result = TCL_ERROR; } @@ -827,7 +827,7 @@ Tcl_PkgPresentEx( if (foundVersion == NULL) { Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, - NULL); + (char *)NULL); } return foundVersion; } @@ -840,7 +840,7 @@ Tcl_PkgPresentEx( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "package %s is not present", name)); } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, (char *)NULL); return NULL; } @@ -1508,7 +1508,7 @@ CheckVersionAndConvert( ckfree(ibuf); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected version number but got \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", (char *)NULL); return TCL_ERROR; } @@ -1771,7 +1771,7 @@ CheckRequirement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected versionMin-versionMax but got \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", (char *)NULL); return TCL_ERROR; } diff --git a/generic/tclProc.c b/generic/tclProc.c index 80d4c32..70cfbda 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -148,14 +148,14 @@ Tcl_ProcObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (char *)NULL); return TCL_ERROR; } if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (char *)NULL); return TCL_ERROR; } @@ -463,7 +463,7 @@ TclCreateProc( "precompiled header expects %d", procName, numArgs, procPtr->numArgs)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", NULL); + "BYTECODELIES", (char *)NULL); goto procError; } localPtr = procPtr->firstLocalPtr; @@ -493,14 +493,14 @@ TclCreateProc( Tcl_AppendToObj(errorObj, "\"", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); + "FORMALARGUMENTFORMAT", (char *)NULL); goto procError; } if ((fieldCount == 0) || (Tcl_GetCharLength(fieldValues[0]) == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); + "FORMALARGUMENTFORMAT", (char *)NULL); goto procError; } @@ -517,7 +517,7 @@ TclCreateProc( "formal parameter \"%s\" is an array element", TclGetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); + "FORMALARGUMENTFORMAT", (char *)NULL); goto procError; } } else if (p[0] == ':' && p[1] == ':') { @@ -527,7 +527,7 @@ TclCreateProc( Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); + "FORMALARGUMENTFORMAT", (char *)NULL); goto procError; } p++; @@ -555,7 +555,7 @@ TclCreateProc( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", NULL); + "BYTECODELIES", (char *)NULL); goto procError; } @@ -580,7 +580,7 @@ TclCreateProc( "default value inconsistent with precompiled body", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", NULL); + "BYTECODELIES", (char *)NULL); goto procError; } } @@ -731,7 +731,7 @@ TclGetFrame( levelError: Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", (char *)NULL); return -1; } @@ -833,7 +833,7 @@ TclObjGetFrame( } Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, (char *)NULL); return -1; } @@ -1087,7 +1087,7 @@ ProcWrongNumArgs( if (defPtr->value.objPtr != NULL) { TclNewObj(argObj); - Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL); + Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", (char *)NULL); } else if (defPtr->flags & VAR_IS_ARGS) { numArgs--; final = "?arg ...?"; @@ -1859,7 +1859,7 @@ InterpProcNR2( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invoked \"%s\" outside of a loop", ((result == TCL_BREAK) ? "break" : "continue"))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", (char *)NULL); result = TCL_ERROR; /* FALLTHRU */ @@ -1941,7 +1941,7 @@ TclProcCompileProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "a precompiled script jumped interps", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "CROSSINTERPBYTECODE", NULL); + "CROSSINTERPBYTECODE", (char *)NULL); return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; @@ -2446,7 +2446,7 @@ SetLambdaFromAny( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't interpret \"%s\" as a lambda expression", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (char *)NULL); return TCL_ERROR; } diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 3259b48..9620bb9 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -732,7 +732,7 @@ TclRegError( snprintf(cbuf, sizeof(cbuf), "%d", status); (void) TclReError(REG_ITOA, cbuf, sizeof(cbuf)); - Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL); + Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, (char *)NULL); } /* diff --git a/generic/tclResult.c b/generic/tclResult.c index 4b8775a..7364f3f 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1334,7 +1334,7 @@ TclProcessReturn( if (valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } else { - Tcl_SetErrorCode(interp, "NONE", NULL); + Tcl_SetErrorCode(interp, "NONE", (char *)NULL); } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], @@ -1416,7 +1416,7 @@ TclMergeReturnOptions( "bad %s value: expected dictionary but got \"%s\"", compare, TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", - NULL); + (char *)NULL); goto error; } @@ -1465,7 +1465,7 @@ TclMergeReturnOptions( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad -level value: expected non-negative integer but got" " \"%s\"", TclGetString(valuePtr))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", (char *)NULL); goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]); @@ -1488,7 +1488,7 @@ TclMergeReturnOptions( "bad -errorcode value: expected a list but got \"%s\"", TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE", - NULL); + (char *)NULL); goto error; } } @@ -1510,7 +1510,7 @@ TclMergeReturnOptions( "bad -errorstack value: expected a list but got \"%s\"", TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", - NULL); + (char *)NULL); goto error; } if (length % 2) { @@ -1522,7 +1522,7 @@ TclMergeReturnOptions( "forbidden odd-sized list for -errorstack: \"%s\"", TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", - "ODDSIZEDLIST_ERRORSTACK", NULL); + "ODDSIZEDLIST_ERRORSTACK", (char *)NULL); goto error; } } @@ -1675,7 +1675,7 @@ Tcl_SetReturnOptions( || (objc % 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected dict but got \"%s\"", TclGetString(options))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", (char *)NULL); code = TCL_ERROR; } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv, &mergedOpts, &code, &level)) { diff --git a/generic/tclScan.c b/generic/tclScan.c index 2861e0b..80f0f77 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -425,7 +425,7 @@ ValidateFormat( if (flags & SCAN_BIG) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unsigned bignum scans are invalid", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED", (char *)NULL); goto error; } break; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index a5d9ad1..432d11b 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1481,7 +1481,7 @@ TclParseNumber( Tcl_AppendToObj(msg, " (looks like invalid octal number)", -1); } Tcl_SetObjResult(interp, msg); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (char *)NULL); } } @@ -4693,7 +4693,7 @@ Tcl_InitBignumFromDouble( const char *s = "integer value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL); } return TCL_ERROR; } diff --git a/generic/tclTest.c b/generic/tclTest.c index 2fd6714..491fea0 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1397,7 +1397,7 @@ CreatedCommandProc( &info); if (!found) { Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand", - NULL); + (char *)NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "CreatedCommandProc in ", @@ -1418,7 +1418,7 @@ CreatedCommandProc2( found = Tcl_GetCommandInfo(interp, "value:at:", &info); if (!found) { Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand", - NULL); + (char *)NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "CreatedCommandProc2 in ", @@ -1769,7 +1769,7 @@ TestdstringCmd( } else { Tcl_AppendResult(interp, "bad gresult option \"", argv[2], "\": must be staticsmall, staticlarge, free, or special", - NULL); + (char *)NULL); return TCL_ERROR; } Tcl_DStringGetResult(interp, &dstring); @@ -2906,7 +2906,7 @@ TestgetplatformCmd( if (argc != 1) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - NULL); + (char *)NULL); return TCL_ERROR; } @@ -4639,23 +4639,23 @@ TestseterrorcodeCmd( } switch (argc) { case 1: - Tcl_SetErrorCode(interp, "NONE", NULL); + Tcl_SetErrorCode(interp, "NONE", (char *)NULL); break; case 2: - Tcl_SetErrorCode(interp, argv[1], NULL); + Tcl_SetErrorCode(interp, argv[1], (char *)NULL); break; case 3: - Tcl_SetErrorCode(interp, argv[1], argv[2], NULL); + Tcl_SetErrorCode(interp, argv[1], argv[2], (char *)NULL); break; case 4: - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL); + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], (char *)NULL); break; case 5: - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL); + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], (char *)NULL); break; case 6: Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], - argv[5], NULL); + argv[5], (char *)NULL); } return TCL_ERROR; } @@ -4735,7 +4735,7 @@ TestfeventCmd( } else { Tcl_AppendResult(interp, "called \"testfevent code\" before \"testfevent create\"", - NULL); + (char *)NULL); return TCL_ERROR; } } else if (strcmp(argv[1], "create") == 0) { @@ -7614,7 +7614,7 @@ TestconcatobjCmd( if (concatPtr == tmpPtr) { result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (a) concatObj is not a new obj ", - NULL); + (char *)NULL); switch (tmpPtr->refCount) { case 0: Tcl_AppendResult(interp, "(no new refCount)", NULL); @@ -7641,7 +7641,7 @@ TestconcatobjCmd( if (concatPtr == tmpPtr) { result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (b) concatObj is not a new obj ", - NULL); + (char *)NULL); switch (tmpPtr->refCount) { case 0: Tcl_AppendResult(interp, "(refCount removed?)", NULL); @@ -7770,7 +7770,7 @@ TestconcatobjCmd( if (concatPtr == tmpPtr) { result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (f) concatObj is not a new obj ", - NULL); + (char *)NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); switch (tmpPtr->refCount) { @@ -7801,7 +7801,7 @@ TestconcatobjCmd( if (concatPtr == tmpPtr) { result = TCL_ERROR; Tcl_AppendResult(interp, "\n\t* (g) concatObj is not a new obj ", - NULL); + (char *)NULL); (void) Tcl_ListObjLength(NULL, concatPtr, &len); switch (tmpPtr->refCount) { @@ -8165,7 +8165,7 @@ TestInterpResolverCmd( case 0: /*down*/ if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) { Tcl_AppendResult(interp, "could not remove the resolver scheme", - NULL); + (char *)NULL); return TCL_ERROR; } } diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 1302b4e..0040d75 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -917,7 +917,7 @@ ThreadSend( if (resultPtr->code != TCL_OK) { if (resultPtr->errorCode) { - Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL); + Tcl_SetErrorCode(interp, resultPtr->errorCode, (char *)NULL); ckfree(resultPtr->errorCode); } if (resultPtr->errorInfo) { diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 3b8bcd6..2a71717 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -833,7 +833,7 @@ Tcl_AfterObjCmd( "bad argument \"%s\": must be" " cancel, idle, info, or an integer", arg)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument", - arg, NULL); + arg, (char *)NULL); return TCL_ERROR; } } @@ -972,7 +972,7 @@ Tcl_AfterObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "event \"%s\" doesn't exist", eventStr)); - Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL); + Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, (char *)NULL); return TCL_ERROR; } else { Tcl_Obj *resultListPtr; diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 8b5f2c3..11f3af4 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -372,7 +372,7 @@ Tcl_TraceObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad operations \"%s\": should be one or more of rwua", flagOps)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", (char *)NULL); return TCL_ERROR; #endif } @@ -443,7 +443,7 @@ TraceExecutionObjCmd( "bad operation list \"\": must be one or more of" " enter, leave, enterstep, or leavestep", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", - NULL); + (char *)NULL); return TCL_ERROR; } for (i = 0; i < listLen; i++) { @@ -684,7 +684,7 @@ TraceCommandObjCmd( "bad operation list \"\": must be one or more of" " delete or rename", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", - NULL); + (char *)NULL); return TCL_ERROR; } @@ -883,7 +883,7 @@ TraceVariableObjCmd( "bad operation list \"\": must be one or more of" " array, read, unset, or write", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", - NULL); + (char *)NULL); return TCL_ERROR; } for (i = 0; i < listLen ; i++) { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index dab5c3a..0d2df75 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -652,7 +652,7 @@ FindElement( "%s element in braces followed by \"%.*s\" " "instead of space", typeStr, (int) (p2-p), p)); Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK", - NULL); + (char *)NULL); } return TCL_ERROR; } @@ -704,7 +704,7 @@ FindElement( "%s element in quotes followed by \"%.*s\" " "instead of space", typeStr, (int) (p2-p), p)); Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK", - NULL); + (char *)NULL); } return TCL_ERROR; } @@ -737,7 +737,7 @@ FindElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unmatched open brace in %s", typeStr)); Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "BRACE", - NULL); + (char *)NULL); } return TCL_ERROR; } else if (inQuotes) { @@ -745,7 +745,7 @@ FindElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unmatched open quote in %s", typeStr)); Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "QUOTE", - NULL); + (char *)NULL); } return TCL_ERROR; } @@ -892,7 +892,7 @@ Tcl_SplitList( Tcl_SetObjResult(interp, Tcl_NewStringObj( "internal error in Tcl_SplitList", -1)); Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", - NULL); + (char *)NULL); } return TCL_ERROR; } @@ -3698,7 +3698,7 @@ TclGetIntForIndex( bytes += 4; } TclCheckBadOctal(interp, bytes); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", (char *)NULL); } return TCL_ERROR; @@ -3822,7 +3822,7 @@ SetEndOffsetFromAny( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad index \"%s\": must be end?[+-]integer?", bytes)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", (char *)NULL); } return TCL_ERROR; } @@ -3858,7 +3858,7 @@ SetEndOffsetFromAny( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad index \"%s\": must be end?[+-]integer?", bytes)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", (char *)NULL); } return TCL_ERROR; } @@ -4701,7 +4701,7 @@ TclReToGlob( invalidGlob: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); - Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); + Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, (char *)NULL); } Tcl_DStringFree(dsPtr); return TCL_ERROR; diff --git a/generic/tclVar.c b/generic/tclVar.c index 5cc1f3a..428cc0c 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -302,7 +302,7 @@ NotArrayError( Tcl_SetObjResult(interp, Tcl_ObjPrintf("\"%s\" isn't an array", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, (char *)NULL); return TCL_ERROR; } @@ -611,7 +611,7 @@ TclObjLookupVarEx( if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, NOSUCHVAR, -1); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", (char *)NULL); } return NULL; } @@ -647,7 +647,7 @@ TclObjLookupVarEx( TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", - NULL); + (char *)NULL); } return NULL; } @@ -713,7 +713,7 @@ TclObjLookupVarEx( if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, errMsg, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(part1Ptr), NULL); + TclGetString(part1Ptr), (char *)NULL); } if (newPart2) { Tcl_DecrRefCount(part2Ptr); @@ -1086,7 +1086,7 @@ TclLookupArrayElement( TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NOSUCHVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); + arrayNamePtr?TclGetString(arrayNamePtr):NULL, (char *)NULL); } return NULL; } @@ -1101,7 +1101,7 @@ TclLookupArrayElement( TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, DANGLINGVAR, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); + arrayNamePtr?TclGetString(arrayNamePtr):NULL, (char *)NULL); } return NULL; } @@ -1121,7 +1121,7 @@ TclLookupArrayElement( TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NEEDARRAY, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL); + arrayNamePtr?TclGetString(arrayNamePtr):NULL, (char *)NULL); } return NULL; } @@ -1142,7 +1142,7 @@ TclLookupArrayElement( TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NOSUCHELEMENT, index); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", - TclGetString(elNamePtr), NULL); + TclGetString(elNamePtr), (char *)NULL); } } } @@ -1481,7 +1481,7 @@ TclPtrGetVarIdx( */ errorReturn: - Tcl_SetErrorCode(interp, "TCL", "READ", "VARNAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "READ", "VARNAME", (char *)NULL); if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); } @@ -1884,11 +1884,11 @@ TclPtrSetVarIdx( if (TclIsVarArrayElement(varPtr)) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", DANGLINGELEMENT, index); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", (char *)NULL); } else { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", DANGLINGVAR, index); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", (char *)NULL); } } goto earlyError; @@ -1901,7 +1901,7 @@ TclPtrSetVarIdx( if (TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISARRAY,index); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (char *)NULL); } goto earlyError; } @@ -2025,7 +2025,7 @@ TclPtrSetVarIdx( cleanup: if (resultPtr == NULL) { - Tcl_SetErrorCode(interp, "TCL", "WRITE", "VARNAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "VARNAME", (char *)NULL); } if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, arrayPtr); @@ -2498,7 +2498,7 @@ TclPtrUnsetVarIdx( if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", ((arrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); - Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL); + Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", (char *)NULL); } } @@ -3683,7 +3683,7 @@ ArraySetCmd( CleanupVar(varPtr, arrayPtr); TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", NEEDARRAY, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(arrayNameObj), NULL); + TclGetString(arrayNameObj), (char *)NULL); return TCL_ERROR; } @@ -3750,7 +3750,7 @@ ArraySetCmd( if (elemLen & 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "list must have an even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", (char *)NULL); return TCL_ERROR; } if (elemLen == 0) { @@ -3801,7 +3801,7 @@ ArraySetCmd( TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", NEEDARRAY, -1); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (char *)NULL); return TCL_ERROR; } } @@ -4185,7 +4185,7 @@ ObjMakeUpvar( "bad variable name \"%s\": can't create namespace " "variable that refers to procedure variable", TclGetString(myNamePtr))); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", (char *)NULL); return TCL_ERROR; } } @@ -4301,7 +4301,7 @@ TclPtrObjMakeUpvarIdx( "bad variable name \"%s\": can't create a scalar " "variable that looks like an array element", myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", - NULL); + (char *)NULL); return TCL_ERROR; } } @@ -4320,7 +4320,7 @@ TclPtrObjMakeUpvarIdx( if (varPtr == NULL) { TclObjVarErrMsg(interp, myNamePtr, NULL, "create", errMsg, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(myNamePtr), NULL); + TclGetString(myNamePtr), (char *)NULL); return TCL_ERROR; } } @@ -4328,14 +4328,14 @@ TclPtrObjMakeUpvarIdx( if (varPtr == otherPtr) { Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_NewStringObj( "can't upvar from variable to itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", (char *)NULL); return TCL_ERROR; } if (TclIsVarTraced(varPtr)) { Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( "variable \"%s\" has traces: can't use for upvar", myName)); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", (char *)NULL); return TCL_ERROR; } else if (!TclIsVarUndefined(varPtr)) { Var *linkPtr; @@ -4350,7 +4350,7 @@ TclPtrObjMakeUpvarIdx( if (!TclIsVarLink(varPtr)) { Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( "variable \"%s\" already exists", myName)); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", (char *)NULL); return TCL_ERROR; } @@ -4700,7 +4700,7 @@ Tcl_VariableObjCmd( TclObjVarErrMsg(interp, varNamePtr, NULL, "define", ISARRAYELEMENT, -1); - Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); + Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", (char *)NULL); return TCL_ERROR; } @@ -4851,7 +4851,7 @@ Tcl_UpvarObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(levelObj))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", - TclGetString(levelObj), NULL); + TclGetString(levelObj), (char *)NULL); return TCL_ERROR; } @@ -4943,7 +4943,7 @@ SetArraySearchObj( syntax: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "illegal search identifier \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, (char *)NULL); return TCL_ERROR; } @@ -5037,7 +5037,7 @@ ParseSearchId( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't find search \"%s\"", string)); badLookup: - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, (char *)NULL); return NULL; } @@ -5742,7 +5742,7 @@ ObjFindNamespaceVar( if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown variable \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, (char *)NULL); } return (Tcl_Var) varPtr; } -- cgit v0.12 From bc6f233de0035bc4d1152bcf906ae41c47baa696 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 31 May 2024 08:58:03 +0000 Subject: [7c934f4a3d] Make sure to also trap background errors --- tests/oo.test | 55 +++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 43 insertions(+), 12 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index 2662ed1..3201394 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4204,6 +4204,16 @@ test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable } {{-append -clear -set} {Get Set}} +proc ::bgerrorIntercept {varName body} { + catch {rename bgerror ___old_bgerror} + interp alias {} ::bgerror {} ::lappend $varName + try { + uplevel 1 $body + } finally { + rename ::bgerror "" + catch {rename ___old_bgerror bgerror} + } +} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { method eat {} {} @@ -4319,13 +4329,20 @@ test oo-35.7.1 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { } set ::result {} } -body { - set FH [RpcClient new] - $FH create_bug - $FH destroy + # In this case, sub-objects are deleted during major object NS cleanup and + # are trying to call back into the major object (which is mostky gone at + # this point). Things are messy; error is reported via bgerror as the + # avenue most likely to reach a user. + bgerrorIntercept ::result { + set FH [RpcClient new] + $FH create_bug + $FH destroy + update + } join $result \n } -cleanup { base destroy -} -result {} +} -result {impossible to invoke method "write": no defined method or unknown method} test oo-35.7.2 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { oo::class create base oo::class create RpcClient { @@ -4353,13 +4370,21 @@ test oo-35.7.2 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { } set ::result {} } -body { - set FH [RpcClient new] - $FH create_bug - $FH destroy + # In this case, sub-objects are deleted during major object NS cleanup, and + # we've a destructor on the major class to monitor when it happens. Things + # are still messy, but the order is clear; error is reported via bgerror as + # the avenue most likely to reach a user. + bgerrorIntercept ::result { + set FH [RpcClient new] + $FH create_bug + $FH destroy + update + } join $result \n } -cleanup { base destroy -} -result {Destroyed} +} -result {Destroyed +impossible to invoke method "write": no defined method or unknown method} test oo-35.7.3 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { oo::class create base oo::class create RpcClient { @@ -4394,14 +4419,20 @@ test oo-35.7.3 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { } set ::result {} } -body { - set FH [RpcClient new] - $FH create_bug - $FH destroy + # In this case, sub-objects are deleted while the destructor is running and + # the destroy is neat, so things work sanely. Error follows standard Tcl + # error flow route; bgerror is not used. + bgerrorIntercept ::result { + set FH [RpcClient new] + $FH create_bug + $FH destroy + update + } join $result \n } -cleanup { base destroy } -result "Destroyed\nRpcClient -> otto-111" - +rename bgerrorIntercept {} cleanupTests return -- cgit v0.12 From ee5a83885e20b459ae9d38cc5592b5a0caf098c1 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 31 May 2024 10:56:00 +0000 Subject: More elegant background error interception, used more widely in oo.test --- tests/oo.test | 50 ++++++++++++++++++++++++++++---------------------- 1 file changed, 28 insertions(+), 22 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index 3201394..41520a7 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -13,6 +13,20 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +# A helper for intercepting background errors +proc ::bgerrorIntercept {varName body} { + set old [interp bgerror {}] + interp bgerror {} [list apply {{var msg args} { + upvar #0 $var v + lappend v $msg + }} $varName] + try { + uplevel 1 $body + } finally { + interp bgerror {} $old + } +} + # The foundational objects oo::object and oo::class are sensitive to reference # counting errors and are deallocated only when an interp is deleted, so in @@ -668,28 +682,30 @@ test oo-3.6 {basic test of OO functionality: errors in destructor} -setup { } -result {1 foo {}} test oo-3.7 {basic test of OO functionality: errors in destructor} -setup { oo::class create cls - set result {} - proc bgerror msg {lappend ::result $msg} } -cleanup { cls destroy - rename bgerror {} } -body { oo::define cls destructor {error foo} - list [rename [cls create obj] {}] \ - [update idletasks] $result [info commands obj] -} -result {{} {} foo {}} + bgerrorIntercept result { + set result [cls create obj] + lappend result [rename obj {}] + update idletasks + lappend result [info commands obj] + } +} -result {::obj {} foo {}} test oo-3.8 {basic test of OO functionality: errors in destructor} -setup { oo::class create cls - set result {} - proc bgerror msg {lappend ::result $msg} } -cleanup { cls destroy - rename bgerror {} } -body { oo::define cls destructor {error foo} - list [namespace delete [info object namespace [cls create obj]]] \ - [update idletasks] $result [info commands obj] -} -result {{} {} foo {}} + bgerrorIntercept result { + set result [cls create obj] + lappend result [namespace delete [info object namespace obj]] + update idletasks + lappend result [info commands obj] + } +} -result {::obj {} foo {}} test oo-3.9 {Bug 2944404: deleting the object in the destructor} -setup { oo::class create cls set result {} @@ -4204,16 +4220,6 @@ test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable } {{-append -clear -set} {Get Set}} -proc ::bgerrorIntercept {varName body} { - catch {rename bgerror ___old_bgerror} - interp alias {} ::bgerror {} ::lappend $varName - try { - uplevel 1 $body - } finally { - rename ::bgerror "" - catch {rename ___old_bgerror bgerror} - } -} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { method eat {} {} -- cgit v0.12 From 2da2d370b8544b349e29bc2bf08e3fb7b5372d14 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 3 Jun 2024 11:37:47 +0000 Subject: Use (char *)NULL as end sentinel in documentation (as Linux man-pages already do too, e.g. [https://linux.die.net/man/3/tcl_appendresult]) --- doc/AddErrInfo.3 | 2 +- doc/Eval.3 | 2 +- doc/SetResult.3 | 2 +- doc/StringObj.3 | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3 index 99ec904..aad1cd7 100644 --- a/doc/AddErrInfo.3 +++ b/doc/AddErrInfo.3 @@ -68,7 +68,7 @@ If negative, all bytes up to the first null byte are used. The \fB\-errorcode\fR return option will be set to this value. .AP "const char" *element in String to record as one element of the \fB\-errorcode\fR return option. -Last \fIelement\fR argument must be NULL. +Last \fIelement\fR argument must be (char *)NULL. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. diff --git a/doc/Eval.3 b/doc/Eval.3 index 277d028..27ef204 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -151,7 +151,7 @@ of any length, concatenates them into a single string, then calls \fBTcl_Eval\fR to execute that string as a Tcl command. It returns the result of the command and also modifies \fIinterp->result\fR in the same way as \fBTcl_Eval\fR. -The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end +The last argument to \fBTcl_VarEval\fR must be (char *)NULL to indicate the end of arguments. .PP \fBTcl_VarEvalVA\fR is the same as \fBTcl_VarEval\fR except that diff --git a/doc/SetResult.3 b/doc/SetResult.3 index 0b0697a..549b1b5 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -149,7 +149,7 @@ It also manages conversion to and from the \fIresult\fR field of the \fIinterp\fR so as to handle backward-compatibility with old-style extensions. Any number of \fIresult\fR arguments may be passed in a single -call; the last argument in the list must be a NULL pointer. +call; the last argument in the list must (char *)NULL. .PP \fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that instead of taking a variable number of arguments it takes an argument list. diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 9ce4d16..91b852d 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -249,7 +249,7 @@ except that it can be passed more than one value to append and each value must be a null-terminated string (i.e. none of the values may contain internal null characters). Any number of \fIstring\fR arguments may be provided, but the last argument -must be a NULL pointer to indicate the end of the list. +must be (char *)NULL to indicate the end of the list. .PP \fBTcl_AppendStringsToObjVA\fR is the same as \fBTcl_AppendStringsToObj\fR except that instead of taking a variable number of arguments it takes an -- cgit v0.12 From 9fe1ca1deadbb5e38e31b93203ce6722c85251d4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 10 Jun 2024 10:12:38 +0000 Subject: Missing verb in SetResult.3 --- doc/SetResult.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/SetResult.3 b/doc/SetResult.3 index 549b1b5..4a68aac 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -149,7 +149,7 @@ It also manages conversion to and from the \fIresult\fR field of the \fIinterp\fR so as to handle backward-compatibility with old-style extensions. Any number of \fIresult\fR arguments may be passed in a single -call; the last argument in the list must (char *)NULL. +call; the last argument in the list must be (char *)NULL. .PP \fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that instead of taking a variable number of arguments it takes an argument list. -- cgit v0.12 From e6843a795b4572ae7dbe75d60b04cea43dae9c48 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 10 Jun 2024 15:25:23 +0000 Subject: Make installManPage more robust against newlines. Backported from 8.7 --- unix/installManPage | 43 +++++++++++++++++++++++++++++-------------- 1 file changed, 29 insertions(+), 14 deletions(-) diff --git a/unix/installManPage b/unix/installManPage index 1e29bb0..3d5fa7b 100755 --- a/unix/installManPage +++ b/unix/installManPage @@ -61,20 +61,35 @@ test -z "$Sym" && Loc="$Dir/" # Names=`sed -n ' # Look for a line that starts with .SH NAME - /^\.SH NAME/{ -# Read next line - n -# Remove all commas ... - s/,//g -# ... and backslash-escaped spaces. - s/\\\ //g -# Delete from \- to the end of line - s/ \\\-.*// -# Convert all non-space non-alphanum sequences -# to single underscores. - s/[^ A-Za-z0-9][^ A-Za-z0-9]*/_/g -# print the result and exit - p;q + /^\.SH NAME/,/^\./{ + + + /^\./!{ + + # Remove all commas... + s/,//g + + # ... and backslash-escaped spaces. + s/\\\ //g + + /\\\-.*/{ + # Delete from \- to the end of line + s/ \\\-.*// + h + s/.*/./ + x + } + + # Convert all non-space non-alphanum sequences + # to single underscores. + s/[^ A-Za-z0-9][^ A-Za-z0-9]*/_/g + p + g + /^\./{ + q + } + } + }' $ManPage` if test -z "$Names" ; then -- cgit v0.12 From 1cb534fcd6867c00fcd0b7e2a3f9537a825f820e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Jun 2024 09:49:35 +0000 Subject: Add some METHOD headers --- doc/encoding.n | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/doc/encoding.n b/doc/encoding.n index e78a8e7..8a0b163 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -33,6 +33,7 @@ formats. .PP Performs one of several encoding related operations, depending on \fIoption\fR. The legal \fIoption\fRs are: +.\" METHOD: convertfrom .TP \fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR . @@ -42,6 +43,7 @@ characters in \fIdata\fR are treated as binary data where the lower sequence of bytes is treated as a string in the specified \fIencoding\fR. If \fIencoding\fR is not specified, the current system encoding is used. +.\" METHOD: convertto .TP \fBencoding convertto\fR ?\fIencoding\fR? \fIstring\fR . @@ -51,6 +53,7 @@ string. Each byte is stored in the lower 8-bits of a Unicode character (indeed, the resulting string is a binary string as far as Tcl is concerned, at least initially). If \fIencoding\fR is not specified, the current system encoding is used. +.\" METHOD: dirs .TP \fBencoding dirs\fR ?\fIdirectoryList\fR? . @@ -63,6 +66,7 @@ search path. It is an error for \fIdirectoryList\fR to not be a valid list. If, when a search for an encoding data file is happening, an element in \fIdirectoryList\fR does not refer to a readable, searchable directory, that element is ignored. +.\" METHOD: names .TP \fBencoding names\fR . @@ -73,6 +77,7 @@ The encodings and .QW iso8859-1 are guaranteed to be present in the list. +.\" METHOD: system .TP \fBencoding system\fR ?\fIencoding\fR? . @@ -91,7 +96,7 @@ The result is the unicode codepoint: .QW "\eu306F" , which is the Hiragana letter HA. .SH "SEE ALSO" -Tcl_GetEncoding(3) +Tcl_GetEncoding(3), fconfigure(n) .SH KEYWORDS encoding, unicode .\" Local Variables: -- cgit v0.12 From 7ed586b080115e8bfdbe926e6d03f23637592bed Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Jun 2024 09:31:22 +0000 Subject: use "int fd" for file descriptors, like everywhere else in the code. Mark some parameters as unused --- tests/oo.test | 2 +- unix/tclUnixPipe.c | 41 ++++++++++++++++++++++------------------- 2 files changed, 23 insertions(+), 20 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index 41520a7..594b2cf 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4427,7 +4427,7 @@ test oo-35.7.3 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { } -body { # In this case, sub-objects are deleted while the destructor is running and # the destroy is neat, so things work sanely. Error follows standard Tcl - # error flow route; bgerror is not used. + # error flow route; bgerror is not used. bgerrorIntercept ::result { set FH [RpcClient new] $FH create_bug diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 1a2129d..2ad72c3 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -78,23 +78,23 @@ static int SetupStdFile(TclFile file, int type); */ static const Tcl_ChannelType pipeChannelType = { - "pipe", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ + "pipe", + TCL_CHANNEL_VERSION_5, TCL_CLOSE2PROC, /* Close proc. */ - PipeInputProc, /* Input proc. */ - PipeOutputProc, /* Output proc. */ + PipeInputProc, + PipeOutputProc, NULL, /* Seek proc. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ - PipeWatchProc, /* Initialize notifier. */ - PipeGetHandleProc, /* Get OS handles out of channel. */ - PipeClose2Proc, /* close2proc. */ - PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ - NULL, /* wide seek proc */ - NULL, /* thread action proc */ - NULL /* truncation */ + PipeWatchProc, + PipeGetHandleProc, + PipeClose2Proc, + PipeBlockModeProc, + NULL, /* Flush proc. */ + NULL, /* Bubbled event handler proc. */ + NULL, /* Seek proc. */ + NULL, /* Thread action proc. */ + NULL /* Truncation proc. */ }; /* @@ -283,6 +283,7 @@ TclpTempFileNameForLibrary( Tcl_Obj *path) /* Path name of the library in the VFS. */ { Tcl_Obj *retval = TclpTempFileName(); + (void)path; if (retval == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -827,7 +828,7 @@ TclpCreateCommandChannel( * background exec). */ { char channelName[16 + TCL_INTEGER_SPACE]; - int channelId; + int fd; PipeState *statePtr = (PipeState *)ckalloc(sizeof(PipeState)); int mode; @@ -851,13 +852,13 @@ TclpCreateCommandChannel( */ if (readFile) { - channelId = GetFd(readFile); + fd = GetFd(readFile); } else if (writeFile) { - channelId = GetFd(writeFile); + fd = GetFd(writeFile); } else if (errorFile) { - channelId = GetFd(errorFile); + fd = GetFd(errorFile); } else { - channelId = 0; + fd = 0; } /* @@ -866,7 +867,7 @@ TclpCreateCommandChannel( * natural to use "pipe%d". */ - snprintf(channelName, sizeof(channelName), "file%d", channelId); + snprintf(channelName, sizeof(channelName), "file%d", fd); statePtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, statePtr, mode); return statePtr->channel; @@ -897,6 +898,7 @@ Tcl_CreatePipe( int flags) /* Reserved for future use. */ { int fileNums[2]; + (void)flags; if (pipe(fileNums) < 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("pipe creation failed: %s", @@ -1359,6 +1361,7 @@ Tcl_PidObjCmd( PipeState *pipePtr; int i; Tcl_Obj *resultPtr; + (void)dummy; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); -- cgit v0.12 From f6f180df58c8c736937a105dbb2cdac6755f7c13 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Jun 2024 09:59:13 +0000 Subject: Add METHOD headers to documentation. Other doc cleanup, backported from 8.7/9.0 --- doc/SaveResult.3 | 1 + doc/SetResult.3 | 1 + doc/chan.n | 126 +++++++++++++++++++++++++++++++++---------------------- 3 files changed, 79 insertions(+), 49 deletions(-) diff --git a/doc/SaveResult.3 b/doc/SaveResult.3 index 918941e..fe532b6 100644 --- a/doc/SaveResult.3 +++ b/doc/SaveResult.3 @@ -27,6 +27,7 @@ int \fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR) .sp \fBTcl_DiscardResult\fR(\fIsavedPtr\fR) +.fi .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in diff --git a/doc/SetResult.3 b/doc/SetResult.3 index 4a68aac..9c6d47c 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -37,6 +37,7 @@ const char * \fBTcl_AppendElement\fR(\fIinterp, element\fR) .sp \fBTcl_FreeResult\fR(\fIinterp\fR) +.fi .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out diff --git a/doc/chan.n b/doc/chan.n index 77e9326..53f8123 100644 --- a/doc/chan.n +++ b/doc/chan.n @@ -21,6 +21,7 @@ channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR which correspond to the process's standard input, output and error streams respectively). \fIOption\fR indicates what to do with the channel; any unique abbreviation for \fIoption\fR is acceptable. Valid options are: +.\" METHOD: blocked .TP \fBchan blocked \fIchannelId\fR . @@ -30,6 +31,7 @@ process to block, and returns 1 if that was the case. It returns 0 otherwise. Note that this only ever returns 1 when the channel has been configured to be non-blocking; all Tcl channels have blocking turned on by default. +.\" METHOD: close .TP \fBchan close \fIchannelId\fR ?\fIdirection\fR? . @@ -90,6 +92,7 @@ system resource, which can change how other processes or systems respond to the Tcl program. .VE 8.6 .RE +.\" METHOD: configure .TP \fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... . @@ -112,8 +115,10 @@ for the options supported by that specific type of channel. For example, see the manual entry for the \fBsocket\fR command for additional options for sockets, and the \fBopen\fR command for additional options for serial devices. +.RE +.\" OPTION: -blocking .TP -\fB\-blocking\fR \fIboolean\fR +\fB\-blocking\fI boolean\fR . The \fB\-blocking\fR option determines whether I/O operations on the channel can cause the process to block indefinitely. The value of the @@ -125,8 +130,9 @@ documentation for those commands for details. For non-blocking mode to work correctly, the application must be using the Tcl event loop (e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR command). +.\" OPTION: -buffering .TP -\fB\-buffering\fR \fInewValue\fR +\fB\-buffering\fI newValue\fR . If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output until its internal buffer is full or until the \fBchan flush\fR @@ -139,13 +145,15 @@ channels that connect to terminal-like devices; for these channels the initial setting is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR. +.\" OPTION: -buffersize .TP -\fB\-buffersize\fR \fInewSize\fR +\fB\-buffersize\fI newSize\fR . -\fINewvalue\fR must be an integer; its value is used to set the size +\fInewSize\fR must be an integer; its value is used to set the size of buffers, in bytes, subsequently allocated for this channel to store -input or output. \fINewvalue\fR must be a number of no more than one +input or output. \fInewSize\fR must be a number of no more than one million, allowing buffers of up to one million bytes in size. +.\" OPTION: -encoding .TP \fB\-encoding\fR \fIname\fR . @@ -174,6 +182,7 @@ The default encoding for newly opened channels is the same platform- and locale-dependent system encoding used for interfacing with the operating system, as returned by \fBencoding system\fR. .RE +.\" OPTION: -eofchar .TP \fB\-eofchar\fR \fIchar\fR .TP @@ -197,10 +206,11 @@ for writing. The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7f; attempting to set \fB\-eofchar\fR to a value outside of this range will generate an error. +.\" OPTION: -translation .TP -\fB\-translation\fR \fImode\fR +\fB\-translation\fI translation\fR .TP -\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR +\fB\-translation\fR \fB{\fIinTranslation outTranslation\fB}\fR . In Tcl scripts the end of a line is always represented using a single newline character (\en). However, in actual files and devices the end @@ -226,9 +236,7 @@ you can specify a single value that will apply to both reading and writing. When querying the translation mode of a read-write channel, a two-element list will always be returned. The following values are currently supported: -.TP -\fBauto\fR -. +.IP \fBauto\fR As the input translation mode, \fBauto\fR treats any of newline (\fBlf\fR), carriage return (\fBcr\fR), or carriage return followed by a newline (\fBcrlf\fR) as the end of line representation. The end of @@ -239,26 +247,24 @@ all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses \fBlf\fR, and for the various flavors of Windows it chooses \fBcrlf\fR. The default setting for \fB\-translation\fR is \fBauto\fR for both input and output. -.TP -\fBbinary\fR -. -No end-of-line translations are performed. This is nearly identical -to \fBlf\fR mode, except that in addition \fBbinary\fR mode also sets -the end-of-file character to the empty string (which disables it) and -sets the encoding to \fBbinary\fR (which disables encoding filtering). -See the description of \fB\-eofchar\fR and \fB\-encoding\fR for more -information. -.TP -\fBcr\fR -. +.IP \fBbinary\fR +Like \fBlf\fR, no end-of-line translation is performed, but in addition, sets +\fB\-eofchar\fR to the empty string to disable it, and sets \fB\-encoding\fR +to \fBiso8859-1\fR. With this one setting, a channel is fully configured +for binary input and output: Each byte read from the channel +becomes the Unicode character having the same value as that byte, and each +character written to the channel becomes a single byte in the output. This +makes it possible to work seamlessly with binary data as long as each character +in the data remains in the range of 0 to 255 so that there is no distinction +between binary data and text. For example, A JPEG image can be read from a +such a channel, manipulated, and then written back to such a channel. +.IP \fBcr\fR The end of a line in the underlying file or device is represented by a single carriage return character. As the input translation mode, \fBcr\fR mode converts carriage returns to newline characters. As the output translation mode, \fBcr\fR mode translates newline characters to carriage returns. -.TP -\fBcrlf\fR -. +.IP \fBcrlf\fR The end of a line in the underlying file or device is represented by a carriage return character followed by a linefeed character. As the input translation mode, \fBcrlf\fR mode converts @@ -266,15 +272,13 @@ carriage-return-linefeed sequences to newline characters. As the output translation mode, \fBcrlf\fR mode translates newline characters to carriage-return-linefeed sequences. This mode is typically used on Windows platforms and for network connections. -.TP -\fBlf\fR -. +.IP \fBlf\fR The end of a line in the underlying file or device is represented by a single newline (linefeed) character. In this mode no translations occur during either input or output. This mode is typically used on UNIX platforms. .RE -.RE +.\" METHOD: copy .TP \fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR? . @@ -346,6 +350,7 @@ incoming bytes are valid UTF-8 characters and convert them according to the output encoding. The behaviour of the system for bytes which are not valid UTF-8 characters is undefined in this case. .RE +.\" METHOD: create .TP \fBchan create \fImode cmdPrefix\fR . @@ -364,7 +369,7 @@ reading, writing, or both. It has to be a list containing any of the strings .QW \fBread\fR or -.QW \fBwrite\fR . +.QW \fBwrite\fR , The list must have at least one element, as a channel you can neither write to nor read from makes no sense. The handler command for the new channel must support the chosen @@ -412,12 +417,14 @@ interpreters. While it arranges for the execution of arbitrary Tcl code the system also makes sure that the code is always executed within the safe interpreter. .RE +.\" METHOD: eof .TP \fBchan eof \fIchannelId\fR . Test whether the last input operation on the channel called \fIchannelId\fR failed because the end of the data stream was reached, returning 1 if end-of-file was reached, and 0 otherwise. +.\" METHOD: event .TP \fBchan event \fIchannelId event\fR ?\fIscript\fR? . @@ -444,7 +451,8 @@ while waiting for the data to arrive. If an application invokes no input data available, the process will block; until the input data arrives, it will not be able to service other events, so it will appear to the user to -.QW "freeze up" . +.QW "freeze up" +\&. With \fBchan event\fR, the process can tell when data is present and only invoke \fBchan gets\fR or \fBchan read\fR when they will not block. @@ -486,6 +494,7 @@ to report the error. In addition, the file event handler is deleted if it ever returns an error; this is done in order to prevent infinite loops due to buggy handlers. .RE +.\" METHOD: flush .TP \fBchan flush \fIchannelId\fR . @@ -500,6 +509,7 @@ buffered output has been flushed; the remainder will be flushed in the background as fast as the underlying file or device is able to absorb it. .RE +.\" METHOD: gets .TP \fBchan gets \fIchannelId\fR ?\fIvarName\fR? . @@ -521,12 +531,14 @@ distinguished from an empty line using the \fBchan eof\fR command, and the partial-line-but-non-blocking case can be distinguished with the \fBchan blocked\fR command. .RE +.\" METHOD: names .TP \fBchan names\fR ?\fIpattern\fR? . Produces a list of all channel names. If \fIpattern\fR is specified, only those channel names that match it (according to the rules of \fBstring match\fR) will be returned. +.\" METHOD: pending .TP \fBchan pending \fImode channelId\fR . @@ -538,8 +550,10 @@ callback to impose application-specific limits on input line lengths to avoid a potential denial-of-service attack where a hostile user crafts an extremely long line that exceeds the available memory to buffer it). Returns -1 if the channel was not opened for the mode in question. +.\" METHOD: pipe .TP \fBchan pipe\fR +. .VS 8.6 Creates a standalone pipe whose read- and write-side channels are returned as a 2-element list, the first element being the read side and @@ -560,10 +574,12 @@ differences, but the details of what exactly gets written when are not. This is most likely to show up when using pipelines for testing; care should be taken to ensure that deadlocks do not occur and that potential short reads are allowed for. -.RE .VE 8.6 +.RE +.\" METHOD: pop .TP \fBchan pop \fIchannelId\fR +. .VS 8.6 Removes the topmost transformation from the channel \fIchannelId\fR, if there is any. If there are no transformations added to \fIchannelId\fR, this is @@ -571,6 +587,7 @@ equivalent to \fBchan close\fR of that channel. The result is normally the empty string, but can be an error in some situations (i.e. where the underlying system stream is closed and that results in an error). .VE 8.6 +.\" METHOD: postevent .TP \fBchan postevent \fIchannelId eventSpec\fR . @@ -607,8 +624,10 @@ where the event is posted from a safe interpreter and listened for by a trusted interpreter. \fBChan event\fR handlers are \fIalways\fR executed in the interpreter that set them up. .RE +.\" METHOD: push .TP \fBchan push \fIchannelId cmdPrefix\fR +. .VS 8.6 Adds a new transformation on top of the channel \fIchannelId\fR. The \fIcmdPrefix\fR argument describes a list of one or more words which represent @@ -619,6 +638,7 @@ is important to make sure that the transformation is capable of supporting the channel mode that it is used with or this can make the channel neither readable nor writable. .VE 8.6 +.\" METHOD: puts .TP \fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR . @@ -658,6 +678,7 @@ used in an event-driven fashion with the \fBchan event\fR command (do not invoke \fBchan puts\fR unless you have recently been notified via a file event that the channel is ready for more output data). .RE +.\" METHOD: read .TP \fBchan read \fIchannelId\fR ?\fInumChars\fR? .TP @@ -712,6 +733,7 @@ end-of-file character, see \fBchan configure -eofchar\fR. If there no end-of-file character has been configured for the channel, then \fBchan read\fR will block forever. .RE +.\" METHOD: seek .TP \fBchan seek \fIchannelId offset\fR ?\fIorigin\fR? . @@ -720,20 +742,14 @@ the channel named \fIchannelId\fR to be \fIoffset\fR bytes relative to \fIorigin\fR. \fIOffset\fR must be an integer (which may be negative) and \fIorigin\fR must be one of the following: .RS -.TP 10 -\fBstart\fR -. +.IP \fBstart\fR The new access position will be \fIoffset\fR bytes from the start of the underlying file or device. -.TP 10 -\fBcurrent\fR -. +.IP \fBcurrent\fR The new access position will be \fIoffset\fR bytes from the current access position; a negative \fIoffset\fR moves the access position backwards in the underlying file or device. -.TP 10 -\fBend\fR -. +.IP \fBend\fR The new access position will be \fIoffset\fR bytes from the end of the file or device. A negative \fIoffset\fR places the access position before the end of file, and a positive \fIoffset\fR places the access @@ -751,6 +767,7 @@ Note that \fIoffset\fR values are byte offsets, not character offsets. Both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes, not characters, unlike \fBchan read\fR. .RE +.\" METHOD: tell .TP \fBchan tell \fIchannelId\fR . @@ -760,6 +777,7 @@ value returned is a byte offset that can be passed to \fBchan seek\fR in order to set the channel to a particular position. Note that this value is in terms of bytes, not characters like \fBchan read\fR. The value returned is -1 for channels that do not support seeking. +.\" METHOD: truncate .TP \fBchan truncate \fIchannelId\fR ?\fIlength\fR? . @@ -769,10 +787,18 @@ offset within the underlying data stream if \fIlength\fR is omitted). The channel is flushed before truncation. . .SH EXAMPLES +.SS "SIMPLE CHANNEL OPERATION EXAMPLES" +.PP +Instruct Tcl to always send output to \fBstdout\fR immediately, +whether or not it is to a terminal: +.PP +.CS +\fBfconfigure\fR stdout -buffering none +.CE .PP -This opens a file using a known encoding (CP1252, a very common encoding -on Windows), searches for a string, rewrites that part, and truncates the -file after a further two lines. +In the following example a file is opened using the encoding CP1252, which is +common on Windows, searches for a string, rewrites that part, and truncates the +file two lines later. .PP .CS set f [open somefile.txt r+] @@ -782,7 +808,7 @@ set offset 0 \fI# Search for string "FOOBAR" in the file\fR while {[\fBchan gets\fR $f line] >= 0} { set idx [string first FOOBAR $line] - if {$idx > -1} { + if {$idx >= 0} { \fI# Found it; rewrite line\fR \fBchan seek\fR $f [expr {$offset + $idx}] @@ -803,8 +829,8 @@ while {[\fBchan gets\fR $f line] >= 0} { \fBchan close\fR $f .CE .PP -A network server that does echoing of its input line-by-line without -preventing servicing of other connections at the same time. +A network server that echoes its input line-by-line without +preventing servicing of other connections at the same time: .PP .CS # This is a very simple logger... @@ -842,9 +868,11 @@ vwait forever .SH "SEE ALSO" close(n), eof(n), fblocked(n), fconfigure(n), fcopy(n), file(n), fileevent(n), flush(n), gets(n), open(n), puts(n), read(n), seek(n), -socket(n), tell(n), refchan(n), transchan(n) +socket(n), tell(n), refchan(n), transchan(n), +Tcl_StandardChannels(3) .SH KEYWORDS -channel, input, output, events, offset +blocking, channel, end of file, events, input, non-blocking, +offset, output, readable, seek, stdio, tell, writable '\" Local Variables: '\" mode: nroff '\" End: -- cgit v0.12 From aacd5eef2d2bf6b7d03aad0941282762e8957566 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Jun 2024 12:10:50 +0000 Subject: Fix [1d26e580cf]: safe interp can't source files with BOM. (init.tcl has a BOM now, for testing purposes. Don't merge this to core-8-6-branch!) --- library/init.tcl | 2 +- library/safe.tcl | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/library/init.tcl b/library/init.tcl index a6745ab..81e6243 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -1,4 +1,4 @@ -# init.tcl -- +# init.tcl -- # # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. diff --git a/library/safe.tcl b/library/safe.tcl index 71c1e67..9c605f2 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -987,6 +987,10 @@ proc ::safe::AliasSource {child args} { fconfigure $f -encoding $encoding } set contents [read $f] + # See [Bug 1d26e580cf] + if {[string index $contents 0] eq "\uFEFF"} { + set contents [string range $contents 1 end] + } close $f ::interp eval $child [list info script $file] } msg opt] -- cgit v0.12 From e4a0bd43132f37661c7177534ec26a6c34a2cb9d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Jun 2024 13:40:18 +0000 Subject: Move BOM handling a few lines later --- library/safe.tcl | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 9c605f2..5baacb5 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -987,14 +987,14 @@ proc ::safe::AliasSource {child args} { fconfigure $f -encoding $encoding } set contents [read $f] - # See [Bug 1d26e580cf] - if {[string index $contents 0] eq "\uFEFF"} { - set contents [string range $contents 1 end] - } close $f ::interp eval $child [list info script $file] } msg opt] if {$code == 0} { + # See [Bug 1d26e580cf] + if {[string index $contents 0] eq "\uFEFF"} { + set contents [string range $contents 1 end] + } set code [catch {::interp eval $child $contents} msg opt] set replacementMsg $msg } -- cgit v0.12 From e80a9647f5b435daaa052bbe487314a47794fdca Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Jun 2024 08:57:12 +0000 Subject: Use tabs for indenting in stead of 8 spaces --- library/history.tcl | 2 +- library/http/http.tcl | 37 ++++++++++++++++++------------------- library/http1.0/http.tcl | 4 ++-- library/init.tcl | 10 +++++----- library/msgcat/msgcat.tcl | 6 +++--- library/opt/optparse.tcl | 2 +- library/package.tcl | 20 ++++++++++---------- library/platform/shell.tcl | 2 +- library/reg/pkgIndex.tcl | 4 ++-- library/safe.tcl | 16 ++++++++-------- library/tcltest/tcltest.tcl | 18 +++++++++--------- library/tm.tcl | 2 +- tests/remote.tcl | 8 ++++---- 13 files changed, 65 insertions(+), 66 deletions(-) diff --git a/library/history.tcl b/library/history.tcl index f06ffc9..79b7604 100644 --- a/library/history.tcl +++ b/library/history.tcl @@ -197,7 +197,7 @@ proc ::tcl::HistInfo {{count {}}} { if {![info exists history($i)]} { continue } - set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]] + set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]] append result $newline[format "%6d %s" $i $cmd] set newline \n } diff --git a/library/http/http.tcl b/library/http/http.tcl index fb256a3..5dcd76c 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -281,9 +281,8 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { # PASSED TO http::geturl AS -command callback. catch {fileevent $state(sock) readable {}} catch {fileevent $state(sock) writable {}} - } elseif { - ([info exists state(-keepalive)] && !$state(-keepalive)) - || ([info exists state(connection)] && ("close" in $state(connection))) + } elseif {([info exists state(-keepalive)] && !$state(-keepalive)) + || ([info exists state(connection)] && ("close" in $state(connection))) } { set closeQueue 1 set connId $state(socketinfo) @@ -772,7 +771,7 @@ proc http::geturl {url args} { if {[regexp -- $pat $flag]} { # Validate numbers if { [info exists type($flag)] - && (![string is $type($flag) -strict $value]) + && (![string is $type($flag) -strict $value]) } { unset $token return -code error \ @@ -1697,9 +1696,9 @@ proc http::ReceiveResponse {token} { coroutine ${token}EventCoroutine http::Event $sock $token if {[info exists state(-handler)] || [info exists state(-progress)]} { - fileevent $sock readable [list http::EventGateway $sock $token] + fileevent $sock readable [list http::EventGateway $sock $token] } else { - fileevent $sock readable ${token}EventCoroutine + fileevent $sock readable ${token}EventCoroutine } return } @@ -1725,15 +1724,15 @@ proc http::EventGateway {sock token} { fileevent $sock readable {} catch {${token}EventCoroutine} res opts if {[info commands ${token}EventCoroutine] ne {}} { - # The coroutine can be deleted by completion (a non-yield return), by - # http::Finish (when there is a premature end to the transaction), by - # http::reset or http::cleanup, or if the caller set option -channel - # but not option -handler: in the last case reading from the socket is - # now managed by commands ::http::Copy*, http::ReceiveChunked, and - # http::make-transformation-chunked. - # - # Catch in case the coroutine has closed the socket. - catch {fileevent $sock readable [list http::EventGateway $sock $token]} + # The coroutine can be deleted by completion (a non-yield return), by + # http::Finish (when there is a premature end to the transaction), by + # http::reset or http::cleanup, or if the caller set option -channel + # but not option -handler: in the last case reading from the socket is + # now managed by commands ::http::Copy*, http::ReceiveChunked, and + # http::make-transformation-chunked. + # + # Catch in case the coroutine has closed the socket. + catch {fileevent $sock readable [list http::EventGateway $sock $token]} } # If there was an error, re-throw it. @@ -3379,10 +3378,10 @@ proc http::wait {token} { proc http::formatQuery {args} { if {[llength $args] % 2} { - return \ - -code error \ - -errorcode [list HTTP BADARGCNT $args] \ - {Incorrect number of arguments, must be an even number.} + return \ + -code error \ + -errorcode [list HTTP BADARGCNT $args] \ + {Incorrect number of arguments, must be an even number.} } set result "" set sep "" diff --git a/library/http1.0/http.tcl b/library/http1.0/http.tcl index 8329de4..ce112d8 100644 --- a/library/http1.0/http.tcl +++ b/library/http1.0/http.tcl @@ -94,8 +94,8 @@ proc http_get { url args } { meta {} currentsize 0 totalsize 0 - type text/html - body {} + type text/html + body {} status "" } set options {-blocksize -channel -command -handler -headers \ diff --git a/library/init.tcl b/library/init.tcl index a6745ab..e4e184f 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -611,12 +611,12 @@ proc auto_import {pattern} { auto_load_index foreach pattern $patternList { - foreach name [array names auto_index $pattern] { - if {([namespace which -command $name] eq "") + foreach name [array names auto_index $pattern] { + if {([namespace which -command $name] eq "") && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} { - namespace inscope :: $auto_index($name) - } - } + namespace inscope :: $auto_index($name) + } + } } } diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 851ad77..e112470 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -18,7 +18,7 @@ package provide msgcat 1.6.1 namespace eval msgcat { namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\ - mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ + mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ mcpackageconfig mcpackagelocale # Records the list of locales to search @@ -460,7 +460,7 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} { return -code error "wrong # args: should be\ \"[lrange [info level 0] 0 1]\"" } - set locale [string tolower $locale] + set locale [string tolower $locale] } set ns [uplevel 1 {::namespace current}] @@ -631,7 +631,7 @@ proc msgcat::mcpackageconfig {subcommand option {value ""}} { \"[lrange [info level 0] 0 2] value\"" } } elseif {$subcommand eq "set"} { - return -code error\ + return -code error\ "wrong # args: should be \"[lrange [info level 0] 0 2]\"" } diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl index 0a6cdfa..1aec83b 100644 --- a/library/opt/optparse.tcl +++ b/library/opt/optparse.tcl @@ -785,7 +785,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { if {[regexp {^-(.+)$} $arg1 x type]} { # flags/optValue as they are optional, need a "value", # on the contrary, for a variable (non optional), - # default value is pointless, 'cept for choices : + # default value is pointless, 'cept for choices : if {$isflag || $isopt || ($type == "choice")} { return [OptNewInst $state $varname $type $arg2 ""] } else { diff --git a/library/package.tcl b/library/package.tcl index 33ee7aa..7b2b2e9 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -31,16 +31,16 @@ proc tcl::Pkg::CompareExtension {fileName {ext {}}} { global tcl_platform if {$ext eq ""} {set ext [info sharedlibextension]} if {$tcl_platform(platform) eq "windows"} { - return [string equal -nocase [file extension $fileName] $ext] + return [string equal -nocase [file extension $fileName] $ext] } else { - # Some unices add trailing numbers after the .so, so - # we could have something like '.so.1.2'. - set root $fileName - while {1} { - set currExt [file extension $root] - if {$currExt eq $ext} { - return 1 - } + # Some unices add trailing numbers after the .so, so + # we could have something like '.so.1.2'. + set root $fileName + while {1} { + set currExt [file extension $root] + if {$currExt eq $ext} { + return 1 + } # The current extension does not match; if it is not a numeric # value, quit, as we are only looking to ignore version number @@ -51,7 +51,7 @@ proc tcl::Pkg::CompareExtension {fileName {ext {}}} { if {![string is integer -strict [string range $currExt 1 end]]} { return 0 } - set root [file rootname $root] + set root [file rootname $root] } } } diff --git a/library/platform/shell.tcl b/library/platform/shell.tcl index 60d5b37..053ce53 100644 --- a/library/platform/shell.tcl +++ b/library/platform/shell.tcl @@ -131,7 +131,7 @@ proc ::platform::shell::RUN {shell code} { set e [TEMP] set code [catch { - exec $shell $c 2> $e + exec $shell $c 2> $e } res] file delete $c diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index 6603e3e..3b430b1 100644 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -2,8 +2,8 @@ if {![package vsatisfies [package provide Tcl] 8.5]} return if {[info sharedlibextension] != ".dll"} return if {[::tcl::pkgconfig get debug]} { package ifneeded registry 1.3.5 \ - [list load [file join $dir tclreg13g.dll] Registry] + [list load [file join $dir tclreg13g.dll] Registry] } else { package ifneeded registry 1.3.5 \ - [list load [file join $dir tclreg13.dll] Registry] + [list load [file join $dir tclreg13.dll] Registry] } diff --git a/library/safe.tcl b/library/safe.tcl index 71c1e67..e7044f8 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -376,7 +376,7 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} { # Prevent the addition of dirs on the tm list to the # result if they are already known. if {[dict exists $remap_access_path $dir]} { - if {$firstpass} { + if {$firstpass} { # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path. # Later passes handle subdirectories, which belong in the # access path but not in the module path. @@ -596,9 +596,9 @@ proc ::safe::interpDelete {child} { # Safe Base sub-interpreter, so each one is deleted cleanly and not by # the automatic mechanism built into [interp delete]. foreach sub [interp children $child] { - if {[info exists ::safe::[VarName [list $child $sub]]]} { - ::safe::interpDelete [list $child $sub] - } + if {[info exists ::safe::[VarName [list $child $sub]]]} { + ::safe::interpDelete [list $child $sub] + } } # If the child has a cleanup hook registered, call it. Check the @@ -1192,14 +1192,14 @@ proc ::safe::AliasExeName {child} { proc ::safe::RejectExcessColons {child} { set stripped [regsub -all -- {:::*} $child ::] if {[string range $stripped end-1 end] eq {::}} { - return -code error {interpreter name must not end in "::"} + return -code error {interpreter name must not end in "::"} } if {$stripped ne $child} { - set msg {interpreter name has excess colons in namespace separators} - return -code error $msg + set msg {interpreter name has excess colons in namespace separators} + return -code error $msg } if {[string range $stripped 0 1] eq {::}} { - return -code error {interpreter name must not begin "::"} + return -code error {interpreter name must not begin "::"} } return } diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 2fc5838..168f521 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1158,15 +1158,15 @@ proc tcltest::SafeFetch {n1 n2 op} { proc tcltest::Asciify {s} { set print "" foreach c [split $s ""] { - if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} { - append print $c - } elseif {$c < "\u0100"} { - append print \\x[format %02X [scan $c %c]] - } elseif {$c > "\uFFFF"} { - append print \\U[format %08X [scan $c %c]] - } else { - append print \\u[format %04X [scan $c %c]] - } + if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} { + append print $c + } elseif {$c < "\u0100"} { + append print \\x[format %02X [scan $c %c]] + } elseif {$c > "\uFFFF"} { + append print \\U[format %08X [scan $c %c]] + } else { + append print \\u[format %04X [scan $c %c]] + } } return $print } diff --git a/library/tm.tcl b/library/tm.tcl index ca68ce1..796d09f 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -335,7 +335,7 @@ proc ::tcl::tm::Defaults {} { foreach ev [::list \ TCL${major}.${n}_TM_PATH \ TCL${major}_${n}_TM_PATH \ - ] { + ] { if {![info exists env($ev)]} continue foreach p [split $env($ev) $sep] { path add $p diff --git a/tests/remote.tcl b/tests/remote.tcl index 2b975c6..6a39b47 100644 --- a/tests/remote.tcl +++ b/tests/remote.tcl @@ -40,9 +40,9 @@ proc __readAndExecute__ {s} { set l [gets $s] if {[string compare $l "--Marker--Marker--Marker--"] == 0} { - puts $s [__doCommands__ $command($s) $s] + puts $s [__doCommands__ $command($s) $s] puts $s "--Marker--Marker--Marker--" - set command($s) "" + set command($s) "" return } if {[string compare $l ""] == 0} { @@ -59,8 +59,8 @@ proc __readAndExecute__ {s} { puts "Server closing $s, eof from client" } close $s - unset command($s) - return + unset command($s) + return } append command($s) $l "\n" } -- cgit v0.12 From a0aae59b0afcfb3e2537275e7fb8af08abcdb084 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 13 Jun 2024 14:37:30 +0000 Subject: test illustrating [1095bf7f756f9aed]: safe ensemble commands must be compiled in safe interp --- tests/namespace.test | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/tests/namespace.test b/tests/namespace.test index 08531e4..712c0e5 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -3294,6 +3294,22 @@ test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a0 info class [format %s constructor] oo::object } "" +test namespace-55.2 {compiled ensembles inside safe interpreters (for safe sub-commands), bug [1095bf7f756f9aed]} -setup { + interp create -safe si + set code { + proc test_comp_dict d { dict for {k v} $d {expr $v} } + regexp -inline {Command 1:(?:[^\n]*\n){1,5}} [::tcl::unsupported::disassemble proc test_comp_dict] + } +} -body { + set a [ eval $code] + set b [si eval $code] + list [expr {$a eq $b}] [regexp { dictFirst } $a] [regexp { dictFirst } $b] $a $b +} -cleanup { + rename test_comp_dict {} + unset -nocomplain a b + interp delete si +} -match glob -result {1 1 1 *} + test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} { namespace eval ::testing { proc abc {} {} -- cgit v0.12 From 25563412733e3cf0de60568af0289ec9e9b4e534 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 13 Jun 2024 14:39:03 +0000 Subject: fixes [1095bf7f756f9aed]: safe ensemble commands will be compiled now in safe interp too --- generic/tclEnsemble.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index dea3bed..367a4e5 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1615,6 +1615,8 @@ TclMakeEnsemble( Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } + /* don't compile unsafe subcommands in unsafe interp */ + cmdPtr->compileProc = NULL; } else { /* * Not hidden, so just create it. Yay! @@ -1624,8 +1626,8 @@ TclMakeEnsemble( Tcl_NRCreateCommand(interp, TclGetString(toObj), map[i].proc, map[i].nreProc, map[i].clientData, NULL); + cmdPtr->compileProc = map[i].compileProc; } - cmdPtr->compileProc = map[i].compileProc; } } Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); @@ -3107,7 +3109,7 @@ TclCompileEnsemble( Tcl_IncrRefCount(targetCmdObj); newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); TclDecrRefCount(targetCmdObj); - if (newCmdPtr == NULL || Tcl_IsSafe(interp) + if (newCmdPtr == NULL || (Tcl_IsSafe(interp) && !cmdPtr->compileProc) || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION || newCmdPtr->flags & CMD_HAS_EXEC_TRACES || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { @@ -3115,7 +3117,6 @@ TclCompileEnsemble( * Maps to an undefined command or a command without a compiler. * Cannot compile. */ - goto cleanup; } cmdPtr = newCmdPtr; -- cgit v0.12 From 381d344fbac15671fd5508f114575656decd0268 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 13 Jun 2024 16:00:41 +0000 Subject: small amend cleaning var in test --- tests/namespace.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/namespace.test b/tests/namespace.test index 712c0e5..17c9438 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -3306,7 +3306,7 @@ test namespace-55.2 {compiled ensembles inside safe interpreters (for safe sub-c list [expr {$a eq $b}] [regexp { dictFirst } $a] [regexp { dictFirst } $b] $a $b } -cleanup { rename test_comp_dict {} - unset -nocomplain a b + unset -nocomplain code a b interp delete si } -match glob -result {1 1 1 *} -- cgit v0.12 From 6e35e60556fac3ed7066ea6c26557639a2a7b1d2 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 13 Jun 2024 16:13:22 +0000 Subject: typo in comment --- generic/tclEnsemble.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 367a4e5..6e16a6a 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1615,7 +1615,7 @@ TclMakeEnsemble( Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } - /* don't compile unsafe subcommands in unsafe interp */ + /* don't compile unsafe subcommands in safe interp */ cmdPtr->compileProc = NULL; } else { /* -- cgit v0.12 From 1e9345e974c421c6b52d2699591adac15b98b3cb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Jun 2024 22:07:14 +0000 Subject: Backport some code cleanup from 8.7/9.0. Fix indenting --- unix/Makefile.in | 2 +- unix/installManPage | 4 +- unix/tclLoadDl.c | 2 +- unix/tclLoadDyld.c | 2 +- unix/tclLoadNext.c | 2 +- unix/tclLoadOSF.c | 4 +- unix/tclUnixChan.c | 96 ++++----- unix/tclUnixCompat.c | 16 +- unix/tclUnixSock.c | 599 +++++++++++++++++++++++++-------------------------- unix/tclUnixTest.c | 40 ++-- win/Makefile.in | 2 +- win/nmakehlp.c | 45 ++-- 12 files changed, 404 insertions(+), 410 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 463d153..53826c4 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -888,7 +888,7 @@ install-libraries: libraries @if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ] ; then \ echo "Customizing tcl module path"; \ echo "if {![interp issafe]} { ::tcl::tm::roots [list $(TCL_MODULE_PATH)] }" >> \ - "$(SCRIPT_INSTALL_DIR)/tm.tcl"; \ + "$(SCRIPT_INSTALL_DIR)/tm.tcl"; \ fi install-tzdata: diff --git a/unix/installManPage b/unix/installManPage index 3d5fa7b..3cb266d 100755 --- a/unix/installManPage +++ b/unix/installManPage @@ -12,8 +12,8 @@ Suffix="" while true; do case $1 in - -s | --symlinks ) Sym="-s " ;; - -z | --compress ) Gzip=$2; shift ;; + -s | --symlinks ) Sym="-s " ;; + -z | --compress ) Gzip=$2; shift ;; -e | --extension ) Gz=$2; shift ;; -x | --suffix ) Suffix=$2; shift ;; -*) cat <fd, &iostate); Tcl_DStringInit(&ds); - Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds); + Tcl_ExternalToUtfDString(NULL, (char *)&iostate.c_cc[VSTART], 1, &ds); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); TclDStringClear(&ds); - Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTOP], 1, &ds); + Tcl_ExternalToUtfDString(NULL, (char *)&iostate.c_cc[VSTOP], 1, &ds); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); } @@ -1284,22 +1284,18 @@ TtyParseMode( * not allow preprocessor directives in their arguments. */ - if ( -#if defined(PAREXT) - strchr("noems", parity) +#ifdef PAREXT +#define PARITY_CHARS "noems" +#define PARITY_MSG "n, o, e, m, or s" #else - strchr("noe", parity) +#define PARITY_CHARS "noe" +#define PARITY_MSG "n, o, or e" #endif /* PAREXT */ - == NULL) { + + if (strchr(PARITY_CHARS, parity) == NULL) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s parity: should be %s", bad, -#if defined(PAREXT) - "n, o, e, m, or s" -#else - "n, o, or e" -#endif /* PAREXT */ - )); + "%s parity: should be %s", bad, PARITY_MSG)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", (char *)NULL); } return TCL_ERROR; @@ -1598,12 +1594,11 @@ TclpGetDefaultStdChannel( * Some #def's to make the code a little clearer! */ -#define ZERO_OFFSET ((Tcl_SeekOffset) 0) #define ERROR_OFFSET ((Tcl_SeekOffset) -1) switch (type) { case TCL_STDIN: - if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + if ((TclOSseek(0, 0, SEEK_CUR) == ERROR_OFFSET) && (errno == EBADF)) { return NULL; } @@ -1612,7 +1607,7 @@ TclpGetDefaultStdChannel( bufMode = "line"; break; case TCL_STDOUT: - if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + if ((TclOSseek(1, 0, SEEK_CUR) == ERROR_OFFSET) && (errno == EBADF)) { return NULL; } @@ -1621,7 +1616,7 @@ TclpGetDefaultStdChannel( bufMode = "line"; break; case TCL_STDERR: - if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET) + if ((TclOSseek(2, 0, SEEK_CUR) == ERROR_OFFSET) && (errno == EBADF)) { return NULL; } @@ -1634,7 +1629,6 @@ TclpGetDefaultStdChannel( break; } -#undef ZERO_OFFSET #undef ERROR_OFFSET channel = Tcl_MakeFileChannel(INT2PTR(fd), mode); diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 853e93a..5d118db 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -999,17 +999,17 @@ TclWinCPUID( #if defined(HAVE_CPUID) #if defined(__x86_64__) || defined(_M_AMD64) || defined (_M_X64) __asm__ __volatile__("movq %%rbx, %%rsi \n\t" /* save %rbx */ - "cpuid \n\t" - "xchgq %%rsi, %%rbx \n\t" /* restore the old %rbx */ - : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) - : "a"(index)); + "cpuid \n\t" + "xchgq %%rsi, %%rbx \n\t" /* restore the old %rbx */ + : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) + : "a"(index)); status = TCL_OK; #elif defined(__i386__) || defined(_M_IX86) __asm__ __volatile__("mov %%ebx, %%esi \n\t" /* save %ebx */ - "cpuid \n\t" - "xchg %%esi, %%ebx \n\t" /* restore the old %ebx */ - : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) - : "a"(index)); + "cpuid \n\t" + "xchg %%esi, %%ebx \n\t" /* restore the old %ebx */ + : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) + : "a"(index)); status = TCL_OK; #endif #endif diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 441f75b..3c14984 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -62,8 +62,7 @@ struct TcpState { * Only needed for server sockets */ - Tcl_TcpAcceptProc *acceptProc; - /* Proc to call on accept. */ + Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ void *acceptProcData; /* The data for the accept proc. */ /* @@ -146,23 +145,23 @@ static Tcl_FileProc WrapNotify; */ static const Tcl_ChannelType tcpChannelType = { - "tcp", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - TcpCloseProc, /* Close proc. */ - TcpInputProc, /* Input proc. */ - TcpOutputProc, /* Output proc. */ + "tcp", + TCL_CHANNEL_VERSION_5, + TcpCloseProc, + TcpInputProc, + TcpOutputProc, NULL, /* Seek proc. */ NULL, /* Set option proc. */ - TcpGetOptionProc, /* Get option proc. */ - TcpWatchProc, /* Initialize notifier. */ - TcpGetHandleProc, /* Get OS handles out of channel. */ - TcpClose2Proc, /* Close2 proc. */ - TcpBlockModeProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ - NULL, /* wide seek proc. */ - TcpThreadActionProc, /* thread action proc. */ - NULL /* truncate proc. */ + TcpGetOptionProc, + TcpWatchProc, + TcpGetHandleProc, + TcpClose2Proc, + TcpBlockModeProc, + NULL, /* Flush proc. */ + NULL, /* Bubbled event handler proc. */ + NULL, /* Seek proc. */ + TcpThreadActionProc, + NULL /* Truncate proc. */ }; /* @@ -196,8 +195,8 @@ printaddrinfo( * * InitializeHostName -- * - * This routine sets the process global value of the name of the local - * host on which the process is running. + * This routine sets the process global value of the name of the local + * host on which the process is running. * * Results: * None. @@ -219,7 +218,7 @@ InitializeHostName( memset(&u, (int) 0, sizeof(struct utsname)); if (uname(&u) >= 0) { /* INTL: Native. */ - hp = TclpGetHostByName(u.nodename); /* INTL: Native. */ + hp = TclpGetHostByName(u.nodename); /* INTL: Native. */ if (hp == NULL) { /* * Sometimes the nodename is fully qualified, but gets truncated @@ -238,11 +237,11 @@ InitializeHostName( ckfree(node); } } - if (hp != NULL) { + if (hp != NULL) { native = hp->h_name; - } else { + } else { native = u.nodename; - } + } } if (native == NULL) { native = tclEmptyStringRep; @@ -383,8 +382,8 @@ TcpBlockModeProc( SET_BITS(statePtr->flags, TCP_NONBLOCKING); } if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { - statePtr->cachedBlocking = mode; - return 0; + statePtr->cachedBlocking = mode; + return 0; } if (TclUnixSetBlockingMode(statePtr->fds.fd, mode) < 0) { return errno; @@ -413,8 +412,8 @@ TcpBlockModeProc( * return any error code. * * Results: - * 0 if the connection has completed, -1 if still in progress or there is - * an error. + * 0 if the connection has completed, -1 if still in progress or there is + * an error. * * Side effects: * Processes socket events off the system queue. May process @@ -449,30 +448,30 @@ WaitForConnect( } if (errorCodePtr == NULL || GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { - timeout = 0; + timeout = 0; } else { - timeout = -1; + timeout = -1; } do { - if (TclUnixWaitForFile(statePtr->fds.fd, - TCL_WRITABLE | TCL_EXCEPTION, timeout) != 0) { - TcpConnect(NULL, statePtr); - } - - /* - * Do this only once in the nonblocking case and repeat it until the - * socket is final when blocking. - */ + if (TclUnixWaitForFile(statePtr->fds.fd, + TCL_WRITABLE | TCL_EXCEPTION, timeout) != 0) { + TcpConnect(NULL, statePtr); + } + + /* + * Do this only once in the nonblocking case and repeat it until the + * socket is final when blocking. + */ } while (timeout == -1 && GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)); if (errorCodePtr != NULL) { - if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { - *errorCodePtr = EAGAIN; - return -1; - } else if (statePtr->connectError != 0) { - *errorCodePtr = ENOTCONN; - return -1; - } + if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { + *errorCodePtr = EAGAIN; + return -1; + } else if (statePtr->connectError != 0) { + *errorCodePtr = ENOTCONN; + return -1; + } } return 0; } @@ -627,10 +626,10 @@ TcpCloseProc( fds = next; } if (statePtr->addrlist != NULL) { - freeaddrinfo(statePtr->addrlist); + freeaddrinfo(statePtr->addrlist); } if (statePtr->myaddrlist != NULL) { - freeaddrinfo(statePtr->myaddrlist); + freeaddrinfo(statePtr->myaddrlist); } ckfree(statePtr); return errorCode; @@ -707,7 +706,7 @@ IPv6AddressNeedsNumericRendering( struct in6_addr addr) { if (IN6_ARE_ADDR_EQUAL(&addr, &in6addr_any)) { - return 1; + return 1; } /* @@ -716,11 +715,11 @@ IPv6AddressNeedsNumericRendering( */ if (!IN6_IS_ADDR_V4MAPPED(&addr)) { - return 0; + return 0; } return (addr.s6_addr[12] == 0 && addr.s6_addr[13] == 0 - && addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0); + && addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0); } #if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5)))) #pragma GCC diagnostic pop @@ -739,7 +738,7 @@ TcpHostPortList( int flags = 0; getnameinfo(&addr.sa, salen, nhost, sizeof(nhost), nport, sizeof(nport), - NI_NUMERICHOST | NI_NUMERICSERV); + NI_NUMERICHOST | NI_NUMERICSERV); Tcl_DStringAppendElement(dsPtr, nhost); /* @@ -748,14 +747,14 @@ TcpHostPortList( */ if (addr.sa.sa_family == AF_INET) { - if (addr.sa4.sin_addr.s_addr == INADDR_ANY) { - flags |= NI_NUMERICHOST; - } + if (addr.sa4.sin_addr.s_addr == INADDR_ANY) { + flags |= NI_NUMERICHOST; + } #ifndef NEED_FAKE_RFC2553 } else if (addr.sa.sa_family == AF_INET6) { - if (IPv6AddressNeedsNumericRendering(addr.sa6.sin6_addr)) { - flags |= NI_NUMERICHOST; - } + if (IPv6AddressNeedsNumericRendering(addr.sa6.sin6_addr)) { + flags |= NI_NUMERICHOST; + } #endif /* NEED_FAKE_RFC2553 */ } @@ -764,22 +763,22 @@ TcpHostPortList( */ if (interp != NULL && - Tcl_GetVar2(interp, SUPPRESS_RDNS_VAR, NULL, 0) != NULL) { - flags |= NI_NUMERICHOST; + Tcl_GetVar2(interp, SUPPRESS_RDNS_VAR, NULL, 0) != NULL) { + flags |= NI_NUMERICHOST; } if (getnameinfo(&addr.sa, salen, host, sizeof(host), NULL, 0, - flags) == 0) { - /* - * Reverse mapping worked. - */ + flags) == 0) { + /* + * Reverse mapping worked. + */ - Tcl_DStringAppendElement(dsPtr, host); + Tcl_DStringAppendElement(dsPtr, host); } else { - /* - * Reverse mapping failed - use the numeric rep once more. - */ + /* + * Reverse mapping failed - use the numeric rep once more. + */ - Tcl_DStringAppendElement(dsPtr, nhost); + Tcl_DStringAppendElement(dsPtr, nhost); } Tcl_DStringAppendElement(dsPtr, nport); } @@ -828,25 +827,25 @@ TcpGetOptionProc( (strncmp(optionName, "-error", len) == 0)) { socklen_t optlen = sizeof(int); - if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { - /* - * Suppress errors as long as we are not done. - */ - - errno = 0; - } else if (statePtr->connectError != 0) { - errno = statePtr->connectError; - statePtr->connectError = 0; - } else { - int err; - - getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, (char *) &err, - &optlen); - errno = err; - } - if (errno != 0) { + if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { + /* + * Suppress errors as long as we are not done. + */ + + errno = 0; + } else if (statePtr->connectError != 0) { + errno = statePtr->connectError; + statePtr->connectError = 0; + } else { + int err; + + getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, (char *) &err, + &optlen); + errno = err; + } + if (errno != 0) { Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), -1); - } + } return TCL_OK; } @@ -854,13 +853,13 @@ TcpGetOptionProc( (strncmp(optionName, "-connecting", len) == 0)) { Tcl_DStringAppend(dsPtr, GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", -1); - return TCL_OK; + return TCL_OK; } if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { - address peername; - socklen_t size = sizeof(peername); + address peername; + socklen_t size = sizeof(peername); if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { /* @@ -882,11 +881,11 @@ TcpGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } - TcpHostPortList(interp, dsPtr, peername, size); + TcpHostPortList(interp, dsPtr, peername, size); if (len) { - return TCL_OK; - } - Tcl_DStringEndSublist(dsPtr); + return TCL_OK; + } + Tcl_DStringEndSublist(dsPtr); } else { /* * getpeername failed - but if we were asked for all the options @@ -898,7 +897,7 @@ TcpGetOptionProc( if (len) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get peername: %s", + "can't get peername: %s", Tcl_PosixError(interp))); } return TCL_ERROR; @@ -922,7 +921,7 @@ TcpGetOptionProc( * In async connect output an empty string */ - found = 1; + found = 1; } else { for (fds = &statePtr->fds; fds != NULL; fds = fds->next) { size = sizeof(sockname); @@ -932,23 +931,23 @@ TcpGetOptionProc( } } } - if (found) { - if (len) { - return TCL_OK; - } - Tcl_DStringEndSublist(dsPtr); - } else { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get sockname: %s", Tcl_PosixError(interp))); - } + if (found) { + if (len) { + return TCL_OK; + } + Tcl_DStringEndSublist(dsPtr); + } else { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get sockname: %s", Tcl_PosixError(interp))); + } return TCL_ERROR; } } if (len > 0) { return Tcl_BadChannelOption(interp, optionName, - "connecting peername sockname"); + "connecting peername sockname"); } return TCL_OK; @@ -1055,22 +1054,22 @@ TcpWatchProc( TcpState *statePtr = (TcpState *)instanceData; if (statePtr->acceptProc != NULL) { - /* - * Make sure we don't mess with server sockets since they will never - * be readable or writable at the Tcl level. This keeps Tcl scripts - * from interfering with the -accept behavior (bug #3394732). - */ + /* + * Make sure we don't mess with server sockets since they will never + * be readable or writable at the Tcl level. This keeps Tcl scripts + * from interfering with the -accept behavior (bug #3394732). + */ - return; + return; } if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { - /* - * Async sockets use a FileHandler internally while connecting, so we - * need to cache this request until the connection has succeeded. - */ + /* + * Async sockets use a FileHandler internally while connecting, so we + * need to cache this request until the connection has succeeded. + */ - statePtr->filehandlers = mask; + statePtr->filehandlers = mask; } else if (mask) { /* @@ -1194,18 +1193,17 @@ TcpConnect( int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING); int ret = -1, error = EHOSTUNREACH; int async = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT); + static const int reuseaddr = 1; if (async_callback) { - goto reenter; + goto reenter; } for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; - statePtr->addr = statePtr->addr->ai_next) { - for (statePtr->myaddr = statePtr->myaddrlist; - statePtr->myaddr != NULL; - statePtr->myaddr = statePtr->myaddr->ai_next) { - int reuseaddr = 1; - + statePtr->addr = statePtr->addr->ai_next) { + for (statePtr->myaddr = statePtr->myaddrlist; + statePtr->myaddr != NULL; + statePtr->myaddr = statePtr->myaddr->ai_next) { /* * No need to try combinations of local and remote addresses of * different families. @@ -1215,19 +1213,19 @@ TcpConnect( continue; } - /* - * Close the socket if it is still open from the last unsuccessful - * iteration. - */ + /* + * Close the socket if it is still open from the last unsuccessful + * iteration. + */ - if (statePtr->fds.fd >= 0) { + if (statePtr->fds.fd >= 0) { close(statePtr->fds.fd); statePtr->fds.fd = -1; - errno = 0; + errno = 0; } statePtr->fds.fd = socket(statePtr->addr->ai_family, SOCK_STREAM, - 0); + 0); if (statePtr->fds.fd < 0) { continue; } @@ -1246,28 +1244,28 @@ TcpConnect( TclSockMinimumBuffers(INT2PTR(statePtr->fds.fd), SOCKET_BUFSIZE); if (async) { - ret = TclUnixSetBlockingMode(statePtr->fds.fd, - TCL_MODE_NONBLOCKING); - if (ret < 0) { - continue; - } - } - - /* - * Must reset the error variable here, before we use it for the - * first time in this iteration. - */ - - error = 0; - - (void) setsockopt(statePtr->fds.fd, SOL_SOCKET, SO_REUSEADDR, - (char *) &reuseaddr, sizeof(reuseaddr)); - ret = bind(statePtr->fds.fd, statePtr->myaddr->ai_addr, - statePtr->myaddr->ai_addrlen); - if (ret < 0) { - error = errno; - continue; - } + ret = TclUnixSetBlockingMode(statePtr->fds.fd, + TCL_MODE_NONBLOCKING); + if (ret < 0) { + continue; + } + } + + /* + * Must reset the error variable here, before we use it for the + * first time in this iteration. + */ + + error = 0; + + (void) setsockopt(statePtr->fds.fd, SOL_SOCKET, SO_REUSEADDR, + (char *) &reuseaddr, sizeof(reuseaddr)); + ret = bind(statePtr->fds.fd, statePtr->myaddr->ai_addr, + statePtr->myaddr->ai_addrlen); + if (ret < 0) { + error = errno; + continue; + } /* * Attempt to connect. The connect may fail at present with an @@ -1277,35 +1275,35 @@ TcpConnect( */ ret = connect(statePtr->fds.fd, statePtr->addr->ai_addr, - statePtr->addr->ai_addrlen); - if (ret < 0) { - error = errno; - } + statePtr->addr->ai_addrlen); + if (ret < 0) { + error = errno; + } if (ret < 0 && errno == EINPROGRESS) { - Tcl_CreateFileHandler(statePtr->fds.fd, - TCL_WRITABLE | TCL_EXCEPTION, TcpAsyncCallback, - statePtr); - errno = EWOULDBLOCK; - SET_BITS(statePtr->flags, TCP_ASYNC_PENDING); - return TCL_OK; - - reenter: - CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); - Tcl_DeleteFileHandler(statePtr->fds.fd); - - /* - * Read the error state from the socket to see if the async - * connection has succeeded or failed. As this clears the - * error condition, we cache the status in the socket state - * struct for later retrieval by [fconfigure -error]. - */ - - optlen = sizeof(int); - - getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, - (char *) &error, &optlen); - errno = error; - } + Tcl_CreateFileHandler(statePtr->fds.fd, + TCL_WRITABLE | TCL_EXCEPTION, TcpAsyncCallback, + statePtr); + errno = EWOULDBLOCK; + SET_BITS(statePtr->flags, TCP_ASYNC_PENDING); + return TCL_OK; + + reenter: + CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); + Tcl_DeleteFileHandler(statePtr->fds.fd); + + /* + * Read the error state from the socket to see if the async + * connection has succeeded or failed. As this clears the + * error condition, we cache the status in the socket state + * struct for later retrieval by [fconfigure -error]. + */ + + optlen = sizeof(int); + + getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, + (char *) &error, &optlen); + errno = error; + } if (error == 0) { goto out; } @@ -1316,43 +1314,43 @@ TcpConnect( statePtr->connectError = error; CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); if (async_callback) { - /* - * An asynchonous connection has finally succeeded or failed. - */ - - TcpWatchProc(statePtr, statePtr->filehandlers); - TclUnixSetBlockingMode(statePtr->fds.fd, statePtr->cachedBlocking); - - if (error != 0) { - SET_BITS(statePtr->flags, TCP_ASYNC_FAILED); - } - - /* - * We need to forward the writable event that brought us here, because - * upon reading of getsockopt(SO_ERROR), at least some OSes clear the - * writable state from the socket, and so a subsequent select() on - * behalf of a script level [fileevent] would not fire. It doesn't - * hurt that this is also called in the successful case and will save - * the event mechanism one roundtrip through select(). - */ + /* + * An asynchonous connection has finally succeeded or failed. + */ + + TcpWatchProc(statePtr, statePtr->filehandlers); + TclUnixSetBlockingMode(statePtr->fds.fd, statePtr->cachedBlocking); + + if (error != 0) { + SET_BITS(statePtr->flags, TCP_ASYNC_FAILED); + } + + /* + * We need to forward the writable event that brought us here, because + * upon reading of getsockopt(SO_ERROR), at least some OSes clear the + * writable state from the socket, and so a subsequent select() on + * behalf of a script level [fileevent] would not fire. It doesn't + * hurt that this is also called in the successful case and will save + * the event mechanism one roundtrip through select(). + */ if (statePtr->cachedBlocking == TCL_MODE_NONBLOCKING) { Tcl_NotifyChannel(statePtr->channel, TCL_WRITABLE); } } if (error != 0) { - /* - * Failure for either a synchronous connection, or an async one that - * failed before it could enter background mode, e.g. because an - * invalid -myaddr was given. - */ - - if (interp != NULL) { - errno = error; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open socket: %s", Tcl_PosixError(interp))); - } - return TCL_ERROR; + /* + * Failure for either a synchronous connection, or an async one that + * failed before it could enter background mode, e.g. because an + * invalid -myaddr was given. + */ + + if (interp != NULL) { + errno = error; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; } return TCL_OK; } @@ -1395,16 +1393,16 @@ Tcl_OpenTcpClient( */ if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) - || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, - &errorMsg)) { - if (addrlist != NULL) { - freeaddrinfo(addrlist); - } - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open socket: %s", errorMsg)); - } - return NULL; + || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, + &errorMsg)) { + if (addrlist != NULL) { + freeaddrinfo(addrlist); + } + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", errorMsg)); + } + return NULL; } /* @@ -1424,14 +1422,14 @@ Tcl_OpenTcpClient( */ if (TcpConnect(interp, statePtr) != TCL_OK) { - TcpCloseProc(statePtr, NULL); - return NULL; + TcpCloseProc(statePtr, NULL); + return NULL; } snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, (long)statePtr); statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - statePtr, TCL_READABLE | TCL_WRITABLE); + statePtr, TCL_READABLE | TCL_WRITABLE); if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation", "auto crlf") == TCL_ERROR) { Tcl_Close(NULL, statePtr->channel); @@ -1461,7 +1459,7 @@ Tcl_MakeTcpClientChannel( void *sock) /* The socket to wrap up into a channel. */ { return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock, - TCL_READABLE | TCL_WRITABLE); + TCL_READABLE | TCL_WRITABLE); } /* @@ -1556,7 +1554,7 @@ Tcl_OpenTcpServer( for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { sock = socket(addrPtr->ai_family, addrPtr->ai_socktype, - addrPtr->ai_protocol); + addrPtr->ai_protocol); if (sock == -1) { if (howfar < SOCKET) { howfar = SOCKET; @@ -1579,98 +1577,97 @@ Tcl_OpenTcpServer( TclSockMinimumBuffers(INT2PTR(sock), SOCKET_BUFSIZE); /* - * Set up to reuse server addresses automatically and bind to the - * specified port. + * Set up to reuse server addresses and/or ports if requested. */ (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &reuseaddr, sizeof(reuseaddr)); - /* - * Make sure we use the same port number when opening two server - * sockets for IPv4 and IPv6 on a random port. - * - * As sockaddr_in6 uses the same offset and size for the port member - * as sockaddr_in, we can handle both through the IPv4 API. - */ + /* + * Make sure we use the same port number when opening two server + * sockets for IPv4 and IPv6 on a random port. + * + * As sockaddr_in6 uses the same offset and size for the port member + * as sockaddr_in, we can handle both through the IPv4 API. + */ if (port == 0 && chosenport != 0) { ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = - htons(chosenport); + htons(chosenport); } #ifdef IPV6_V6ONLY /* - * Missing on: Solaris 2.8 - */ + * Missing on: Solaris 2.8 + */ - if (addrPtr->ai_family == AF_INET6) { - int v6only = 1; + if (addrPtr->ai_family == AF_INET6) { + int v6only = 1; - (void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY, - &v6only, sizeof(v6only)); - } + (void) setsockopt(sock, IPPROTO_IPV6, IPV6_V6ONLY, + &v6only, sizeof(v6only)); + } #endif /* IPV6_V6ONLY */ status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen); - if (status == -1) { + if (status == -1) { if (howfar < BIND) { howfar = BIND; my_errno = errno; } - close(sock); - sock = -1; - continue; - } - if (port == 0 && chosenport == 0) { - address sockname; - socklen_t namelen = sizeof(sockname); - - /* - * Synchronize port numbers when binding to port 0 of multiple - * addresses. - */ - - if (getsockname(sock, &sockname.sa, &namelen) >= 0) { - chosenport = ntohs(sockname.sa4.sin_port); - } - } - status = listen(sock, SOMAXCONN); - if (status < 0) { + close(sock); + sock = -1; + continue; + } + if (port == 0 && chosenport == 0) { + address sockname; + socklen_t namelen = sizeof(sockname); + + /* + * Synchronize port numbers when binding to port 0 of multiple + * addresses. + */ + + if (getsockname(sock, &sockname.sa, &namelen) >= 0) { + chosenport = ntohs(sockname.sa4.sin_port); + } + } + status = listen(sock, SOMAXCONN); + if (status < 0) { if (howfar < LISTEN) { howfar = LISTEN; my_errno = errno; } - close(sock); - sock = -1; - continue; - } - if (statePtr == NULL) { - /* - * Allocate a new TcpState for this socket. - */ - - statePtr = (TcpState *)ckalloc(sizeof(TcpState)); - memset(statePtr, 0, sizeof(TcpState)); - statePtr->acceptProc = acceptProc; - statePtr->acceptProcData = acceptProcData; - snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, (long) statePtr); - newfds = &statePtr->fds; - } else { - newfds = (TcpFdList *)ckalloc(sizeof(TcpFdList)); - memset(newfds, (int) 0, sizeof(TcpFdList)); - fds->next = newfds; - } - newfds->fd = sock; - newfds->statePtr = statePtr; - fds = newfds; - - /* - * Set up the callback mechanism for accepting connections from new - * clients. - */ - - Tcl_CreateFileHandler(sock, TCL_READABLE, TcpAccept, fds); + close(sock); + sock = -1; + continue; + } + if (statePtr == NULL) { + /* + * Allocate a new TcpState for this socket. + */ + + statePtr = (TcpState *)ckalloc(sizeof(TcpState)); + memset(statePtr, 0, sizeof(TcpState)); + statePtr->acceptProc = acceptProc; + statePtr->acceptProcData = acceptProcData; + snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, (long)statePtr); + newfds = &statePtr->fds; + } else { + newfds = (TcpFdList *)ckalloc(sizeof(TcpFdList)); + memset(newfds, (int) 0, sizeof(TcpFdList)); + fds->next = newfds; + } + newfds->fd = sock; + newfds->statePtr = statePtr; + fds = newfds; + + /* + * Set up the callback mechanism for accepting connections from new + * clients. + */ + + Tcl_CreateFileHandler(sock, TCL_READABLE, TcpAccept, fds); } error: @@ -1683,15 +1680,15 @@ Tcl_OpenTcpServer( return statePtr->channel; } if (interp != NULL) { - Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", -1); + Tcl_Obj *errorObj = Tcl_NewStringObj("couldn't open socket: ", -1); if (errorMsg == NULL) { - errno = my_errno; - Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), -1); - } else { + errno = my_errno; + Tcl_AppendToObj(errorObj, Tcl_PosixError(interp), -1); + } else { Tcl_AppendToObj(errorObj, errorMsg, -1); } - Tcl_SetObjResult(interp, errorObj); + Tcl_SetObjResult(interp, errorObj); } if (sock != -1) { close(sock); @@ -1756,9 +1753,9 @@ TcpAccept( if (fds->statePtr->acceptProc != NULL) { getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port), - NI_NUMERICHOST|NI_NUMERICSERV); + NI_NUMERICHOST|NI_NUMERICSERV); fds->statePtr->acceptProc(fds->statePtr->acceptProcData, - newSockState->channel, host, atoi(port)); + newSockState->channel, host, atoi(port)); } } diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 92ea830..3bda2e1 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -105,7 +105,7 @@ TclplatformtestInit( Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfork", TestforkObjCmd, - NULL, NULL); + NULL, NULL); Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd, @@ -164,7 +164,7 @@ TestfilehandlerCmd( if (argc < 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " option ... \"", NULL); - return TCL_ERROR; + return TCL_ERROR; } pipePtr = NULL; if (argc >= 3) { @@ -259,9 +259,9 @@ TestfilehandlerCmd( return TCL_ERROR; } - while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) { + while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) { /* Empty loop body. */ - } + } } else if (strcmp(argv[1], "fill") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", @@ -270,9 +270,9 @@ TestfilehandlerCmd( } memset(buffer, 'a', 4000); - while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) { + while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) { /* Empty loop body. */ - } + } } else if (strcmp(argv[1], "fillpartial") == 0) { char buf[TCL_INTEGER_SPACE]; @@ -480,18 +480,18 @@ TestgetopenfileCmd( ClientData filePtr; if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName forWriting\"", NULL); - return TCL_ERROR; + return TCL_ERROR; } if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr) == TCL_ERROR) { - return TCL_ERROR; + return TCL_ERROR; } if (filePtr == NULL) { - Tcl_AppendResult(interp, + Tcl_AppendResult(interp, "Tcl_GetOpenFile succeeded but FILE * NULL!", NULL); - return TCL_ERROR; + return TCL_ERROR; } return TCL_OK; } @@ -521,9 +521,9 @@ TestsetdefencdirCmd( const char **argv) /* Argument strings. */ { if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " defaultDir\"", NULL); - return TCL_ERROR; + return TCL_ERROR; } Tcl_SetDefaultEncodingDir(argv[1]); @@ -557,14 +557,14 @@ TestforkObjCmd( pid_t pid; if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, ""); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; } pid = fork(); if (pid == -1) { - Tcl_AppendResult(interp, - "Cannot fork", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, + "Cannot fork", NULL); + return TCL_ERROR; } /* Only needed when pthread_atfork is not present, * should not hurt otherwise. */ @@ -600,8 +600,8 @@ TestgetdefencdirCmd( const char **argv) /* Argument strings. */ { if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], NULL); + return TCL_ERROR; } Tcl_AppendResult(interp, Tcl_GetDefaultEncodingDir(), NULL); diff --git a/win/Makefile.in b/win/Makefile.in index 3b89dd7..c433b6c 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -516,7 +516,7 @@ ${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} ${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT} @$(RM) ${TEST_EXE_FILE} $(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ - tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) + tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) $(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest # use prebuilt zlib1.dll diff --git a/win/nmakehlp.c b/win/nmakehlp.c index b0799f8..4fc9f7a 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -90,7 +90,7 @@ main( case 'c': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, - "usage: %s -c \n" + "usage: %s -c \n" "Tests for whether cl.exe supports an option\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, @@ -271,7 +271,7 @@ CheckForCompilerFeature( if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, - "Tried to launch: \"%s\", but got error [%lu]: ", cmdline, err); + "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars], @@ -318,11 +318,11 @@ CheckForCompilerFeature( */ return !(strstr(Out.buffer, "D4002") != NULL - || strstr(Err.buffer, "D4002") != NULL - || strstr(Out.buffer, "D9002") != NULL - || strstr(Err.buffer, "D9002") != NULL - || strstr(Out.buffer, "D2021") != NULL - || strstr(Err.buffer, "D2021") != NULL); + || strstr(Err.buffer, "D4002") != NULL + || strstr(Out.buffer, "D9002") != NULL + || strstr(Err.buffer, "D9002") != NULL + || strstr(Out.buffer, "D2021") != NULL + || strstr(Err.buffer, "D2021") != NULL); } static int @@ -405,7 +405,7 @@ CheckForLinkerFeature( if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, - "Tried to launch: \"%s\", but got error [%lu]: ", cmdline, err); + "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars], @@ -600,9 +600,9 @@ list_free(list_item_t **listPtrPtr) * * Usage is something like: * nmakehlp -S << $** > $@ - * @PACKAGE_NAME@ $(PACKAGE_NAME) - * @PACKAGE_VERSION@ $(PACKAGE_VERSION) - * << + * @PACKAGE_NAME@ $(PACKAGE_NAME) + * @PACKAGE_VERSION@ $(PACKAGE_VERSION) + * << */ static int @@ -730,7 +730,7 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) return 2; /* Have no real error reporting mechanism into nmake */ } dirlen = strlen(dir); - if (dirlen > sizeof(path) - 3) { + if ((dirlen + 3) > sizeof(path)) { return 2; } strncpy(path, dir, dirlen); @@ -747,8 +747,9 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) #else hSearch = FindFirstFile(path, &finfo); #endif - if (hSearch == INVALID_HANDLE_VALUE) + if (hSearch == INVALID_HANDLE_VALUE) { return 1; /* Not found */ + } /* Loop through all subdirs checking if the keypath is under there */ ret = 1; /* Assume not found */ @@ -758,11 +759,13 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) * We need to check it is a directory despite the * FindExSearchLimitToDirectories in the above call. See SDK docs */ - if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) + if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) { continue; + } sublen = strlen(finfo.cFileName); - if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) + if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) { continue; /* Path does not fit, assume not matched */ + } strncpy(path+dirlen+1, finfo.cFileName, sublen); path[dirlen+1+sublen] = '\\'; strncpy(path+dirlen+1+sublen+1, keypath, keylen+1); @@ -782,13 +785,13 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) * LocateDependency -- * * Locates a dependency for a package. - * keypath - a relative path within the package directory - * that is used to confirm it is the correct directory. + * keypath - a relative path within the package directory + * that is used to confirm it is the correct directory. * The search path for the package directory is currently only - * the parent and grandparent of the current working directory. - * If found, the command prints - * name_DIRPATH= - * and returns 0. If not found, does not print anything and returns 1. + * the parent and grandparent of the current working directory. + * If found, the command prints + * name_DIRPATH= + * and returns 0. If not found, does not print anything and returns 1. */ static int LocateDependency(const char *keypath) { -- cgit v0.12 From e715bc67dad8fd0fc152aff7a0f595f8d5fd1286 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 21 Jun 2024 09:17:17 +0000 Subject: Fix wrong example: Should be "-translation binary" here, not "-encoding binary" --- doc/fileevent.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/fileevent.n b/doc/fileevent.n index 2751040..d9b70a5 100644 --- a/doc/fileevent.n +++ b/doc/fileevent.n @@ -125,7 +125,7 @@ proc GetData {chan} { } } -fconfigure $chan -blocking 0 -encoding binary +fconfigure $chan -blocking 0 -translation binary \fBfileevent\fR $chan readable [list GetData $chan] .CE .PP -- cgit v0.12 From f82e67e7bfa7df973c5d4fc862b964c90ec5b72c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 21 Jun 2024 14:44:17 +0000 Subject: Revise use of "-translation binary" in testcases: Use it where usefull, don't use it any more where misleading --- tests-perf/chan.perf.tcl | 6 +++--- tests/chanio.test | 24 ++++++++++++------------ tests/encoding.test | 8 ++++---- tests/ioCmd.test | 5 ++--- 4 files changed, 21 insertions(+), 22 deletions(-) diff --git a/tests-perf/chan.perf.tcl b/tests-perf/chan.perf.tcl index 56acccf..6bc9204 100644 --- a/tests-perf/chan.perf.tcl +++ b/tests-perf/chan.perf.tcl @@ -27,12 +27,12 @@ namespace path {::tclTestPerf} proc _get_test_chan {{bufSize 4096}} { lassign [chan pipe] ch wch; - fconfigure $ch -translation binary -encoding utf-8 -buffersize $bufSize -buffering full - fconfigure $wch -translation binary -encoding utf-8 -buffersize $bufSize -buffering full + fconfigure $ch -translation lf -encoding utf-8 -buffersize $bufSize -buffering full + fconfigure $wch -translation lf -encoding utf-8 -buffersize $bufSize -buffering full exec [info nameofexecutable] -- $bufSize >@$wch << { set bufSize [lindex $::argv end] - fconfigure stdout -translation binary -encoding utf-8 -buffersize $bufSize -buffering full + fconfigure stdout -translation lf -encoding utf-8 -buffersize $bufSize -buffering full set buf [string repeat test 1000]; # 4K # write ~ 10*1M + 10*2M + 10*10M + 1*20M: set i 0; while {$i < int((10*1e6 + 10*2e6 + 10*10e6 + 1*20e6)/4e3)} { diff --git a/tests/chanio.test b/tests/chanio.test index 0766c35..fb566d4 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6649,7 +6649,7 @@ test chan-io-52.3 {TclCopyChannel} -constraints {fcopy} -setup { } -body { set f1 [open $thisScript] set f2 [open $path(test1) w] - chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0 + chan configure $f1 -translation binary -blocking 0 chan configure $f2 -translation cr -encoding iso8859-1 -blocking 0 set s0 [chan copy $f1 $f2] set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] @@ -6680,8 +6680,8 @@ test chan-io-52.5 {TclCopyChannel, all} -constraints {fcopy} -setup { } -body { set f1 [open $thisScript] set f2 [open $path(test1) w] - chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0 - chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0 + chan configure $f1 -translation binary -blocking 0 + chan configure $f2 -translation binary -blocking 0 chan copy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified. set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 @@ -6696,8 +6696,8 @@ test chan-io-52.5a {TclCopyChannel, all, other negative value} -setup { } -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] - chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0 - chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0 + chan configure $f1 -translation binary -blocking 0 + chan configure $f2 -translation binary -blocking 0 chan copy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 @@ -6712,8 +6712,8 @@ test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} -setup { } -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] - chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0 - chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0 + chan configure $f1 -translation binary -blocking 0 + chan configure $f2 -translation binary -blocking 0 chan copy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 @@ -6728,8 +6728,8 @@ test chan-io-52.6 {TclCopyChannel} -setup { } -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] - chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0 - chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0 + chan configure $f1 -translation binary -blocking 0 + chan configure $f2 -translation binary -blocking 0 set s0 [chan copy $f1 $f2 -size [expr {[file size $thisScript] + 5}]] set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 @@ -6746,8 +6746,8 @@ test chan-io-52.7 {TclCopyChannel} -constraints {fcopy} -setup { } -body { set f1 [open $thisScript] set f2 [open $path(test1) w] - chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0 - chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0 + chan configure $f1 -translation binary -blocking 0 + chan configure $f2 -translation binary -blocking 0 chan copy $f1 $f2 set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] if {[file size $thisScript] == [file size $path(test1)]} { @@ -6864,7 +6864,7 @@ test chan-io-53.2 {CopyData} -setup { } -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] - chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0 + chan configure $f1 -translation binary -blocking 0 chan configure $f2 -translation cr -encoding iso8859-1 -blocking 0 chan copy $f1 $f2 -command [namespace code {set s0}] set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] diff --git a/tests/encoding.test b/tests/encoding.test index 3feaa55..93a52aa 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -183,11 +183,11 @@ test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { test encoding-8.1 {Tcl_ExternalToUtf} { set f [open [file join [temporaryDirectory] dummy] w] - fconfigure $f -translation binary -encoding iso8859-1 + fconfigure $f -translation binary puts -nonewline $f "ab\x8C\xC1g" close $f set f [open [file join [temporaryDirectory] dummy] r] - fconfigure $f -translation binary -encoding shiftjis + fconfigure $f -translation lf -encoding shiftjis set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] @@ -211,11 +211,11 @@ test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} { test encoding-10.1 {Tcl_UtfToExternal} { set f [open [file join [temporaryDirectory] dummy] w] - fconfigure $f -translation binary -encoding shiftjis + fconfigure $f -translation lf -encoding shiftjis puts -nonewline $f "ab\u4E4Eg" close $f set f [open [file join [temporaryDirectory] dummy] r] - fconfigure $f -translation binary -encoding iso8859-1 + fconfigure $f -translation binary set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 74fabe7..b167475 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -61,7 +61,7 @@ test iocmd-1.7 {puts command} { } 7 test iocmd-1.8 {puts command} { set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} -encoding iso8859-1 + fconfigure $f -translation binary puts -nonewline $f [binary format a4a5 foo bar] close $f file size $path(test1) @@ -249,8 +249,7 @@ test iocmd-8.8 {fconfigure command} { test iocmd-8.9 {fconfigure command} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ - -eofchar {} -encoding binary + fconfigure $f1 -translation binary -buffering none -buffersize 4040 set x [fconfigure $f1] close $f1 set x -- cgit v0.12 From 505740c99d4bb50bc18f46ae7c618c2de0f9a130 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 27 Jun 2024 10:20:35 +0000 Subject: cmdAH.test: strengthening time64bit constraint (try to fix test failures [fd91b0ca09cb171f]), always prefer size of st_mtime if testsize available --- tests/cmdAH.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 526c261..0a3c76d 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -22,8 +22,8 @@ testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint time64bit [expr { - $::tcl_platform(pointerSize) >= 8 || - [llength [info command testsize]] && [testsize st_mtime] >= 8 + ([llength [info command testsize]] ? + [testsize st_mtime] : $::tcl_platform(pointerSize)) >= 8 }] testConstraint linkDirectory [expr { ![testConstraint win] || -- cgit v0.12 From ad497e8cd5d6e480a6caefba2666e5641527df66 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 29 Jun 2024 11:51:32 +0000 Subject: Fix docs for tcl::tm::roots - takes a single argument. --- doc/tm.n | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/tm.n b/doc/tm.n index bdc167a..60d1aae 100644 --- a/doc/tm.n +++ b/doc/tm.n @@ -15,7 +15,7 @@ tm \- Facilities for locating and loading of Tcl Modules \fB::tcl::tm::path add \fR?\fIpath\fR...? \fB::tcl::tm::path remove \fR?\fIpath\fR...? \fB::tcl::tm::path list\fR -\fB::tcl::tm::roots \fR?\fIpath\fR...? +\fB::tcl::tm::roots \fR\fIpaths\fR .fi .BE .SH DESCRIPTION @@ -56,10 +56,10 @@ ignores all paths which are not on the list. Returns a list containing all registered module paths, in the order that they are searched for modules. .TP -\fB::tcl::tm::roots \fR?\fIpath\fR...? +\fB::tcl::tm::roots \fR\fIpaths\fR . Similar to \fBpath add\fR, and layered on top of it. This command -takes a list of paths, extends each with +takes a single argument containing a list of paths, extends each with .QW "\fBtcl\fIX\fB/site-tcl\fR" , and .QW "\fBtcl\fIX\fB/\fIX\fB.\fIy\fR" , -- cgit v0.12 From 570e6997db0a989a0c23ed8a5f162c22211c0ee4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 30 Jun 2024 14:45:46 +0000 Subject: macos-11 is no longer available on GITHUB, so switch to macos-12 --- .github/workflows/mac-build.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index 30408d8..bd8e703 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -11,7 +11,7 @@ permissions: contents: read jobs: xcode: - runs-on: macos-11 + runs-on: macos-12 defaults: run: shell: bash @@ -34,7 +34,7 @@ jobs: MAC_CI: 1 timeout-minutes: 15 clang: - runs-on: macos-11 + runs-on: macos-12 strategy: matrix: config: -- cgit v0.12 From 778f45c5349cd0bc32e3f3bc07d1811f56c7ba3f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 1 Jul 2024 19:22:00 +0000 Subject: Fix [5fca83d78c]: [encoding system] is wrong in an ISO-8859-1 locale --- tests/cmdAH.test | 2 +- unix/tclUnixInit.c | 67 ++++++++++++++++++++++++++++-------------------------- 2 files changed, 36 insertions(+), 33 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 0a3c76d..5ab1ec7 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -22,7 +22,7 @@ testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint time64bit [expr { - ([llength [info command testsize]] ? + ([llength [info command testsize]] ? [testsize st_mtime] : $::tcl_platform(pointerSize)) >= 8 }] testConstraint linkDirectory [expr { diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 5a27359..c7b2efe 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -55,31 +55,31 @@ static const char *const processors[NUMPROCESSORS] = { }; typedef struct { - union { - unsigned int dwOemId; - struct { - int wProcessorArchitecture; - int wReserved; + union { + unsigned int dwOemId; + struct { + int wProcessorArchitecture; + int wReserved; + }; }; - }; - unsigned int dwPageSize; - void *lpMinimumApplicationAddress; - void *lpMaximumApplicationAddress; - void *dwActiveProcessorMask; - unsigned int dwNumberOfProcessors; - unsigned int dwProcessorType; - unsigned int dwAllocationGranularity; - int wProcessorLevel; - int wProcessorRevision; + unsigned int dwPageSize; + void *lpMinimumApplicationAddress; + void *lpMaximumApplicationAddress; + void *dwActiveProcessorMask; + unsigned int dwNumberOfProcessors; + unsigned int dwProcessorType; + unsigned int dwAllocationGranularity; + int wProcessorLevel; + int wProcessorRevision; } SYSTEM_INFO; typedef struct { - unsigned int dwOSVersionInfoSize; - unsigned int dwMajorVersion; - unsigned int dwMinorVersion; - unsigned int dwBuildNumber; - unsigned int dwPlatformId; - wchar_t szCSDVersion[128]; + unsigned int dwOSVersionInfoSize; + unsigned int dwMajorVersion; + unsigned int dwMinorVersion; + unsigned int dwBuildNumber; + unsigned int dwPlatformId; + wchar_t szCSDVersion[128]; } OSVERSIONINFOW; #endif @@ -337,7 +337,6 @@ static int MacOSXGetLibraryPath(Tcl_Interp *interp, MODULE_SCOPE long tclMacOSXDarwinRelease; long tclMacOSXDarwinRelease = 0; #endif - /* *--------------------------------------------------------------------------- @@ -600,17 +599,21 @@ SearchKnownEncodings( int left = 0; int right = sizeof(localeTable)/sizeof(LocaleTable); + /* Here, search for i in the interval left <= i < right. */ while (left < right) { int test = (left + right)/2; int code = strcmp(localeTable[test].lang, encoding); if (code == 0) { + /* Found it at i == test. */ return localeTable[test].encoding; } if (code < 0) { + /* Restrict the search to the interval test < i < right. */ left = test+1; } else { - right = test-1; + /* Restrict the search to the interval left <= i < test. */ + right = test; } } return NULL; @@ -853,15 +856,15 @@ TclpSetVariables( } } #endif /* HAVE_COREFOUNDATION */ - p = pkgPath; - while ((q = strchr(p, ':')) != NULL) { - Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, q-p)); - p = q+1; - } - if (*p) { - Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, -1)); - } - Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_pkgPath", -1), NULL, pkgListObj, TCL_GLOBAL_ONLY); + p = pkgPath; + while ((q = strchr(p, ':')) != NULL) { + Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, q-p)); + p = q+1; + } + if (*p) { + Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, -1)); + } + Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_pkgPath", -1), NULL, pkgListObj, TCL_GLOBAL_ONLY); #ifdef DJGPP Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY); -- cgit v0.12 From b3a4cff38fe89dffa98affcf23de984ed9e718fa Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 1 Jul 2024 20:04:27 +0000 Subject: further attempt to fix [fd91b0ca09cb171f] (check whether some disk/driver may have 2038 problem) --- tests/cmdAH.test | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 5ab1ec7..2b5b0e9 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -25,6 +25,22 @@ testConstraint time64bit [expr { ([llength [info command testsize]] ? [testsize st_mtime] : $::tcl_platform(pointerSize)) >= 8 }] +testConstraint filetime64bit [expr { + [testConstraint time64bit] && ( + ![testConstraint unix] || [apply {{} { + # check whether disk may have 2038 problem, see [fd91b0ca09cb171f]: + set fn [makeFile "" foo.text] + if {[catch { + exec sh -c "TZ=:UTC LC_TYME=en_US touch -ma -t '207006290000' '$fn' && TZ=:UTC LC_TYME=en_US ls -l '$fn'" + } res]} { + #puts "Check constraint failed:\t$res" + set res {} + } + removeFile $fn + regexp {\mJun\s+29\s+2070\M} $res + }}] + ) +}] testConstraint linkDirectory [expr { ![testConstraint win] || ($::tcl_platform(osVersion) >= 5.0 @@ -1296,14 +1312,14 @@ test cmdAH-24.14.1 { } -match regexp -result {could not (?:get modification time|read)} -returnCodes error # 3155760000 is 64-bit Unix time, Wed Jan 01 00:00:00 GMT 2070: -test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup { +test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit filetime64bit} -setup { set filename [makeFile "" foo.text] } -body { list [file atime $filename 3155760000] [file atime $filename] } -cleanup { removeFile $filename } -result {3155760000 3155760000} -test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup { +test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit filetime64bit} -setup { set filename [makeFile "" foo.text] } -body { list [file mtime $filename 3155760000] [file mtime $filename] -- cgit v0.12 From 344ec769621fb26f9489a9eaab5647c86fccf046 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 2 Jul 2024 12:22:24 +0000 Subject: Fix for [0de6c1d79c] crash (cherry-picked from trunk) --- generic/tclCmdIL.c | 25 ++++++++++++++++++++++++- tests/info.test | 9 +++++++++ 2 files changed, 33 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index aef0399..3198cc9 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1160,8 +1160,31 @@ InfoFrameCmd( } corPtr = corPtr->callerEEPtr->corPtr; } - topLevel += (*cmdFramePtrPtr)->level; + if (iPtr->cmdFramePtr == NULL || *cmdFramePtrPtr == NULL) { + if (objc == 1) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + } else { + if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { + code = TCL_ERROR; + } else { + Tcl_Obj *objs[2]; + /* + * TODO - "precompiled" is a lie. Chosen only because as documented + * no other fields in the dictionary need be returned. Should + * add a new type like "unknown" meaning no further information + * available. + * TODO - should we check that "level" is 1 ? + */ + TclNewLiteralStringObj(objs[0], "type"); + TclNewLiteralStringObj(objs[1], "precompiled"); + Tcl_SetObjResult(interp, Tcl_NewListObj(2, objs)); + } + } + return code; + } + + topLevel += (*cmdFramePtrPtr)->level; if (topLevel != iPtr->cmdFramePtr->level) { framePtr = iPtr->cmdFramePtr; while (framePtr) { diff --git a/tests/info.test b/tests/info.test index 69be6a3..ff3457f 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2415,6 +2415,15 @@ test info-39.2 {Bug 4b61afd660} -setup { rename probe {} } -result 3 +test info-40.0 {Bug 0de6c1d79c crash} -setup { + interp create child + child hide info +} -cleanup { + interp delete child +} -body { + child invokehidden info frame +} -result 1 + # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests -- cgit v0.12 From f66787a44e4ecff034041fcd1817e2a8613ecb85 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 2 Jul 2024 12:36:17 +0000 Subject: fix crash [0de6c1d79c] more consistently (an error "bad level" for info instead of artifical dummy info) --- generic/tclCmdIL.c | 30 +++++------------------------- tests/info.test | 9 ++++++--- 2 files changed, 11 insertions(+), 28 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 3198cc9..877f94e 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1160,32 +1160,9 @@ InfoFrameCmd( } corPtr = corPtr->callerEEPtr->corPtr; } + topLevel += *cmdFramePtrPtr ? (*cmdFramePtrPtr)->level : 1; - if (iPtr->cmdFramePtr == NULL || *cmdFramePtrPtr == NULL) { - if (objc == 1) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); - } else { - if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) { - code = TCL_ERROR; - } else { - Tcl_Obj *objs[2]; - /* - * TODO - "precompiled" is a lie. Chosen only because as documented - * no other fields in the dictionary need be returned. Should - * add a new type like "unknown" meaning no further information - * available. - * TODO - should we check that "level" is 1 ? - */ - TclNewLiteralStringObj(objs[0], "type"); - TclNewLiteralStringObj(objs[1], "precompiled"); - Tcl_SetObjResult(interp, Tcl_NewListObj(2, objs)); - } - } - return code; - } - - topLevel += (*cmdFramePtrPtr)->level; - if (topLevel != iPtr->cmdFramePtr->level) { + if (iPtr->cmdFramePtr && topLevel != iPtr->cmdFramePtr->level) { framePtr = iPtr->cmdFramePtr; while (framePtr) { framePtr->level = topLevel--; @@ -1234,6 +1211,9 @@ InfoFrameCmd( } framePtr = iPtr->cmdFramePtr; + if (!framePtr) { + goto levelError; + } while (++level <= 0) { framePtr = framePtr->nextPtr; if (!framePtr) { diff --git a/tests/info.test b/tests/info.test index ff3457f..17c114b 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2418,11 +2418,14 @@ test info-39.2 {Bug 4b61afd660} -setup { test info-40.0 {Bug 0de6c1d79c crash} -setup { interp create child child hide info +} -body { + list [child invokehidden info frame] \ + [catch {child invokehidden info frame 0} msg] $msg \ + [catch {child invokehidden info frame 1} msg] $msg } -cleanup { interp delete child -} -body { - child invokehidden info frame -} -result 1 + unset -nocomplain msg +} -result {1 1 {bad level "0"} 1 {bad level "1"}} # cleanup catch {namespace delete test_ns_info1 test_ns_info2} -- cgit v0.12 From 537494be8151ed09a6afb6d07f752ca542f79fa0 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 2 Jul 2024 14:36:59 +0000 Subject: info frame: restored return {type precompiled} in case of no frame information; see [0de6c1d79cfba2ea] for description --- generic/tclCmdIL.c | 16 +++++++++------- tests/info.test | 8 +++++--- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 877f94e..b4f821f 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1211,9 +1211,6 @@ InfoFrameCmd( } framePtr = iPtr->cmdFramePtr; - if (!framePtr) { - goto levelError; - } while (++level <= 0) { framePtr = framePtr->nextPtr; if (!framePtr) { @@ -1282,9 +1279,14 @@ TclInfoFrame( static const char *const typeString[TCL_LOCATION_LAST] = { "eval", "eval", "eval", "precompiled", "source", "proc" }; - Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; + Proc *procPtr = NULL; int needsFree = -1; + if (!framePtr) { + goto precompiled; + } + procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; + /* * Pull the information and construct the dictionary to return, as list. * Regarding use of the CmdFrame fields see tclInt.h, and its definition. @@ -1312,11 +1314,11 @@ TclInfoFrame( break; case TCL_LOCATION_PREBC: + precompiled: /* * Precompiled. Result contains the type as signal, nothing else. */ - - ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); + ADD_PAIR("type", Tcl_NewStringObj(typeString[TCL_LOCATION_PREBC], -1)); break; case TCL_LOCATION_BC: { @@ -1431,7 +1433,7 @@ TclInfoFrame( * _visible_ CallFrame. */ - if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) { + if (framePtr && (framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) { CallFrame *current = framePtr->framePtr; CallFrame *top = iPtr->varFramePtr; CallFrame *idx; diff --git a/tests/info.test b/tests/info.test index 17c114b..0921466 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2420,12 +2420,14 @@ test info-40.0 {Bug 0de6c1d79c crash} -setup { child hide info } -body { list [child invokehidden info frame] \ - [catch {child invokehidden info frame 0} msg] $msg \ - [catch {child invokehidden info frame 1} msg] $msg + [child invokehidden info frame 0] \ + [child invokehidden info frame 1] \ + [catch {child invokehidden info frame -1} msg] $msg \ + [catch {child invokehidden info frame 2} msg] $msg } -cleanup { interp delete child unset -nocomplain msg -} -result {1 1 {bad level "0"} 1 {bad level "1"}} +} -result {1 {type precompiled} {type precompiled} 1 {bad level "-1"} 1 {bad level "2"}} # cleanup catch {namespace delete test_ns_info1 test_ns_info2} -- cgit v0.12 From 2e6ac166449d709bee99ad8f569bc7aca1d08e2a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 3 Jul 2024 12:34:15 +0000 Subject: Tcl_RegisterObjType() in alphabetical order. Backport some formatting and type-casts from 8.7/9.0 --- generic/tclObj.c | 190 ++++++++++++++++++++++++++++--------------------------- 1 file changed, 97 insertions(+), 93 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 35c62c3..ec4655e 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -5,9 +5,9 @@ * Tcl commands. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * Copyright (c) 1999 by Scriptics Corporation. - * Copyright (c) 2001 by ActiveState Corporation. - * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 1999 Scriptics Corporation. + * Copyright (c) 2001 ActiveState Corporation. + * Copyright (c) 2005 Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen * * See the file "license.terms" for information on usage and redistribution of @@ -78,20 +78,20 @@ typedef struct ObjData { typedef struct ThreadSpecificData { Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj - * generated by a call to the function - * TclSubstTokens() from a literal text - * where bs+nl sequences occurred in it, if - * any. I.e. this table keeps track of - * invisible and stripped continuation lines. - * Its keys are Tcl_Obj pointers, the values - * are ContLineLoc pointers. See the file - * tclCompile.h for the definition of this - * structure, and for references to all - * related places in the core. */ + * generated by a call to the function + * TclSubstTokens() from a literal text + * where bs+nl sequences occurred in it, if + * any. I.e. this table keeps track of + * invisible and stripped continuation lines. + * Its keys are Tcl_Obj pointers, the values + * are ContLineLoc pointers. See the file + * tclCompile.h for the definition of this + * structure, and for references to all + * related places in the core. */ #if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) Tcl_HashTable *objThreadMap;/* Thread local table that is used to check - * that a Tcl_Obj was not allocated by some - * other thread. */ + * that a Tcl_Obj was not allocated by some + * other thread. */ #endif /* TCL_MEM_DEBUG && TCL_THREADS */ } ThreadSpecificData; @@ -169,7 +169,7 @@ static __thread PendingObjData pendingObjData; static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = \ - Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) + (PendingObjData *)Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif /* @@ -195,7 +195,7 @@ static Tcl_ThreadDataKey pendingObjDataKey; if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \ (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \ } else { \ - (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \ + (bignum).dp = (mp_digit *)(objPtr)->internalRep.twoPtrValue.ptr1; \ (bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \ (bignum).alloc = \ (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7FFF; \ @@ -394,18 +394,18 @@ TclInitObjSubsystem(void) Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); + Tcl_RegisterObjType(&tclArraySearchType); Tcl_RegisterObjType(&tclByteArrayType); + Tcl_RegisterObjType(&tclByteCodeType); + Tcl_RegisterObjType(&tclCmdNameType); + Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); - Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); - Tcl_RegisterObjType(&tclDictType); - Tcl_RegisterObjType(&tclByteCodeType); - Tcl_RegisterObjType(&tclArraySearchType); - Tcl_RegisterObjType(&tclCmdNameType); - Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); + Tcl_RegisterObjType(&tclRegexpType); + Tcl_RegisterObjType(&tclStringType); /* For backward compatibility only ... */ Tcl_RegisterObjType(&oldBooleanType); @@ -457,7 +457,7 @@ TclFinalizeThreadObjects(void) if (tablePtr != NULL) { for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - ObjData *objData = Tcl_GetHashValue(hPtr); + ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); if (objData != NULL) { ckfree(objData); @@ -636,7 +636,8 @@ TclContinuationsEnterDerived( int start, int *clNext) { - int length, end, num; + int length; + int end, num; int *wordCLLast = clNext; /* @@ -730,10 +731,10 @@ TclContinuationsCopy( { ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr); + Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr); if (hPtr) { - ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr); + ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_GetHashValue(hPtr); TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc); } @@ -764,12 +765,12 @@ TclContinuationsGet( { ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (!hPtr) { - return NULL; + return NULL; } - return Tcl_GetHashValue(hPtr); + return (ContLineLoc *)Tcl_GetHashValue(hPtr); } /* @@ -897,7 +898,7 @@ Tcl_AppendAllObjTypes( for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1)); + Tcl_NewStringObj((char *)Tcl_GetHashKey(&typeTable, hPtr), -1)); } Tcl_MutexUnlock(&tableMutex); return TCL_OK; @@ -930,7 +931,7 @@ Tcl_GetObjType( Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); if (hPtr != NULL) { - typePtr = Tcl_GetHashValue(hPtr); + typePtr = (const Tcl_ObjType *)Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); return typePtr; @@ -1017,7 +1018,7 @@ TclDbDumpActiveObjects( fprintf(outFile, "total objects: %d\n", tablePtr->numEntries); for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - ObjData *objData = Tcl_GetHashValue(hPtr); + ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); if (objData != NULL) { fprintf(outFile, @@ -1317,13 +1318,13 @@ TclFreeObj( if (!tablePtr) { Tcl_Panic("TclFreeObj: object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, (char *)objPtr); if (hPtr) { /* * As the Tcl_Obj is going to be deleted we remove the entry. */ - ObjData *objData = Tcl_GetHashValue(hPtr); + ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); if (objData != NULL) { ckfree(objData); @@ -1401,10 +1402,10 @@ TclFreeObj( { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; if (tsdPtr->lineCLPtr) { - hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); @@ -1492,10 +1493,10 @@ TclFreeObj( { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr; if (tsdPtr->lineCLPtr) { - hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); + hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); @@ -2005,14 +2006,15 @@ static int ParseBoolean( Tcl_Obj *objPtr) /* The object to parse/convert. */ { - int i, length, newBool; + int newBool; char lowerCase[6]; + int i, length; const char *str = TclGetStringFromObj(objPtr, &length); if ((length < 1) || (length > 5)) { /* - * Longest valid boolean string rep. is "false". - */ + * Longest valid boolean string rep. is "false". + */ return TCL_ERROR; } @@ -2284,8 +2286,8 @@ Tcl_GetDoubleFromObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "floating point value is Not a Number", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", - (char *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", + (char *)NULL); } return TCL_ERROR; } @@ -2794,9 +2796,9 @@ Tcl_GetLongFromObj( #endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected integer but got \"%s\"", - TclGetString(objPtr))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL); } return TCL_ERROR; @@ -3090,9 +3092,9 @@ Tcl_GetWideIntFromObj( } if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected integer but got \"%s\"", - TclGetString(objPtr))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL); } return TCL_ERROR; @@ -3426,9 +3428,9 @@ GetBignumFromObj( #endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected integer but got \"%s\"", - TclGetString(objPtr))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL); } return TCL_ERROR; @@ -3678,8 +3680,8 @@ TclGetNumberFromObj( #endif if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; - mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, - (int) sizeof(mp_int)); + mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey, + (int)sizeof(mp_int)); UNPACK_BIGNUM(objPtr, *bigPtr); *typePtr = TCL_NUMBER_BIG; @@ -3746,7 +3748,7 @@ Tcl_DbIncrRefCount( hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", - "incr ref count"); + "incr ref count"); } } # endif /* TCL_THREADS */ @@ -3809,7 +3811,7 @@ Tcl_DbDecrRefCount( hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", - "decr ref count"); + "decr ref count"); } } # endif /* TCL_THREADS */ @@ -3874,7 +3876,7 @@ Tcl_DbIsShared( hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", - "check shared status"); + "check shared status"); } } # endif /* TCL_THREADS */ @@ -3976,8 +3978,8 @@ TclCompareObjKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - Tcl_Obj *objPtr1 = keyPtr; - Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; + Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr; + Tcl_Obj *objPtr2 = (Tcl_Obj *)hPtr->key.oneWordValue; const char *p1, *p2; size_t l1, l2; @@ -3985,7 +3987,9 @@ TclCompareObjKeys( * If the object pointers are the same then they match. * OPT: this comparison was moved to the caller - if (objPtr1 == objPtr2) return 1; + if (objPtr1 == objPtr2) { + return 1; + } */ /* @@ -4065,7 +4069,7 @@ TclHashObjKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ { - Tcl_Obj *objPtr = keyPtr; + Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; int length; const char *string = TclGetStringFromObj(objPtr, &length); unsigned int result = 0; @@ -4163,24 +4167,24 @@ Tcl_GetCommandFromObj( * to discard the old rep and create a new one. */ - resPtr = objPtr->internalRep.twoPtrValue.ptr1; + resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) { - Command *cmdPtr = resPtr->cmdPtr; - - if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch) - && !(cmdPtr->flags & CMD_IS_DELETED) - && (interp == cmdPtr->nsPtr->interp) - && !(cmdPtr->nsPtr->flags & NS_DYING)) { - Namespace *refNsPtr = (Namespace *) - TclGetCurrentNamespace(interp); - - if ((resPtr->refNsPtr == NULL) - || ((refNsPtr == resPtr->refNsPtr) - && (resPtr->refNsId == refNsPtr->nsId) - && (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) { - return (Tcl_Command) cmdPtr; - } - } + Command *cmdPtr = resPtr->cmdPtr; + + if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch) + && !(cmdPtr->flags & CMD_IS_DELETED) + && (interp == cmdPtr->nsPtr->interp) + && !(cmdPtr->nsPtr->flags & NS_DYING)) { + Namespace *refNsPtr = (Namespace *) + TclGetCurrentNamespace(interp); + + if ((resPtr->refNsPtr == NULL) + || ((refNsPtr == resPtr->refNsPtr) + && (resPtr->refNsId == refNsPtr->nsId) + && (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) { + return (Tcl_Command) cmdPtr; + } + } } /* @@ -4188,11 +4192,11 @@ Tcl_GetCommandFromObj( * had is invalid one way or another. */ - /* See [] why we cannot call SetCmdNameFromAny() directly here. */ + /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */ if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { - return NULL; + return NULL; } - resPtr = objPtr->internalRep.twoPtrValue.ptr1; + resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL); } @@ -4225,13 +4229,13 @@ TclSetCmdNameObj( Command *cmdPtr) /* Points to Command structure that the * CmdName object should refer to. */ { - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; ResolvedCmdName *resPtr; Namespace *currNsPtr; const char *name; if (objPtr->typePtr == &tclCmdNameType) { - resPtr = objPtr->internalRep.twoPtrValue.ptr1; + resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) { return; } @@ -4295,9 +4299,9 @@ FreeCmdNameInternalRep( Tcl_Obj *objPtr) /* CmdName object with internal * representation to free. */ { - ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + ResolvedCmdName *resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; - if (resPtr != NULL) { + if (resPtr != (ResolvedCmdName *)NULL) { /* * Decrement the reference count of the ResolvedCmdName structure. If * there are no more uses, free the ResolvedCmdName structure. @@ -4344,7 +4348,7 @@ DupCmdNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; + ResolvedCmdName *resPtr = (ResolvedCmdName *)srcPtr->internalRep.twoPtrValue.ptr1; copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; @@ -4380,7 +4384,7 @@ SetCmdNameFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr) /* The object to convert. */ { - Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *)interp; const char *name; Command *cmdPtr; Namespace *currNsPtr; @@ -4410,7 +4414,7 @@ SetCmdNameFromAny( if (cmdPtr) { cmdPtr->refCount++; - resPtr = objPtr->internalRep.twoPtrValue.ptr1; + resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr == &tclCmdNameType) && resPtr && (resPtr->refCount == 1)) { /* @@ -4498,8 +4502,8 @@ Tcl_RepresentationCmd( snprintf(ptrBuffer, sizeof(ptrBuffer), "%p", (void *) objv[1]); descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d," - " object pointer at %s", - objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", + " object pointer at %s", + objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", objv[1]->refCount, ptrBuffer); /* @@ -4529,9 +4533,9 @@ Tcl_RepresentationCmd( } if (objv[1]->bytes) { - Tcl_AppendToObj(descObj, ", string representation \"", -1); + Tcl_AppendToObj(descObj, ", string representation \"", -1); Tcl_AppendLimitedToObj(descObj, objv[1]->bytes, objv[1]->length, - 16, "..."); + 16, "..."); Tcl_AppendToObj(descObj, "\"", -1); } else { Tcl_AppendToObj(descObj, ", no string representation", -1); -- cgit v0.12 From ed61508601920700625f11f345ba75ffc3093832 Mon Sep 17 00:00:00 2001 From: sebres Date: Sun, 14 Jul 2024 19:14:26 +0000 Subject: [info vars] test coverage for global vars resolve --- tests/info.test | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/tests/info.test b/tests/info.test index 0921466..a5573c1 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2398,6 +2398,28 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body { # ------------------------------------------------------------------------- unset -nocomplain res +test info-19.7 {info vars: before TIP #278 - global vars resolved in namespace} -setup { + catch {namespace delete x} +} -body { + expr { [llength [namespace eval x {info vars}]] > 0 } +} -cleanup { + namespace delete x +} -result 1 +test info-19.8 {info vars: before TIP #278 - global vars resolved in namespace} -setup { + catch {namespace delete x} +} -body { + namespace eval x {info vars tcl_platform} +} -cleanup { + namespace delete x +} -result {tcl_platform} +test info-19.9 {info vars: global vars resolved by pattern} -setup { + catch {namespace delete x} +} -body { + namespace eval x {info vars ::tcl_platform} +} -cleanup { + namespace delete x +} -result {::tcl_platform} + test info-39.2 {Bug 4b61afd660} -setup { proc probe {} { return [dict get [info frame -1] line] -- cgit v0.12 From 7cb086504f107b8de60f5c8c1c7afddcd0649421 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 14 Jul 2024 19:52:41 +0000 Subject: Stop variable from disappearing by accident when referred to by name. [74b6110204] --- generic/tclOOBasic.c | 5 +++++ tests/oo.test | 14 ++++++++++++++ 2 files changed, 19 insertions(+) diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 40a70c2..792ff9c 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -723,6 +723,11 @@ TclOO_Object_VarName( } /* + * The variable reference must not disappear too soon. [Bug 74b6110204] + */ + TclSetVarNamespaceVar(varPtr); + + /* * Now that we've pinned down what variable we're really talking about * (including traversing variable links), convert back to a name. */ diff --git a/tests/oo.test b/tests/oo.test index 594b2cf..a41113d 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2910,6 +2910,20 @@ test oo-19.3 {OO: varname method and variable decl: Bug 3603695} -setup { } -cleanup { testClass destroy } -result 0 +test oo-19.4 {OO: varname ghosts [Bug 74b6110204]} -setup { + oo::class create testClass { + export varname + self export createWithNamespace + } + set obj [testClass createWithNamespace testoo19_4 testoo19_4] + set ns [info object namespace $obj] +} -body { + set v [$obj varname foo] + list [namespace which -variable $v] \ + [info exists $v] [namespace which -variable $v] +} -cleanup { + testClass destroy +} -result {::testoo19_4::foo 0 ::testoo19_4::foo} test oo-20.1 {OO: variable method} -body { oo::class create testClass { -- cgit v0.12 From 7e796a8a329db44fd484393c3292c8a5cd4801da Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 15 Jul 2024 14:29:13 +0000 Subject: Make [self] work inside [$obj eval]. [91b3a5bb14e6e8ae] --- doc/object.n | 5 +++++ generic/tclOOBasic.c | 3 ++- tests/oo.test | 10 ++++++++++ 3 files changed, 17 insertions(+), 1 deletion(-) diff --git a/doc/object.n b/doc/object.n index df657a9..381b963 100644 --- a/doc/object.n +++ b/doc/object.n @@ -64,6 +64,11 @@ The \fBoo::object\fR class supports the following non-exported methods: This method concatenates the arguments, \fIarg\fR, as if with \fBconcat\fR, and then evaluates the resulting script in the namespace that is uniquely associated with \fIobj\fR, returning the result of the evaluation. +.RS +.PP +Note that object-internal commands such as \fBmy\fR and \fBself\fR can be +invoked in this context. +.RE .TP \fIobj \fBunknown ?\fImethodName\fR? ?\fIarg ...\fR? . diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 792ff9c..13749b2 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -415,7 +415,8 @@ TclOO_Object_Eval( */ (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, - Tcl_GetObjectNamespace(object), 0); + Tcl_GetObjectNamespace(object), FRAME_IS_METHOD); + framePtr->clientData = context; framePtr->objc = objc; framePtr->objv = objv; /* Reference counts do not need to be * incremented here. */ diff --git a/tests/oo.test b/tests/oo.test index a41113d..7210da3 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2857,6 +2857,16 @@ test oo-18.11 {OO: define/self command support} -setup { (in definition script for class "::foo" line 1) invoked from within "oo::define foo {rename ::foo {}; self {error foobar}}"} +test oo-18.12 {OO: self callable via eval method} -setup { + oo::class create parent { + export eval + } + parent create ::foo +} -body { + foo eval { self } +} -cleanup { + parent destroy +} -result ::foo test oo-19.1 {OO: varname method} -setup { oo::object create inst -- cgit v0.12 From 2b40376fa31e57a9e8b17ce792cd3cb105fe6988 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 16 Jul 2024 16:24:02 +0000 Subject: clock.test: more regression tests: clock-46.[56] cherry-picked from 8.7, clock-46.7 to illustrate regression [3ee8f1c2a785f4d8] (8.6 is not affected) --- tests/clock.test | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/tests/clock.test b/tests/clock.test index b54d9f0..70d527e 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -36113,6 +36113,25 @@ test clock-46.4 {regression test - month thirteen} \ clock scan 20041301 } -result [clock scan 2005-01-01 -format %Y-%m-%d] +test clock-46.5 {regression test - good time} \ + -body { + # 12:01 apm are valid input strings... + list [clock scan "12:01 am" -base 0 -gmt 1] \ + [clock scan "12:01 pm" -base 0 -gmt 1] + } -result {60 43260} +test clock-46.6 {freescan: regression test - bad time} \ + -body { + # 13:00 am/pm are invalid input strings... + list [clock scan "13:00 am" -base 0 -gmt 1] \ + [clock scan "13:00 pm" -base 0 -gmt 1] + } -result {-1 -1} + +test clock-46.7 {regression test - switch day by large not-valid time, see bug [3ee8f1c2a785f4d8]} { + list [clock scan 23:59:59 -base 0 -gmt 1 -format %H:%M:%S] \ + [clock scan 24:00:00 -base 0 -gmt 1 -format %H:%M:%S] \ + [clock scan 48:00:00 -base 0 -gmt 1 -format %H:%M:%S] +} {86399 86400 172800} + test clock-47.1 {regression test - four-digit time} { clock scan 0012 } [clock scan 0012 -format %H%M] -- cgit v0.12 From 5f3c32b889d1b4df82754f9b53050340935136b7 Mon Sep 17 00:00:00 2001 From: sebres Date: Sun, 28 Jul 2024 19:24:02 +0000 Subject: tests/cmdAH.test: amend to [fd91b0ca09cb171f] - fixed typos --- tests/cmdAH.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 2b5b0e9..614ec0f 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -31,7 +31,7 @@ testConstraint filetime64bit [expr { # check whether disk may have 2038 problem, see [fd91b0ca09cb171f]: set fn [makeFile "" foo.text] if {[catch { - exec sh -c "TZ=:UTC LC_TYME=en_US touch -ma -t '207006290000' '$fn' && TZ=:UTC LC_TYME=en_US ls -l '$fn'" + exec sh -c "TZ=:UTC LC_TIME=en_US touch -ma -t '207006290000' '$fn' && TZ=:UTC LC_TIME=en_US ls -l '$fn'" } res]} { #puts "Check constraint failed:\t$res" set res {} -- cgit v0.12 From 112d2f30567307db2e61e64d72cd800248d663be Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 30 Jul 2024 14:18:52 +0000 Subject: [3adf9e3a] Document argument bufferSize of Tcl_ZlibInflate --- doc/TclZlib.3 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/doc/TclZlib.3 b/doc/TclZlib.3 index 4a5df89..106a5ef 100644 --- a/doc/TclZlib.3 +++ b/doc/TclZlib.3 @@ -18,7 +18,7 @@ int \fBTcl_ZlibDeflate\fR(\fIinterp, format, dataObj, level, dictObj\fR) .sp int -\fBTcl_ZlibInflate\fR(\fIinterp, format, dataObj, dictObj\fR) +\fBTcl_ZlibInflate\fR(\fIinterp, format, dataObj, bufferSize, dictObj\fR) .sp unsigned int \fBTcl_ZlibCRC32\fR(\fIinitValue, bytes, length\fR) @@ -85,6 +85,9 @@ section \fBGZIP OPTIONS DICTIONARY\fR for details about the contents of this dictionary. .AP "unsigned int" initValue in The initial value for the checksum algorithm. +.AP "int" bufferSize in +A hint as to what size of buffer is to be used to receive the data. +Use 0 to use a geric guess based on the input data. .AP "unsigned char" *bytes in An array of bytes to run the checksum algorithm over, or NULL to get the recommended initial value for the checksum algorithm. -- cgit v0.12 From 18bed14255436204ba96c0ba02fcf225c5c393cc Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 30 Jul 2024 14:50:07 +0000 Subject: continuity of test names --- tests/info.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/info.test b/tests/info.test index a5573c1..140a7bb 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1841,7 +1841,7 @@ test info-30.48 {Bug 2850901} testevalex { # ------------------------------------------------------------------------- # literal sharing 2, bug 2933089 -test info-40.1 {location information not confused by literal sharing, bug 2933089} -setup { +test info-39.1 {location information not confused by literal sharing, bug 2933089} -setup { set result {} proc print_one {} {} @@ -2437,7 +2437,7 @@ test info-39.2 {Bug 4b61afd660} -setup { rename probe {} } -result 3 -test info-40.0 {Bug 0de6c1d79c crash} -setup { +test info-41.0 {Bug 0de6c1d79c crash} -setup { interp create child child hide info } -body { -- cgit v0.12 From e92ac699c1a4fc8683a61f855f5250c72d12b1c1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 5 Aug 2024 22:48:31 +0000 Subject: add/document the zlib command to the set of commands in a safe interpreter --- doc/interp.n | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/interp.n b/doc/interp.n index 1127632..42b1e08 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -605,6 +605,7 @@ built-in commands: \fBtell\fR \fBtime\fR \fBtrace\fR \fBunset\fR \fBupdate\fR \fBuplevel\fR \fBupvar\fR \fBvariable\fR \fBvwait\fR \fBwhile\fR +\fBzlib\fR .DE The following commands are hidden by \fBinterp create\fR when it creates a safe interpreter: -- cgit v0.12