BRL-CAD/tcl
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge 8.7. Random indent fixes

Browse Source
This commit is contained in:
jan.nijtmans
2024-06-27 21:50:59 +00:00
parent 0d26404eee b99f44e2b6
commit 811b044eb5
28 changed files with 654 additions and 653 deletions
Download Patch File Download Diff File Expand all files Collapse all files
generic/tcl.h
+4 -4
View File
@@ -2514,8 +2514,8 @@ TclBounceRefCount(
int line)
{
if (objPtr) {
if ((objPtr)->refCount == 0) {
Tcl_DbDecrRefCount(objPtr, fn, line);
if ((objPtr)->refCount == 0) {
Tcl_DbDecrRefCount(objPtr, fn, line);
}
}
}
@@ -2552,8 +2552,8 @@ TclBounceRefCount(
Tcl_Obj* objPtr)
{
if (objPtr) {
if ((objPtr)->refCount == 0) {
Tcl_DecrRefCount(objPtr);
if ((objPtr)->refCount == 0) {
Tcl_DecrRefCount(objPtr);
}
}
}
generic/tclBasic.c
+2 -2
View File
@@ -2795,7 +2795,7 @@ Tcl_CreateObjCommand(
/* If not NULL, gives a function to call when
* this command is deleted. */
{
Interp *iPtr = (Interp *) interp;
Interp *iPtr = (Interp *)interp;
Namespace *nsPtr;
const char *tail;
@@ -2804,7 +2804,7 @@ Tcl_CreateObjCommand(
* The interpreter is being deleted. Don't create any new commands;
* it's not safe to muck with the interpreter anymore.
*/
return (Tcl_Command) NULL;
return NULL;
}
/*
generic/tclBinary.c
+2 -2
View File
@@ -185,7 +185,7 @@ typedef struct {
#define BYTEARRAY_MAX_LEN (TCL_SIZE_MAX - (Tcl_Size)offsetof(ByteArray, bytes))
#define BYTEARRAY_SIZE(len) \
( (len < 0 || BYTEARRAY_MAX_LEN < (len)) \
( (len < 0 || BYTEARRAY_MAX_LEN < (len)) \
? (Tcl_Panic("negative length specified or max size of a Tcl value exceeded"), 0) \
: (offsetof(ByteArray, bytes) + (len)) )
#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
@@ -440,7 +440,7 @@ unsigned char *
Tcl_SetByteArrayLength(
Tcl_Obj *objPtr, /* The ByteArray object. */
Tcl_Size numBytes) /* Number of bytes in resized array
* Must be >= 0 */
* Must be >= 0 */
{
ByteArray *byteArrayPtr;
Tcl_ObjInternalRep *irPtr;
generic/tclCkalloc.c
+7 -7
View File
@@ -171,7 +171,7 @@ TclDumpMemoryInfo(
char buf[1024];
if (clientData == NULL) {
return 0;
return 0;
}
snprintf(buf, sizeof(buf),
"total mallocs %10" TCL_Z_MODIFIER "u\n"
@@ -826,7 +826,7 @@ MemoryCmd(
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
TclGetString(objv[2]), Tcl_PosixError(interp)));
TclGetString(objv[2]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
@@ -871,8 +871,8 @@ MemoryCmd(
fileP = fopen(fileName, "w");
if (fileP == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot open output file: %s",
Tcl_PosixError(interp)));
"cannot open output file: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
}
TclDbDumpActiveObjects(fileP);
@@ -936,9 +936,9 @@ MemoryCmd(
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": should be active, break_on_malloc, info, "
"init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
TclGetString(objv[1])));
"bad option \"%s\": should be active, break_on_malloc, info, "
"init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
TclGetString(objv[1])));
return TCL_ERROR;
argError:
generic/tclCmdAH.c
+3 -3
View File
@@ -2347,9 +2347,9 @@ StoreStatData(
TclNewObj(result);
Tcl_IncrRefCount(result);
#define DOBJPUT(key, objValue) \
Tcl_DictObjPut(NULL, result, \
Tcl_NewStringObj((key), -1), \
(objValue));
Tcl_DictObjPut(NULL, result, \
Tcl_NewStringObj((key), -1), \
(objValue));
DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev));
DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
DOBJPUT("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink));
generic/tclCompCmds.c
+2 -2
View File
@@ -967,7 +967,7 @@ TclCompileConstCmd(
* that.
*/
if (!isScalar) {
return TCL_ERROR;
return TCL_ERROR;
}
/*
@@ -3448,7 +3448,7 @@ TclLocalScalar(
{
Tcl_Token token[2] = {
{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1},
{TCL_TOKEN_TEXT, NULL, 0, 0}
{TCL_TOKEN_TEXT, NULL, 0, 0}
};
token[1].start = bytes;
generic/tclDictObj.c
+7 -7
View File
@@ -152,17 +152,17 @@ const Tcl_ObjType tclDictType = {
#define DictSetInternalRep(objPtr, dictRepPtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (dictRepPtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), &tclDictType, &ir); \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (dictRepPtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), &tclDictType, &ir); \
} while (0)
#define DictGetInternalRep(objPtr, dictRepPtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &tclDictType); \
(dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL; \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &tclDictType); \
(dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
generic/tclFCmd.c
+2 -2
View File
@@ -918,8 +918,8 @@ FileBasename(
Tcl_IncrRefCount(splitPtr);
if (objc != 0) {
/*
* Return the last component, unless it is the only component, and it
/*
* Return the last component, unless it is the only component, and it
* is the root of an absolute path.
*/
generic/tclFileName.c
+40 -40
View File
@@ -390,50 +390,50 @@ TclpGetNativePathType(
switch (tclPlatform) {
case TCL_PLATFORM_UNIX: {
const char *origPath = path;
const char *origPath = path;
/*
* Paths that begin with / are absolute.
*/
/*
* Paths that begin with / are absolute.
*/
if (path[0] == '/') {
++path;
/*
* Check for "//" network path prefix
*/
if ((*path == '/') && path[1] && (path[1] != '/')) {
path += 2;
while (*path && *path != '/') {
++path;
}
}
if (driveNameLengthPtr != NULL) {
/*
* We need this addition in case the "//" code was used.
*/
if (path[0] == '/') {
++path;
/*
* Check for "//" network path prefix
*/
if ((*path == '/') && path[1] && (path[1] != '/')) {
path += 2;
while (*path && *path != '/') {
++path;
}
}
if (driveNameLengthPtr != NULL) {
/*
* We need this addition in case the "//" code was used.
*/
*driveNameLengthPtr = (path - origPath);
}
} else {
type = TCL_PATH_RELATIVE;
}
break;
*driveNameLengthPtr = (path - origPath);
}
} else {
type = TCL_PATH_RELATIVE;
}
break;
}
case TCL_PLATFORM_WINDOWS: {
Tcl_DString ds;
const char *rootEnd;
Tcl_DString ds;
const char *rootEnd;
Tcl_DStringInit(&ds);
rootEnd = ExtractWinRoot(path, &ds, 0, &type);
if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
*driveNameLengthPtr = rootEnd - path;
if (driveNameRef != NULL) {
*driveNameRef = Tcl_DStringToObj(&ds);
Tcl_IncrRefCount(*driveNameRef);
}
}
Tcl_DStringFree(&ds);
break;
Tcl_DStringInit(&ds);
rootEnd = ExtractWinRoot(path, &ds, 0, &type);
if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
*driveNameLengthPtr = rootEnd - path;
if (driveNameRef != NULL) {
*driveNameRef = Tcl_DStringToObj(&ds);
Tcl_IncrRefCount(*driveNameRef);
}
}
Tcl_DStringFree(&ds);
break;
}
}
return type;
@@ -655,8 +655,8 @@ SplitUnixPath(
length = path - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
nextElt = Tcl_NewStringObj(elementStart, length);
Tcl_ListObjAppendElement(NULL, result, nextElt);
nextElt = Tcl_NewStringObj(elementStart, length);
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
if (*path++ == '\0') {
break;
generic/tclIORTrans.c
+15 -15
View File
@@ -599,9 +599,9 @@ TclChanPushObjCmd(
*/
if (TclListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
TclGetString(cmdObj), TclGetString(resObj)));
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
@@ -624,9 +624,9 @@ TclChanPushObjCmd(
Tcl_DecrRefCount(resObj);
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" does not support all required methods",
TclGetString(cmdObj)));
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" does not support all required methods",
TclGetString(cmdObj)));
goto error;
}
@@ -646,9 +646,9 @@ TclChanPushObjCmd(
}
if (!mode) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" makes the channel inaccessible",
TclGetString(cmdObj)));
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" makes the channel inaccessible",
TclGetString(cmdObj)));
goto error;
}
@@ -657,16 +657,16 @@ TclChanPushObjCmd(
*/
if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"drain\" but not \"read\"",
TclGetString(cmdObj)));
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"drain\" but not \"read\"",
TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"flush\" but not \"write\"",
TclGetString(cmdObj)));
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"flush\" but not \"write\"",
TclGetString(cmdObj)));
goto error;
}
generic/tclIOSock.c
+1 -1
View File
@@ -263,7 +263,7 @@ TclCreateSocketAddress(
(result == EAI_SYSTEM) ? Tcl_PosixError(interp) :
#endif /* EAI_SYSTEM */
gai_strerror(result);
return 0;
return 0;
}
/*
generic/tclIcu.c
+65 -64
View File
@@ -149,7 +149,8 @@ TCL_DECLARE_MUTEX(icu_mutex);
static int FunctionNotAvailableError(Tcl_Interp *interp) {
if (interp) {
Tcl_SetResult(interp, "ICU function not available", TCL_STATIC);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("ICU function not available", TCL_INDEX_NONE));
}
return TCL_ERROR;
}
@@ -267,7 +268,7 @@ static int DetectableEncodings(Tcl_Interp *interp)
const char *name;
int32_t len;
name = uenum_next(enumerator, &len, &status);
if (name == NULL || U_FAILURE(status)) {
if (name == NULL || U_FAILURE(status)) {
name = "unknown";
len = 7;
status = U_ZERO_ERRORZ; /* Reset on error */
@@ -321,7 +322,7 @@ IcuDetectObjCmd(
int all = 0;
if (objc == 3) {
if (strcmp("-all", Tcl_GetString(objv[2]))) {
if (strcmp("-all", Tcl_GetString(objv[2]))) {
Tcl_SetObjResult(
interp,
Tcl_ObjPrintf("Invalid option %s, must be \"-all\"",
@@ -374,7 +375,7 @@ IcuConverterNamesObjCmd (
int32_t i;
for (i = 0; i < count; ++i) {
const char *name = ucnv_getAvailableName(i);
if (name) {
if (name) {
Tcl_ListObjAppendElement(
NULL, resultObj, Tcl_NewStringObj(name, -1));
}
@@ -426,9 +427,9 @@ IcuConverterAliasesObjCmd (
Tcl_Obj *resultObj = Tcl_NewListObj(count, NULL);
uint16_t i;
for (i = 0; i < count; ++i) {
status = U_ZERO_ERRORZ; /* Reset in case U_AMBIGUOUS_ALIAS_WARNING */
status = U_ZERO_ERRORZ; /* Reset in case U_AMBIGUOUS_ALIAS_WARNING */
const char *aliasName = ucnv_getAlias(name, i, &status);
if (status != U_AMBIGUOUS_ALIAS_WARNING && U_FAILURE(status)) {
if (status != U_AMBIGUOUS_ALIAS_WARNING && U_FAILURE(status)) {
status = U_ZERO_ERRORZ; /* Reset error for next iteration */
continue;
}
@@ -447,15 +448,15 @@ TclIcuCleanup(
{
Tcl_MutexLock(&icu_mutex);
if (icu_fns.nopen-- <= 1) {
int i;
if (u_cleanup != NULL) {
int i;
if (u_cleanup != NULL) {
u_cleanup();
}
for (i = 0; i < (int)(sizeof(icu_fns.libs) / sizeof(icu_fns.libs[0]));
++i) {
if (icu_fns.libs[i] != NULL) {
Tcl_FSUnloadFile(NULL, icu_fns.libs[i]);
}
Tcl_FSUnloadFile(NULL, icu_fns.libs[i]);
}
}
memset(&icu_fns, 0, sizeof(icu_fns));
}
@@ -531,57 +532,57 @@ TclIcuInit(
}
}
if (icu_fns.libs[0] != NULL) {
/* Loaded icuuc, load others with the same version */
nameobj = Tcl_ObjPrintf(DLLNAME, "i18n", icuversion+1);
Tcl_IncrRefCount(nameobj);
/* Ignore errors. Calls to contained functions will fail. */
(void) Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[1]);
Tcl_DecrRefCount(nameobj);
}
/* Loaded icuuc, load others with the same version */
nameobj = Tcl_ObjPrintf(DLLNAME, "i18n", icuversion+1);
Tcl_IncrRefCount(nameobj);
/* Ignore errors. Calls to contained functions will fail. */
(void) Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[1]);
Tcl_DecrRefCount(nameobj);
}
#if defined(_WIN32)
/*
* On Windows, if no ICU install found, look for the system's
* (Win10 1703 or later). There are two cases. Newer systems
* have icu.dll containing all functions. Older systems have
* icucc.dll and icuin.dll
*/
/*
* On Windows, if no ICU install found, look for the system's
* (Win10 1703 or later). There are two cases. Newer systems
* have icu.dll containing all functions. Older systems have
* icucc.dll and icuin.dll
*/
if (icu_fns.libs[0] == NULL) {
Tcl_ResetResult(interp);
nameobj = Tcl_NewStringObj("icu.dll", TCL_INDEX_NONE);
Tcl_IncrRefCount(nameobj);
if (Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[0])
== TCL_OK) {
/* Reload same for second set of functions. */
(void) Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[1]);
/* Functions do NOT have version suffixes */
/* Reload same for second set of functions. */
(void) Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[1]);
/* Functions do NOT have version suffixes */
icuversion[0] = '\0';
}
Tcl_DecrRefCount(nameobj);
}
if (icu_fns.libs[0] == NULL) {
/* No icu.dll. Try last fallback */
Tcl_ResetResult(interp);
nameobj = Tcl_NewStringObj("icuuc.dll", TCL_INDEX_NONE);
Tcl_IncrRefCount(nameobj);
if (Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[0])
== TCL_OK) {
Tcl_DecrRefCount(nameobj);
nameobj = Tcl_NewStringObj("icuin.dll", TCL_INDEX_NONE);
Tcl_IncrRefCount(nameobj);
(void) Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[1]);
/* Functions do NOT have version suffixes */
icuversion[0] = '\0';
}
Tcl_DecrRefCount(nameobj);
/* No icu.dll. Try last fallback */
Tcl_ResetResult(interp);
nameobj = Tcl_NewStringObj("icuuc.dll", TCL_INDEX_NONE);
Tcl_IncrRefCount(nameobj);
if (Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[0])
== TCL_OK) {
Tcl_DecrRefCount(nameobj);
nameobj = Tcl_NewStringObj("icuin.dll", TCL_INDEX_NONE);
Tcl_IncrRefCount(nameobj);
(void) Tcl_LoadFile(interp, nameobj, NULL, 0, NULL, &icu_fns.libs[1]);
/* Functions do NOT have version suffixes */
icuversion[0] = '\0';
}
Tcl_DecrRefCount(nameobj);
}
#endif
#define ICUUC_SYM(name) \
strcpy(symbol, #name ); \
strcat(symbol, icuversion); \
icu_fns._##name = (fn_ ## name) \
Tcl_FindSymbol(NULL, icu_fns.libs[0], symbol)
if (icu_fns.libs[0] != NULL) {
strcpy(symbol, #name ); \
strcat(symbol, icuversion); \
icu_fns._##name = (fn_ ## name) \
Tcl_FindSymbol(NULL, icu_fns.libs[0], symbol)
if (icu_fns.libs[0] != NULL) {
ICUUC_SYM(u_cleanup);
ICUUC_SYM(u_errorName);
@@ -589,7 +590,7 @@ TclIcuInit(
ICUUC_SYM(ucnv_countAvailable);
ICUUC_SYM(ucnv_getAlias);
ICUUC_SYM(ucnv_getAvailableName);
ICUUC_SYM(ubrk_open);
ICUUC_SYM(ubrk_close);
ICUUC_SYM(ubrk_preceding);
@@ -606,20 +607,20 @@ TclIcuInit(
}
#define ICUIN_SYM(name) \
strcpy(symbol, #name ); \
strcat(symbol, icuversion); \
icu_fns._##name = (fn_ ## name) \
Tcl_FindSymbol(NULL, icu_fns.libs[1], symbol)
if (icu_fns.libs[1] != NULL) {
ICUIN_SYM(ucsdet_close);
ICUIN_SYM(ucsdet_detect);
ICUIN_SYM(ucsdet_detectAll);
ICUIN_SYM(ucsdet_getName);
ICUIN_SYM(ucsdet_getAllDetectableCharsets);
ICUIN_SYM(ucsdet_open);
ICUIN_SYM(ucsdet_setText);
strcpy(symbol, #name ); \
strcat(symbol, icuversion); \
icu_fns._##name = (fn_ ## name) \
Tcl_FindSymbol(NULL, icu_fns.libs[1], symbol)
if (icu_fns.libs[1] != NULL) {
ICUIN_SYM(ucsdet_close);
ICUIN_SYM(ucsdet_detect);
ICUIN_SYM(ucsdet_detectAll);
ICUIN_SYM(ucsdet_getName);
ICUIN_SYM(ucsdet_getAllDetectableCharsets);
ICUIN_SYM(ucsdet_open);
ICUIN_SYM(ucsdet_setText);
#undef ICUIN_SYM
}
}
}
#undef ICU_SYM
@@ -627,12 +628,12 @@ TclIcuInit(
Tcl_MutexUnlock(&icu_mutex);
if (icu_fns.libs[0] != NULL) {
/*
* Note refcounts updated BEFORE command definition to protect
* against self redefinition.
*/
/*
* Note refcounts updated BEFORE command definition to protect
* against self redefinition.
*/
if (icu_fns.libs[1] != NULL) {
/* Commands needing both libraries */
/* Commands needing both libraries */
/* Ref count number of commands */
icu_fns.nopen += 1;
generic/tclListObj.c
+5 -5
View File
@@ -2964,11 +2964,11 @@ TclLsetFlat(
}
indexArray++;
/*
* Special case 0-length lists. The Tcl indexing function treat
* will return any value beyond length as TCL_SIZE_MAX for this
* case.
*/
/*
* Special case 0-length lists. The Tcl indexing function treat
* will return any value beyond length as TCL_SIZE_MAX for this
* case.
*/
if ((index == TCL_SIZE_MAX) && (elemCount == 0)) {
index = 0;
}
generic/tclOO.c
+1 -1
View File
@@ -751,7 +751,7 @@ AllocObject(
TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,
MyClassDeleted);
MyClassDeleted);
return oPtr;
}
generic/tclOOInt.h
+8 -8
View File
@@ -529,16 +529,16 @@ MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp,
Object *useThisObj);
MODULE_SCOPE int TclMethodIsType(Tcl_Method method,
const Tcl_MethodType *typePtr,
void **clientDataPtr);
const Tcl_MethodType *typePtr,
void **clientDataPtr);
MODULE_SCOPE Tcl_Method TclNewInstanceMethod(Tcl_Interp *interp,
Tcl_Object object, Tcl_Obj *nameObj,
int flags, const Tcl_MethodType *typePtr,
void *clientData);
Tcl_Object object, Tcl_Obj *nameObj,
int flags, const Tcl_MethodType *typePtr,
void *clientData);
MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls,
Tcl_Obj *nameObj, int flags,
const Tcl_MethodType *typePtr,
void *clientData);
Tcl_Obj *nameObj, int flags,
const Tcl_MethodType *typePtr,
void *clientData);
MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
Tcl_Class cls, const char *nameStr,
const char *nsNameStr, Tcl_Size objc,
generic/tclObj.c
+40 -40
View File
@@ -703,7 +703,7 @@ TclContinuationsCopy(
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
if (hPtr) {
ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_GetHashValue(hPtr);
@@ -737,10 +737,10 @@ TclContinuationsGet(
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (!hPtr) {
return NULL;
return NULL;
}
return (ContLineLoc *)Tcl_GetHashValue(hPtr);
}
@@ -1379,10 +1379,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) {
Tcl_Free(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
@@ -1470,10 +1470,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) {
Tcl_Free(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
@@ -2427,8 +2427,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;
}
@@ -2678,9 +2678,9 @@ Tcl_GetLongFromObj(
#endif
if (TclHasInternalRep(objPtr, &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;
@@ -2986,9 +2986,9 @@ Tcl_GetWideIntFromObj(
}
if (TclHasInternalRep(objPtr, &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;
@@ -3155,9 +3155,9 @@ TclGetWideBitsFromObj(
}
if (TclHasInternalRep(objPtr, &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;
@@ -3479,9 +3479,9 @@ GetBignumFromObj(
}
if (TclHasInternalRep(objPtr, &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;
@@ -3887,7 +3887,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 */
@@ -3960,7 +3960,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 */
@@ -4042,7 +4042,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 */
@@ -4154,7 +4154,7 @@ TclCompareObjKeys(
* OPT: this comparison was moved to the caller
if (objPtr1 == objPtr2) {
return 1;
return 1;
}
*/
@@ -4335,21 +4335,21 @@ Tcl_GetCommandFromObj(
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
if (TclHasInternalRep(objPtr, &tclCmdNameType)) {
Command *cmdPtr = resPtr->cmdPtr;
Command *cmdPtr = resPtr->cmdPtr;
if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
&& (interp == cmdPtr->nsPtr->interp)
&& !(cmdPtr->nsPtr->flags & NS_DYING)) {
Namespace *refNsPtr = (Namespace *)
TclGetCurrentNamespace(interp);
if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
&& (interp == cmdPtr->nsPtr->interp)
&& !(cmdPtr->nsPtr->flags & NS_DYING)) {
Namespace *refNsPtr = (Namespace *)
TclGetCurrentNamespace(interp);
if ((resPtr->refNsPtr == NULL)
if ((resPtr->refNsPtr == NULL)
|| ((refNsPtr == resPtr->refNsPtr)
&& (resPtr->refNsId == refNsPtr->nsId)
&& (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) {
return (Tcl_Command) cmdPtr;
}
}
&& (resPtr->refNsId == refNsPtr->nsId)
&& (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) {
return (Tcl_Command) cmdPtr;
}
}
}
/*
@@ -4359,7 +4359,7 @@ Tcl_GetCommandFromObj(
/* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */
if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
return NULL;
return NULL;
}
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL);
@@ -4668,9 +4668,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);
generic/tclResult.c
+47 -47
View File
@@ -716,7 +716,7 @@ TclProcessReturn(
iPtr->errorInfo = NULL;
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
&valuePtr);
if (valuePtr != NULL) {
Tcl_Size length;
@@ -728,41 +728,41 @@ TclProcessReturn(
}
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
&valuePtr);
&valuePtr);
if (valuePtr != NULL) {
Tcl_Size len, valueObjc;
Tcl_Obj **valueObjv;
Tcl_Size len, valueObjc;
Tcl_Obj **valueObjv;
if (Tcl_IsShared(iPtr->errorStack)) {
Tcl_Obj *newObj;
if (Tcl_IsShared(iPtr->errorStack)) {
Tcl_Obj *newObj;
newObj = Tcl_DuplicateObj(iPtr->errorStack);
Tcl_DecrRefCount(iPtr->errorStack);
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
newObj = Tcl_DuplicateObj(iPtr->errorStack);
Tcl_DecrRefCount(iPtr->errorStack);
Tcl_IncrRefCount(newObj);
iPtr->errorStack = newObj;
}
/*
* List extraction done after duplication to avoid moving the rug
* if someone does [return -errorstack [info errorstack]]
*/
/*
* List extraction done after duplication to avoid moving the rug
* if someone does [return -errorstack [info errorstack]]
*/
if (TclListObjGetElements(interp, valuePtr, &valueObjc,
&valueObjv) == TCL_ERROR) {
return TCL_ERROR;
}
iPtr->resetErrorStack = 0;
TclListObjLength(interp, iPtr->errorStack, &len);
if (TclListObjGetElements(interp, valuePtr, &valueObjc,
&valueObjv) == TCL_ERROR) {
return TCL_ERROR;
}
iPtr->resetErrorStack = 0;
TclListObjLength(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
*/
/*
* Reset while keeping the list internalrep as much as possible.
*/
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
valueObjv);
Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc,
valueObjv);
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE],
&valuePtr);
&valuePtr);
if (valuePtr != NULL) {
Tcl_SetObjErrorCode(interp, valuePtr);
} else {
@@ -770,7 +770,7 @@ TclProcessReturn(
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE],
&valuePtr);
&valuePtr);
if (valuePtr != NULL) {
TclGetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
}
@@ -843,8 +843,8 @@ TclMergeReturnOptions(
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad %s value: expected dictionary but got \"%s\"",
compare, TclGetString(objv[1])));
"bad %s value: expected dictionary but got \"%s\"",
compare, TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS",
(void *)NULL);
goto error;
@@ -874,7 +874,7 @@ TclMergeReturnOptions(
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
if (valuePtr != NULL) {
if (TclGetCompletionCodeFromObj(interp, valuePtr,
&code) == TCL_ERROR) {
&code) == TCL_ERROR) {
goto error;
}
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
@@ -893,8 +893,8 @@ TclMergeReturnOptions(
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad -level value: expected non-negative integer but got"
" \"%s\"", TclGetString(valuePtr)));
"bad -level value: expected non-negative integer but got"
" \"%s\"", TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", (void *)NULL);
goto error;
}
@@ -915,8 +915,8 @@ TclMergeReturnOptions(
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad -errorcode value: expected a list but got \"%s\"",
TclGetString(valuePtr)));
"bad -errorcode value: expected a list but got \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE",
(void *)NULL);
goto error;
@@ -937,24 +937,24 @@ TclMergeReturnOptions(
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad -errorstack value: expected a list but got \"%s\"",
TclGetString(valuePtr)));
"bad -errorstack value: expected a list but got \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK",
(void *)NULL);
(void *)NULL);
goto error;
}
if (length % 2) {
/*
* Errorstack must always be an even-sized list
*/
if (length % 2) {
/*
* Errorstack must always be an even-sized list
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"forbidden odd-sized list for -errorstack: \"%s\"",
"forbidden odd-sized list for -errorstack: \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT",
"ODDSIZEDLIST_ERRORSTACK", (void *)NULL);
"ODDSIZEDLIST_ERRORSTACK", (void *)NULL);
goto error;
}
}
}
/*
@@ -1034,7 +1034,7 @@ Tcl_GetReturnOptions(
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "");
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack);
}
if (iPtr->errorCode) {
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode);
@@ -1105,7 +1105,7 @@ Tcl_SetReturnOptions(
if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
|| (objc % 2)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected dict but got \"%s\"", TclGetString(options)));
"expected dict but got \"%s\"", TclGetString(options)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", (void *)NULL);
code = TCL_ERROR;
} else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
generic/tclTestABSList.c
+24 -24
View File
@@ -75,8 +75,8 @@ static const Tcl_ObjType lstringTypes[11] = {
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
},
NULL) /* "in" operator */
},
{/*1*/
"lstring",
freeRep,
@@ -91,7 +91,7 @@ static const Tcl_ObjType lstringTypes[11] = {
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
NULL) /* "in" operator */
},
{/*2*/
"lstring",
@@ -107,7 +107,7 @@ static const Tcl_ObjType lstringTypes[11] = {
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
NULL) /* "in" operator */
},
{/*3*/
"lstring",
@@ -123,7 +123,7 @@ static const Tcl_ObjType lstringTypes[11] = {
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
NULL) /* "in" operator */
},
{/*4*/
"lstring",
@@ -139,7 +139,7 @@ static const Tcl_ObjType lstringTypes[11] = {
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
NULL) /* "in" operator */
},
{/*5*/
"lstring",
@@ -155,7 +155,7 @@ static const Tcl_ObjType lstringTypes[11] = {
NULL, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
NULL) /* "in" operator */
},
{/*6*/
"lstring",
@@ -171,7 +171,7 @@ static const Tcl_ObjType lstringTypes[11] = {
my_LStringGetElements, /* GetElements */
NULL, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
NULL) /* "in" operator */
},
{/*7*/
"lstring",
@@ -187,7 +187,7 @@ static const Tcl_ObjType lstringTypes[11] = {
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
NULL, /* Replace */
NULL) /* "in" operator */
NULL) /* "in" operator */
},
{/*8*/
"lstring",
@@ -203,7 +203,7 @@ static const Tcl_ObjType lstringTypes[11] = {
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
NULL) /* "in" operator */
},
{/*9*/
"lstring",
@@ -219,7 +219,7 @@ static const Tcl_ObjType lstringTypes[11] = {
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
NULL) /* "in" operator */
},
{/*10*/
"lstring",
@@ -235,7 +235,7 @@ static const Tcl_ObjType lstringTypes[11] = {
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace, /* Replace */
NULL) /* "in" operator */
NULL) /* "in" operator */
}
};
@@ -856,14 +856,14 @@ UpdateStringOfLString(Tcl_Obj *objPtr)
flagPtr = (int *) Tcl_Alloc(llen*sizeof(int));
}
for (bytesNeeded = 0, i = 0; i < llen; i++) {
Tcl_Obj *elemObj;
const char *elemStr;
Tcl_Size elemLen;
Tcl_Obj *elemObj;
const char *elemStr;
Tcl_Size elemLen;
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
typePtr->indexProc(NULL, objPtr, i, &elemObj);
Tcl_IncrRefCount(elemObj);
elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
/* Note TclScanElement updates flagPtr[i] */
elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
/* Note TclScanElement updates flagPtr[i] */
bytesNeeded += Tcl_ScanCountedElement(elemStr, elemLen, &flagPtr[i]);
if (bytesNeeded < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
@@ -881,9 +881,9 @@ UpdateStringOfLString(Tcl_Obj *objPtr)
objPtr->bytes = (char *) Tcl_Alloc(bytesNeeded);
p = objPtr->bytes;
for (i = 0; i < llen; i++) {
Tcl_Obj *elemObj;
const char *elemStr;
Tcl_Size elemLen;
Tcl_Obj *elemObj;
const char *elemStr;
Tcl_Size elemLen;
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
typePtr->indexProc(NULL, objPtr, i, &elemObj);
Tcl_IncrRefCount(elemObj);
@@ -984,7 +984,7 @@ lgen(
elemObj = Tcl_GetObjResult(intrp);
if (status != TCL_OK) {
Tcl_SetObjResult(intrp, Tcl_ObjPrintf(
"Error: %s\nwhile executing %s\n",
"Error: %s\nwhile executing %s\n",
elemObj ? Tcl_GetString(elemObj) : "NULL", Tcl_GetString(genCmd)));
return NULL;
}
@@ -1102,9 +1102,9 @@ static const Tcl_ObjType lgenType = {
NULL, /* slice */
NULL, /* reverse */
NULL, /* get elements */
NULL, /* set element */
NULL, /* replace */
NULL) /* "in" operator */
NULL, /* set element */
NULL, /* replace */
NULL) /* "in" operator */
};
/*
generic/tclThreadAlloc.c
+1 -1
View File
@@ -214,7 +214,7 @@ GetCache(void)
if (cachePtr == NULL) {
Tcl_Panic("alloc: could not allocate new cache");
}
memset(cachePtr, 0, sizeof(Cache));
memset(cachePtr, 0, sizeof(Cache));
Tcl_MutexLock(listLockPtr);
cachePtr->nextPtr = firstCachePtr;
firstCachePtr = cachePtr;
generic/tclTimer.c
+17 -17
View File
@@ -823,10 +823,10 @@ Tcl_AfterObjCmd(
const char *arg = TclGetString(objv[1]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument \"%s\": must be"
" cancel, idle, info, or an integer", arg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
arg, (void *)NULL);
"bad argument \"%s\": must be"
" cancel, idle, info, or an integer", arg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
arg, (void *)NULL);
return TCL_ERROR;
}
}
@@ -952,7 +952,7 @@ Tcl_AfterObjCmd(
"after#%d", afterPtr->id));
}
}
Tcl_SetObjResult(interp, resultObj);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
if (objc != 3) {
@@ -961,11 +961,11 @@ Tcl_AfterObjCmd(
}
afterPtr = GetAfterEvent(assocPtr, objv[2]);
if (afterPtr == NULL) {
const char *eventStr = TclGetString(objv[2]);
const char *eventStr = TclGetString(objv[2]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"event \"%s\" doesn't exist", eventStr));
Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, (void *)NULL);
"event \"%s\" doesn't exist", eventStr));
Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, (void *)NULL);
return TCL_ERROR;
} else {
Tcl_Obj *resultListPtr;
@@ -975,7 +975,7 @@ Tcl_AfterObjCmd(
afterPtr->commandPtr);
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
(afterPtr->token == NULL) ? "idle" : "timer", -1));
Tcl_SetObjResult(interp, resultListPtr);
Tcl_SetObjResult(interp, resultListPtr);
}
break;
default:
@@ -1043,17 +1043,17 @@ AfterDelay(
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
diff = 1;
}
if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
diff = 1;
}
if (diff > 0) {
Tcl_Sleep((int) diff);
if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
break;
}
if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
break;
}
} else {
break;
}
break;
}
} else {
diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
if (diff > TCL_TIME_MAXIMUM_SLICE) {
generic/tclTrace.c
+9 -9
View File
@@ -1119,7 +1119,7 @@ Tcl_UntraceCommand(
cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
/*
/*
* Bug 3484621: up the interp's epoch if this is a BC'ed command
*/
@@ -2547,15 +2547,15 @@ TclCallVarTraces(
/* Keep the original pointer for possible use in an error message */
element = part2;
if (part2 == NULL) {
if (TclIsVarArrayElement(varPtr)) {
Tcl_Obj *keyObj = VarHashGetKey(varPtr);
part2 = Tcl_GetString(keyObj);
}
if (TclIsVarArrayElement(varPtr)) {
Tcl_Obj *keyObj = VarHashGetKey(varPtr);
part2 = Tcl_GetString(keyObj);
}
} else if ((flags & VAR_TRACED_UNSET) && !(flags & VAR_ARRAY_ELEMENT)) {
/* On unset traces, part2 has already been set by the caller, and
* the VAR_ARRAY_ELEMENT flag indicates whether the accessed
* variable actually has a second part, or is a scalar */
element = NULL;
/* On unset traces, part2 has already been set by the caller, and
* the VAR_ARRAY_ELEMENT flag indicates whether the accessed
* variable actually has a second part, or is a scalar */
element = NULL;
}
/*
generic/tclUtil.c
+28 -28
View File
@@ -3232,10 +3232,10 @@ TclNeedSpace(
end = Tcl_UtfPrev(end, start);
while (*end == '{') {
if (end == start) {
return 0;
}
end = Tcl_UtfPrev(end, start);
if (end == start) {
return 0;
}
end = Tcl_UtfPrev(end, start);
}
*
@@ -3244,7 +3244,7 @@ TclNeedSpace(
while ((--end >= start) && (*end == '{')) {
}
if (end < start) {
return 0;
return 0;
}
/*
@@ -3366,9 +3366,9 @@ GetWideForIndex(
Tcl_Obj *objPtr, /* Points to the value to be parsed */
Tcl_WideInt endValue, /* The value to be stored at *widePtr if
* objPtr holds "end".
* NOTE: this value may be TCL_INDEX_NONE. */
* NOTE: this value may be TCL_INDEX_NONE. */
Tcl_WideInt *widePtr) /* Location filled in with a wide integer
* representing an index. */
* representing an index. */
{
int numType;
void *cd;
@@ -3378,7 +3378,7 @@ GetWideForIndex(
if (numType == TCL_NUMBER_INT) {
/* objPtr holds an integer in the signed wide range */
*widePtr = *(Tcl_WideInt *)cd;
if ((*widePtr < 0)) {
if ((*widePtr < 0)) {
*widePtr = (endValue == -1) ? WIDE_MIN : -1;
}
return TCL_OK;
@@ -3453,10 +3453,10 @@ Tcl_GetIntForIndex(
} else if (wide > TCL_SIZE_MAX) {
*indexPtr = TCL_SIZE_MAX; /* Beyond max possible index */
} else if (wide < -1-TCL_SIZE_MAX) {
*indexPtr = -1-TCL_SIZE_MAX; /* Below most negative index */
} else if ((wide < 0) && (endValue >= 0)) {
*indexPtr = TCL_INDEX_NONE; /* No clue why this special case */
} else {
*indexPtr = -1-TCL_SIZE_MAX; /* Below most negative index */
} else if ((wide < 0) && (endValue >= 0)) {
*indexPtr = TCL_INDEX_NONE; /* No clue why this special case */
} else {
*indexPtr = (Tcl_Size) wide;
}
}
@@ -3497,9 +3497,9 @@ GetEndOffsetFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr, /* Pointer to the object to parse */
Tcl_WideInt endValue, /* The value to be stored at "widePtr" if
* "objPtr" holds "end". */
* "objPtr" holds "end". */
Tcl_WideInt *widePtr) /* Location filled in with an integer
* representing an index. */
* representing an index. */
{
Tcl_ObjInternalRep *irPtr;
Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
@@ -3532,14 +3532,14 @@ GetEndOffsetFromObj(
*/
if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1)
/* If it's possible, do the full list parse. */
&& (TCL_OK == TclListObjLength(NULL, objPtr, &length))
&& (length > 1)) {
goto parseError;
&& (TCL_OK == TclListObjLength(NULL, objPtr, &length))
&& (length > 1)) {
goto parseError;
}
/* Passed the list screen, so parse for index arithmetic expression */
if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE, &opPtr,
TCL_PARSE_INTEGER_ONLY)) {
TCL_PARSE_INTEGER_ONLY)) {
Tcl_WideInt w1=0, w2=0;
/* value starts with valid integer... */
@@ -3698,12 +3698,12 @@ GetEndOffsetFromObj(
if (offset == WIDE_MAX) {
/*
* Encodes end+1. This is distinguished from end+n as noted
* in function header.
* in function header.
* NOTE: this may wrap around if the caller passes (as lset does)
* listLen-1 as endValue and and listLen is 0. The -1 will be
* interpreted as FF...FF and adding 1 will result in 0 which
* is what we want. Callers like lset which pass in listLen-1 == -1
* as endValue will have to adjust accordingly.
* as endValue will have to adjust accordingly.
*/
*widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1;
} else if (offset == WIDE_MIN) {
@@ -3720,14 +3720,14 @@ GetEndOffsetFromObj(
/* Report a parse error. */
parseError:
if (interp != NULL) {
char * bytes = TclGetString(objPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad index \"%s\": must be integer?[+-]integer? or"
" end?[+-]integer?", bytes));
if (!strncmp(bytes, "end-", 4)) {
bytes += 4;
}
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", (char *)NULL);
char * bytes = TclGetString(objPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad index \"%s\": must be integer?[+-]integer? or"
" end?[+-]integer?", bytes));
if (!strncmp(bytes, "end-", 4)) {
bytes += 4;
}
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", (char *)NULL);
}
return TCL_ERROR;
generic/tclVar.c
+18 -18
View File
@@ -2505,7 +2505,7 @@ TclPtrUnsetVarIdx(
if (result != TCL_OK) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset",
((initialArrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index);
((initialArrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index);
Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", (char *)NULL);
}
}
@@ -2614,22 +2614,22 @@ UnsetVarStruct(
if ((dummyVar.flags & VAR_TRACED_UNSET)
|| (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) {
/*
* Pass the array element name to TclObjCallVarTraces(), because
* it cannot be determined from dummyVar. Alternatively, indicate
* via flags whether the variable involved in the code that caused
* the trace to be triggered was an array element, for the correct
* formatting of error messages.
*/
if (part2Ptr) {
flags |= VAR_ARRAY_ELEMENT;
} else if (TclIsVarArrayElement(varPtr)) {
part2Ptr = VarHashGetKey(varPtr);
}
/*
* Pass the array element name to TclObjCallVarTraces(), because
* it cannot be determined from dummyVar. Alternatively, indicate
* via flags whether the variable involved in the code that caused
* the trace to be triggered was an array element, for the correct
* formatting of error messages.
*/
if (part2Ptr) {
flags |= VAR_ARRAY_ELEMENT;
} else if (TclIsVarArrayElement(varPtr)) {
part2Ptr = VarHashGetKey(varPtr);
}
dummyVar.flags &= ~VAR_TRACE_ACTIVE;
TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr,
(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT))
(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT))
| TCL_TRACE_UNSETS,
/* leaveErrMsg */ 0, index);
@@ -7086,13 +7086,13 @@ SetArrayDefault(
*/
if (tablePtr->defaultObj) {
Tcl_DecrRefCount(tablePtr->defaultObj);
Tcl_DecrRefCount(tablePtr->defaultObj);
Tcl_DecrRefCount(tablePtr->defaultObj);
Tcl_DecrRefCount(tablePtr->defaultObj);
}
tablePtr->defaultObj = defaultObj;
if (tablePtr->defaultObj) {
Tcl_IncrRefCount(tablePtr->defaultObj);
Tcl_IncrRefCount(tablePtr->defaultObj);
Tcl_IncrRefCount(tablePtr->defaultObj);
Tcl_IncrRefCount(tablePtr->defaultObj);
}
}
generic/tclZipfs.c
+1 -1
View File
@@ -1659,7 +1659,7 @@ ZipFSOpenArchive(
ZIPFS_POSIX_ERROR(interp, "seek error");
goto error;
}
/* What's the magic about 64 * 1024 * 1024 ? */
/* What's the magic about 64 * 1024 * 1024 ? */
if ((zf->length <= ZIP_CENTRAL_END_LEN) ||
(zf->length - ZIP_CENTRAL_END_LEN) >
(64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) {
library/icu.tcl
+92 -92
View File
@@ -22,121 +22,121 @@ namespace eval ::tcl::unsupported::icu {
variable icuToTcl
proc LogError {message} {
puts stderr $message
puts stderr $message
}
proc Init {} {
variable tclToIcu
variable icuToTcl
# There are some special cases where names do not line up
# at all. Map Tcl -> ICU
array set specialCases {
ebcdic ebcdic-cp-us
macCentEuro maccentraleurope
utf16 UTF16_PlatformEndian
utf-16be UnicodeBig
utf-16le UnicodeLittle
utf32 UTF32_PlatformEndian
}
# Ignore all errors. Do not want to hold up Tcl
# if ICU not available
if {[catch {
foreach tclName [encoding names] {
if {[catch {
set icuNames [aliases $tclName]
} erMsg]} {
LogError "Could not get aliases for $tclName: $erMsg"
continue
}
if {[llength $icuNames] == 0} {
# E.g. macGreek -> x-MacGreek
set icuNames [aliases x-$tclName]
if {[llength $icuNames] == 0} {
# Still no joy, check for special cases
if {[info exists specialCases($tclName)]} {
set icuNames [aliases $specialCases($tclName)]
}
}
}
# If the Tcl name is also an ICU name use it else use
# the first name which is the canonical ICU name
set pos [lsearch -exact -nocase $icuNames $tclName]
if {$pos >= 0} {
lappend tclToIcu($tclName) [lindex $icuNames $pos] {*}[lreplace $icuNames $pos $pos]
} else {
set tclToIcu($tclName) $icuNames
}
foreach icuName $icuNames {
lappend icuToTcl($icuName) $tclName
}
}
} errMsg]} {
LogError $errMsg
}
array default set tclToIcu ""
array default set icuToTcl ""
variable tclToIcu
variable icuToTcl
# There are some special cases where names do not line up
# at all. Map Tcl -> ICU
array set specialCases {
ebcdic ebcdic-cp-us
macCentEuro maccentraleurope
utf16 UTF16_PlatformEndian
utf-16be UnicodeBig
utf-16le UnicodeLittle
utf32 UTF32_PlatformEndian
}
# Ignore all errors. Do not want to hold up Tcl
# if ICU not available
if {[catch {
foreach tclName [encoding names] {
if {[catch {
set icuNames [aliases $tclName]
} erMsg]} {
LogError "Could not get aliases for $tclName: $erMsg"
continue
}
if {[llength $icuNames] == 0} {
# E.g. macGreek -> x-MacGreek
set icuNames [aliases x-$tclName]
if {[llength $icuNames] == 0} {
# Still no joy, check for special cases
if {[info exists specialCases($tclName)]} {
set icuNames [aliases $specialCases($tclName)]
}
}
}
# If the Tcl name is also an ICU name use it else use
# the first name which is the canonical ICU name
set pos [lsearch -exact -nocase $icuNames $tclName]
if {$pos >= 0} {
lappend tclToIcu($tclName) [lindex $icuNames $pos] {*}[lreplace $icuNames $pos $pos]
} else {
set tclToIcu($tclName) $icuNames
}
foreach icuName $icuNames {
lappend icuToTcl($icuName) $tclName
}
}
} errMsg]} {
LogError $errMsg
}
array default set tclToIcu ""
array default set icuToTcl ""
# Redefine ourselves to no-op.
proc Init {} {}
# Redefine ourselves to no-op.
proc Init {} {}
}
# Primarily used during development
proc MappedIcuNames {{pat *}} {
Init
variable icuToTcl
return [array names icuToTcl $pat]
Init
variable icuToTcl
return [array names icuToTcl $pat]
}
# Primarily used during development
proc UnmappedIcuNames {{pat *}} {
Init
variable icuToTcl
set unmappedNames {}
foreach icuName [converters] {
if {[llength [icuToTcl $icuName]] == 0} {
lappend unmappedNames $icuName
}
foreach alias [aliases $icuName] {
if {[llength [icuToTcl $alias]] == 0} {
lappend unmappedNames $alias
}
}
}
# Aliases can be duplicates. Remove
return [lsort -unique [lsearch -inline -all $unmappedNames $pat]]
Init
variable icuToTcl
set unmappedNames {}
foreach icuName [converters] {
if {[llength [icuToTcl $icuName]] == 0} {
lappend unmappedNames $icuName
}
foreach alias [aliases $icuName] {
if {[llength [icuToTcl $alias]] == 0} {
lappend unmappedNames $alias
}
}
}
# Aliases can be duplicates. Remove
return [lsort -unique [lsearch -inline -all $unmappedNames $pat]]
}
# Primarily used during development
proc UnmappedTclNames {{pat *}} {
Init
variable tclToIcu
set unmappedNames {}
foreach tclName [encoding names] {
# Note entry will always exist. Check if empty
if {[llength [tclToIcu $tclName]] == 0} {
lappend unmappedNames $tclName
}
}
return [lsearch -inline -all $unmappedNames $pat]
Init
variable tclToIcu
set unmappedNames {}
foreach tclName [encoding names] {
# Note entry will always exist. Check if empty
if {[llength [tclToIcu $tclName]] == 0} {
lappend unmappedNames $tclName
}
}
return [lsearch -inline -all $unmappedNames $pat]
}
# Returns the Tcl equivalent of an ICU encoding name or
# the empty string in case not found.
proc icuToTcl {icuName} {
Init
proc icuToTcl {icuName} {
variable icuToTcl
return [lindex $icuToTcl($icuName) 0]
}
icuToTcl $icuName
Init
proc icuToTcl {icuName} {
variable icuToTcl
return [lindex $icuToTcl($icuName) 0]
}
icuToTcl $icuName
}
# Returns the ICU equivalent of an Tcl encoding name or
# the empty string in case not found.
proc tclToIcu {tclName} {
Init
proc tclToIcu {tclName} {
variable tclToIcu
return [lindex $tclToIcu($tclName) 0]
}
tclToIcu $tclName
Init
proc tclToIcu {tclName} {
variable tclToIcu
return [lindex $tclToIcu($tclName) 0]
}
tclToIcu $tclName
}
library/init.tcl
+9 -9
View File
@@ -43,15 +43,15 @@ package require -exact tcl 9.0b3
if {![info exists auto_path]} {
if {[info exists env(TCLLIBPATH)] && (![interp issafe])} {
set auto_path [apply {{} {
lmap path $::env(TCLLIBPATH) {
# Paths relative to unresolvable home dirs are ignored
if {[catch {file tildeexpand $path} expanded_path]} {
continue
}
set expanded_path
}
}}]
set auto_path [apply {{} {
lmap path $::env(TCLLIBPATH) {
# Paths relative to unresolvable home dirs are ignored
if {[catch {file tildeexpand $path} expanded_path]} {
continue
}
set expanded_path
}
}}]
} else {
set auto_path ""
}
tests/icu.test
+12 -12
View File
@@ -11,28 +11,28 @@ testConstraint icu [expr {[info commands ::tcl::unsupported::icu::detect] ne ""}
namespace eval icu {
test icu-detect-0 {Return list of ICU encodings} -constraints icu -body {
set encoders [::tcl::unsupported::icu detect]
list [::tcl::mathop::in UTF-8 $encoders] [::tcl::mathop::in ISO-8859-1 $encoders]
set encoders [::tcl::unsupported::icu detect]
list [::tcl::mathop::in UTF-8 $encoders] [::tcl::mathop::in ISO-8859-1 $encoders]
} -result {1 1}
test icu-detect-1 {Guess encoding} -constraints icu -body {
::tcl::unsupported::icu detect [readFile [info script]]
::tcl::unsupported::icu detect [readFile [info script]]
} -result ISO-8859-1
test icu-detect-2 {Get all possible encodings} -constraints icu -body {
set encodings [::tcl::unsupported::icu detect [readFile [info script]] -all]
list [::tcl::mathop::in UTF-8 $encodings] [::tcl::mathop::in ISO-8859-1 $encodings]
set encodings [::tcl::unsupported::icu detect [readFile [info script]] -all]
list [::tcl::mathop::in UTF-8 $encodings] [::tcl::mathop::in ISO-8859-1 $encodings]
} -result {1 1}
test icu-tclToIcu-0 {Map Tcl encoding} -constraints icu -body {
# tis-620 because it is ambiguous in ICU on some platforms
# but should return the preferred encoding
list [::tcl::unsupported::icu tclToIcu utf-8] [::tcl::unsupported::icu tclToIcu tis-620] [::tcl::unsupported::icu tclToIcu shiftjis]
# tis-620 because it is ambiguous in ICU on some platforms
# but should return the preferred encoding
list [::tcl::unsupported::icu tclToIcu utf-8] [::tcl::unsupported::icu tclToIcu tis-620] [::tcl::unsupported::icu tclToIcu shiftjis]
} -result {UTF-8 TIS-620 ibm-943_P15A-2003}
test icu-tclToIcu-1 {Map Tcl encoding - no map} -constraints icu -body {
# Should not raise an error
::tcl::unsupported::icu tclToIcu dummy
# Should not raise an error
::tcl::unsupported::icu tclToIcu dummy
} -result {}
test icu-icuToTcl-0 {Map ICU encoding} -constraints icu -body {
@@ -40,8 +40,8 @@ namespace eval icu {
} -result {utf-8 tis-620 cp932}
test icu-icuToTcl-1 {Map ICU encoding - no map} -constraints icu -body {
# Should not raise an error
::tcl::unsupported::icu icuToTcl dummy
# Should not raise an error
::tcl::unsupported::icu icuToTcl dummy
} -result {}
}
tools/ucm2tests.tcl
+192 -192
View File
@@ -16,31 +16,31 @@ namespace eval ucm {
# Map Tcl encoding name to ICU UCM file name
variable encNameMap
array set encNameMap {
cp1250 glibc-CP1250-2.1.2
cp1251 glibc-CP1251-2.1.2
cp1252 glibc-CP1252-2.1.2
cp1253 glibc-CP1253-2.1.2
cp1254 glibc-CP1254-2.1.2
cp1255 glibc-CP1255-2.1.2
cp1256 glibc-CP1256-2.1.2
cp1257 glibc-CP1257-2.1.2
cp1258 glibc-CP1258-2.1.2
gb1988 glibc-GB_1988_80-2.3.3
iso8859-1 glibc-ISO_8859_1-2.1.2
iso8859-2 glibc-ISO_8859_2-2.1.2
iso8859-3 glibc-ISO_8859_3-2.1.2
iso8859-4 glibc-ISO_8859_4-2.1.2
iso8859-5 glibc-ISO_8859_5-2.1.2
iso8859-6 glibc-ISO_8859_6-2.1.2
iso8859-7 glibc-ISO_8859_7-2.3.3
iso8859-8 glibc-ISO_8859_8-2.3.3
iso8859-9 glibc-ISO_8859_9-2.1.2
iso8859-10 glibc-ISO_8859_10-2.1.2
iso8859-11 glibc-ISO_8859_11-2.1.2
iso8859-13 glibc-ISO_8859_13-2.3.3
iso8859-14 glibc-ISO_8859_14-2.1.2
iso8859-15 glibc-ISO_8859_15-2.1.2
iso8859-16 glibc-ISO_8859_16-2.3.3
cp1250 glibc-CP1250-2.1.2
cp1251 glibc-CP1251-2.1.2
cp1252 glibc-CP1252-2.1.2
cp1253 glibc-CP1253-2.1.2
cp1254 glibc-CP1254-2.1.2
cp1255 glibc-CP1255-2.1.2
cp1256 glibc-CP1256-2.1.2
cp1257 glibc-CP1257-2.1.2
cp1258 glibc-CP1258-2.1.2
gb1988 glibc-GB_1988_80-2.3.3
iso8859-1 glibc-ISO_8859_1-2.1.2
iso8859-2 glibc-ISO_8859_2-2.1.2
iso8859-3 glibc-ISO_8859_3-2.1.2
iso8859-4 glibc-ISO_8859_4-2.1.2
iso8859-5 glibc-ISO_8859_5-2.1.2
iso8859-6 glibc-ISO_8859_6-2.1.2
iso8859-7 glibc-ISO_8859_7-2.3.3
iso8859-8 glibc-ISO_8859_8-2.3.3
iso8859-9 glibc-ISO_8859_9-2.1.2
iso8859-10 glibc-ISO_8859_10-2.1.2
iso8859-11 glibc-ISO_8859_11-2.1.2
iso8859-13 glibc-ISO_8859_13-2.3.3
iso8859-14 glibc-ISO_8859_14-2.1.2
iso8859-15 glibc-ISO_8859_15-2.1.2
iso8859-16 glibc-ISO_8859_16-2.3.3
}
# Array keyed by Tcl encoding name. Each element contains mapping of
@@ -72,8 +72,8 @@ proc ucm::warn {msg} {
proc ucm::log {msg} {
variable verbose
if {$verbose} {
variable errorChan
puts $errorChan $msg
variable errorChan
puts $errorChan $msg
}
}
proc ucm::print {s} {
@@ -88,21 +88,21 @@ proc ucm::parse_SBCS {encName fd} {
set result {}
while {[gets $fd line] >= 0} {
if {[string match #* $line]} {
continue
}
if {[string equal "END CHARMAP" [string trim $line]]} {
break
}
if {![regexp {^\s*<U([[:xdigit:]]{4})>\s*((\\x[[:xdigit:]]{2})+)\s*(\|(0|1|2|3|4))} $line -> unichar bytes - - precision]} {
error "Unexpected line parsing SBCS: $line"
}
set bytes [string map {\\x {}} $bytes]; # \xNN -> NN
if {$precision eq "" || $precision eq "0"} {
lappend result $unichar $bytes
} else {
# It is a fallback mapping - ignore
}
if {[string match #* $line]} {
continue
}
if {[string equal "END CHARMAP" [string trim $line]]} {
break
}
if {![regexp {^\s*<U([[:xdigit:]]{4})>\s*((\\x[[:xdigit:]]{2})+)\s*(\|(0|1|2|3|4))} $line -> unichar bytes - - precision]} {
error "Unexpected line parsing SBCS: $line"
}
set bytes [string map {\\x {}} $bytes]; # \xNN -> NN
if {$precision eq "" || $precision eq "0"} {
lappend result $unichar $bytes
} else {
# It is a fallback mapping - ignore
}
}
set charMap($encName) $result
@@ -110,33 +110,33 @@ proc ucm::parse_SBCS {encName fd} {
set valid {}
set mapped {}
foreach {unich bytes} $result {
lappend mapped $unich
lappend valid $bytes
lappend mapped $unich
lappend valid $bytes
}
set invalidCodeSequences($encName) {}
for {set i 0} {$i <= 255} {incr i} {
set hex [format %.2X $i]
if {[lsearch -exact $valid $hex] < 0} {
lappend invalidCodeSequences($encName) $hex
}
set hex [format %.2X $i]
if {[lsearch -exact $valid $hex] < 0} {
lappend invalidCodeSequences($encName) $hex
}
}
set unmappedCodePoints($encName) {}
for {set i 0} {$i <= 65535} {incr i} {
set hex [format %.4X $i]
if {[lsearch -exact $mapped $hex] < 0} {
lappend unmappedCodePoints($encName) $hex
# Only look for (at most) one below 256 and one above 1024
if {$i < 255} {
# Found one so jump past 8 bits
set i 255
} else {
break
}
}
if {$i == 255} {
set i 1023
}
set hex [format %.4X $i]
if {[lsearch -exact $mapped $hex] < 0} {
lappend unmappedCodePoints($encName) $hex
# Only look for (at most) one below 256 and one above 1024
if {$i < 255} {
# Found one so jump past 8 bits
set i 255
} else {
break
}
}
if {$i == 255} {
set i 1023
}
}
lappend unmappedCodePoints($encName) D800 DC00 10000 10FFFF
}
@@ -153,41 +153,41 @@ proc ucm::generate_boilerplate {} {
proc ucmConvertfromMismatches {enc map} {
set mismatches {}
foreach {unihex hex} $map {
set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits
set unich [subst "\\U$unihex"]
if {[encoding convertfrom -profile strict $enc [binary decode hex $hex]] ne $unich} {
lappend mismatches "<[printable $unich],$hex>"
}
set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits
set unich [subst "\\U$unihex"]
if {[encoding convertfrom -profile strict $enc [binary decode hex $hex]] ne $unich} {
lappend mismatches "<[printable $unich],$hex>"
}
}
return $mismatches
}
proc ucmConverttoMismatches {enc map} {
set mismatches {}
foreach {unihex hex} $map {
set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits
set unich [subst "\\U$unihex"]
if {[encoding convertto -profile strict $enc $unich] ne [binary decode hex $hex]} {
lappend mismatches "<[printable $unich],$hex>"
}
set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits
set unich [subst "\\U$unihex"]
if {[encoding convertto -profile strict $enc $unich] ne [binary decode hex $hex]} {
lappend mismatches "<[printable $unich],$hex>"
}
}
return $mismatches
}
if {[info commands printable] eq ""} {
proc printable {s} {
set print ""
foreach c [split $s ""] {
set i [scan $c %c]
if {[string is print $c] && ($i <= 127)} {
append print $c
} elseif {$i <= 0xff} {
append print \\x[format %02X $i]
} elseif {$i <= 0xffff} {
append print \\u[format %04X $i]
} else {
append print \\U[format %08X $i]
}
}
return $print
set print ""
foreach c [split $s ""] {
set i [scan $c %c]
if {[string is print $c] && ($i <= 127)} {
append print $c
} elseif {$i <= 0xff} {
append print \\x[format %02X $i]
} elseif {$i <= 0xffff} {
append print \\u[format %04X $i]
} else {
append print \\U[format %08X $i]
}
}
return $print
}
}
}
@@ -203,79 +203,79 @@ proc ucm::generate_tests {} {
variable encSubchar
if {[info exists outputPath]} {
set outputChan [open $outputPath w]
fconfigure $outputChan -translation lf
set outputChan [open $outputPath w]
fconfigure $outputChan -translation lf
} else {
set outputChan stdout
set outputChan stdout
}
array set tclNames {}
foreach encName [encoding names] {
set tclNames($encName) ""
set tclNames($encName) ""
}
generate_boilerplate
foreach encName [lsort -dictionary [array names encNameMap]] {
if {![info exists charMap($encName)]} {
warn "No character map read for $encName"
continue
}
unset tclNames($encName)
if {![info exists charMap($encName)]} {
warn "No character map read for $encName"
continue
}
unset tclNames($encName)
# Print the valid tests
print "\n#\n# $encName (generated from $encNameMap($encName))"
print "\ntest encoding-convertfrom-ucmCompare-$encName {Compare against ICU UCM} -body \{"
print " ucmConvertfromMismatches $encName {$charMap($encName)}"
print "\} -result {}"
print "\ntest encoding-convertto-ucmCompare-$encName {Compare against ICU UCM} -body \{"
print " ucmConverttoMismatches $encName {$charMap($encName)}"
print "\} -result {}"
if {0} {
# This will generate individual tests for every char
# and test in lead, tail, middle, solo configurations
# but takes considerable time
print "lappend encValidStrings \{*\}\{"
foreach {unich hex} $charMap($encName) {
print " $encName \\u$unich $hex {} {}"
}
print "\}; # $encName"
}
# Print the valid tests
print "\n#\n# $encName (generated from $encNameMap($encName))"
print "\ntest encoding-convertfrom-ucmCompare-$encName {Compare against ICU UCM} -body \{"
print " ucmConvertfromMismatches $encName {$charMap($encName)}"
print "\} -result {}"
print "\ntest encoding-convertto-ucmCompare-$encName {Compare against ICU UCM} -body \{"
print " ucmConverttoMismatches $encName {$charMap($encName)}"
print "\} -result {}"
if {0} {
# This will generate individual tests for every char
# and test in lead, tail, middle, solo configurations
# but takes considerable time
print "lappend encValidStrings \{*\}\{"
foreach {unich hex} $charMap($encName) {
print " $encName \\u$unich $hex {} {}"
}
print "\}; # $encName"
}
# Generate the invalidity checks
print "\n# $encName - invalid byte sequences"
print "lappend encInvalidBytes \{*\}\{"
foreach hex $invalidCodeSequences($encName) {
# Map XXXX... to \xXX\xXX...
set uhex [regsub -all .. $hex {\\x\0}]
set uhex \\U[string range 00000000$hex end-7 end]
print " $encName $hex tcl8 $uhex -1 {} {}"
print " $encName $hex replace \\uFFFD -1 {} {}"
print " $encName $hex strict {} 0 {} {}"
}
print "\}; # $encName"
# Generate the invalidity checks
print "\n# $encName - invalid byte sequences"
print "lappend encInvalidBytes \{*\}\{"
foreach hex $invalidCodeSequences($encName) {
# Map XXXX... to \xXX\xXX...
set uhex [regsub -all .. $hex {\\x\0}]
set uhex \\U[string range 00000000$hex end-7 end]
print " $encName $hex tcl8 $uhex -1 {} {}"
print " $encName $hex replace \\uFFFD -1 {} {}"
print " $encName $hex strict {} 0 {} {}"
}
print "\}; # $encName"
print "\n# $encName - invalid byte sequences"
print "lappend encUnencodableStrings \{*\}\{"
if {[info exists encSubchar($encName)]} {
set subchar $encSubchar($encName)
} else {
set subchar "3F"; # Tcl uses ? by default
}
foreach hex $unmappedCodePoints($encName) {
set uhex \\U[string range 00000000$hex end-7 end]
print " $encName $uhex tcl8 $subchar -1 {} {}"
print " $encName $uhex replace $subchar -1 {} {}"
print " $encName $uhex strict {} 0 {} {}"
}
print "\}; # $encName"
print "\n# $encName - invalid byte sequences"
print "lappend encUnencodableStrings \{*\}\{"
if {[info exists encSubchar($encName)]} {
set subchar $encSubchar($encName)
} else {
set subchar "3F"; # Tcl uses ? by default
}
foreach hex $unmappedCodePoints($encName) {
set uhex \\U[string range 00000000$hex end-7 end]
print " $encName $uhex tcl8 $subchar -1 {} {}"
print " $encName $uhex replace $subchar -1 {} {}"
print " $encName $uhex strict {} 0 {} {}"
}
print "\}; # $encName"
}
if {[array size tclNames]} {
warn "Missing encoding: [lsort [array names tclNames]]"
warn "Missing encoding: [lsort [array names tclNames]]"
}
if {[info exists outputPath]} {
close $outputChan
unset outputChan
close $outputChan
unset outputChan
}
}
@@ -285,51 +285,51 @@ proc ucm::parse_file {encName ucmPath} {
set fd [open $ucmPath]
try {
# Parse the metadata
unset -nocomplain state
while {[gets $fd line] >= 0} {
if {[regexp {<(code_set_name|mb_cur_max|mb_cur_min|uconv_class|subchar)>\s+(\S+)} $line -> key val]} {
set state($key) $val
} elseif {[regexp {^\s*CHARMAP\s*$} $line]} {
set state(charmap) ""
break
} else {
# Skip all else
}
}
if {![info exists state(charmap)]} {
abort "Error: $ucmPath has No CHARMAP line."
}
foreach key {code_set_name uconv_class} {
if {[info exists state($key)]} {
set state($key) [string trim $state($key) {"}]
}
}
if {[info exists charMap($encName)]} {
abort "Duplicate file for $encName ($path)"
}
if {![info exists state(uconv_class)]} {
abort "Error: $ucmPath has no uconv_class definition."
}
if {[info exists state(subchar)]} {
# \xNN\xNN.. -> NNNN..
set encSubchar($encName) [string map {\\x {}} $state(subchar)]
}
switch -exact -- $state(uconv_class) {
SBCS {
if {[catch {
parse_SBCS $encName $fd
} result]} {
abort "Could not process $ucmPath. $result"
}
}
default {
log "Skipping $ucmPath -- not SBCS encoding."
return
}
}
# Parse the metadata
unset -nocomplain state
while {[gets $fd line] >= 0} {
if {[regexp {<(code_set_name|mb_cur_max|mb_cur_min|uconv_class|subchar)>\s+(\S+)} $line -> key val]} {
set state($key) $val
} elseif {[regexp {^\s*CHARMAP\s*$} $line]} {
set state(charmap) ""
break
} else {
# Skip all else
}
}
if {![info exists state(charmap)]} {
abort "Error: $ucmPath has No CHARMAP line."
}
foreach key {code_set_name uconv_class} {
if {[info exists state($key)]} {
set state($key) [string trim $state($key) {"}]
}
}
if {[info exists charMap($encName)]} {
abort "Duplicate file for $encName ($path)"
}
if {![info exists state(uconv_class)]} {
abort "Error: $ucmPath has no uconv_class definition."
}
if {[info exists state(subchar)]} {
# \xNN\xNN.. -> NNNN..
set encSubchar($encName) [string map {\\x {}} $state(subchar)]
}
switch -exact -- $state(uconv_class) {
SBCS {
if {[catch {
parse_SBCS $encName $fd
} result]} {
abort "Could not process $ucmPath. $result"
}
}
default {
log "Skipping $ucmPath -- not SBCS encoding."
return
}
}
} finally {
close $fd
close $fd
}
}
@@ -337,14 +337,14 @@ proc ucm::run {} {
variable encNameMap
variable outputPath
switch [llength $::argv] {
2 {set outputPath [lindex $::argv 1]}
1 {}
default {
abort "Usage: [info nameofexecutable] $::argv0 path/to/icu/ucm/data ?outputfile?"
}
2 {set outputPath [lindex $::argv 1]}
1 {}
default {
abort "Usage: [info nameofexecutable] $::argv0 path/to/icu/ucm/data ?outputfile?"
}
}
foreach {encName fname} [array get encNameMap] {
ucm::parse_file $encName [file join [lindex $::argv 0] ${fname}.ucm]
ucm::parse_file $encName [file join [lindex $::argv 0] ${fname}.ucm]
}
generate_tests
}