From da96c5304100d70d932bcb73796c068d7e416cae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 12 Mar 2019 20:39:42 +0000 Subject: Even better support for -DTCL_UTF_MAX=6. Ongoing improvements (TIP being planned) --- doc/source.n | 2 +- generic/tcl.decls | 13 +++-- generic/tcl.h | 2 +- generic/tclDecls.h | 39 ++++++++++---- generic/tclEncoding.c | 138 +++++++++++++++++++++++++++++++++++++++++++++---- generic/tclInt.h | 8 +-- generic/tclStringObj.c | 6 +-- generic/tclStubInit.c | 29 +++++++++-- generic/tclUtf.c | 10 ++-- tests/chanio.test | 4 +- tests/encoding.test | 23 ++++++--- tests/io.test | 4 +- tests/ioCmd.test | 8 +-- tests/source.test | 4 +- win/tclWin32Dll.c | 4 +- win/tclWinFile.c | 8 +-- 16 files changed, 236 insertions(+), 66 deletions(-) diff --git a/doc/source.n b/doc/source.n index 3fc001e..353b8fb 100644 --- a/doc/source.n +++ b/doc/source.n @@ -43,7 +43,7 @@ or which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP -A leading BOM (Byte order mark) contained in the file is ignored for unicode encodings (utf-8, unicode). +A leading BOM (Byte order mark) contained in the file is ignored for unicode encodings (utf-8, utf-16, ucs-2). .PP The \fB\-encoding\fR option is used to specify the encoding of the data stored in \fIfileName\fR. When the \fB\-encoding\fR option diff --git a/generic/tcl.decls b/generic/tcl.decls index 5b3afeb..7ceb8c0 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1339,7 +1339,7 @@ declare 377 { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 { - Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars) + Tcl_Obj *Tcl_NewUtf16Obj(const unsigned short *unicode, int numChars) } declare 379 { void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, @@ -1352,7 +1352,7 @@ declare 381 { int Tcl_GetUniChar(Tcl_Obj *objPtr, int index) } declare 382 {deprecated {No longer in use, changed to macro}} { - Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) + unsigned short *Tcl_GetUnicode(Tcl_Obj *objPtr) } declare 383 { Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) @@ -1542,7 +1542,7 @@ declare 433 { # introduced in 8.4a3 declare 434 { - Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) + unsigned short *Tcl_GetUtf16FromObj(Tcl_Obj *objPtr, int *lengthPtr) } # TIP#15 (math function introspection) dkf @@ -2379,6 +2379,13 @@ declare 643 { int Tcl_IsShared(Tcl_Obj *objPtr) } +declare 644 { + int *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) +} +declare 645 { + Tcl_Obj *Tcl_NewUnicodeObj(const int *unicode, int numChars) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index c287a84..27cf7c3 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2160,7 +2160,7 @@ typedef struct Tcl_EncodingType { * XXX: string rep that Tcl_UniChar represents. Changing the size * XXX: of Tcl_UniChar is /not/ supported. */ -typedef unsigned int Tcl_UniChar; +typedef int Tcl_UniChar; #else typedef unsigned short Tcl_UniChar; #endif diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 865c960..6f1a956 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1139,7 +1139,7 @@ EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp, EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 378 */ -EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, +EXTERN Tcl_Obj * Tcl_NewUtf16Obj(const unsigned short *unicode, int numChars); /* 379 */ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, @@ -1150,7 +1150,7 @@ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, int index); /* 382 */ TCL_DEPRECATED("No longer in use, changed to macro") -Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); +unsigned short * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ @@ -1295,8 +1295,7 @@ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length); /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ -EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, - int *lengthPtr); +EXTERN unsigned short * Tcl_GetUtf16FromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 435 */ TCL_DEPRECATED("") int Tcl_GetMathFuncInfo(Tcl_Interp *interp, @@ -1896,6 +1895,11 @@ EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr); EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr); /* 643 */ EXTERN int Tcl_IsShared(Tcl_Obj *objPtr); +/* 644 */ +EXTERN int * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, + int *lengthPtr); +/* 645 */ +EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const int *unicode, int numChars); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2309,11 +2313,11 @@ typedef struct TclStubs { int (*tcl_UniCharIsPunct) (int ch); /* 375 */ int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ - Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */ + Tcl_Obj * (*tcl_NewUtf16Obj) (const unsigned short *unicode, int numChars); /* 378 */ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ - TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") unsigned short * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ @@ -2365,7 +2369,7 @@ typedef struct TclStubs { char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 431 */ int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ - Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ + unsigned short * (*tcl_GetUtf16FromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */ @@ -2575,6 +2579,8 @@ typedef struct TclStubs { void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */ void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */ int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ + int * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 644 */ + Tcl_Obj * (*tcl_NewUnicodeObj) (const int *unicode, int numChars); /* 645 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3361,8 +3367,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_RegExpExecObj) /* 376 */ #define Tcl_RegExpGetInfo \ (tclStubsPtr->tcl_RegExpGetInfo) /* 377 */ -#define Tcl_NewUnicodeObj \ - (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ +#define Tcl_NewUtf16Obj \ + (tclStubsPtr->tcl_NewUtf16Obj) /* 378 */ #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ #define Tcl_GetCharLength \ @@ -3473,8 +3479,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */ #define Tcl_GetChannelThread \ (tclStubsPtr->tcl_GetChannelThread) /* 433 */ -#define Tcl_GetUnicodeFromObj \ - (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */ +#define Tcl_GetUtf16FromObj \ + (tclStubsPtr->tcl_GetUtf16FromObj) /* 434 */ #define Tcl_GetMathFuncInfo \ (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */ #define Tcl_ListMathFuncs \ @@ -3893,6 +3899,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DecrRefCount) /* 642 */ #define Tcl_IsShared \ (tclStubsPtr->tcl_IsShared) /* 643 */ +#define Tcl_GetUnicodeFromObj \ + (tclStubsPtr->tcl_GetUnicodeFromObj) /* 644 */ +#define Tcl_NewUnicodeObj \ + (tclStubsPtr->tcl_NewUnicodeObj) /* 645 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4074,6 +4084,13 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_BackgroundError #define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR) +#if TCL_UTF_MAX <= 4 +# undef Tcl_GetUnicodeFromObj +# define Tcl_GetUnicodeFromObj Tcl_GetUtf16FromObj +# undef Tcl_NewUnicodeObj +# define Tcl_NewUnicodeObj Tcl_NewUtf16Obj +#endif + /* * Deprecated Tcl procedures: */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 7eb73e8..74e7513 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -234,12 +234,17 @@ static int TableToUtfProc(ClientData clientData, const char *src, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static size_t unilen(const char *src); -static int UniCharToUtfProc(ClientData clientData, +static int Utf16ToUtfProc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -static int UtfToUniCharProc(ClientData clientData, +static int UtfToUtf16Proc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static int UtfToUcs2Proc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, @@ -595,14 +600,27 @@ TclInitEncodingSubsystem(void) type.clientData = NULL; Tcl_CreateEncoding(&type); - type.encodingName = "unicode"; - type.toUtfProc = UniCharToUtfProc; - type.fromUtfProc = UtfToUniCharProc; + type.encodingName = "ucs-2"; + type.toUtfProc = Utf16ToUtfProc; + type.fromUtfProc = UtfToUcs2Proc; type.freeProc = NULL; type.nullSize = 2; type.clientData = NULL; Tcl_CreateEncoding(&type); + type.encodingName = "utf-16"; + type.toUtfProc = Utf16ToUtfProc; + type.fromUtfProc = UtfToUtf16Proc; + type.freeProc = NULL; + type.nullSize = 2; + type.clientData = NULL; + Tcl_CreateEncoding(&type); + +#ifndef TCL_NO_DEPRECATED + type.encodingName = "unicode"; + Tcl_CreateEncoding(&type); +#endif + /* * Need the iso8859-1 encoding in order to process binary data, so force * it to always be embedded. Note that this encoding *must* be a proper @@ -2401,9 +2419,9 @@ UtfToUtfProc( /* *------------------------------------------------------------------------- * - * UniCharToUtfProc -- + * Utf16ToUtfProc -- * - * Convert from Unicode to UTF-8. + * Convert from UTF-16 to UTF-8. * * Results: * Returns TCL_OK if conversion was successful. @@ -2415,7 +2433,7 @@ UtfToUtfProc( */ static int -UniCharToUtfProc( +Utf16ToUtfProc( ClientData clientData, /* Not used. */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ @@ -2491,9 +2509,9 @@ UniCharToUtfProc( /* *------------------------------------------------------------------------- * - * UtfToUniCharProc -- + * UtfToUtf16Proc -- * - * Convert from UTF-8 to Unicode. + * Convert from UTF-8 to UTF-16. * * Results: * Returns TCL_OK if conversion was successful. @@ -2505,7 +2523,7 @@ UniCharToUtfProc( */ static int -UtfToUniCharProc( +UtfToUtf16Proc( ClientData clientData, /* TableEncodingData that specifies * encoding. */ const char *src, /* Source string in UTF-8. */ @@ -2612,6 +2630,104 @@ UtfToUniCharProc( /* *------------------------------------------------------------------------- * + * UtfToUcs2Proc -- + * + * Convert from UTF-8 to UCS-2. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +UtfToUcs2Proc( + ClientData clientData, /* TableEncodingData that specifies + * encoding. */ + const char *src, /* Source string in UTF-8. */ + int srcLen, /* Source string length in bytes. */ + int flags, /* Conversion control flags. */ + Tcl_EncodingState *statePtr,/* Place for conversion routine to store state + * information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst, /* Output buffer in which converted string is + * stored. */ + int dstLen, /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr, /* Filled with the number of bytes from the + * source string that were converted. This may + * be less than the original source length if + * there was a problem converting some source + * characters. */ + int *dstWrotePtr, /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr) /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; + int result, numChars, len; + Tcl_UniChar ch = 0; + + srcStart = src; + srcEnd = src + srcLen; + srcClose = srcEnd; + if ((flags & TCL_ENCODING_END) == 0) { + srcClose -= TCL_UTF_MAX; + } + + dstStart = dst; + dstEnd = dst + dstLen - sizeof(Tcl_UniChar); + + result = TCL_OK; + for (numChars = 0; src < srcEnd; numChars++) { + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { + /* + * If there is more string to follow, this will ensure that the + * last UTF-8 character in the source buffer hasn't been cut off. + */ + + result = TCL_CONVERT_MULTIBYTE; + break; + } + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + src += (len = TclUtfToUniChar(src, &ch)); + if ((ch >= 0xD800) && (len < 3)) { + src += TclUtfToUniChar(src, &ch); + ch = 0xFFFD; + } + + /* + * Need to handle this in a way that won't cause misalignment by + * casting dst to a Tcl_UniChar. [Bug 1122671] + */ + +#ifdef WORDS_BIGENDIAN + *dst++ = (ch >> 8); + *dst++ = (ch & 0xFF); +#else + *dst++ = (ch & 0xFF); + *dst++ = (ch >> 8); +#endif + } + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * * TableToUtfProc -- * * Convert from the encoding specified by the TableEncodingData into diff --git a/generic/tclInt.h b/generic/tclInt.h index beb7a35..0db08f9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3243,14 +3243,14 @@ MODULE_SCOPE void TclRegisterCommandTypeName( const char *nameStr); #if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) MODULE_SCOPE int TclUtfToWChar(const char *src, WCHAR *chPtr); -MODULE_SCOPE char * TclWCharToUtfDString(const WCHAR *uniStr, +MODULE_SCOPE char * Tcl_Utf16ToUtfDString(const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); -MODULE_SCOPE WCHAR * TclUtfToWCharDString(const char *src, +MODULE_SCOPE unsigned short * Tcl_UtfToUtf16DString(const char *src, int length, Tcl_DString *dsPtr); #else # define TclUtfToWChar TclUtfToUniChar -# define TclWCharToUtfDString Tcl_UniCharToUtfDString -# define TclUtfToWCharDString Tcl_UtfToUniCharDString +# define Tcl_Utf16ToUtfDString Tcl_UniCharToUtfDString +# define Tcl_UtfToUtf16DString Tcl_UtfToUniCharDString #endif MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index ee0a3c3..6cbf5e7 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -606,14 +606,14 @@ Tcl_GetUniChar( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && (TCL_UTF_MAX<=4) #undef Tcl_GetUnicode -Tcl_UniChar * +unsigned short * Tcl_GetUnicode( Tcl_Obj *objPtr) /* The object to find the unicode string * for. */ { - return Tcl_GetUnicodeFromObj(objPtr, NULL); + return Tcl_GetUtf16FromObj(objPtr, NULL); } #endif /* TCL_NO_DEPRECATED */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index e67d976..3cafbc0 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -59,6 +59,24 @@ #undef TclStaticPackage #undef Tcl_BackgroundError #define TclStaticPackage Tcl_StaticPackage +#undef Tcl_GetUnicodeFromObj +#undef Tcl_NewUnicodeObj + +static void uniCodePanic() { +#if TCL_UTF_MAX <= 4 + Tcl_Panic("This extension is compiled with -DTCL_UTF_MAX=6, but Tcl is compiled with -DTCL_UTF_MAX=4"); +#else + Tcl_Panic("This extension is compiled with -DTCL_UTF_MAX=4, but Tcl is compiled with -DTCL_UTF_MAX=6"); +#endif +} +#if TCL_UTF_MAX <= 4 +# define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, int *)) uniCodePanic +# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, int)) uniCodePanic +#else +# define Tcl_GetUtf16FromObj (unsigned short *(*)(Tcl_Obj *, int *)) uniCodePanic +# define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *)) uniCodePanic +# define Tcl_NewUtf16Obj (Tcl_Obj *(*)(const unsigned short *, int)) uniCodePanic +#endif /* See bug 510001: TclSockMinimumBuffers needs plat imp */ #if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 @@ -244,7 +262,7 @@ Tcl_WinUtfToTChar( if (!string) { return NULL; } - return (char *)TclUtfToWCharDString(string, len, dsPtr); + return (char *)Tcl_UtfToUtf16DString(string, len, dsPtr); } char * @@ -262,7 +280,7 @@ Tcl_WinTCharToUtf( } else { len /= 2; } - return TclWCharToUtfDString((const WCHAR *)string, len, dsPtr); + return Tcl_Utf16ToUtfDString((const WCHAR *)string, len, dsPtr); } #if defined(TCL_WIDE_INT_IS_LONG) @@ -410,7 +428,6 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig # define Tcl_SetExitProc 0 # define Tcl_SetPanicProc 0 # define Tcl_FindExecutable 0 -# define Tcl_GetUnicode 0 # define TclOldFreeObj 0 #else /* TCL_NO_DEPRECATED */ # define Tcl_SeekOld seekOld @@ -1345,7 +1362,7 @@ const TclStubs tclStubs = { Tcl_UniCharIsPunct, /* 375 */ Tcl_RegExpExecObj, /* 376 */ Tcl_RegExpGetInfo, /* 377 */ - Tcl_NewUnicodeObj, /* 378 */ + Tcl_NewUtf16Obj, /* 378 */ Tcl_SetUnicodeObj, /* 379 */ Tcl_GetCharLength, /* 380 */ Tcl_GetUniChar, /* 381 */ @@ -1401,7 +1418,7 @@ const TclStubs tclStubs = { Tcl_AttemptDbCkrealloc, /* 431 */ Tcl_AttemptSetObjLength, /* 432 */ Tcl_GetChannelThread, /* 433 */ - Tcl_GetUnicodeFromObj, /* 434 */ + Tcl_GetUtf16FromObj, /* 434 */ Tcl_GetMathFuncInfo, /* 435 */ Tcl_ListMathFuncs, /* 436 */ Tcl_SubstObj, /* 437 */ @@ -1611,6 +1628,8 @@ const TclStubs tclStubs = { Tcl_IncrRefCount, /* 641 */ Tcl_DecrRefCount, /* 642 */ Tcl_IsShared, /* 643 */ + Tcl_GetUnicodeFromObj, /* 644 */ + Tcl_NewUnicodeObj, /* 645 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index b5d8824..cea0875 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -268,14 +268,14 @@ Tcl_UniCharToUtfDString( #if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) char * -TclWCharToUtfDString( - const WCHAR *uniStr, /* WCHAR string to convert to UTF-8. */ +Tcl_Utf16ToUtfDString( + const unsigned short *uniStr, /* WCHAR string to convert to UTF-8. */ int uniLength, /* Length of WCHAR string in Tcl_UniChars * (must be >= 0). */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { - const WCHAR *w, *wEnd; + const unsigned short *w, *wEnd; char *p, *string; int oldLength, len = 1; @@ -636,8 +636,8 @@ Tcl_UtfToUniCharDString( } #if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) -WCHAR * -TclUtfToWCharDString( +unsigned short * +Tcl_UtfToUtf16DString( const char *src, /* UTF-8 string to convert to Unicode. */ int length, /* Length of UTF-8 string in bytes, or -1 for * strlen(). */ diff --git a/tests/chanio.test b/tests/chanio.test index 9dc9e7c..1439fe4 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -888,7 +888,7 @@ test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup # Tcl_ExternalToUtf() set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none - chan configure $f -encoding unicode + chan configure $f -encoding utf-16 chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 chan gets $f @@ -1129,7 +1129,7 @@ test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { chan event $f read [namespace code { lappend x [chan gets $f line] $line [testchannel inputbuffered $f] }] - chan configure $f -encoding unicode -buffersize 16 -blocking 0 + chan configure $f -encoding utf-16 -buffersize 16 -blocking 0 vwait [namespace which -variable x] chan configure $f -translation auto -encoding ascii -blocking 1 # here diff --git a/tests/encoding.test b/tests/encoding.test index 4736928..da34f03 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -322,18 +322,29 @@ test encoding-15.3 {UtfToUtfProc null character input} teststringbytes { set z } c080 -test encoding-16.1 {UnicodeToUtfProc} -body { - set val [encoding convertfrom unicode NN] +test encoding-16.1 {Utf16ToUtfProc} -body { + set val [encoding convertfrom utf-16 NN] list $val [format %x [scan $val %c]] } -result "\u4e4e 4e4e" -test encoding-16.2 {UnicodeToUtfProc} -body { - set val [encoding convertfrom unicode "\xd8\xd8\xdc\xdc"] +test encoding-16.2 {Utf16ToUtfProc} -body { + set val [encoding convertfrom utf-16 "\xd8\xd8\xdc\xdc"] + list $val [format %x [scan $val %c]] +} -result "\U460dc 460dc" +test encoding-16.3 {Ucs2ToUtfProc} -body { + set val [encoding convertfrom ucs-2 NN] + list $val [format %x [scan $val %c]] +} -result "\u4e4e 4e4e" +test encoding-16.4 {Ucs2ToUtfProc} -body { + set val [encoding convertfrom ucs-2 "\xd8\xd8\xdc\xdc"] list $val [format %x [scan $val %c]] } -result "\U460dc 460dc" -test encoding-17.1 {UtfToUnicodeProc} -body { - encoding convertto unicode "\U460dc" +test encoding-17.1 {UtfToUtf16Proc} -body { + encoding convertto utf-16 "\U460dc" } -result "\xd8\xd8\xdc\xdc" +test encoding-17.2 {UtfToUcs2Proc} -body { + encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460dc"] +} -result "\ufffd" test encoding-18.1 {TableToUtfProc} { } {} diff --git a/tests/io.test b/tests/io.test index d42f59e..905f822 100644 --- a/tests/io.test +++ b/tests/io.test @@ -918,7 +918,7 @@ test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio test set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none - fconfigure $f -encoding unicode + fconfigure $f -encoding utf-16 puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" fconfigure $f -buffersize 16 gets $f @@ -1162,7 +1162,7 @@ test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testcha variable x lappend x [gets $f line] $line [testchannel inputbuffered $f] } - fconfigure $f -encoding unicode -buffersize 16 -blocking 0 + fconfigure $f -encoding utf-16 -buffersize 16 -blocking 0 vwait [namespace which -variable x] fconfigure $f -translation auto -encoding ascii -blocking 1 # here diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 68bc542..dc6d1d3 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -231,22 +231,22 @@ test iocmd-8.6 {fconfigure command} { test iocmd-8.7 {fconfigure command} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} -encoding unicode + fconfigure $f1 -translation lf -eofchar {} -encoding utf-16 set x [fconfigure $f1] close $f1 set x -} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} +} {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -translation lf} test iocmd-8.8 {fconfigure command} { file delete $path(test1) set f1 [open $path(test1) w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ - -eofchar {} -encoding unicode + -eofchar {} -encoding utf-16 set x "" lappend x [fconfigure $f1 -buffering] lappend x [fconfigure $f1] close $f1 set x -} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} +} {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -translation lf}} test iocmd-8.9 {fconfigure command} { file delete $path(test1) set f1 [open $path(test1) w] diff --git a/tests/source.test b/tests/source.test index 8b146d3..c6cccd6 100644 --- a/tests/source.test +++ b/tests/source.test @@ -240,12 +240,12 @@ test source-7.2 {source -encoding test} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] - fconfigure $f -encoding unicode + fconfigure $f -encoding utf-16 puts $f "set symbol(square-root) \u221A; set x correct" close $f } -body { set x unset - source -encoding unicode $sourcefile + source -encoding utf-16 $sourcefile set x } -cleanup { removeFile source.file diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 36205e1..f5809e8 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -475,7 +475,7 @@ Tcl_WinUtfToTChar( if (!string) { return NULL; } - return TclUtfToWCharDString(string, len, dsPtr); + return (WCHAR *) Tcl_UtfToUtf16DString(string, len, dsPtr); } char * @@ -495,7 +495,7 @@ Tcl_WinTCharToUtf( } else { len /= 2; } - return TclWCharToUtfDString((unsigned short *)string, len, dsPtr); + return Tcl_Utf16ToUtfDString(string, len, dsPtr); } /* diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 3524a16..e5dd484 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1465,14 +1465,14 @@ TclpGetUserHome( Tcl_DStringFree(&ds); } else { Tcl_DStringInit(&ds); - wName = TclUtfToWCharDString(domain + 1, -1, &ds); + wName = Tcl_UtfToUtf16DString(domain + 1, -1, &ds); rc = NetGetDCName(NULL, wName, (LPBYTE *) &wDomain); Tcl_DStringFree(&ds); nameLen = domain - name; } if (rc == 0) { Tcl_DStringInit(&ds); - wName = TclUtfToWCharDString(name, nameLen, &ds); + wName = Tcl_UtfToUtf16DString(name, nameLen, &ds); while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) { /* * user does not exists - if domain was not specified, @@ -1490,14 +1490,14 @@ TclpGetUserHome( wHomeDir = uiPtr->usri1_home_dir; if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { size = lstrlenW(wHomeDir); - TclWCharToUtfDString(wHomeDir, size, bufferPtr); + Tcl_Utf16ToUtfDString(wHomeDir, size, bufferPtr); } else { /* * User exists but has no home dir. Return * "{GetProfilesDirectory}/". */ GetProfilesDirectoryW(buf, &size); - TclWCharToUtfDString(buf, size-1, bufferPtr); + Tcl_Utf16ToUtfDString(buf, size-1, bufferPtr); Tcl_DStringAppend(bufferPtr, "/", 1); Tcl_DStringAppend(bufferPtr, name, nameLen); } -- cgit v0.12 From 6d0e92b89ee6d83f8255334bf2f2a7c23e19c009 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 17 Mar 2019 22:01:42 +0000 Subject: More WIP. Seems to be *almost* working. --- generic/tcl.decls | 74 ++++++---- generic/tclDecls.h | 152 ++++++++++++++------- generic/tclInt.h | 11 -- generic/tclStringObj.c | 2 +- generic/tclStubInit.c | 44 ++++-- generic/tclUtf.c | 362 +++++++++++++++++++++++++++++++++++++------------ generic/tclUtil.c | 2 +- 7 files changed, 460 insertions(+), 187 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 6187cfc..2c21b91 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1197,9 +1197,9 @@ declare 334 { declare 335 { int Tcl_UtfToTitle(char *src) } -#declare 336 { -# int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr) -#} +declare 336 { + int Tcl_UtfToUtf16(const char *src, unsigned short *chPtr) +} declare 337 { int Tcl_UtfToUpper(char *src) } @@ -1245,21 +1245,21 @@ declare 350 { declare 351 { int Tcl_UniCharIsWordChar(int ch) } -#declare 352 { -# int Tcl_UniCharLen(const Tcl_UniChar *uniStr) -#} -#declare 353 { -# int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, -# unsigned long numChars) -#} -#declare 354 { -# char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr, -# int uniLength, Tcl_DString *dsPtr) -#} -#declare 355 { -# Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src, -# int length, Tcl_DString *dsPtr) -#} +declare 352 { + int Tcl_Utf16Len(const unsigned short *uniStr) +} +declare 353 { + int Tcl_Utf16Ncmp(const unsigned short *ucs, const unsigned short *uct, + unsigned long numChars) +} +declare 354 { + char *Tcl_Utf16ToUtfDString(const unsigned short *uniStr, + int uniLength, Tcl_DString *dsPtr) +} +declare 355 { + unsigned short *Tcl_UtfToUtf16DString(const char *src, + int length, Tcl_DString *dsPtr) +} declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) @@ -1342,7 +1342,7 @@ declare 378 { Tcl_Obj *Tcl_NewUtf16Obj(const unsigned short *unicode, int numChars) } declare 379 { - void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, + void Tcl_SetUtf16Obj(Tcl_Obj *objPtr, const unsigned short *unicode, int numChars) } declare 380 { @@ -1358,7 +1358,7 @@ declare 383 { Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) } declare 384 { - void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, + void Tcl_AppendUtf16ToObj(Tcl_Obj *objPtr, const unsigned short *unicode, int length) } declare 385 { @@ -1484,12 +1484,12 @@ declare 418 { int Tcl_IsChannelExisting(const char *channelName) } declare 419 { - int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, + int Tcl_Utf16Ncasecmp(const unsigned short *ucs, const unsigned short *uct, unsigned long numChars) } declare 420 { - int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, - const Tcl_UniChar *uniPattern, int nocase) + int Tcl_Utf16CaseMatch(const unsigned short *uniStr, + const unsigned short *uniPattern, int nocase) } declare 421 { Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key) @@ -2387,23 +2387,39 @@ declare 645 { Tcl_Obj *Tcl_NewUnicodeObj(const int *unicode, int numChars) } declare 646 { - int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr) + int Tcl_UtfToUniChar(const char *src, int *chPtr) } declare 647 { - int Tcl_UniCharLen(const Tcl_UniChar *uniStr) + int Tcl_UniCharLen(const int *uniStr) } declare 648 { - int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, + int Tcl_UniCharNcmp(const int *ucs, const int *uct, unsigned long numChars) } declare 649 { - char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr, - int uniLength, Tcl_DString *dsPtr) + int Tcl_UniCharNcasecmp(const int *ucs, const int *uct, + unsigned long numChars) } declare 650 { - Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src, + char *Tcl_UniCharToUtfDString(const int *uniStr, + int uniLength, Tcl_DString *dsPtr) +} +declare 651 { + int *Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr) } +declare 652 { + int Tcl_UniCharCaseMatch(const int *uniStr, + const int *uniPattern, int nocase) +} +declare 653 { + void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const int *unicode, + int length) +} +declare 654 { + void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const int *unicode, + int numChars) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b9f710f..f0d0b4c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1025,7 +1025,9 @@ EXTERN char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, EXTERN int Tcl_UtfToLower(char *src); /* 335 */ EXTERN int Tcl_UtfToTitle(char *src); -/* Slot 336 is reserved */ +/* 336 */ +EXTERN int Tcl_UtfToUtf16(const char *src, + unsigned short *chPtr); /* 337 */ EXTERN int Tcl_UtfToUpper(char *src); /* 338 */ @@ -1059,10 +1061,18 @@ EXTERN int Tcl_UniCharIsSpace(int ch); EXTERN int Tcl_UniCharIsUpper(int ch); /* 351 */ EXTERN int Tcl_UniCharIsWordChar(int ch); -/* Slot 352 is reserved */ -/* Slot 353 is reserved */ -/* Slot 354 is reserved */ -/* Slot 355 is reserved */ +/* 352 */ +EXTERN int Tcl_Utf16Len(const unsigned short *uniStr); +/* 353 */ +EXTERN int Tcl_Utf16Ncmp(const unsigned short *ucs, + const unsigned short *uct, + unsigned long numChars); +/* 354 */ +EXTERN char * Tcl_Utf16ToUtfDString(const unsigned short *uniStr, + int uniLength, Tcl_DString *dsPtr); +/* 355 */ +EXTERN unsigned short * Tcl_UtfToUtf16DString(const char *src, int length, + Tcl_DString *dsPtr); /* 356 */ EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); @@ -1133,8 +1143,8 @@ EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, EXTERN Tcl_Obj * Tcl_NewUtf16Obj(const unsigned short *unicode, int numChars); /* 379 */ -EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, int numChars); +EXTERN void Tcl_SetUtf16Obj(Tcl_Obj *objPtr, + const unsigned short *unicode, int numChars); /* 380 */ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ @@ -1145,8 +1155,8 @@ unsigned short * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ -EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, int length); +EXTERN void Tcl_AppendUtf16ToObj(Tcl_Obj *objPtr, + const unsigned short *unicode, int length); /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); @@ -1239,12 +1249,12 @@ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ EXTERN int Tcl_IsChannelExisting(const char *channelName); /* 419 */ -EXTERN int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, +EXTERN int Tcl_Utf16Ncasecmp(const unsigned short *ucs, + const unsigned short *uct, unsigned long numChars); /* 420 */ -EXTERN int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, - const Tcl_UniChar *uniPattern, int nocase); +EXTERN int Tcl_Utf16CaseMatch(const unsigned short *uniStr, + const unsigned short *uniPattern, int nocase); /* 421 */ EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key); @@ -1892,19 +1902,30 @@ EXTERN int * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, /* 645 */ EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const int *unicode, int numChars); /* 646 */ -EXTERN int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr); +EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr); /* 647 */ -EXTERN int Tcl_UniCharLen(const Tcl_UniChar *uniStr); +EXTERN int Tcl_UniCharLen(const int *uniStr); /* 648 */ -EXTERN int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, +EXTERN int Tcl_UniCharNcmp(const int *ucs, const int *uct, unsigned long numChars); /* 649 */ -EXTERN char * Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr, - int uniLength, Tcl_DString *dsPtr); +EXTERN int Tcl_UniCharNcasecmp(const int *ucs, const int *uct, + unsigned long numChars); /* 650 */ -EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length, +EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, + int uniLength, Tcl_DString *dsPtr); +/* 651 */ +EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr); +/* 652 */ +EXTERN int Tcl_UniCharCaseMatch(const int *uniStr, + const int *uniPattern, int nocase); +/* 653 */ +EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, + const int *unicode, int length); +/* 654 */ +EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, + const int *unicode, int numChars); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2276,7 +2297,7 @@ typedef struct TclStubs { char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */ int (*tcl_UtfToLower) (char *src); /* 334 */ int (*tcl_UtfToTitle) (char *src); /* 335 */ - void (*reserved336)(void); + int (*tcl_UtfToUtf16) (const char *src, unsigned short *chPtr); /* 336 */ int (*tcl_UtfToUpper) (char *src); /* 337 */ int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */ int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ @@ -2292,10 +2313,10 @@ typedef struct TclStubs { int (*tcl_UniCharIsSpace) (int ch); /* 349 */ int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ - void (*reserved352)(void); - void (*reserved353)(void); - void (*reserved354)(void); - void (*reserved355)(void); + int (*tcl_Utf16Len) (const unsigned short *uniStr); /* 352 */ + int (*tcl_Utf16Ncmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */ + char * (*tcl_Utf16ToUtfDString) (const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ + unsigned short * (*tcl_UtfToUtf16DString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */ @@ -2319,12 +2340,12 @@ typedef struct TclStubs { int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ Tcl_Obj * (*tcl_NewUtf16Obj) (const unsigned short *unicode, int numChars); /* 378 */ - void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ + void (*tcl_SetUtf16Obj) (Tcl_Obj *objPtr, const unsigned short *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ TCL_DEPRECATED_API("No longer in use, changed to macro") unsigned short * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ - void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */ + void (*tcl_AppendUtf16ToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ @@ -2359,8 +2380,8 @@ typedef struct TclStubs { void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */ void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ - int (*tcl_UniCharNcasecmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 419 */ - int (*tcl_UniCharCaseMatch) (const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* 420 */ + int (*tcl_Utf16Ncasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */ + int (*tcl_Utf16CaseMatch) (const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 420 */ Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, const void *key); /* 421 */ Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */ void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */ @@ -2586,11 +2607,15 @@ typedef struct TclStubs { int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ int * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 644 */ Tcl_Obj * (*tcl_NewUnicodeObj) (const int *unicode, int numChars); /* 645 */ - int (*tcl_UtfToUniChar) (const char *src, Tcl_UniChar *chPtr); /* 646 */ - int (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 647 */ - int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 648 */ - char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 649 */ - Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 650 */ + int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ + int (*tcl_UniCharLen) (const int *uniStr); /* 647 */ + int (*tcl_UniCharNcmp) (const int *ucs, const int *uct, unsigned long numChars); /* 648 */ + int (*tcl_UniCharNcasecmp) (const int *ucs, const int *uct, unsigned long numChars); /* 649 */ + char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 650 */ + int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 651 */ + int (*tcl_UniCharCaseMatch) (const int *uniStr, const int *uniPattern, int nocase); /* 652 */ + void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const int *unicode, int length); /* 653 */ + void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const int *unicode, int numChars); /* 654 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3293,7 +3318,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UtfToLower) /* 334 */ #define Tcl_UtfToTitle \ (tclStubsPtr->tcl_UtfToTitle) /* 335 */ -/* Slot 336 is reserved */ +#define Tcl_UtfToUtf16 \ + (tclStubsPtr->tcl_UtfToUtf16) /* 336 */ #define Tcl_UtfToUpper \ (tclStubsPtr->tcl_UtfToUpper) /* 337 */ #define Tcl_WriteChars \ @@ -3324,10 +3350,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ #define Tcl_UniCharIsWordChar \ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ -/* Slot 352 is reserved */ -/* Slot 353 is reserved */ -/* Slot 354 is reserved */ -/* Slot 355 is reserved */ +#define Tcl_Utf16Len \ + (tclStubsPtr->tcl_Utf16Len) /* 352 */ +#define Tcl_Utf16Ncmp \ + (tclStubsPtr->tcl_Utf16Ncmp) /* 353 */ +#define Tcl_Utf16ToUtfDString \ + (tclStubsPtr->tcl_Utf16ToUtfDString) /* 354 */ +#define Tcl_UtfToUtf16DString \ + (tclStubsPtr->tcl_UtfToUtf16DString) /* 355 */ #define Tcl_GetRegExpFromObj \ (tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */ #define Tcl_EvalTokens \ @@ -3374,8 +3404,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_RegExpGetInfo) /* 377 */ #define Tcl_NewUtf16Obj \ (tclStubsPtr->tcl_NewUtf16Obj) /* 378 */ -#define Tcl_SetUnicodeObj \ - (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ +#define Tcl_SetUtf16Obj \ + (tclStubsPtr->tcl_SetUtf16Obj) /* 379 */ #define Tcl_GetCharLength \ (tclStubsPtr->tcl_GetCharLength) /* 380 */ #define Tcl_GetUniChar \ @@ -3384,8 +3414,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetUnicode) /* 382 */ #define Tcl_GetRange \ (tclStubsPtr->tcl_GetRange) /* 383 */ -#define Tcl_AppendUnicodeToObj \ - (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */ +#define Tcl_AppendUtf16ToObj \ + (tclStubsPtr->tcl_AppendUtf16ToObj) /* 384 */ #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ #define Tcl_SetNotifier \ @@ -3454,10 +3484,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */ #define Tcl_IsChannelExisting \ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ -#define Tcl_UniCharNcasecmp \ - (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */ -#define Tcl_UniCharCaseMatch \ - (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */ +#define Tcl_Utf16Ncasecmp \ + (tclStubsPtr->tcl_Utf16Ncasecmp) /* 419 */ +#define Tcl_Utf16CaseMatch \ + (tclStubsPtr->tcl_Utf16CaseMatch) /* 420 */ #define Tcl_FindHashEntry \ (tclStubsPtr->tcl_FindHashEntry) /* 421 */ #define Tcl_CreateHashEntry \ @@ -3914,10 +3944,18 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharLen) /* 647 */ #define Tcl_UniCharNcmp \ (tclStubsPtr->tcl_UniCharNcmp) /* 648 */ +#define Tcl_UniCharNcasecmp \ + (tclStubsPtr->tcl_UniCharNcasecmp) /* 649 */ #define Tcl_UniCharToUtfDString \ - (tclStubsPtr->tcl_UniCharToUtfDString) /* 649 */ + (tclStubsPtr->tcl_UniCharToUtfDString) /* 650 */ #define Tcl_UtfToUniCharDString \ - (tclStubsPtr->tcl_UtfToUniCharDString) /* 650 */ + (tclStubsPtr->tcl_UtfToUniCharDString) /* 651 */ +#define Tcl_UniCharCaseMatch \ + (tclStubsPtr->tcl_UniCharCaseMatch) /* 652 */ +#define Tcl_AppendUnicodeToObj \ + (tclStubsPtr->tcl_AppendUnicodeToObj) /* 653 */ +#define Tcl_SetUnicodeObj \ + (tclStubsPtr->tcl_SetUnicodeObj) /* 654 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4104,6 +4142,22 @@ extern const TclStubs *tclStubsPtr; # define Tcl_GetUnicodeFromObj Tcl_GetUtf16FromObj # undef Tcl_NewUnicodeObj # define Tcl_NewUnicodeObj Tcl_NewUtf16Obj +# undef Tcl_SetUnicodeObj +# define Tcl_SetUnicodeObj Tcl_SetUtf16Obj +# undef Tcl_AppendUnicodeToObj +# define Tcl_AppendUnicodeToObj Tcl_AppendUtf16ToObj +# undef Tcl_UniCharToUtfDString +# define Tcl_UniCharToUtfDString Tcl_Utf16ToUtfDString +# undef Tcl_UtfToUniCharDString +# define Tcl_UtfToUniCharDString Tcl_UtfToUtf16DString +# undef Tcl_UtfToUniChar +# define Tcl_UtfToUniChar Tcl_UtfToUtf16 +# undef Tcl_UniCharNcmp +# define Tcl_UniCharNcmp Tcl_Utf16Ncmp +# undef Tcl_UniCharNcasecmp +# define Tcl_UniCharNcasecmp Tcl_Utf16Ncasecmp +# undef Tcl_UniCharCaseMatch +# define Tcl_UniCharCaseMatch Tcl_Utf16CaseMatch #endif /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 99a2a58..37f4795 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3240,17 +3240,6 @@ MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); -#if (TCL_UTF_MAX > 3) && (defined(__CYGWIN__) || defined(_WIN32)) -MODULE_SCOPE int TclUtfToUtf16(const char *src, unsigned short *chPtr); -MODULE_SCOPE char * Tcl_Utf16ToUtfDString(const unsigned short *uniStr, - int uniLength, Tcl_DString *dsPtr); -MODULE_SCOPE unsigned short * Tcl_UtfToUtf16DString(const char *src, - int length, Tcl_DString *dsPtr); -#else -# define TclUtfToUtf16 TclUtfToUniChar -# define Tcl_Utf16ToUtfDString Tcl_UniCharToUtfDString -# define Tcl_UtfToUtf16DString Tcl_UtfToUniCharDString -#endif MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCount(int ch); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 205db00..46bd26f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -613,7 +613,7 @@ Tcl_GetUnicode( Tcl_Obj *objPtr) /* The object to find the unicode string * for. */ { - return Tcl_GetUtf16FromObj(objPtr, NULL); + return Tcl_GetUnicodeFromObj(objPtr, NULL); } #endif /* TCL_NO_DEPRECATED */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b85c360..ca26e8d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -62,6 +62,14 @@ #define TclStaticPackage Tcl_StaticPackage #undef Tcl_GetUnicodeFromObj #undef Tcl_NewUnicodeObj +#undef Tcl_SetUnicodeObj +#undef Tcl_UniCharToUtfDString +#undef Tcl_UtfToUniCharDString +#undef Tcl_UtfToUniChar +#undef Tcl_UniCharNcmp +#undef Tcl_UniCharNcasecmp +#undef Tcl_UniCharCaseMatch +#undef Tcl_AppendUnicodeToObj static void uniCodePanic() { #if TCL_UTF_MAX == 3 @@ -70,13 +78,21 @@ static void uniCodePanic() { Tcl_Panic("This extension is compiled with -DTCL_UTF_MAX==3, but Tcl is compiled with -DTCL_UTF_MAX>3"); #endif } + #if TCL_UTF_MAX == 3 +#ifdef TCL_NO_DEPRECATED +# define Tcl_GetUnicode 0 +#endif # define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, int *)) uniCodePanic # define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, int)) uniCodePanic +# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *,const int *, int)) uniCodePanic +# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const int *, int)) uniCodePanic #else -# define Tcl_GetUtf16FromObj (unsigned short *(*)(Tcl_Obj *, int *)) uniCodePanic # define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *)) uniCodePanic +# define Tcl_GetUtf16FromObj (unsigned short *(*)(Tcl_Obj *, int *)) uniCodePanic # define Tcl_NewUtf16Obj (Tcl_Obj *(*)(const unsigned short *, int)) uniCodePanic +# define Tcl_SetUtf16Obj (void(*)(Tcl_Obj *, const unsigned short *, int)) uniCodePanic +# define Tcl_AppendUtf16ToObj (void(*)(Tcl_Obj *, const unsigned short *, int)) uniCodePanic #endif /* See bug 510001: TclSockMinimumBuffers needs plat imp */ @@ -1335,7 +1351,7 @@ const TclStubs tclStubs = { Tcl_UtfToExternalDString, /* 333 */ Tcl_UtfToLower, /* 334 */ Tcl_UtfToTitle, /* 335 */ - 0, /* 336 */ + Tcl_UtfToUtf16, /* 336 */ Tcl_UtfToUpper, /* 337 */ Tcl_WriteChars, /* 338 */ Tcl_WriteObj, /* 339 */ @@ -1351,10 +1367,10 @@ const TclStubs tclStubs = { Tcl_UniCharIsSpace, /* 349 */ Tcl_UniCharIsUpper, /* 350 */ Tcl_UniCharIsWordChar, /* 351 */ - 0, /* 352 */ - 0, /* 353 */ - 0, /* 354 */ - 0, /* 355 */ + Tcl_Utf16Len, /* 352 */ + Tcl_Utf16Ncmp, /* 353 */ + Tcl_Utf16ToUtfDString, /* 354 */ + Tcl_UtfToUtf16DString, /* 355 */ Tcl_GetRegExpFromObj, /* 356 */ Tcl_EvalTokens, /* 357 */ Tcl_FreeParse, /* 358 */ @@ -1378,12 +1394,12 @@ const TclStubs tclStubs = { Tcl_RegExpExecObj, /* 376 */ Tcl_RegExpGetInfo, /* 377 */ Tcl_NewUtf16Obj, /* 378 */ - Tcl_SetUnicodeObj, /* 379 */ + Tcl_SetUtf16Obj, /* 379 */ Tcl_GetCharLength, /* 380 */ Tcl_GetUniChar, /* 381 */ Tcl_GetUnicode, /* 382 */ Tcl_GetRange, /* 383 */ - Tcl_AppendUnicodeToObj, /* 384 */ + Tcl_AppendUtf16ToObj, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ Tcl_GetAllocMutex, /* 387 */ @@ -1418,8 +1434,8 @@ const TclStubs tclStubs = { Tcl_SpliceChannel, /* 416 */ Tcl_ClearChannelHandlers, /* 417 */ Tcl_IsChannelExisting, /* 418 */ - Tcl_UniCharNcasecmp, /* 419 */ - Tcl_UniCharCaseMatch, /* 420 */ + Tcl_Utf16Ncasecmp, /* 419 */ + Tcl_Utf16CaseMatch, /* 420 */ Tcl_FindHashEntry, /* 421 */ Tcl_CreateHashEntry, /* 422 */ Tcl_InitCustomHashTable, /* 423 */ @@ -1648,8 +1664,12 @@ const TclStubs tclStubs = { Tcl_UtfToUniChar, /* 646 */ Tcl_UniCharLen, /* 647 */ Tcl_UniCharNcmp, /* 648 */ - Tcl_UniCharToUtfDString, /* 649 */ - Tcl_UtfToUniCharDString, /* 650 */ + Tcl_UniCharNcasecmp, /* 649 */ + Tcl_UniCharToUtfDString, /* 650 */ + Tcl_UtfToUniCharDString, /* 651 */ + Tcl_UniCharCaseMatch, /* 652 */ + Tcl_AppendUnicodeToObj, /* 653 */ + Tcl_SetUnicodeObj, /* 654 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index ff8f6bd..c5a2ca5 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -223,17 +223,17 @@ three: *--------------------------------------------------------------------------- */ +#undef Tcl_UniCharToUtfDString char * Tcl_UniCharToUtfDString( - const Tcl_UniChar *uniStr, /* Unicode string to convert to UTF-8. */ - int uniLength, /* Length of Unicode string in Tcl_UniChars - * (must be >= 0). */ + const int *uniStr, /* Unicode string to convert to UTF-8. */ + int uniLength, /* Length of Unicode string (must be >= 0). */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { - const Tcl_UniChar *w, *wEnd; + const int *w, *wEnd; char *p, *string; - int oldLength, len = 1; + int oldLength; /* * UTF-8 string length in bytes will be <= Unicode string length * 4. @@ -246,27 +246,14 @@ Tcl_UniCharToUtfDString( p = string; wEnd = uniStr + uniLength; for (w = uniStr; w < wEnd; ) { - if (!len && ((*w & 0xFC00) != 0xDC00)) { - /* Special case for handling high surrogates. */ - p += Tcl_UniCharToUtf(-1, p); - } - len = Tcl_UniCharToUtf(*w, p); - p += len; - if ((*w >= 0xD800) && (len < 3)) { - len = 0; /* Indication that high surrogate was found */ - } + p += Tcl_UniCharToUtf(*w, p); w++; } - if (!len) { - /* Special case for handling high surrogates. */ - p += Tcl_UniCharToUtf(-1, p); - } Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); return string; } -#if (TCL_UTF_MAX > 3) && (defined(__CYGWIN__) || defined(_WIN32)) char * Tcl_Utf16ToUtfDString( const unsigned short *uniStr, /* Utf-16 string to convert to UTF-8. */ @@ -279,11 +266,11 @@ Tcl_Utf16ToUtfDString( int oldLength, len = 1; /* - * UTF-8 string length in bytes will be <= Unicode string length * 4. + * UTF-8 string length in bytes will be <= Utf16 string length * 3. */ oldLength = Tcl_DStringLength(dsPtr); - Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4); + Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 3); string = Tcl_DStringValue(dsPtr) + oldLength; p = string; @@ -308,7 +295,6 @@ Tcl_Utf16ToUtfDString( return string; } -#endif /* *--------------------------------------------------------------------------- * @@ -351,13 +337,14 @@ static const unsigned short cp1252[32] = { 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 }; +#undef Tcl_UtfToUniChar int Tcl_UtfToUniChar( - register const char *src, /* The UTF-8 string. */ - register Tcl_UniChar *chPtr)/* Filled with the Tcl_UniChar represented by + const char *src, /* The UTF-8 string. */ + int *chPtr)/* Filled with the Unicode represented by * the UTF-8 string. */ { - Tcl_UniChar byte; + int byte; /* * Unroll 1 to 4 byte UTF-8 sequences. @@ -373,20 +360,6 @@ Tcl_UtfToUniChar( * characters representing themselves. */ -#if TCL_UTF_MAX == 3 - /* If *chPtr contains a high surrogate (produced by a previous - * Tcl_UtfToUniChar() call) and the next 3 bytes are UTF-8 continuation - * bytes, then we must produce a follow-up low surrogate. We only - * do that if the high surrogate matches the bits we encounter. - */ - if ((byte >= 0x80) - && (((((byte - 0x10) << 2) & 0xFC) | 0xD800) == (*chPtr & 0xFCFC)) - && ((src[1] & 0xF0) == (((*chPtr << 4) & 0x30) | 0x80)) - && ((src[2] & 0xC0) == 0x80)) { - *chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00; - return 3; - } -#endif if ((unsigned)(byte-0x80) < (unsigned)0x20) { *chPtr = cp1252[byte-0x80]; } else { @@ -432,23 +405,11 @@ Tcl_UtfToUniChar( /* * Four-byte-character lead byte followed by three trail bytes. */ -#if TCL_UTF_MAX == 3 - Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2) - | ((src[2] & 0x3F) >> 4)) - 0x40; - if (high >= 0x400) { - /* out of range, < 0x10000 or > 0x10ffff */ - } else { - /* produce high surrogate, advance source pointer */ - *chPtr = 0xD800 + high; - return 1; - } -#else *chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)); if (((unsigned)(*chPtr) - 0x10000) <= 0xFFFFF) { return 4; } -#endif } /* @@ -461,9 +422,8 @@ Tcl_UtfToUniChar( return 1; } -#if (TCL_UTF_MAX > 3) && (defined(__CYGWIN__) || defined(_WIN32)) int -TclUtfToUtf16( +Tcl_UtfToUtf16( const char *src, /* The UTF-8 string. */ unsigned short *chPtr)/* Filled with the Utf-16 representation of * the UTF-8 string. */ @@ -561,7 +521,6 @@ TclUtfToUtf16( *chPtr = byte; return 1; } -#endif /* *--------------------------------------------------------------------------- @@ -581,7 +540,8 @@ TclUtfToUtf16( *--------------------------------------------------------------------------- */ -Tcl_UniChar * +#undef Tcl_UtfToUniCharDString +int * Tcl_UtfToUniCharDString( const char *src, /* UTF-8 string to convert to Unicode. */ int length, /* Length of UTF-8 string in bytes, or -1 for @@ -590,7 +550,7 @@ Tcl_UtfToUniCharDString( * appended to this previously initialized * DString. */ { - Tcl_UniChar ch = 0, *w, *wString; + int ch = 0, *w, *wString; const char *p, *end; int oldLength; @@ -606,8 +566,8 @@ Tcl_UtfToUniCharDString( oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, - oldLength + (int) ((length + 1) * sizeof(Tcl_UniChar))); - wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength); + oldLength + (int) ((length + 1) * sizeof(int))); + wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength); w = wString; p = src; @@ -634,7 +594,6 @@ Tcl_UtfToUniCharDString( return wString; } -#if (TCL_UTF_MAX > 3) && (defined(__CYGWIN__) || defined(_WIN32)) unsigned short * Tcl_UtfToUtf16DString( const char *src, /* UTF-8 string to convert to Unicode. */ @@ -667,13 +626,13 @@ Tcl_UtfToUtf16DString( p = src; end = src + length - 4; while (p < end) { - p += TclUtfToUtf16(p, &ch); + p += Tcl_UtfToUtf16(p, &ch); *w++ = ch; } end += 4; while (p < end) { if (Tcl_UtfCharComplete(p, end-p)) { - p += TclUtfToUtf16(p, &ch); + p += Tcl_UtfToUtf16(p, &ch); } else if (((UCHAR(*p)-0x80)) < 0x20) { ch = cp1252[UCHAR(*p++)-0x80]; } else { @@ -687,7 +646,6 @@ Tcl_UtfToUtf16DString( return wString; } -#endif /* *--------------------------------------------------------------------------- * @@ -734,6 +692,13 @@ Tcl_UtfCharComplete( *--------------------------------------------------------------------------- */ +#if TCL_UTF_MAX == 3 +# undef Tcl_UtfToUniChar +# define Tcl_UtfToUniChar Tcl_UtfToUtf16 +# undef Tcl_UniCharLen +# define Tcl_UniCharLen Tcl_Utf16Len +#endif + int Tcl_NumUtfChars( register const char *src, /* The UTF-8 string to measure. */ @@ -1671,9 +1636,10 @@ Tcl_UniCharToTitle( *---------------------------------------------------------------------- */ +#undef Tcl_UniCharLen int Tcl_UniCharLen( - const Tcl_UniChar *uniStr) /* Unicode string to find length of. */ + const int *uniStr) /* Unicode string to find length of. */ { int len = 0; @@ -1684,6 +1650,19 @@ Tcl_UniCharLen( return len; } +int +Tcl_Utf16Len( + const unsigned short *utf16Str) /* Unicode string to find length of. */ +{ + int len = 0; + + while (*utf16Str != '\0') { + len++; + utf16Str++; + } + return len; +} + /* *---------------------------------------------------------------------- * @@ -1701,10 +1680,11 @@ Tcl_UniCharLen( *---------------------------------------------------------------------- */ +#undef Tcl_UniCharNcmp int Tcl_UniCharNcmp( - const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ - const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ + const int *ucs, /* Unicode string to compare to uct. */ + const int *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ { #ifdef WORDS_BIGENDIAN @@ -1712,7 +1692,7 @@ Tcl_UniCharNcmp( * We are definitely on a big-endian machine; memcmp() is safe */ - return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); + return memcmp(ucs, uct, numChars*sizeof(int)); #else /* !WORDS_BIGENDIAN */ /* @@ -1727,7 +1707,34 @@ Tcl_UniCharNcmp( return 0; #endif /* WORDS_BIGENDIAN */ } - + +int +Tcl_Utf16Ncmp( + const unsigned short *ucs, /* Unicode string to compare to uct. */ + const unsigned short *uct, /* Unicode string ucs is compared to. */ + unsigned long numChars) /* Number of unichars to compare. */ +{ +#ifdef WORDS_BIGENDIAN + /* + * We are definitely on a big-endian machine; memcmp() is safe + */ + + return memcmp(ucs, uct, numChars*sizeof(unsigned short)); + +#else /* !WORDS_BIGENDIAN */ + /* + * We can't simply call memcmp() because that is not lexically correct. + */ + + for ( ; numChars != 0; ucs++, uct++, numChars--) { + if (*ucs != *uct) { + return (*ucs - *uct); + } + } + return 0; +#endif /* WORDS_BIGENDIAN */ +} + /* *---------------------------------------------------------------------- * @@ -1746,16 +1753,17 @@ Tcl_UniCharNcmp( *---------------------------------------------------------------------- */ +#undef Tcl_UniCharNcasecmp int Tcl_UniCharNcasecmp( - const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ - const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ + const int *ucs, /* Unicode string to compare to uct. */ + const int *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ { for ( ; numChars != 0; numChars--, ucs++, uct++) { if (*ucs != *uct) { - Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); - Tcl_UniChar lct = Tcl_UniCharToLower(*uct); + int lcs = Tcl_UniCharToLower(*ucs); + int lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { return (lcs - lct); @@ -1764,7 +1772,25 @@ Tcl_UniCharNcasecmp( } return 0; } - +int +Tcl_Utf16Ncasecmp( + const unsigned short *ucs, /* Utf16 string to compare to uct. */ + const unsigned short *uct, /* Utf16 string ucs is compared to. */ + unsigned long numChars) /* Number of Utf16 characters to compare. */ +{ + for ( ; numChars != 0; numChars--, ucs++, uct++) { + if (*ucs != *uct) { + int lcs = Tcl_UniCharToLower(*ucs); + int lct = Tcl_UniCharToLower(*uct); + + if (lcs != lct) { + return (lcs - lct); + } + } + } + return 0; +} + /* *---------------------------------------------------------------------- * @@ -2097,15 +2123,16 @@ Tcl_UniCharIsWordChar( *---------------------------------------------------------------------- */ +#undef Tcl_UniCharCaseMatch int Tcl_UniCharCaseMatch( - const Tcl_UniChar *uniStr, /* Unicode String. */ - const Tcl_UniChar *uniPattern, + const int *uniStr, /* Unicode String. */ + const int *uniPattern, /* Pattern, which may contain special * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { - Tcl_UniChar ch1 = 0, p; + int ch1 = 0, p; while (1) { p = *uniPattern; @@ -2156,7 +2183,7 @@ Tcl_UniCharCaseMatch( if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while (*uniStr && (p != *uniStr) - && (p != (Tcl_UniChar)Tcl_UniCharToLower(*uniStr))) { + && (p != Tcl_UniCharToLower(*uniStr))) { uniStr++; } } else { @@ -2193,16 +2220,16 @@ Tcl_UniCharCaseMatch( */ if (p == '[') { - Tcl_UniChar startChar, endChar; + int startChar, endChar; uniPattern++; - ch1 = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniStr) : *uniStr); + ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); uniStr++; while (1) { if ((*uniPattern == ']') || (*uniPattern == 0)) { return 0; } - startChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniPattern) + startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) : *uniPattern); uniPattern++; if (*uniPattern == '-') { @@ -2210,7 +2237,7 @@ Tcl_UniCharCaseMatch( if (*uniPattern == 0) { return 0; } - endChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniPattern) + endChar = (nocase ? Tcl_UniCharToLower(*uniPattern) : *uniPattern); uniPattern++; if (((startChar <= ch1) && (ch1 <= endChar)) @@ -2264,6 +2291,173 @@ Tcl_UniCharCaseMatch( } } +int +Tcl_Utf16CaseMatch( + const unsigned short *uniStr, /* Unicode String. */ + const unsigned short *uniPattern, + /* Pattern, which may contain special + * characters. */ + int nocase) /* 0 for case sensitive, 1 for insensitive */ +{ + unsigned short ch1 = 0, p; + + while (1) { + p = *uniPattern; + + /* + * See if we're at the end of both the pattern and the string. If so, + * we succeeded. If we're at the end of the pattern but not at the end + * of the string, we failed. + */ + + if (p == 0) { + return (*uniStr == 0); + } + if ((*uniStr == 0) && (p != '*')) { + return 0; + } + + /* + * Check for a "*" as the next pattern character. It matches any + * substring. We handle this by skipping all the characters up to the + * next matching one in the pattern, and then calling ourselves + * recursively for each postfix of string, until either we match or we + * reach the end of the string. + */ + + if (p == '*') { + /* + * Skip all successive *'s in the pattern + */ + + while (*(++uniPattern) == '*') { + /* empty body */ + } + p = *uniPattern; + if (p == 0) { + return 1; + } + if (nocase) { + p = Tcl_UniCharToLower(p); + } + while (1) { + /* + * Optimization for matching - cruise through the string + * quickly if the next char in the pattern isn't a special + * character + */ + + if ((p != '[') && (p != '?') && (p != '\\')) { + if (nocase) { + while (*uniStr && (p != *uniStr) + && (p != Tcl_UniCharToLower(*uniStr))) { + uniStr++; + } + } else { + while (*uniStr && (p != *uniStr)) { + uniStr++; + } + } + } + if (Tcl_Utf16CaseMatch(uniStr, uniPattern, nocase)) { + return 1; + } + if (*uniStr == 0) { + return 0; + } + uniStr++; + } + } + + /* + * Check for a "?" as the next pattern character. It matches any + * single character. + */ + + if (p == '?') { + uniPattern++; + uniStr++; + continue; + } + + /* + * Check for a "[" as the next pattern character. It is followed by a + * list of characters that are acceptable, or by a range (two + * characters separated by "-"). + */ + + if (p == '[') { + unsigned short startChar, endChar; + + uniPattern++; + ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); + uniStr++; + while (1) { + if ((*uniPattern == ']') || (*uniPattern == 0)) { + return 0; + } + startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) + : *uniPattern); + uniPattern++; + if (*uniPattern == '-') { + uniPattern++; + if (*uniPattern == 0) { + return 0; + } + endChar = (nocase ? Tcl_UniCharToLower(*uniPattern) + : *uniPattern); + uniPattern++; + if (((startChar <= ch1) && (ch1 <= endChar)) + || ((endChar <= ch1) && (ch1 <= startChar))) { + /* + * Matches ranges of form [a-z] or [z-a]. + */ + break; + } + } else if (startChar == ch1) { + break; + } + } + while (*uniPattern != ']') { + if (*uniPattern == 0) { + uniPattern--; + break; + } + uniPattern++; + } + uniPattern++; + continue; + } + + /* + * If the next pattern character is '\', just strip off the '\' so we + * do exact matching on the character that follows. + */ + + if (p == '\\') { + if (*(++uniPattern) == '\0') { + return 0; + } + } + + /* + * There's no special character. Just make sure that the next bytes of + * each string match. + */ + + if (nocase) { + if (Tcl_UniCharToLower(*uniStr) != + Tcl_UniCharToLower(*uniPattern)) { + return 0; + } + } else if (*uniStr != *uniPattern) { + return 0; + } + uniStr++; + uniPattern++; + } +} + /* *---------------------------------------------------------------------- * @@ -2348,7 +2542,7 @@ TclUniCharMatch( if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while ((string < stringEnd) && (p != *string) - && (p != (Tcl_UniChar)Tcl_UniCharToLower(*string))) { + && (p != Tcl_UniCharToLower(*string))) { string++; } } else { @@ -2389,20 +2583,20 @@ TclUniCharMatch( Tcl_UniChar ch1, startChar, endChar; pattern++; - ch1 = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*string) : *string); + ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string); string++; while (1) { if ((*pattern == ']') || (pattern == patternEnd)) { return 0; } - startChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*pattern) : *pattern); + startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern); pattern++; if (*pattern == '-') { pattern++; if (pattern == patternEnd) { return 0; } - endChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*pattern) + endChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern); pattern++; if (((startChar <= ch1) && (ch1 <= endChar)) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 0788aed..e432560 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2302,7 +2302,7 @@ Tcl_StringCaseMatch( if (nocase) { while (*str) { charLen = TclUtfToUniChar(str, &ch1); - if (ch2==ch1 || ch2==(Tcl_UniChar)Tcl_UniCharToLower(ch1)) { + if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) { break; } str += charLen; -- cgit v0.12 From 0c863ddec8f39d1afec9b67d4e899e4489d6f46e Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 10 May 2019 20:30:41 +0000 Subject: Start of TIP 543 implementation. --- doc/TraceVar.3 | 2 +- generic/tcl.h | 4 ++++ generic/tclTrace.c | 6 ++++-- 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/doc/TraceVar.3 b/doc/TraceVar.3 index 19cb467..e481985 100644 --- a/doc/TraceVar.3 +++ b/doc/TraceVar.3 @@ -95,7 +95,7 @@ Invoke \fIproc\fR whenever an attempt is made to modify the variable. Invoke \fIproc\fR whenever the variable is unset. A variable may be unset either explicitly by an \fBunset\fR command, or implicitly when a procedure returns (its local variables are -automatically unset) or when the interpreter is deleted (all +automatically unset) or when the interpreter or namespace is deleted (all variables are automatically unset). .TP \fBTCL_TRACE_ARRAY\fR diff --git a/generic/tcl.h b/generic/tcl.h index e34a609..d76b334 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1031,7 +1031,11 @@ typedef struct Tcl_DString { #define TCL_TRACE_WRITES 0x20 #define TCL_TRACE_UNSETS 0x40 #define TCL_TRACE_DESTROYED 0x80 + +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #define TCL_INTERP_DESTROYED 0x100 +#endif + #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 #ifndef TCL_REMOVE_OBSOLETE_TRACES diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 20fa7e7..8662d70 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -79,8 +79,7 @@ typedef struct { * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly * by the command being traced, not because of * an internal trace. - * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also be used - * in command execution traces. + * The flag 'TCL_TRACE_DESTROYED' may also be used in command execution traces. */ #define TCL_TRACE_ENTER_DURING_EXEC 4 @@ -2565,6 +2564,9 @@ TclObjCallVarTraces( leaveErrMsg); } +#undef TCL_INTERP_DESTROYED +#define TCL_INTERP_DESTROYED 0x100 + int TclCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ -- cgit v0.12 From 8265ea67d6285031031eeee4037a3b9b35262a10 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 11 May 2019 15:04:57 +0000 Subject: Convert deprecation to elimination for Tcl 9. --- doc/TraceVar.3 | 5 +++-- generic/tcl.h | 4 ---- generic/tclTrace.c | 16 ---------------- 3 files changed, 3 insertions(+), 22 deletions(-) diff --git a/doc/TraceVar.3 b/doc/TraceVar.3 index ef5d80a..dd72563 100644 --- a/doc/TraceVar.3 +++ b/doc/TraceVar.3 @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_TraceVar 3 8.7 Tcl "Tcl Library Procedures" +.TH Tcl_TraceVar 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME @@ -333,7 +333,8 @@ The routine \fBTcl_InterpDeleted\fR is an important tool for this. When \fBTcl_InterpDeleted\fR returns 1, \fIproc\fR will not be able to invoke any scripts in \fIinterp\fR. You may encounter old code using a deprecated flag value \fBTCL_INTERP_DESTROYED\fR to signal this -condition, but any supported code should be converted to stop using it. +condition, but Tcl 9 no longer supports this. Any supported code +must be converted to stop using it. .PP A trace procedure can be called at any time, even when there are partially formed results stored in the interpreter. If diff --git a/generic/tcl.h b/generic/tcl.h index ee8ab68..160de7a 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -887,10 +887,6 @@ typedef struct Tcl_DString { #define TCL_TRACE_UNSETS 0x40 #define TCL_TRACE_DESTROYED 0x80 -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -#define TCL_INTERP_DESTROYED 0x100 -#endif - #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 #ifndef TCL_REMOVE_OBSOLETE_TRACES diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 56010e4..e3b02b7 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -2565,9 +2565,6 @@ TclObjCallVarTraces( leaveErrMsg); } -#undef TCL_INTERP_DESTROYED -#define TCL_INTERP_DESTROYED 0x100 - int TclCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ @@ -2647,13 +2644,6 @@ TclCallVarTraces( } /* - * Ignore any caller-provided TCL_INTERP_DESTROYED flag. Only we can - * set it correctly. - */ - - flags &= ~TCL_INTERP_DESTROYED; - - /* * Invoke traces on the array containing the variable, if relevant. */ @@ -2675,9 +2665,6 @@ TclCallVarTraces( if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, code); } - if (Tcl_InterpDeleted((Tcl_Interp *) iPtr)) { - flags |= TCL_INTERP_DESTROYED; - } result = tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { @@ -2719,9 +2706,6 @@ TclCallVarTraces( if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, code); } - if (Tcl_InterpDeleted((Tcl_Interp *) iPtr)) { - flags |= TCL_INTERP_DESTROYED; - } result = tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { -- cgit v0.12 From d063a23455c0d66176444ee46ce756685f57da85 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 May 2019 07:32:37 +0000 Subject: More WIP: eliminate all usage of (platform-specific) Tcl_WinTCharToUtf()/Tcl_WinUtfToTChar() to its proposed portable replacements: Tcl_Utf16ToUtfDString()/Tcl_UtfToUtf16DString() This allows for Tcl_WinTCharToUtf()/Tcl_WinUtfToTChar() to be declared deprecated. --- doc/Utf.3 | 22 +----- generic/tcl.decls | 51 ++++++------- generic/tcl.h | 2 +- generic/tclCmdMZ.c | 72 +++++++++--------- generic/tclDecls.h | 198 ++++++++++++++++++++++++------------------------- generic/tclExecute.c | 20 ++--- generic/tclIOSock.c | 3 +- generic/tclInt.h | 2 +- generic/tclMain.c | 5 +- generic/tclRegexp.c | 2 +- generic/tclStringObj.c | 54 +++++++------- generic/tclStubInit.c | 98 ++++++++++++------------ generic/tclTestObj.c | 34 +-------- generic/tclUtf.c | 56 +++++++------- generic/tclUtil.c | 4 +- generic/tclZipfs.c | 3 +- tests/stringObj.test | 16 ---- win/tclWin32Dll.c | 4 +- win/tclWinDde.c | 173 +++++++++++++++++++++++------------------- win/tclWinFCmd.c | 36 ++++++--- win/tclWinFile.c | 47 ++++++++---- win/tclWinInit.c | 4 +- win/tclWinLoad.c | 3 +- win/tclWinPipe.c | 21 ++++-- win/tclWinReg.c | 97 +++++++++++++----------- win/tclWinSerial.c | 3 +- win/tclWinSock.c | 4 +- 27 files changed, 519 insertions(+), 515 deletions(-) diff --git a/doc/Utf.3 b/doc/Utf.3 index f082e22..235584a 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToUtf16, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_Utf16ToUtfDString, Tcl_UtfToUtf16DString, Tcl_UniCharLen, Tcl_Utf16Len, Tcl_UniCharNcmp, Tcl_UniCharNcasecmp, Tcl_Utf16Ncmp, Tcl_Utf16Ncasecmp, Tcl_UniCharCaseMatch, Tcl_Utf16CaseMatch, Tcl_UtfNcmp, Tcl_UtfNcasecmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings +Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToUtf16, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_Utf16ToUtfDString, Tcl_UtfToUtf16DString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharNcasecmp, Tcl_UniCharCaseMatch, Tcl_UtfNcmp, Tcl_UtfNcasecmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings .SH SYNOPSIS .nf \fB#include \fR @@ -40,27 +40,15 @@ int \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int -\fBTcl_Utf16Len\fR(\fIutf16Str\fR) -.sp -int \fBTcl_UniCharNcmp\fR(\fIucs, uct, numChars\fR) .sp int \fBTcl_UniCharNcasecmp\fR(\fIucs, uct, numChars\fR) .sp int -\fBTcl_Utf16Ncmp\fR(\fIutf16s, tf16t, numChars\fR) -.sp -int -\fBTcl_Utf16Ncasecmp\fR(\fIutf16s, utf16t, numChars\fR) -.sp -int \fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR) .sp int -\fBTcl_Utf16CaseMatch\fR(\fIutf16Str, utf16Pattern, nocase\fR) -.sp -int \fBTcl_UtfNcmp\fR(\fIcs, ct, numChars\fR) .sp int @@ -129,8 +117,7 @@ A null-terminated utf-16 string. The length of the UTF-8 string in bytes (not UTF-8 characters). If negative, all bytes up to the first null byte are used. .AP int uniLength in -The length of the Unicode string in characters. Must be greater than or -equal to 0. +The length of the Unicode string in characters. .AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. .AP "unsigned long" numChars in @@ -219,11 +206,6 @@ is the Unicode case insensitive version. a Unicode pattern, and a boolean value specifying whether the match should be case sensitive and returns whether the string matches the pattern. .PP -\fBTcl_Utf16CaseMatch\fR is the utf-16 equivalent to -\fBTcl_StringCaseMatch\fR. It accepts a null-terminated utf-16 string, -a utf-16 pattern, and a boolean value specifying whether the match should -be case sensitive and returns whether the string matches the pattern. -.PP \fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It accepts two null-terminated UTF-8 strings and the number of characters to compare. (Both strings are assumed to be at least \fInumChars\fR diff --git a/generic/tcl.decls b/generic/tcl.decls index 2c1e801..a93f957 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1245,11 +1245,11 @@ declare 350 { declare 351 { int Tcl_UniCharIsWordChar(int ch) } -declare 352 { - int Tcl_Utf16Len(const unsigned short *uniStr) +declare 352 {deprecated {Use Tcl_GetCharLength}} { + int Tcl_UniCharLen(const unsigned short *uniStr) } declare 353 { - int Tcl_Utf16Ncmp(const unsigned short *ucs, const unsigned short *uct, + int Tcl_UniCharNcmp(const unsigned short *ucs, const unsigned short *uct, unsigned long numChars) } declare 354 { @@ -1339,10 +1339,10 @@ declare 377 { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 { - Tcl_Obj *Tcl_NewUtf16Obj(const unsigned short *unicode, int numChars) + Tcl_Obj *Tcl_NewUnicodeObj(const unsigned short *unicode, int numChars) } declare 379 { - void Tcl_SetUtf16Obj(Tcl_Obj *objPtr, const unsigned short *unicode, + void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const unsigned short *unicode, int numChars) } declare 380 { @@ -1358,7 +1358,7 @@ declare 383 { Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) } declare 384 { - void Tcl_AppendUtf16ToObj(Tcl_Obj *objPtr, const unsigned short *unicode, + void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const unsigned short *unicode, int length) } declare 385 { @@ -1484,11 +1484,11 @@ declare 418 { int Tcl_IsChannelExisting(const char *channelName) } declare 419 { - int Tcl_Utf16Ncasecmp(const unsigned short *ucs, const unsigned short *uct, + int Tcl_UniCharNcasecmp(const unsigned short *ucs, const unsigned short *uct, unsigned long numChars) } declare 420 { - int Tcl_Utf16CaseMatch(const unsigned short *uniStr, + int Tcl_UniCharCaseMatch(const unsigned short *uniStr, const unsigned short *uniPattern, int nocase) } declare 421 { @@ -1542,7 +1542,7 @@ declare 433 { # introduced in 8.4a3 declare 434 { - unsigned short *Tcl_GetUtf16FromObj(Tcl_Obj *objPtr, int *lengthPtr) + unsigned short *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } # TIP#15 (math function introspection) dkf @@ -2387,43 +2387,40 @@ declare 644 { # TIP #542 declare 646 { - void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const int *unicode, - int numChars) + int Tcl_UtfToUniChar(const char *src, int *chPtr) } declare 647 { - Tcl_Obj *Tcl_NewUnicodeObj(const int *unicode, int numChars) + char *Tcl_UniCharToUtfDString(const int *uniStr, + int uniLength, Tcl_DString *dsPtr) } declare 648 { - int *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) + int *Tcl_UtfToUniCharDString(const char *src, + int length, Tcl_DString *dsPtr) } declare 649 { - void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const int *unicode, - int length) + void TclSetUnicodeObj(Tcl_Obj *objPtr, const int *unicode, + int numChars) } declare 650 { - int Tcl_UtfToUniChar(const char *src, int *chPtr) + Tcl_Obj *TclNewUnicodeObj(const int *unicode, int numChars) } declare 651 { - char *Tcl_UniCharToUtfDString(const int *uniStr, - int uniLength, Tcl_DString *dsPtr) + int *TclGetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } declare 652 { - int *Tcl_UtfToUniCharDString(const char *src, - int length, Tcl_DString *dsPtr) + void TclAppendUnicodeToObj(Tcl_Obj *objPtr, const int *unicode, + int length) } declare 653 { - int Tcl_UniCharLen(const int *uniStr) + int Tcl_Utf32Ncmp(const int *ucs, const int *uct, + unsigned long numChars) } declare 654 { - int Tcl_UniCharNcmp(const int *ucs, const int *uct, + int Tcl_Utf32Ncasecmp(const int *ucs, const int *uct, unsigned long numChars) } declare 655 { - int Tcl_UniCharNcasecmp(const int *ucs, const int *uct, - unsigned long numChars) -} -declare 656 { - int Tcl_UniCharCaseMatch(const int *uniStr, + int Tcl_Utf32CaseMatch(const int *uniStr, const int *uniPattern, int nocase) } diff --git a/generic/tcl.h b/generic/tcl.h index d689011..e716aae 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2144,7 +2144,7 @@ typedef struct Tcl_EncodingType { */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 3 +#define TCL_UTF_MAX 4 #endif /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 15ea989..f6936e0 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -604,11 +604,11 @@ Tcl_RegsubObjCmd( numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); - strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; + strCmpFn = nocase ? Tcl_Utf32Ncasecmp : Tcl_Utf32Ncmp; - wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); - wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); - wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); + wsrc = TclGetUnicodeFromObj(objv[0], &slen); + wstring = TclGetUnicodeFromObj(objv[1], &wlen); + wsubspec = TclGetUnicodeFromObj(objv[2], &wsublen); wend = wstring + wlen - (slen ? slen - 1 : 0); result = TCL_OK; @@ -619,11 +619,11 @@ Tcl_RegsubObjCmd( */ if (wstring < wend) { - resultPtr = Tcl_NewUnicodeObj(wstring, 0); + resultPtr = TclNewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); for (; wstring < wend; wstring++) { - Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); - Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); + TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); + TclAppendUnicodeToObj(resultPtr, wstring, 1); numMatches++; } wlen = 0; @@ -636,18 +636,18 @@ Tcl_RegsubObjCmd( (slen==1 || (strCmpFn(wstring, wsrc, (unsigned long) slen) == 0))) { if (numMatches == 0) { - resultPtr = Tcl_NewUnicodeObj(wstring, 0); + resultPtr = TclNewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); } if (p != wstring) { - Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); + TclAppendUnicodeToObj(resultPtr, p, wstring - p); p = wstring + slen; } else { p += slen; } wstring = p - 1; - Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); + TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); numMatches++; } } @@ -699,14 +699,14 @@ Tcl_RegsubObjCmd( } else { objPtr = objv[1]; } - wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); + wstring = TclGetUnicodeFromObj(objPtr, &wlen); if (objv[2] == objv[0]) { subPtr = Tcl_DuplicateObj(objv[2]); } else { subPtr = objv[2]; } if (!command) { - wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); + wsubspec = TclGetUnicodeFromObj(subPtr, &wsublen); } result = TCL_OK; @@ -742,7 +742,7 @@ Tcl_RegsubObjCmd( break; } if (numMatches == 0) { - resultPtr = Tcl_NewUnicodeObj(wstring, 0); + resultPtr = TclNewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); if (offset > 0) { /* @@ -750,7 +750,7 @@ Tcl_RegsubObjCmd( * specified. */ - Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); + TclAppendUnicodeToObj(resultPtr, wstring, offset); } } numMatches++; @@ -763,7 +763,7 @@ Tcl_RegsubObjCmd( Tcl_RegExpGetInfo(regExpr, &info); start = info.matches[0].start; end = info.matches[0].end; - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); + TclAppendUnicodeToObj(resultPtr, wstring + offset, start); /* * In command-prefix mode, the substitutions are added as quoted @@ -785,7 +785,7 @@ Tcl_RegsubObjCmd( subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { - args[idx + numParts] = Tcl_NewUnicodeObj( + args[idx + numParts] = TclNewUnicodeObj( wstring + offset + subStart, subEnd - subStart); } else { args[idx + numParts] = Tcl_NewObj(); @@ -826,7 +826,7 @@ Tcl_RegsubObjCmd( * the user code. */ - wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); + wstring = TclGetUnicodeFromObj(objPtr, &wlen); offset += end; if (end == 0 || start == end) { @@ -838,7 +838,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); + TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -867,7 +867,7 @@ Tcl_RegsubObjCmd( idx = ch - '0'; } else if ((ch == '\\') || (ch == '&')) { *wsrc = ch; - Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, + TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar + 1); *wsrc = '\\'; wfirstChar = wsrc + 2; @@ -881,7 +881,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, + TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } @@ -889,7 +889,7 @@ Tcl_RegsubObjCmd( subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { - Tcl_AppendUnicodeToObj(resultPtr, + TclAppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } @@ -901,7 +901,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); + TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { @@ -911,7 +911,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); + TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } else { @@ -923,7 +923,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); + TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -948,7 +948,7 @@ Tcl_RegsubObjCmd( resultPtr = objv[1]; Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); + TclAppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, @@ -2080,7 +2080,7 @@ StringMapCmd( } else { sourceObj = objv[objc-1]; } - ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); + ustring1 = TclGetUnicodeFromObj(sourceObj, &length1); if (length1 == 0) { /* * Empty input string, just stop now. @@ -2090,13 +2090,13 @@ StringMapCmd( } end = ustring1 + length1; - strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + strCmpFn = (nocase ? Tcl_Utf32Ncasecmp : Tcl_Utf32Ncmp); /* * Force result to be Unicode */ - resultPtr = Tcl_NewUnicodeObj(ustring1, 0); + resultPtr = TclNewUnicodeObj(ustring1, 0); if (mapElemc == 2) { /* @@ -2109,7 +2109,7 @@ StringMapCmd( int mapLen, u2lc; Tcl_UniChar *mapString; - ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); + ustring2 = TclGetUnicodeFromObj(mapElemv[0], &length2); p = ustring1; if ((length2 > length1) || (length2 == 0)) { /* @@ -2118,7 +2118,7 @@ StringMapCmd( ustring1 = end; } else { - mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); + mapString = TclGetUnicodeFromObj(mapElemv[1], &mapLen); u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); for (; ustring1 < end; ustring1++) { if (((*ustring1 == *ustring2) || @@ -2126,14 +2126,14 @@ StringMapCmd( (length2==1 || strCmpFn(ustring1, ustring2, (unsigned long) length2) == 0)) { if (p != ustring1) { - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); + TclAppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); + TclAppendUnicodeToObj(resultPtr, mapString, mapLen); } } } @@ -2154,7 +2154,7 @@ StringMapCmd( u2lc = TclStackAlloc(interp, mapElemc * sizeof(int)); } for (index = 0; index < mapElemc; index++) { - mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], + mapStrings[index] = TclGetUnicodeFromObj(mapElemv[index], mapLens+index); if (nocase && ((index % 2) == 0)) { u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); @@ -2178,7 +2178,7 @@ StringMapCmd( * Put the skipped chars onto the result first. */ - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); + TclAppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; @@ -2194,7 +2194,7 @@ StringMapCmd( * Append the map value to the unicode string. */ - Tcl_AppendUnicodeToObj(resultPtr, + TclAppendUnicodeToObj(resultPtr, mapStrings[index+1], mapLens[index+1]); break; } @@ -2211,7 +2211,7 @@ StringMapCmd( * Put the rest of the unmapped chars onto result. */ - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); + TclAppendUnicodeToObj(resultPtr, p, ustring1 - p); } Tcl_SetObjResult(interp, resultPtr); done: diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 65b7b0a..16bf942 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1063,9 +1063,10 @@ EXTERN int Tcl_UniCharIsUpper(int ch); /* 351 */ EXTERN int Tcl_UniCharIsWordChar(int ch); /* 352 */ -EXTERN int Tcl_Utf16Len(const unsigned short *uniStr); +TCL_DEPRECATED("Use Tcl_GetCharLength") +int Tcl_UniCharLen(const unsigned short *uniStr); /* 353 */ -EXTERN int Tcl_Utf16Ncmp(const unsigned short *ucs, +EXTERN int Tcl_UniCharNcmp(const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 354 */ @@ -1141,10 +1142,10 @@ EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp, EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 378 */ -EXTERN Tcl_Obj * Tcl_NewUtf16Obj(const unsigned short *unicode, +EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const unsigned short *unicode, int numChars); /* 379 */ -EXTERN void Tcl_SetUtf16Obj(Tcl_Obj *objPtr, +EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const unsigned short *unicode, int numChars); /* 380 */ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); @@ -1156,7 +1157,7 @@ unsigned short * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ -EXTERN void Tcl_AppendUtf16ToObj(Tcl_Obj *objPtr, +EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const unsigned short *unicode, int length); /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, @@ -1250,11 +1251,11 @@ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ EXTERN int Tcl_IsChannelExisting(const char *channelName); /* 419 */ -EXTERN int Tcl_Utf16Ncasecmp(const unsigned short *ucs, +EXTERN int Tcl_UniCharNcasecmp(const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 420 */ -EXTERN int Tcl_Utf16CaseMatch(const unsigned short *uniStr, +EXTERN int Tcl_UniCharCaseMatch(const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 421 */ EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr, @@ -1297,7 +1298,8 @@ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length); /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ -EXTERN unsigned short * Tcl_GetUtf16FromObj(Tcl_Obj *objPtr, int *lengthPtr); +EXTERN unsigned short * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, + int *lengthPtr); /* 435 */ TCL_DEPRECATED("") int Tcl_GetMathFuncInfo(Tcl_Interp *interp, @@ -1903,34 +1905,31 @@ EXTERN int Tcl_LinkArray(Tcl_Interp *interp, int size); /* Slot 645 is reserved */ /* 646 */ -EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, - const int *unicode, int numChars); +EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr); /* 647 */ -EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const int *unicode, int numChars); +EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, + int uniLength, Tcl_DString *dsPtr); /* 648 */ -EXTERN int * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, - int *lengthPtr); +EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length, + Tcl_DString *dsPtr); /* 649 */ -EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, - const int *unicode, int length); +EXTERN void TclSetUnicodeObj(Tcl_Obj *objPtr, const int *unicode, + int numChars); /* 650 */ -EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr); +EXTERN Tcl_Obj * TclNewUnicodeObj(const int *unicode, int numChars); /* 651 */ -EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, - int uniLength, Tcl_DString *dsPtr); +EXTERN int * TclGetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 652 */ -EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length, - Tcl_DString *dsPtr); +EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr, + const int *unicode, int length); /* 653 */ -EXTERN int Tcl_UniCharLen(const int *uniStr); +EXTERN int Tcl_Utf32Ncmp(const int *ucs, const int *uct, + unsigned long numChars); /* 654 */ -EXTERN int Tcl_UniCharNcmp(const int *ucs, const int *uct, +EXTERN int Tcl_Utf32Ncasecmp(const int *ucs, const int *uct, unsigned long numChars); /* 655 */ -EXTERN int Tcl_UniCharNcasecmp(const int *ucs, const int *uct, - unsigned long numChars); -/* 656 */ -EXTERN int Tcl_UniCharCaseMatch(const int *uniStr, +EXTERN int Tcl_Utf32CaseMatch(const int *uniStr, const int *uniPattern, int nocase); typedef struct { @@ -2319,8 +2318,8 @@ typedef struct TclStubs { int (*tcl_UniCharIsSpace) (int ch); /* 349 */ int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ - int (*tcl_Utf16Len) (const unsigned short *uniStr); /* 352 */ - int (*tcl_Utf16Ncmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */ + TCL_DEPRECATED_API("Use Tcl_GetCharLength") int (*tcl_UniCharLen) (const unsigned short *uniStr); /* 352 */ + int (*tcl_UniCharNcmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */ char * (*tcl_Utf16ToUtfDString) (const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ unsigned short * (*tcl_UtfToUtf16DString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ @@ -2345,13 +2344,13 @@ typedef struct TclStubs { int (*tcl_UniCharIsPunct) (int ch); /* 375 */ int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ - Tcl_Obj * (*tcl_NewUtf16Obj) (const unsigned short *unicode, int numChars); /* 378 */ - void (*tcl_SetUtf16Obj) (Tcl_Obj *objPtr, const unsigned short *unicode, int numChars); /* 379 */ + Tcl_Obj * (*tcl_NewUnicodeObj) (const unsigned short *unicode, int numChars); /* 378 */ + void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const unsigned short *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ TCL_DEPRECATED_API("No longer in use, changed to macro") unsigned short * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ - void (*tcl_AppendUtf16ToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, int length); /* 384 */ + void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ @@ -2386,8 +2385,8 @@ typedef struct TclStubs { void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */ void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ - int (*tcl_Utf16Ncasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */ - int (*tcl_Utf16CaseMatch) (const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 420 */ + int (*tcl_UniCharNcasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */ + int (*tcl_UniCharCaseMatch) (const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 420 */ Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, const void *key); /* 421 */ Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */ void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */ @@ -2401,7 +2400,7 @@ typedef struct TclStubs { char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 431 */ int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ - unsigned short * (*tcl_GetUtf16FromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ + unsigned short * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */ @@ -2613,17 +2612,16 @@ typedef struct TclStubs { int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, int size); /* 644 */ void (*reserved645)(void); - void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const int *unicode, int numChars); /* 646 */ - Tcl_Obj * (*tcl_NewUnicodeObj) (const int *unicode, int numChars); /* 647 */ - int * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 648 */ - void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const int *unicode, int length); /* 649 */ - int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 650 */ - char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 651 */ - int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 652 */ - int (*tcl_UniCharLen) (const int *uniStr); /* 653 */ - int (*tcl_UniCharNcmp) (const int *ucs, const int *uct, unsigned long numChars); /* 654 */ - int (*tcl_UniCharNcasecmp) (const int *ucs, const int *uct, unsigned long numChars); /* 655 */ - int (*tcl_UniCharCaseMatch) (const int *uniStr, const int *uniPattern, int nocase); /* 656 */ + int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ + char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 647 */ + int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 648 */ + void (*tclSetUnicodeObj) (Tcl_Obj *objPtr, const int *unicode, int numChars); /* 649 */ + Tcl_Obj * (*tclNewUnicodeObj) (const int *unicode, int numChars); /* 650 */ + int * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 651 */ + void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const int *unicode, int length); /* 652 */ + int (*tcl_Utf32Ncmp) (const int *ucs, const int *uct, unsigned long numChars); /* 653 */ + int (*tcl_Utf32Ncasecmp) (const int *ucs, const int *uct, unsigned long numChars); /* 654 */ + int (*tcl_Utf32CaseMatch) (const int *uniStr, const int *uniPattern, int nocase); /* 655 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3358,10 +3356,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ #define Tcl_UniCharIsWordChar \ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ -#define Tcl_Utf16Len \ - (tclStubsPtr->tcl_Utf16Len) /* 352 */ -#define Tcl_Utf16Ncmp \ - (tclStubsPtr->tcl_Utf16Ncmp) /* 353 */ +#define Tcl_UniCharLen \ + (tclStubsPtr->tcl_UniCharLen) /* 352 */ +#define Tcl_UniCharNcmp \ + (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ #define Tcl_Utf16ToUtfDString \ (tclStubsPtr->tcl_Utf16ToUtfDString) /* 354 */ #define Tcl_UtfToUtf16DString \ @@ -3410,10 +3408,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_RegExpExecObj) /* 376 */ #define Tcl_RegExpGetInfo \ (tclStubsPtr->tcl_RegExpGetInfo) /* 377 */ -#define Tcl_NewUtf16Obj \ - (tclStubsPtr->tcl_NewUtf16Obj) /* 378 */ -#define Tcl_SetUtf16Obj \ - (tclStubsPtr->tcl_SetUtf16Obj) /* 379 */ +#define Tcl_NewUnicodeObj \ + (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ +#define Tcl_SetUnicodeObj \ + (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ #define Tcl_GetCharLength \ (tclStubsPtr->tcl_GetCharLength) /* 380 */ #define Tcl_GetUniChar \ @@ -3422,8 +3420,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetUnicode) /* 382 */ #define Tcl_GetRange \ (tclStubsPtr->tcl_GetRange) /* 383 */ -#define Tcl_AppendUtf16ToObj \ - (tclStubsPtr->tcl_AppendUtf16ToObj) /* 384 */ +#define Tcl_AppendUnicodeToObj \ + (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */ #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ #define Tcl_SetNotifier \ @@ -3492,10 +3490,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */ #define Tcl_IsChannelExisting \ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ -#define Tcl_Utf16Ncasecmp \ - (tclStubsPtr->tcl_Utf16Ncasecmp) /* 419 */ -#define Tcl_Utf16CaseMatch \ - (tclStubsPtr->tcl_Utf16CaseMatch) /* 420 */ +#define Tcl_UniCharNcasecmp \ + (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */ +#define Tcl_UniCharCaseMatch \ + (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */ #define Tcl_FindHashEntry \ (tclStubsPtr->tcl_FindHashEntry) /* 421 */ #define Tcl_CreateHashEntry \ @@ -3522,8 +3520,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */ #define Tcl_GetChannelThread \ (tclStubsPtr->tcl_GetChannelThread) /* 433 */ -#define Tcl_GetUtf16FromObj \ - (tclStubsPtr->tcl_GetUtf16FromObj) /* 434 */ +#define Tcl_GetUnicodeFromObj \ + (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */ #define Tcl_GetMathFuncInfo \ (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */ #define Tcl_ListMathFuncs \ @@ -3945,28 +3943,26 @@ extern const TclStubs *tclStubsPtr; #define Tcl_LinkArray \ (tclStubsPtr->tcl_LinkArray) /* 644 */ /* Slot 645 is reserved */ -#define Tcl_SetUnicodeObj \ - (tclStubsPtr->tcl_SetUnicodeObj) /* 646 */ -#define Tcl_NewUnicodeObj \ - (tclStubsPtr->tcl_NewUnicodeObj) /* 647 */ -#define Tcl_GetUnicodeFromObj \ - (tclStubsPtr->tcl_GetUnicodeFromObj) /* 648 */ -#define Tcl_AppendUnicodeToObj \ - (tclStubsPtr->tcl_AppendUnicodeToObj) /* 649 */ #define Tcl_UtfToUniChar \ - (tclStubsPtr->tcl_UtfToUniChar) /* 650 */ + (tclStubsPtr->tcl_UtfToUniChar) /* 646 */ #define Tcl_UniCharToUtfDString \ - (tclStubsPtr->tcl_UniCharToUtfDString) /* 651 */ + (tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */ #define Tcl_UtfToUniCharDString \ - (tclStubsPtr->tcl_UtfToUniCharDString) /* 652 */ -#define Tcl_UniCharLen \ - (tclStubsPtr->tcl_UniCharLen) /* 653 */ -#define Tcl_UniCharNcmp \ - (tclStubsPtr->tcl_UniCharNcmp) /* 654 */ -#define Tcl_UniCharNcasecmp \ - (tclStubsPtr->tcl_UniCharNcasecmp) /* 655 */ -#define Tcl_UniCharCaseMatch \ - (tclStubsPtr->tcl_UniCharCaseMatch) /* 656 */ + (tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */ +#define TclSetUnicodeObj \ + (tclStubsPtr->tclSetUnicodeObj) /* 649 */ +#define TclNewUnicodeObj \ + (tclStubsPtr->tclNewUnicodeObj) /* 650 */ +#define TclGetUnicodeFromObj \ + (tclStubsPtr->tclGetUnicodeFromObj) /* 651 */ +#define TclAppendUnicodeToObj \ + (tclStubsPtr->tclAppendUnicodeToObj) /* 652 */ +#define Tcl_Utf32Ncmp \ + (tclStubsPtr->tcl_Utf32Ncmp) /* 653 */ +#define Tcl_Utf32Ncasecmp \ + (tclStubsPtr->tcl_Utf32Ncasecmp) /* 654 */ +#define Tcl_Utf32CaseMatch \ + (tclStubsPtr->tcl_Utf32CaseMatch) /* 655 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4105,10 +4101,10 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_GetLongFromObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj -# undef Tcl_UniCharNcmp +# undef Tcl_Utf32Ncmp # undef Tcl_UtfNcmp # undef Tcl_UtfNcasecmp -# undef Tcl_UniCharNcasecmp +# undef Tcl_Utf32Ncasecmp # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) # define Tcl_ExprLong TclExprLong static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ @@ -4124,13 +4120,13 @@ extern const TclStubs *tclStubsPtr; if (result == TCL_OK) *ptr = (long)intValue; return result; } -# define Tcl_UniCharNcmp(ucs,uct,n) \ +# define Tcl_Utf32Ncmp(ucs,uct,n) \ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n)) # define Tcl_UtfNcmp(s1,s2,n) \ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n)) # define Tcl_UtfNcasecmp(s1,s2,n) \ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n)) -# define Tcl_UniCharNcasecmp(ucs,uct,n) \ +# define Tcl_Utf32Ncasecmp(ucs,uct,n) \ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n)) # endif #endif @@ -4146,33 +4142,37 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_SetLongObj #define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value)) #undef Tcl_GetUnicode -#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL) +#define Tcl_GetUnicode(objPtr) TclGetUnicodeFromObj((objPtr), NULL) #undef Tcl_BackgroundError #define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR) #undef Tcl_StringMatch #define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0) #if TCL_UTF_MAX == 3 -# undef Tcl_GetUnicodeFromObj -# define Tcl_GetUnicodeFromObj Tcl_GetUtf16FromObj -# undef Tcl_NewUnicodeObj -# define Tcl_NewUnicodeObj Tcl_NewUtf16Obj -# undef Tcl_SetUnicodeObj -# define Tcl_SetUnicodeObj Tcl_SetUtf16Obj -# undef Tcl_AppendUnicodeToObj -# define Tcl_AppendUnicodeToObj Tcl_AppendUtf16ToObj +# undef TclGetUnicodeFromObj +# define TclGetUnicodeFromObj Tcl_GetUnicodeFromObj +# undef TclNewUnicodeObj +# define TclNewUnicodeObj Tcl_NewUnicodeObj +# undef TclSetUnicodeObj +# define TclSetUnicodeObj Tcl_SetUnicodeObj +# undef TclAppendUnicodeToObj +# define TclAppendUnicodeToObj Tcl_AppendUnicodeToObj # undef Tcl_UniCharToUtfDString # define Tcl_UniCharToUtfDString Tcl_Utf16ToUtfDString # undef Tcl_UtfToUniCharDString # define Tcl_UtfToUniCharDString Tcl_UtfToUtf16DString # undef Tcl_UtfToUniChar # define Tcl_UtfToUniChar Tcl_UtfToUtf16 -# undef Tcl_UniCharNcmp -# define Tcl_UniCharNcmp Tcl_Utf16Ncmp -# undef Tcl_UniCharNcasecmp -# define Tcl_UniCharNcasecmp Tcl_Utf16Ncasecmp -# undef Tcl_UniCharCaseMatch -# define Tcl_UniCharCaseMatch Tcl_Utf16CaseMatch +# undef Tcl_Utf32Ncmp +# define Tcl_Utf32Ncmp Tcl_UniCharNcmp +# undef Tcl_Utf32Ncasecmp +# define Tcl_Utf32Ncasecmp Tcl_UniCharNcasecmp +# undef Tcl_Utf32CaseMatch +# define Tcl_Utf32CaseMatch Tcl_UniCharCaseMatch +#endif + +#if TCL_UTF_MAX > 3 || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +# undef Tcl_UniCharLen #endif /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ed4fdd7..c31ab79 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5391,12 +5391,12 @@ TEBCresume( objResultPtr = value3Ptr; goto doneStringMap; } - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + ustring1 = TclGetUnicodeFromObj(valuePtr, &length); if (length == 0) { objResultPtr = valuePtr; goto doneStringMap; } - ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); if (length2 > length || length2 == 0) { objResultPtr = valuePtr; goto doneStringMap; @@ -5408,9 +5408,9 @@ TEBCresume( } goto doneStringMap; } - ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); + ustring3 = TclGetUnicodeFromObj(value3Ptr, &length3); - objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); + objResultPtr = TclNewUnicodeObj(ustring1, 0); p = ustring1; end = ustring1 + length; for (; ustring1 < end; ustring1++) { @@ -5418,14 +5418,14 @@ TEBCresume( memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) == 0)) { if (p != ustring1) { - Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p); + TclAppendUnicodeToObj(objResultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3); + TclAppendUnicodeToObj(objResultPtr, ustring3, length3); } } if (p != ustring1) { @@ -5433,7 +5433,7 @@ TEBCresume( * Put the rest of the unmapped chars onto result. */ - Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); + TclAppendUnicodeToObj(objResultPtr, p, ustring1 - p); } doneStringMap: TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", @@ -5461,7 +5461,7 @@ TEBCresume( valuePtr = OBJ_AT_TOS; TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, O2S(valuePtr))); - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + ustring1 = TclGetUnicodeFromObj(valuePtr, &length); match = 1; if (length > 0) { end = ustring1 + length; @@ -5490,8 +5490,8 @@ TEBCresume( || TclHasIntRep(value2Ptr, &tclStringType)) { Tcl_UniChar *ustring1, *ustring2; - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); - ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + ustring1 = TclGetUnicodeFromObj(valuePtr, &length); + ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); match = TclUniCharMatch(ustring1, length, ustring2, length2, nocase); } else if (TclIsPureByteArray(valuePtr) && !nocase) { diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 12e2900..32ed015 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -34,7 +34,8 @@ gai_strerror( } else { tsdPtr->initialized = 1; } - Tcl_WinTCharToUtf(gai_strerrorW(code), -1, &tsdPtr->errorMsg); + Tcl_DStringInit(&tsdPtr->errorMsg); + Tcl_Utf16ToUtfDString(gai_strerrorW(code), -1, &tsdPtr->errorMsg); return Tcl_DStringValue(&tsdPtr->errorMsg); } #endif diff --git a/generic/tclInt.h b/generic/tclInt.h index b6db913..fb35fc1 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4687,7 +4687,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); #ifdef WORDS_BIGENDIAN # define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) #else /* !WORDS_BIGENDIAN */ -# define TclUniCharNcmp Tcl_UniCharNcmp +# define TclUniCharNcmp Tcl_Utf32Ncmp #endif /* WORDS_BIGENDIAN */ /* diff --git a/generic/tclMain.c b/generic/tclMain.c index f7a4cf8..ad039b6 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -60,7 +60,7 @@ */ #if defined(UNICODE) && (TCL_UTF_MAX == 3) -# define NewNativeObj Tcl_NewUnicodeObj +# define NewNativeObj TclNewUnicodeObj #else /* !UNICODE || (TCL_UTF_MAX > 3) */ static inline Tcl_Obj * NewNativeObj( @@ -73,7 +73,8 @@ NewNativeObj( if (length > 0) { length *= sizeof(WCHAR); } - Tcl_WinTCharToUtf(string, length, &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString(string, length, &ds); #else Tcl_ExternalToUtfDString(NULL, (char *) string, length, &ds); #endif diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 804b117..5a8c558 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -482,7 +482,7 @@ Tcl_RegExpExecObj( regexpPtr->string = NULL; regexpPtr->objPtr = textObj; - udata = Tcl_GetUnicodeFromObj(textObj, &length); + udata = TclGetUnicodeFromObj(textObj, &length); if (offset > length) { offset = length; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index d5edaf3..76d875c 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -354,7 +354,7 @@ Tcl_DbNewStringObj( /* *--------------------------------------------------------------------------- * - * Tcl_NewUnicodeObj -- + * TclNewUnicodeObj -- * * This function is creates a new String object and initializes it from * the given Unicode String. If the Utf String is the same size as the @@ -371,7 +371,7 @@ Tcl_DbNewStringObj( */ Tcl_Obj * -Tcl_NewUnicodeObj( +TclNewUnicodeObj( const Tcl_UniChar *unicode, /* The unicode string used to initialize the * new object. */ int numChars) /* Number of characters in the unicode @@ -613,7 +613,7 @@ Tcl_GetUnicode( Tcl_Obj *objPtr) /* The object to find the unicode string * for. */ { - return Tcl_GetUnicodeFromObj(objPtr, NULL); + return TclGetUnicodeFromObj(objPtr, NULL); } #endif /* TCL_NO_DEPRECATED */ @@ -637,7 +637,7 @@ Tcl_GetUnicode( */ Tcl_UniChar * -Tcl_GetUnicodeFromObj( +TclGetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the unicode string * for. */ int *lengthPtr) /* If non-NULL, the location where the string @@ -764,7 +764,7 @@ Tcl_GetRange( ++last; } #endif - return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); + return TclNewUnicodeObj(stringPtr->unicode + first, last - first + 1); } /* @@ -1057,7 +1057,7 @@ Tcl_AttemptSetObjLength( */ void -Tcl_SetUnicodeObj( +TclSetUnicodeObj( Tcl_Obj *objPtr, /* The object to set the string of. */ const Tcl_UniChar *unicode, /* The unicode string used to initialize the * object. */ @@ -1249,7 +1249,7 @@ Tcl_AppendToObj( */ void -Tcl_AppendUnicodeToObj( +TclAppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* The unicode string to append to the * object. */ @@ -1393,7 +1393,7 @@ Tcl_AppendObjToObj( if (TclHasIntRep(appendObjPtr, &tclStringType)) { Tcl_UniChar *unicode = - Tcl_GetUnicodeFromObj(appendObjPtr, &numChars); + TclGetUnicodeFromObj(appendObjPtr, &numChars); AppendUnicodeToUnicodeRep(objPtr, unicode, numChars); } else { @@ -2873,7 +2873,7 @@ TclStringRepeat( Tcl_GetByteArrayFromObj(objPtr, &length); } else if (unichar) { /* Result will be pure Tcl_UniChar array. Pre-size it. */ - Tcl_GetUnicodeFromObj(objPtr, &length); + TclGetUnicodeFromObj(objPtr, &length); } else { /* Result will be concat of string reps. Pre-size it. */ Tcl_GetStringFromObj(objPtr, &length); @@ -2913,7 +2913,7 @@ TclStringRepeat( */ if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length); + objResultPtr = TclNewUnicodeObj(Tcl_GetUnicode(objPtr), length); } else { TclInvalidateStringRep(objPtr); objResultPtr = objPtr; @@ -2934,7 +2934,7 @@ TclStringRepeat( Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } - Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), + TclAppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), (count - done) * length); } else { /* @@ -3091,7 +3091,7 @@ TclStringCat( if ((objPtr->bytes == NULL) || (objPtr->length)) { int numChars; - Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ + TclGetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ if (numChars) { last = objc - oc; if (length == 0) { @@ -3241,7 +3241,7 @@ TclStringCat( objResultPtr = *objv++; objc--; /* Ugly interface! Force resize of the unicode array. */ - Tcl_GetUnicodeFromObj(objResultPtr, &start); + TclGetUnicodeFromObj(objResultPtr, &start); Tcl_InvalidateStringRep(objResultPtr); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { @@ -3258,7 +3258,7 @@ TclStringCat( Tcl_UniChar ch = 0; /* Ugly interface! No scheme to init array size. */ - objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */ + objResultPtr = TclNewUnicodeObj(&ch, 0); /* PANIC? */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { Tcl_DecrRefCount(objResultPtr); if (interp) { @@ -3277,7 +3277,7 @@ TclStringCat( if ((objPtr->bytes == NULL) || (objPtr->length)) { int more; - Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more); + Tcl_UniChar *src = TclGetUnicodeFromObj(objPtr, &more); memcpy(dst, src, more * sizeof(Tcl_UniChar)); dst += more; } @@ -3400,9 +3400,9 @@ TclStringCmp( */ if (nocase) { - s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); - s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); - memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp; + s1 = (char *) TclGetUnicodeFromObj(value1Ptr, &s1len); + s2 = (char *) TclGetUnicodeFromObj(value2Ptr, &s2len); + memCmpFn = (memCmpFn_t)Tcl_Utf32Ncasecmp; } else { s1len = Tcl_GetCharLength(value1Ptr); s2len = Tcl_GetCharLength(value2Ptr); @@ -3427,7 +3427,7 @@ TclStringCmp( s1len *= sizeof(Tcl_UniChar); s2len *= sizeof(Tcl_UniChar); } else { - memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; + memCmpFn = (memCmpFn_t) Tcl_Utf32Ncmp; } } } @@ -3611,9 +3611,9 @@ TclStringFirst( { Tcl_UniChar *try, *end, *uh; - Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); + Tcl_UniChar *un = TclGetUnicodeFromObj(needle, &ln); - uh = Tcl_GetUnicodeFromObj(haystack, &lh); + uh = TclGetUnicodeFromObj(haystack, &lh); if ((lh < ln) || (start > lh - ln)) { /* Don't start the loop if there cannot be a valid answer */ return -1; @@ -3690,8 +3690,8 @@ TclStringLast( } { - Tcl_UniChar *try, *uh = Tcl_GetUnicodeFromObj(haystack, &lh); - Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); + Tcl_UniChar *try, *uh = TclGetUnicodeFromObj(haystack, &lh); + Tcl_UniChar *un = TclGetUnicodeFromObj(needle, &ln); if (last >= lh) { last = lh - 1; @@ -3789,7 +3789,7 @@ TclStringReverse( * Tcl_SetObjLength into growing the unicode rep buffer. */ - objPtr = Tcl_NewUnicodeObj(&ch, 1); + objPtr = TclNewUnicodeObj(&ch, 1); Tcl_SetObjLength(objPtr, stringPtr->numChars); to = Tcl_GetUnicode(objPtr); while (--src >= from) { @@ -3987,16 +3987,16 @@ TclStringReplace( /* The traditional implementation... */ { int numChars; - Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars); + Tcl_UniChar *ustring = TclGetUnicodeFromObj(objPtr, &numChars); /* TODO: Is there an in-place option worth pursuing here? */ - result = Tcl_NewUnicodeObj(ustring, first); + result = TclNewUnicodeObj(ustring, first); if (insertPtr) { Tcl_AppendObjToObj(result, insertPtr); } if (first + count < numChars) { - Tcl_AppendUnicodeToObj(result, ustring + first + count, + TclAppendUnicodeToObj(result, ustring + first + count, numChars - first - count); } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index e11c641..5900257 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -60,16 +60,16 @@ #undef TclBNInitBignumFromLong #undef Tcl_BackgroundError #define TclStaticPackage Tcl_StaticPackage -#undef Tcl_GetUnicodeFromObj -#undef Tcl_NewUnicodeObj -#undef Tcl_SetUnicodeObj +#undef TclGetUnicodeFromObj +#undef TclNewUnicodeObj +#undef TclSetUnicodeObj #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar -#undef Tcl_UniCharNcmp -#undef Tcl_UniCharNcasecmp -#undef Tcl_UniCharCaseMatch -#undef Tcl_AppendUnicodeToObj +#undef Tcl_Utf32Ncmp +#undef Tcl_Utf32Ncasecmp +#undef Tcl_Utf32CaseMatch +#undef TclAppendUnicodeToObj static void uniCodePanic() { #if TCL_UTF_MAX == 3 @@ -80,25 +80,24 @@ static void uniCodePanic() { } #if TCL_UTF_MAX == 3 -# define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, int *)) uniCodePanic -# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, int)) uniCodePanic -# define Tcl_SetUnicodeObj (void (*)(Tcl_Obj *,const int *, int)) uniCodePanic -# define Tcl_AppendUnicodeToObj (void (*)(Tcl_Obj *, const int *, int)) uniCodePanic +# define TclGetUnicodeFromObj (int *(*)(Tcl_Obj *, int *)) uniCodePanic +# define TclNewUnicodeObj (Tcl_Obj *(*)(const int *, int)) uniCodePanic +# define TclSetUnicodeObj (void (*)(Tcl_Obj *,const int *, int)) uniCodePanic +# define TclAppendUnicodeToObj (void (*)(Tcl_Obj *, const int *, int)) uniCodePanic # define Tcl_UtfToUniChar (int (*)(const char *, int *)) uniCodePanic # define Tcl_UniCharToUtfDString (char *(*)(const int *, int, Tcl_DString *)) uniCodePanic # define Tcl_UtfToUniCharDString (int *(*)(const char *, int, Tcl_DString *)) uniCodePanic -# define Tcl_UniCharCaseMatch (int (*)(const int *, const int *, int)) uniCodePanic -# define Tcl_UniCharLen (int (*)(const int *)) uniCodePanic -# define Tcl_UniCharNcmp (int (*)(const int *, const int *, unsigned long)) uniCodePanic -# define Tcl_UniCharNcasecmp (int (*)(const int *, const int *, unsigned long)) uniCodePanic +# define Tcl_Utf32CaseMatch (int (*)(const int *, const int *, int)) uniCodePanic +# define Tcl_Utf32Ncmp (int (*)(const int *, const int *, unsigned long)) uniCodePanic +# define Tcl_Utf32Ncasecmp (int (*)(const int *, const int *, unsigned long)) uniCodePanic #else #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *)) uniCodePanic # endif -# define Tcl_GetUtf16FromObj (unsigned short *(*)(Tcl_Obj *, int *)) uniCodePanic -# define Tcl_NewUtf16Obj (Tcl_Obj *(*)(const unsigned short *, int)) uniCodePanic -# define Tcl_SetUtf16Obj (void(*)(Tcl_Obj *, const unsigned short *, int)) uniCodePanic -# define Tcl_AppendUtf16ToObj (void(*)(Tcl_Obj *, const unsigned short *, int)) uniCodePanic +# define Tcl_GetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, int *)) uniCodePanic +# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const unsigned short *, int)) uniCodePanic +# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const unsigned short *, int)) uniCodePanic +# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const unsigned short *, int)) uniCodePanic #endif /* See bug 510001: TclSockMinimumBuffers needs plat imp */ @@ -303,9 +302,7 @@ Tcl_WinTCharToUtf( if (!string) { return NULL; } - if (len < 0) { - len = wcslen((wchar_t *)string); - } else { + if (len > 0) { len /= 2; } return Tcl_Utf16ToUtfDString((const unsigned short *)string, len, dsPtr); @@ -359,22 +356,22 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))utfNcasecmp #if TCL_UTF_MAX > 3 static int uniCharNcmp(const int *ucs, const int *uct, unsigned int n){ - return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); + return Tcl_Utf32Ncmp(ucs, uct, (unsigned long)n); } -#define Tcl_UniCharNcmp (int(*)(const int*,const int*,unsigned long))uniCharNcmp +#define Tcl_Utf32Ncmp (int(*)(const int*,const int*,unsigned long))uniCharNcmp static int uniCharNcasecmp(const int *ucs, const int *uct, unsigned int n){ - return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); + return Tcl_Utf32Ncasecmp(ucs, uct, (unsigned long)n); } -#define Tcl_UniCharNcasecmp (int(*)(const int*,const int*,unsigned long))uniCharNcasecmp +#define Tcl_Utf32Ncasecmp (int(*)(const int*,const int*,unsigned long))uniCharNcasecmp #else static int utf16Ncmp(const unsigned short *ucs, const unsigned short *uct, unsigned int n){ - return Tcl_Utf16Ncmp(ucs, uct, (unsigned long)n); + return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); } -#define Tcl_Utf16Ncmp (int(*)(const unsigned short*,const unsigned short*,unsigned long))utf16Ncmp +#define Tcl_UniCharNcmp (int(*)(const unsigned short*,const unsigned short*,unsigned long))utf16Ncmp static int utf16Ncasecmp(const unsigned short *ucs, const unsigned short *uct, unsigned int n){ - return Tcl_Utf16Ncasecmp(ucs, uct, (unsigned long)n); + return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); } -#define Tcl_Utf16Ncasecmp (int(*)(const unsigned short*,const unsigned short*,unsigned long))utf16Ncasecmp +#define Tcl_UniCharNcasecmp (int(*)(const unsigned short*,const unsigned short*,unsigned long))utf16Ncasecmp #endif #endif /* TCL_WIDE_INT_IS_LONG */ @@ -522,6 +519,10 @@ tellOld( } #endif /* !TCL_NO_DEPRECATED */ +#if TCL_UTF_MAX > 3 || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +# define Tcl_UniCharLen 0 +#endif + /* * WARNING: The contents of this file is automatically generated by the * tools/genStubs.tcl script. Any modifications to the function declarations @@ -1390,8 +1391,8 @@ const TclStubs tclStubs = { Tcl_UniCharIsSpace, /* 349 */ Tcl_UniCharIsUpper, /* 350 */ Tcl_UniCharIsWordChar, /* 351 */ - Tcl_Utf16Len, /* 352 */ - Tcl_Utf16Ncmp, /* 353 */ + Tcl_UniCharLen, /* 352 */ + Tcl_UniCharNcmp, /* 353 */ Tcl_Utf16ToUtfDString, /* 354 */ Tcl_UtfToUtf16DString, /* 355 */ Tcl_GetRegExpFromObj, /* 356 */ @@ -1416,13 +1417,13 @@ const TclStubs tclStubs = { Tcl_UniCharIsPunct, /* 375 */ Tcl_RegExpExecObj, /* 376 */ Tcl_RegExpGetInfo, /* 377 */ - Tcl_NewUtf16Obj, /* 378 */ - Tcl_SetUtf16Obj, /* 379 */ + Tcl_NewUnicodeObj, /* 378 */ + Tcl_SetUnicodeObj, /* 379 */ Tcl_GetCharLength, /* 380 */ Tcl_GetUniChar, /* 381 */ Tcl_GetUnicode, /* 382 */ Tcl_GetRange, /* 383 */ - Tcl_AppendUtf16ToObj, /* 384 */ + Tcl_AppendUnicodeToObj, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ Tcl_GetAllocMutex, /* 387 */ @@ -1457,8 +1458,8 @@ const TclStubs tclStubs = { Tcl_SpliceChannel, /* 416 */ Tcl_ClearChannelHandlers, /* 417 */ Tcl_IsChannelExisting, /* 418 */ - Tcl_Utf16Ncasecmp, /* 419 */ - Tcl_Utf16CaseMatch, /* 420 */ + Tcl_UniCharNcasecmp, /* 419 */ + Tcl_UniCharCaseMatch, /* 420 */ Tcl_FindHashEntry, /* 421 */ Tcl_CreateHashEntry, /* 422 */ Tcl_InitCustomHashTable, /* 423 */ @@ -1472,7 +1473,7 @@ const TclStubs tclStubs = { Tcl_AttemptDbCkrealloc, /* 431 */ Tcl_AttemptSetObjLength, /* 432 */ Tcl_GetChannelThread, /* 433 */ - Tcl_GetUtf16FromObj, /* 434 */ + Tcl_GetUnicodeFromObj, /* 434 */ Tcl_GetMathFuncInfo, /* 435 */ Tcl_ListMathFuncs, /* 436 */ Tcl_SubstObj, /* 437 */ @@ -1684,17 +1685,16 @@ const TclStubs tclStubs = { Tcl_IsShared, /* 643 */ Tcl_LinkArray, /* 644 */ 0, /* 645 */ - Tcl_SetUnicodeObj, /* 646 */ - Tcl_NewUnicodeObj, /* 647 */ - Tcl_GetUnicodeFromObj, /* 648 */ - Tcl_AppendUnicodeToObj, /* 649 */ - Tcl_UtfToUniChar, /* 650 */ - Tcl_UniCharToUtfDString, /* 651 */ - Tcl_UtfToUniCharDString, /* 652 */ - Tcl_UniCharLen, /* 653 */ - Tcl_UniCharNcmp, /* 654 */ - Tcl_UniCharNcasecmp, /* 655 */ - Tcl_UniCharCaseMatch, /* 656 */ + Tcl_UtfToUniChar, /* 646 */ + Tcl_UniCharToUtfDString, /* 647 */ + Tcl_UtfToUniCharDString, /* 648 */ + TclSetUnicodeObj, /* 649 */ + TclNewUnicodeObj, /* 650 */ + TclGetUnicodeFromObj, /* 651 */ + TclAppendUnicodeToObj, /* 652 */ + Tcl_Utf32Ncmp, /* 653 */ + Tcl_Utf32Ncasecmp, /* 654 */ + Tcl_Utf32CaseMatch, /* 655 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index a289e32..9bab1e9 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1170,7 +1170,6 @@ TeststringobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *unicode; int varIndex, option, i, length; #define MAX_STRINGS 11 const char *index, *string, *strings[MAX_STRINGS+1]; @@ -1179,7 +1178,7 @@ TeststringobjCmd( static const char *const options[] = { "append", "appendstrings", "get", "get2", "length", "length2", "set", "set2", "setlength", "maxchars", "getunicode", - "appendself", "appendself2", NULL + "appendself", NULL }; if (objc < 3) { @@ -1381,37 +1380,6 @@ TeststringobjCmd( Tcl_AppendToObj(varPtr[varIndex], string + i, length - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; - case 12: /* appendself2 */ - if (objc != 4) { - goto wrongNumArgs; - } - if (varPtr[varIndex] == NULL) { - SetVarToObj(varPtr, varIndex, Tcl_NewObj()); - } - - /* - * If the object bound to variable "varIndex" is shared, we must - * "copy on write" and append to a copy of the object. - */ - - if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); - } - - unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length); - - if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { - return TCL_ERROR; - } - if ((i < 0) || (i > length)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "index value out of range", -1)); - return TCL_ERROR; - } - - Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i); - Tcl_SetObjResult(interp, varPtr[varIndex]); - break; } return TCL_OK; diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 380db95..1beadec 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -225,7 +225,7 @@ three: char * Tcl_UniCharToUtfDString( const int *uniStr, /* Unicode string to convert to UTF-8. */ - int uniLength, /* Length of Unicode string (must be >= 0). */ + int uniLength, /* Length of Unicode string. */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { @@ -237,6 +237,14 @@ Tcl_UniCharToUtfDString( * UTF-8 string length in bytes will be <= Unicode string length * 4. */ + if (uniLength < 0) { + uniLength = 0; + w = uniStr; + while (*w != '\0') { + uniLength++; + w++; + } + } oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4); string = Tcl_DStringValue(dsPtr) + oldLength; @@ -256,7 +264,7 @@ Tcl_UniCharToUtfDString( char * Tcl_Utf16ToUtfDString( const unsigned short *uniStr, /* Utf-16 string to convert to UTF-8. */ - int uniLength, /* Length of Utf-16 string (must be >= 0). */ + int uniLength, /* Length of Utf-16 string. */ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended * to this previously initialized DString. */ { @@ -268,6 +276,15 @@ Tcl_Utf16ToUtfDString( * UTF-8 string length in bytes will be <= Utf16 string length * 3. */ + if (uniLength < 0) { + + uniLength = 0; + w = uniStr; + while (*w != '\0') { + uniLength++; + w++; + } + } oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 3); string = Tcl_DStringValue(dsPtr) + oldLength; @@ -692,8 +709,6 @@ Tcl_UtfCharComplete( #if TCL_UTF_MAX == 3 # undef Tcl_UtfToUniChar # define Tcl_UtfToUniChar Tcl_UtfToUtf16 -# undef Tcl_UniCharLen -# define Tcl_UniCharLen Tcl_Utf16Len #endif int @@ -1633,23 +1648,9 @@ Tcl_UniCharToTitle( *---------------------------------------------------------------------- */ -#if TCL_UTF_MAX > 3 +#if TCL_UTF_MAX == 3 && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 int Tcl_UniCharLen( - const int *uniStr) /* Unicode string to find length of. */ -{ - int len = 0; - - while (*uniStr != '\0') { - len++; - uniStr++; - } - return len; -} -#endif /* TCL_UTF_MAX > 3 */ - -int -Tcl_Utf16Len( const unsigned short *utf16Str) /* Unicode string to find length of. */ { int len = 0; @@ -1660,6 +1661,7 @@ Tcl_Utf16Len( } return len; } +#endif /* TCL_UTF_MAX == 3 && !defined(TCL_NO_DEPRECATED) */ /* *---------------------------------------------------------------------- @@ -1680,7 +1682,7 @@ Tcl_Utf16Len( #if TCL_UTF_MAX > 3 int -Tcl_UniCharNcmp( +Tcl_Utf32Ncmp( const int *ucs, /* Unicode string to compare to uct. */ const int *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ @@ -1708,7 +1710,7 @@ Tcl_UniCharNcmp( #endif /* TCL_UTF_MAX > 3 */ int -Tcl_Utf16Ncmp( +Tcl_UniCharNcmp( const unsigned short *ucs, /* Unicode string to compare to uct. */ const unsigned short *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ @@ -1754,7 +1756,7 @@ Tcl_Utf16Ncmp( #if TCL_UTF_MAX > 3 int -Tcl_UniCharNcasecmp( +Tcl_Utf32Ncasecmp( const int *ucs, /* Unicode string to compare to uct. */ const int *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ @@ -1774,7 +1776,7 @@ Tcl_UniCharNcasecmp( #endif /* TCL_UTF_MAX > 3 */ int -Tcl_Utf16Ncasecmp( +Tcl_UniCharNcasecmp( const unsigned short *ucs, /* Utf16 string to compare to uct. */ const unsigned short *uct, /* Utf16 string ucs is compared to. */ unsigned long numChars) /* Number of Utf16 characters to compare. */ @@ -2126,7 +2128,7 @@ Tcl_UniCharIsWordChar( #if TCL_UTF_MAX > 3 int -Tcl_UniCharCaseMatch( +Tcl_Utf32CaseMatch( const int *uniStr, /* Unicode String. */ const int *uniPattern, /* Pattern, which may contain special @@ -2193,7 +2195,7 @@ Tcl_UniCharCaseMatch( } } } - if (Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase)) { + if (Tcl_Utf32CaseMatch(uniStr, uniPattern, nocase)) { return 1; } if (*uniStr == 0) { @@ -2294,7 +2296,7 @@ Tcl_UniCharCaseMatch( #endif /* TCL_UTF_MAX > 3 */ int -Tcl_Utf16CaseMatch( +Tcl_UniCharCaseMatch( const unsigned short *uniStr, /* Unicode String. */ const unsigned short *uniPattern, /* Pattern, which may contain special @@ -2361,7 +2363,7 @@ Tcl_Utf16CaseMatch( } } } - if (Tcl_Utf16CaseMatch(uniStr, uniPattern, nocase)) { + if (Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase)) { return 1; } if (*uniStr == 0) { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index c333e63..218df5d 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2663,8 +2663,8 @@ TclStringMatchObj( if (TclHasIntRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; - udata = Tcl_GetUnicodeFromObj(strObj, &length); - uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); + udata = TclGetUnicodeFromObj(strObj, &length); + uptn = TclGetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); } else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj) && !flags) { diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 3d1941c..776f795 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -4930,7 +4930,8 @@ TclZipfs_AppHook( #ifdef _WIN32 Tcl_DString ds; - archive = Tcl_WinTCharToUtf((*argvPtr)[1], -1, &ds); + Tcl_DStringInit(&ds); + archive = Tcl_Utf16ToUtfDString((*argvPtr)[1], -1, &ds); #else /* !_WIN32 */ archive = (*argvPtr)[1]; #endif /* _WIN32 */ diff --git a/tests/stringObj.test b/tests/stringObj.test index a78b5f8..769486a 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -464,22 +464,6 @@ test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 3 } foo -test stringObj-15.5 {Tcl_Append*ToObj: self appends} testobj { - teststringobj set 1 foo - teststringobj appendself2 1 0 -} foofoo -test stringObj-15.6 {Tcl_Append*ToObj: self appends} testobj { - teststringobj set 1 foo - teststringobj appendself2 1 1 -} foooo -test stringObj-15.7 {Tcl_Append*ToObj: self appends} testobj { - teststringobj set 1 foo - teststringobj appendself2 1 2 -} fooo -test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { - teststringobj set 1 foo - teststringobj appendself2 1 3 -} foo if {[testConstraint testobj]} { testobj freeallvars diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index f5809e8..ac2e02b 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -490,9 +490,7 @@ Tcl_WinTCharToUtf( if (!string) { return NULL; } - if (len < 0) { - len = wcslen((WCHAR *)string); - } else { + if (len > 0) { len /= 2; } return Tcl_Utf16ToUtfDString(string, len, dsPtr); diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 27ddfc8..efa94b2 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -34,7 +34,7 @@ typedef struct RegisteredInterp { struct RegisteredInterp *nextPtr; /* The next interp this application knows * about. */ - TCHAR *name; /* Interpreter's name (malloc-ed). */ + WCHAR *name; /* Interpreter's name (malloc-ed). */ Tcl_Obj *handlerPtr; /* The server handler command */ Tcl_Interp *interp; /* The interpreter attached to this name. */ } RegisteredInterp; @@ -101,7 +101,7 @@ static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); static void DdeExitProc(ClientData clientData); static int DdeGetServicesList(Tcl_Interp *interp, - const TCHAR *serviceName, const TCHAR *topicName); + const WCHAR *serviceName, const WCHAR *topicName); static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv, HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData, DWORD dwData1, DWORD dwData2); @@ -111,7 +111,7 @@ static void DeleteProc(ClientData clientData); static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr, Tcl_Obj *ddeObjectPtr); static int MakeDdeConnection(Tcl_Interp *interp, - const TCHAR *name, HCONV *ddeConvPtr); + const WCHAR *name, HCONV *ddeConvPtr); static void SetDdeError(Tcl_Interp *interp); static int DdeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, @@ -159,7 +159,7 @@ int Dde_Init( Tcl_Interp *interp) { - if (!Tcl_InitStubs(interp, "8.1", 0)) { + if (!Tcl_InitStubs(interp, "8.7-", 0)) { return TCL_ERROR; } @@ -283,10 +283,10 @@ Initialize(void) *---------------------------------------------------------------------- */ -static const TCHAR * +static const WCHAR * DdeSetServerName( Tcl_Interp *interp, - const TCHAR *name, /* The name that will be used to refer to the + const WCHAR *name, /* The name that will be used to refer to the * interpreter in later "send" commands. Must * be globally unique. */ int flags, /* DDE_FLAG_FORCE or 0 */ @@ -296,7 +296,7 @@ DdeSetServerName( int suffix, offset; RegisteredInterp *riPtr, *prevPtr; Tcl_DString dString; - const TCHAR *actualName; + const WCHAR *actualName; Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; int n, srvCount = 0, lastSuffix, r = TCL_OK; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -355,8 +355,9 @@ DdeSetServerName( &srvPtrPtr); } if (r != TCL_OK) { - Tcl_WinUtfToTChar(Tcl_GetStringResult(interp), -1, &dString); - OutputDebugString((TCHAR *) Tcl_DStringValue(&dString)); + Tcl_DStringInit(&dString); + Tcl_UtfToUtf16DString(Tcl_GetString(Tcl_GetObjResult(interp)), -1, &dString); + OutputDebugString((WCHAR *) Tcl_DStringValue(&dString)); Tcl_DStringFree(&dString); return NULL; } @@ -374,13 +375,13 @@ DdeSetServerName( lastSuffix = suffix; if (suffix > 1) { if (suffix == 2) { - Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(TCHAR)); - Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(TCHAR)); + Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(WCHAR)); + Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(WCHAR)); offset = Tcl_DStringLength(&dString); - Tcl_DStringSetLength(&dString, offset + sizeof(TCHAR) * TCL_INTEGER_SPACE); - actualName = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, offset + sizeof(WCHAR) * TCL_INTEGER_SPACE); + actualName = (WCHAR *) Tcl_DStringValue(&dString); } - _sntprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset), + _sntprintf((WCHAR *) (Tcl_DStringValue(&dString) + offset), TCL_INTEGER_SPACE, TEXT("%d"), suffix); } @@ -393,8 +394,9 @@ DdeSetServerName( Tcl_DString ds; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); - Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds); - if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) { + Tcl_DStringInit(&ds); + Tcl_UtfToUtf16DString(Tcl_GetString(namePtr), -1, &ds); + if (_tcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds)) == 0) { suffix++; Tcl_DStringFree(&ds); break; @@ -410,7 +412,7 @@ DdeSetServerName( riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp)); riPtr->interp = interp; - riPtr->name = (TCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(TCHAR)); + riPtr->name = (WCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(WCHAR)); riPtr->nextPtr = tsdPtr->interpListPtr; riPtr->handlerPtr = handlerPtr; if (riPtr->handlerPtr != NULL) { @@ -633,7 +635,7 @@ DdeServerProc( Tcl_DString dString; size_t len; DWORD dlen; - TCHAR *utilString; + WCHAR *utilString; Tcl_Obj *ddeObjectPtr; HDDEDATA ddeReturn = NULL; RegisteredInterp *riPtr; @@ -649,8 +651,8 @@ DdeServerProc( len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, CP_WINUNICODE); @@ -674,8 +676,8 @@ DdeServerProc( len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, CP_WINUNICODE); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; @@ -743,8 +745,8 @@ DdeServerProc( len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); Tcl_DStringInit(&dsBuf); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, CP_WINUNICODE); if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { @@ -752,9 +754,10 @@ DdeServerProc( Tcl_GetString(convPtr->returnPackagePtr); len = convPtr->returnPackagePtr->length; if (uFmt != CF_TEXT) { - Tcl_WinUtfToTChar(returnString, len, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_UtfToUtf16DString(returnString, len, &dsBuf); returnString = Tcl_DStringValue(&dsBuf); - len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; + len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); @@ -765,7 +768,8 @@ DdeServerProc( Tcl_DString ds; Tcl_Obj *variableObjPtr; - Tcl_WinTCharToUtf(utilString, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString(utilString, -1, &ds); variableObjPtr = Tcl_GetVar2Ex( convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, TCL_GLOBAL_ONLY); @@ -773,9 +777,10 @@ DdeServerProc( returnString = Tcl_GetString(variableObjPtr); len = variableObjPtr->length; if (uFmt != CF_TEXT) { - Tcl_WinUtfToTChar(returnString, len, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_UtfToUtf16DString(returnString, len, &dsBuf); returnString = Tcl_DStringValue(&dsBuf); - len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; + len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, @@ -818,16 +823,18 @@ DdeServerProc( Tcl_DStringInit(&dString); Tcl_DStringInit(&ds2); len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1); + utilString = (WCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, CP_WINUNICODE); - Tcl_WinTCharToUtf(utilString, -1, &ds); - utilString = (TCHAR *) DdeAccessData(hData, &len2); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString(utilString, -1, &ds); + utilString = (WCHAR *) DdeAccessData(hData, &len2); len = len2; if (uFmt != CF_TEXT) { - Tcl_WinTCharToUtf(utilString, -1, &ds2); - utilString = (TCHAR *) Tcl_DStringValue(&ds2); + Tcl_DStringInit(&ds2); + Tcl_Utf16ToUtfDString(utilString, -1, &ds2); + utilString = (WCHAR *) Tcl_DStringValue(&ds2); } variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); @@ -862,7 +869,7 @@ DdeServerProc( return (HDDEDATA) DDE_FNOTPROCESSED; } - utilString = (TCHAR *) DdeAccessData(hData, &dlen); + utilString = (WCHAR *) DdeAccessData(hData, &dlen); string = (char *) utilString; if (!dlen) { /* Empty binary array. */ @@ -877,7 +884,8 @@ DdeServerProc( /* unicode */ Tcl_DString dsBuf; - Tcl_WinTCharToUtf(utilString, dlen - sizeof(TCHAR), &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_Utf16ToUtfDString(utilString, (dlen>>1) - 1, &dsBuf); ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf)); Tcl_DStringFree(&dsBuf); @@ -993,7 +1001,7 @@ DdeExitProc( static int MakeDdeConnection( Tcl_Interp *interp, /* Used to report errors. */ - const TCHAR *name, /* The connection to use. */ + const WCHAR *name, /* The connection to use. */ HCONV *ddeConvPtr) { HSZ ddeTopic, ddeService; @@ -1010,7 +1018,8 @@ MakeDdeConnection( if (interp != NULL) { Tcl_DString dString; - Tcl_WinTCharToUtf(name, -1, &dString); + Tcl_DStringInit(&dString); + Tcl_Utf16ToUtfDString(name, -1, &dString); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no registered server named \"%s\"", Tcl_DStringValue(&dString))); Tcl_DStringFree(&dString); @@ -1048,8 +1057,8 @@ DdeCreateClient( DdeEnumServices *es) { WNDCLASSEX wc; - static const TCHAR *szDdeClientClassName = TEXT("TclEval client class"); - static const TCHAR *szDdeClientWindowName = TEXT("TclEval client window"); + static const WCHAR *szDdeClientClassName = TEXT("TclEval client class"); + static const WCHAR *szDdeClientWindowName = TEXT("TclEval client window"); memset(&wc, 0, sizeof(wc)); wc.cbSize = sizeof(wc); @@ -1104,7 +1113,7 @@ DdeServicesOnAck( ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); DdeEnumServices *es; - TCHAR sz[255]; + WCHAR sz[255]; Tcl_DString dString; #ifdef _WIN64 @@ -1119,11 +1128,13 @@ DdeServicesOnAck( Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); GlobalGetAtomName(service, sz, 255); - Tcl_WinTCharToUtf(sz, -1, &dString); + Tcl_DStringInit(&dString); + Tcl_Utf16ToUtfDString(sz, -1, &dString); Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); Tcl_DStringFree(&dString); GlobalGetAtomName(topic, sz, 255); - Tcl_WinTCharToUtf(sz, -1, &dString); + Tcl_DStringInit(&dString); + Tcl_Utf16ToUtfDString(sz, -1, &dString); Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); Tcl_DStringFree(&dString); @@ -1172,8 +1183,8 @@ DdeEnumWindowsCallback( static int DdeGetServicesList( Tcl_Interp *interp, - const TCHAR *serviceName, - const TCHAR *topicName) + const WCHAR *serviceName, + const WCHAR *topicName) { DdeEnumServices es; @@ -1302,7 +1313,7 @@ DdeObjCmd( HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; - const TCHAR *serviceName = NULL, *topicName = NULL; + const WCHAR *serviceName = NULL, *topicName = NULL; const char *string; DWORD ddeResult; Tcl_Obj *objPtr, *handlerPtr = NULL; @@ -1462,9 +1473,10 @@ DdeObjCmd( const char *src = Tcl_GetString(objv[firstArg]); length = objv[firstArg]->length; - Tcl_WinUtfToTChar(src, length, &serviceBuf); - serviceName = (TCHAR *) Tcl_DStringValue(&serviceBuf); - length = Tcl_DStringLength(&serviceBuf) / sizeof(TCHAR); + Tcl_DStringInit(&serviceBuf); + Tcl_UtfToUtf16DString(src, length, &serviceBuf); + serviceName = (WCHAR *) Tcl_DStringValue(&serviceBuf); + length = Tcl_DStringLength(&serviceBuf) / sizeof(WCHAR); } else { length = 0; } @@ -1480,8 +1492,9 @@ DdeObjCmd( const char *src = Tcl_GetString(objv[firstArg + 1]); length = objv[firstArg + 1]->length; - topicName = Tcl_WinUtfToTChar(src, length, &topicBuf); - length = Tcl_DStringLength(&topicBuf) / sizeof(TCHAR); + Tcl_DStringInit(&topicBuf); + topicName = Tcl_UtfToUtf16DString(src, length, &topicBuf); + length = Tcl_DStringLength(&topicBuf) / sizeof(WCHAR); if (length == 0) { topicName = NULL; } else { @@ -1497,7 +1510,8 @@ DdeObjCmd( if (serviceName != NULL) { Tcl_DString dsBuf; - Tcl_WinTCharToUtf(serviceName, -1, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_Utf16ToUtfDString(serviceName, -1, &dsBuf); Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf))); Tcl_DStringFree(&dsBuf); @@ -1520,9 +1534,10 @@ DdeObjCmd( src = Tcl_GetString(objv[firstArg + 2]); dataLength = objv[firstArg + 2]->length; - dataString = (const TCHAR *) - Tcl_WinUtfToTChar(src, dataLength, &dsBuf); - dataLength = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + Tcl_DStringInit(&dsBuf); + dataString = (const WCHAR *) + Tcl_UtfToUtf16DString(src, dataLength, &dsBuf); + dataLength = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); } if (dataLength + 1 < 2) { @@ -1568,13 +1583,14 @@ DdeObjCmd( break; } case DDE_REQUEST: { - const TCHAR *itemString; + const WCHAR *itemString; const char *src; src = Tcl_GetString(objv[firstArg + 2]); length = objv[firstArg + 2]->length; - itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); - length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); + Tcl_DStringInit(&itemBuf); + itemString = Tcl_UtfToUtf16DString(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, @@ -1602,7 +1618,7 @@ DdeObjCmd( result = TCL_ERROR; } else { DWORD tmp; - TCHAR *dataString = (TCHAR *) DdeAccessData(ddeData, &tmp); + WCHAR *dataString = (WCHAR *) DdeAccessData(ddeData, &tmp); if (flags & DDE_FLAG_BINARY) { returnObjPtr = @@ -1610,11 +1626,12 @@ DdeObjCmd( } else { Tcl_DString dsBuf; - if ((tmp >= sizeof(TCHAR)) - && !dataString[tmp / sizeof(TCHAR) - 1]) { - tmp -= sizeof(TCHAR); + if ((tmp >= sizeof(WCHAR)) + && !dataString[tmp / sizeof(WCHAR) - 1]) { + tmp -= sizeof(WCHAR); } - Tcl_WinTCharToUtf(dataString, tmp, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_Utf16ToUtfDString(dataString, tmp>>1, &dsBuf); returnObjPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf)); @@ -1633,14 +1650,15 @@ DdeObjCmd( } case DDE_POKE: { Tcl_DString dsBuf; - const TCHAR *itemString; + const WCHAR *itemString; BYTE *dataString; const char *src; src = Tcl_GetString(objv[firstArg + 2]); length = objv[firstArg + 2]->length; - itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); - length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); + Tcl_DStringInit(&itemBuf); + itemString = Tcl_UtfToUtf16DString(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot have a null item", -1)); @@ -1656,9 +1674,10 @@ DdeObjCmd( const char *data = Tcl_GetString(objv[firstArg + 3]); length = objv[firstArg + 3]->length; + Tcl_DStringInit(&dsBuf); dataString = (BYTE *) - Tcl_WinUtfToTChar(data, length, &dsBuf); - length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + Tcl_UtfToUtf16DString(data, length, &dsBuf); + length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); @@ -1820,9 +1839,10 @@ DdeObjCmd( objPtr = Tcl_ConcatObj(objc, objv); string = Tcl_GetString(objPtr); length = objPtr->length; - Tcl_WinUtfToTChar(string, length, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_UtfToUtf16DString(string, length, &dsBuf); string = Tcl_DStringValue(&dsBuf); - length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR); ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string, (DWORD) length, 0, 0, CF_UNICODETEXT, 0); Tcl_DStringFree(&dsBuf); @@ -1854,7 +1874,7 @@ DdeObjCmd( if (!(flags & DDE_FLAG_ASYNC)) { Tcl_Obj *resultPtr; - TCHAR *ddeDataString; + WCHAR *ddeDataString; /* * The return handle has a two or four element list in it. The @@ -1866,12 +1886,13 @@ DdeObjCmd( */ length = DdeGetData(ddeData, NULL, 0, 0); - ddeDataString = (TCHAR *) Tcl_Alloc(length); + ddeDataString = (WCHAR *) Tcl_Alloc(length); DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); - if (length > sizeof(TCHAR)) { - length -= sizeof(TCHAR); + if (length > sizeof(WCHAR)) { + length -= sizeof(WCHAR); } - Tcl_WinTCharToUtf(ddeDataString, length, &dsBuf); + Tcl_DStringInit(&dsBuf); + Tcl_Utf16ToUtfDString(ddeDataString, length>>1, &dsBuf); resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), Tcl_DStringLength(&dsBuf)); Tcl_DStringFree(&dsBuf); diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 14bb252..e8863dc 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -328,8 +328,10 @@ DoRenameFile( CharLower(nativeSrcPath); CharLower(nativeDstPath); - src = Tcl_WinTCharToUtf(nativeSrcPath, -1, &srcString); - dst = Tcl_WinTCharToUtf(nativeDstPath, -1, &dstString); + Tcl_DStringInit(&srcString); + Tcl_DStringInit(&dstString); + src = Tcl_Utf16ToUtfDString(nativeSrcPath, -1, &srcString); + dst = Tcl_Utf16ToUtfDString(nativeDstPath, -1, &dstString); /* * Check whether the destination path is actually inside the @@ -911,8 +913,10 @@ TclpObjCopyDirectory( return TCL_ERROR; } - Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString); - Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString); + Tcl_DStringInit(&srcString); + Tcl_DStringInit(&dstString); + Tcl_UtfToUtf16DString(Tcl_GetString(normSrcPtr), -1, &srcString); + Tcl_UtfToUtf16DString(Tcl_GetString(normDestPtr), -1, &dstString); ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds); @@ -984,7 +988,8 @@ TclpObjRemoveDirectory( if (normPtr == NULL) { return TCL_ERROR; } - Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native); + Tcl_DStringInit(&native); + Tcl_UtfToUtf16DString(Tcl_GetString(normPtr), -1, &native); ret = DoRemoveDirectory(&native, recursive, &ds); Tcl_DStringFree(&native); } else { @@ -1109,7 +1114,10 @@ DoRemoveJustDirectory( end: if (errorPtr != NULL) { - char *p = Tcl_WinTCharToUtf(nativePath, -1, errorPtr); + char *p; + + Tcl_DStringInit(errorPtr); + p = Tcl_Utf16ToUtfDString(nativePath, -1, errorPtr); for (; *p; ++p) { if (*p == '\\') *p = '/'; } @@ -1323,7 +1331,8 @@ TraverseWinTree( if (nativeErrfile != NULL) { TclWinConvertError(GetLastError()); if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr); + Tcl_DStringInit(errorPtr); + Tcl_Utf16ToUtfDString(nativeErrfile, -1, errorPtr); } result = TCL_ERROR; } @@ -1388,7 +1397,8 @@ TraversalCopy( */ if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeDst, -1, errorPtr); + Tcl_DStringInit(errorPtr); + Tcl_Utf16ToUtfDString(nativeDst, -1, errorPtr); } return TCL_ERROR; } @@ -1443,7 +1453,8 @@ TraversalDelete( } if (errorPtr != NULL) { - Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr); + Tcl_DStringInit(errorPtr); + Tcl_Utf16ToUtfDString(nativeSrc, -1, errorPtr); } return TCL_ERROR; } @@ -1651,7 +1662,8 @@ ConvertFileNameFormat( */ tempString = TclGetStringFromObj(tempPath, &length); - nativeName = Tcl_WinUtfToTChar(tempString, length, &ds); + Tcl_DStringInit(&ds); + nativeName = Tcl_UtfToUtf16DString(tempString, length, &ds); Tcl_DecrRefCount(tempPath); handle = FindFirstFile(nativeName, &data); if (handle == INVALID_HANDLE_VALUE) { @@ -1688,7 +1700,7 @@ ConvertFileNameFormat( } /* - * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying + * Purify reports a extraneous UMR in Tcl_Utf16ToUtfDString() trying * to dereference nativeName as a Unicode string. I have proven to * myself that purify is wrong by running the following example * when nativeName == data.w.cAlternateFileName and noting that @@ -1700,7 +1712,7 @@ ConvertFileNameFormat( */ Tcl_DStringInit(&dsTemp); - Tcl_WinTCharToUtf(nativeName, -1, &dsTemp); + Tcl_Utf16ToUtfDString(nativeName, -1, &dsTemp); Tcl_DStringFree(&ds); /* diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 0b5da4f..2550fde 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -634,10 +634,11 @@ WinReadLinkDirectory( } } - Tcl_WinTCharToUtf( + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString( reparseBuffer->MountPointReparseBuffer.PathBuffer, reparseBuffer->MountPointReparseBuffer - .SubstituteNameLength, &ds); + .SubstituteNameLength>>1, &ds); copy = Tcl_DStringValue(&ds)+offset; len = Tcl_DStringLength(&ds)-offset; @@ -1023,7 +1024,8 @@ TclpMatchInDirectory( dirName = TclDStringAppendLiteral(&dsOrig, "*.*"); } - native = Tcl_WinUtfToTChar(dirName, -1, &ds); + Tcl_DStringInit(&ds); + native = Tcl_UtfToUtf16DString(dirName, -1, &ds); if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) { handle = FindFirstFile(native, &data); } else { @@ -1096,7 +1098,8 @@ TclpMatchInDirectory( native = data.cFileName; attr = data.dwFileAttributes; - utfname = Tcl_WinTCharToUtf(native, -1, &ds); + Tcl_DStringInit(&ds); + utfname = Tcl_Utf16ToUtfDString(native, -1, &ds); if (!matchSpecialDots) { /* @@ -1982,7 +1985,8 @@ TclpGetCwd( && (native[2] == '\\') && (native[3] == '\\')) { native += 2; } - Tcl_WinTCharToUtf(native, -1, bufferPtr); + Tcl_DStringInit(bufferPtr); + Tcl_Utf16ToUtfDString(native, -1, bufferPtr); /* * Convert to forward slashes for easier use in scripts. @@ -2190,7 +2194,8 @@ NativeDev( const char *fullPath; GetFullPathName(nativePath, MAX_PATH, nativeFullPath, &nativePart); - fullPath = Tcl_WinTCharToUtf(nativeFullPath, -1, &ds); + Tcl_DStringInit(&ds); + fullPath = Tcl_Utf16ToUtfDString(nativeFullPath, -1, &ds); if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { const char *p; @@ -2211,7 +2216,8 @@ NativeDev( } else { p++; } - nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); + Tcl_DStringInit(&volString); + nativeVol = Tcl_UtfToUtf16DString(fullPath, p - fullPath, &volString); dw = (DWORD) -1; GetVolumeInformation(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); @@ -2491,7 +2497,8 @@ TclpFilesystemPathType( } else { Tcl_DString ds; - Tcl_WinTCharToUtf(volType, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString(volType, -1, &ds); return TclDStringToObj(&ds); } #undef VOL_BUF_SIZE @@ -2561,7 +2568,10 @@ TclpObjNormalizePath( */ WIN32_FILE_ATTRIBUTE_DATA data; - const WCHAR *nativePath = Tcl_WinUtfToTChar(path, + const WCHAR *nativePath; + + Tcl_DStringInit(&ds); + nativePath = Tcl_UtfToUtf16DString(path, currentPathEndPosition - path, &ds); if (GetFileAttributesEx(nativePath, @@ -2763,11 +2773,14 @@ TclpObjNormalizePath( if (1) { WCHAR wpath[MAX_PATH]; - const WCHAR *nativePath = - Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds); - DWORD wpathlen = GetLongPathNameProc(nativePath, - (WCHAR *) wpath, MAX_PATH); + const WCHAR *nativePath; + DWORD wpathlen; + Tcl_DStringInit(&ds); + nativePath = + Tcl_UtfToUtf16DString(path, lastValidPathEnd - path, &ds); + wpathlen = GetLongPathNameProc(nativePath, + (WCHAR *) wpath, MAX_PATH); /* * We have to make the drive letter uppercase. */ @@ -2794,8 +2807,9 @@ TclpObjNormalizePath( * native encoding, so we have to convert it to Utf. */ - Tcl_WinTCharToUtf((const WCHAR *) Tcl_DStringValue(&dsNorm), - Tcl_DStringLength(&dsNorm), &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString((const WCHAR *) Tcl_DStringValue(&dsNorm), + Tcl_DStringLength(&dsNorm)>>1, &ds); nextCheckpoint = Tcl_DStringLength(&ds); if (*lastValidPathEnd != 0) { /* @@ -2970,7 +2984,8 @@ TclpNativeToNormalized( int len; char *copy, *p; - Tcl_WinTCharToUtf((const WCHAR *) clientData, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString((const WCHAR *) clientData, -1, &ds); copy = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); diff --git a/win/tclWinInit.c b/win/tclWinInit.c index f4c6e06..4219963 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -476,8 +476,8 @@ TclpGetUserName( return NULL; } cchUserNameLen--; - cchUserNameLen *= sizeof(WCHAR); - Tcl_WinTCharToUtf(szUserName, cchUserNameLen, bufferPtr); + Tcl_DStringInit(bufferPtr); + Tcl_Utf16ToUtfDString(szUserName, cchUserNameLen, bufferPtr); } return Tcl_DStringValue(bufferPtr); } diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 69263e9..d0ab6e4 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -95,7 +95,8 @@ TclpDlopen( firstError = (nativeName == NULL) ? ERROR_MOD_NOT_FOUND : GetLastError(); - nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); + Tcl_DStringInit(&ds); + nativeName = Tcl_UtfToUtf16DString(Tcl_GetString(pathPtr), -1, &ds); hInstance = LoadLibraryEx(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index a001816..c382e23 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -577,7 +577,8 @@ TclpOpenFile( break; } - nativePath = Tcl_WinUtfToTChar(path, -1, &ds); + Tcl_DStringInit(&ds); + nativePath = Tcl_UtfToUtf16DString(path, -1, &ds); /* * If the file is not being created, use the existing file attributes. @@ -1290,7 +1291,8 @@ ApplicationType( for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) { Tcl_DStringSetLength(&nameBuf, nameLen); Tcl_DStringAppend(&nameBuf, extensions[i], -1); - nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), + Tcl_DStringInit(&ds); + nativeName = Tcl_UtfToUtf16DString(Tcl_DStringValue(&nameBuf), Tcl_DStringLength(&nameBuf), &ds); found = SearchPath(NULL, nativeName, NULL, MAX_PATH, nativeFullPath, &rest); @@ -1308,7 +1310,8 @@ ApplicationType( if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) { continue; } - strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); + Tcl_DStringInit(&ds); + strcpy(fullName, Tcl_Utf16ToUtfDString(nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); ext = strrchr(fullName, '.'); @@ -1399,7 +1402,8 @@ ApplicationType( */ GetShortPathName(nativeFullPath, nativeFullPath, MAX_PATH); - strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); + Tcl_DStringInit(&ds); + strcpy(fullName, Tcl_Utf16ToUtfDString(nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); } return applType; @@ -1727,7 +1731,8 @@ BuildCommandLine( } } Tcl_DStringFree(linePtr); - Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr); + Tcl_DStringInit(linePtr); + Tcl_UtfToUtf16DString(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr); Tcl_DStringFree(&ds); } @@ -3209,7 +3214,8 @@ TclpOpenTemporaryFile( if (basenameObj) { const char *string = TclGetStringFromObj(basenameObj, &length); - Tcl_WinUtfToTChar(string, length, &buf); + Tcl_DStringInit(&buf); + Tcl_UtfToUtf16DString(string, length, &buf); memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); namePtr += Tcl_DStringLength(&buf); Tcl_DStringFree(&buf); @@ -3229,7 +3235,8 @@ TclpOpenTemporaryFile( sprintf(number, "%d.TMP", counter); counter = (unsigned short) (counter + 1); - Tcl_WinUtfToTChar(number, strlen(number), &buf); + Tcl_DStringInit(&buf); + Tcl_UtfToUtf16DString(number, strlen(number), &buf); Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf) + 1); memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf) + 1); Tcl_DStringFree(&buf); diff --git a/win/tclWinReg.c b/win/tclWinReg.c index f93a553..27d02b4 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -116,7 +116,7 @@ static int ParseKeyName(Tcl_Interp *interp, char *name, char **hostNamePtr, HKEY *rootKeyPtr, char **keyNamePtr); static DWORD RecursiveDeleteKey(HKEY hStartKey, - const TCHAR * pKeyName, REGSAM mode); + const WCHAR * pKeyName, REGSAM mode); static int RegistryObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -168,7 +168,7 @@ Registry_Init( { Tcl_Command cmd; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) { return TCL_ERROR; } @@ -415,7 +415,7 @@ DeleteKey( REGSAM mode) /* Mode flags to pass. */ { char *tail, *buffer, *hostName, *keyName; - const TCHAR *nativeTail; + const WCHAR *nativeTail; HKEY rootKey, subkey; DWORD result; Tcl_DString buf; @@ -468,7 +468,8 @@ DeleteKey( * Now we recursively delete the key and everything below it. */ - nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf); + Tcl_DStringInit(&buf); + nativeTail = Tcl_UtfToUtf16DString(tail, -1, &buf); result = RecursiveDeleteKey(subkey, nativeTail, saveMode); Tcl_DStringFree(&buf); @@ -524,8 +525,9 @@ DeleteValue( } valueName = Tcl_GetString(valueNameObj); - Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); - result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); + Tcl_DStringInit(&ds); + Tcl_UtfToUtf16DString(valueName, valueNameObj->length, &ds); + result = RegDeleteValue(key, (const WCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -568,7 +570,7 @@ GetKeyNames( { const char *pattern; /* Pattern being matched against subkeys */ HKEY key; /* Handle to the key being examined */ - TCHAR buffer[MAX_KEY_LENGTH]; + WCHAR buffer[MAX_KEY_LENGTH]; /* Buffer to hold the subkey name */ DWORD bufSize; /* Size of the buffer */ DWORD index; /* Position of the current subkey */ @@ -613,7 +615,8 @@ GetKeyNames( } break; } - name = Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds); + Tcl_DStringInit(&ds); + name = Tcl_Utf16ToUtfDString(buffer, bufSize, &ds); if (pattern && !Tcl_StringMatch(name, pattern)) { Tcl_DStringFree(&ds); continue; @@ -663,7 +666,7 @@ GetType( DWORD result, type; Tcl_DString ds; const char *valueName; - const TCHAR *nativeValue; + const WCHAR *nativeValue; /* * Attempt to open the key for reading. @@ -679,7 +682,8 @@ GetType( */ valueName = Tcl_GetString(valueNameObj); - nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); + Tcl_DStringInit(&ds); + nativeValue = Tcl_UtfToUtf16DString(valueName, valueNameObj->length, &ds); result = RegQueryValueEx(key, nativeValue, NULL, &type, NULL, NULL); Tcl_DStringFree(&ds); @@ -732,7 +736,7 @@ GetValue( { HKEY key; const char *valueName; - const TCHAR *nativeValue; + const WCHAR *nativeValue; DWORD result, length, type; Tcl_DString data, buf; @@ -757,10 +761,11 @@ GetValue( Tcl_DStringInit(&data); Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1); - length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1; + length = TCL_DSTRING_STATIC_SIZE/sizeof(WCHAR) - 1; valueName = Tcl_GetString(valueNameObj); - nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &buf); + Tcl_DStringInit(&buf); + nativeValue = Tcl_UtfToUtf16DString(valueName, valueNameObj->length, &buf); result = RegQueryValueEx(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); @@ -771,8 +776,8 @@ GetValue( * HKEY_PERFORMANCE_DATA */ - length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR)); - Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR)); + length = Tcl_DStringLength(&data) * (2 / sizeof(WCHAR)); + Tcl_DStringSetLength(&data, (int) length * sizeof(WCHAR)); result = RegQueryValueEx(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); } @@ -811,7 +816,8 @@ GetValue( while ((p < end) && *((WCHAR *) p) != 0) { WCHAR *wp; - Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); + Tcl_DStringInit(&buf); + Tcl_Utf16ToUtfDString((WCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); @@ -823,7 +829,8 @@ GetValue( } Tcl_SetObjResult(interp, resultPtr); } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf); + Tcl_DStringInit(&buf); + Tcl_Utf16ToUtfDString((WCHAR *) Tcl_DStringValue(&data), -1, &buf); Tcl_DStringResult(interp, &buf); } else { /* @@ -880,7 +887,7 @@ GetValueNames( resultPtr = Tcl_NewObj(); Tcl_DStringInit(&buffer); - Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(WCHAR))); index = 0; result = TCL_OK; @@ -897,12 +904,11 @@ GetValueNames( */ size = MAX_KEY_LENGTH; - while (RegEnumValue(key,index, (TCHAR *)Tcl_DStringValue(&buffer), + while (RegEnumValue(key,index, (WCHAR *)Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { - size *= sizeof(TCHAR); - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, - &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString((WCHAR *) Tcl_DStringValue(&buffer), size, &ds); name = Tcl_DStringValue(&ds); if (!pattern || Tcl_StringMatch(name, pattern)) { result = Tcl_ListObjAppendElement(interp, resultPtr, @@ -1008,8 +1014,9 @@ OpenSubKey( */ if (hostName) { - hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf); - result = RegConnectRegistry((TCHAR *)hostName, rootKey, + Tcl_DStringInit(&buf); + hostName = (char *) Tcl_UtfToUtf16DString(hostName, -1, &buf); + result = RegConnectRegistry((WCHAR *)hostName, rootKey, &rootKey); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS) { @@ -1023,12 +1030,13 @@ OpenSubKey( */ if (keyName) { - keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); + Tcl_DStringInit(&buf); + keyName = (char *) Tcl_UtfToUtf16DString(keyName, -1, &buf); } if (flags & REG_CREATE) { DWORD create; - result = RegCreateKeyEx(rootKey, (TCHAR *)keyName, 0, NULL, + result = RegCreateKeyEx(rootKey, (WCHAR *)keyName, 0, NULL, REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); } else if (rootKey == HKEY_PERFORMANCE_DATA) { /* @@ -1039,7 +1047,7 @@ OpenSubKey( *keyPtr = HKEY_PERFORMANCE_DATA; result = ERROR_SUCCESS; } else { - result = RegOpenKeyEx(rootKey, (TCHAR *)keyName, 0, mode, + result = RegOpenKeyEx(rootKey, (WCHAR *)keyName, 0, mode, keyPtr); } if (keyName) { @@ -1159,7 +1167,7 @@ ParseKeyName( static DWORD RecursiveDeleteKey( HKEY startKey, /* Parent of key to be deleted. */ - const TCHAR *keyName, /* Name of key to be deleted in external + const WCHAR *keyName, /* Name of key to be deleted in external * encoding, not UTF. */ REGSAM mode) /* Mode flags to pass. */ { @@ -1185,7 +1193,7 @@ RecursiveDeleteKey( } Tcl_DStringInit(&subkey); - Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(WCHAR))); mode = saveMode; while (result == ERROR_SUCCESS) { @@ -1194,7 +1202,7 @@ RecursiveDeleteKey( */ size = MAX_KEY_LENGTH; - result = RegEnumKeyEx(hKey, 0, (TCHAR *)Tcl_DStringValue(&subkey), + result = RegEnumKeyEx(hKey, 0, (WCHAR *)Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); if (result == ERROR_NO_MORE_ITEMS) { /* @@ -1219,7 +1227,7 @@ RecursiveDeleteKey( break; } else if (result == ERROR_SUCCESS) { result = RecursiveDeleteKey(hKey, - (const TCHAR *) Tcl_DStringValue(&subkey), mode); + (const WCHAR *) Tcl_DStringValue(&subkey), mode); } } Tcl_DStringFree(&subkey); @@ -1275,7 +1283,8 @@ SetValue( } valueName = Tcl_GetString(valueNameObj); - valueName = (char *) Tcl_WinUtfToTChar(valueName, valueNameObj->length, &nameBuf); + Tcl_DStringInit(&nameBuf); + valueName = (char *) Tcl_UtfToUtf16DString(valueName, valueNameObj->length, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { int value; @@ -1287,7 +1296,7 @@ SetValue( } value = ConvertDWORD((DWORD) type, (DWORD) value); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueEx(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; @@ -1319,9 +1328,10 @@ SetValue( Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */ } - Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, + Tcl_DStringInit(&buf); + Tcl_UtfToUtf16DString(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, &buf); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueEx(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), (DWORD) Tcl_DStringLength(&buf)); Tcl_DStringFree(&data); @@ -1330,7 +1340,8 @@ SetValue( Tcl_DString buf; const char *data = Tcl_GetString(dataObj); - data = (char *) Tcl_WinUtfToTChar(data, dataObj->length, &buf); + Tcl_DStringInit(&buf); + data = (char *) Tcl_UtfToUtf16DString(data, dataObj->length, &buf); /* * Include the null in the length, padding if needed for WCHAR. @@ -1338,7 +1349,7 @@ SetValue( Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueEx(key, (WCHAR *) valueName, 0, (DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1); Tcl_DStringFree(&buf); } else { @@ -1350,7 +1361,7 @@ SetValue( */ data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + result = RegSetValueEx(key, (WCHAR *) valueName, 0, (DWORD) type, data, (DWORD) bytelength); } @@ -1410,7 +1421,8 @@ BroadcastValue( } str = Tcl_GetString(objv[0]); - wstr = (WCHAR *) Tcl_WinUtfToTChar(str, objv[0]->length, &ds); + Tcl_DStringInit(&ds); + wstr = (WCHAR *) Tcl_UtfToUtf16DString(str, objv[0]->length, &ds); if (Tcl_DStringLength(&ds) == 0) { wstr = NULL; } @@ -1454,7 +1466,7 @@ AppendSystemError( DWORD error) /* Result code from error. */ { int length; - TCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; + WCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; const char *msg; char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; Tcl_DString ds; @@ -1465,7 +1477,7 @@ AppendSystemError( } length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (TCHAR *) tMsgPtrPtr, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) tMsgPtrPtr, 0, NULL); if (length == 0) { sprintf(msgBuf, "unknown error: %ld", error); @@ -1473,7 +1485,8 @@ AppendSystemError( } else { char *msgPtr; - Tcl_WinTCharToUtf(tMsgPtr, -1, &ds); + Tcl_DStringInit(&ds); + Tcl_Utf16ToUtfDString(tMsgPtr, -1, &ds); LocalFree(tMsgPtr); msgPtr = Tcl_DStringValue(&ds); diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 635ea57..41ddbb7 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1669,7 +1669,8 @@ SerialSetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { goto getStateFailed; } - native = Tcl_WinUtfToTChar(value, -1, &ds); + Tcl_DStringInit(&ds); + native = Tcl_UtfToUtf16DString(value, -1, &ds); result = BuildCommDCB(native, &dcb); Tcl_DStringFree(&ds); diff --git a/win/tclWinSock.c b/win/tclWinSock.c index d52edc3..a61328a 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -367,15 +367,15 @@ InitializeHostName( DWORD length = MAX_COMPUTERNAME_LENGTH + 1; Tcl_DString ds; + Tcl_DStringInit(&ds); if (GetComputerName(tbuf, &length) != 0) { /* * Convert string from native to UTF then change to lowercase. */ - Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds)); + Tcl_UtfToLower(Tcl_Utf16ToUtfDString(tbuf, -1, &ds)); } else { - Tcl_DStringInit(&ds); if (TclpHasSockets(NULL) == TCL_OK) { /* * The buffer size of 256 is recommended by the MSDN page that -- cgit v0.12 From 58260d444e3b5a71fb5d06645d34f42e80d013bf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 May 2019 21:50:14 +0000 Subject: More simplifications, taking deprecations into account --- generic/tcl.decls | 27 ++---- generic/tcl.h | 2 +- generic/tclCmdMZ.c | 4 +- generic/tclDecls.h | 53 ++++------- generic/tclInt.h | 2 +- generic/tclStringObj.c | 4 +- generic/tclStubInit.c | 20 ++--- generic/tclUtf.c | 237 +++---------------------------------------------- 8 files changed, 46 insertions(+), 303 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index a93f957..38c5206 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1248,8 +1248,8 @@ declare 351 { declare 352 {deprecated {Use Tcl_GetCharLength}} { int Tcl_UniCharLen(const unsigned short *uniStr) } -declare 353 { - int Tcl_UniCharNcmp(const unsigned short *ucs, const unsigned short *uct, +declare 353 {deprecated {Use Tcl_UtfNcmp}} { + int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars) } declare 354 { @@ -1483,13 +1483,13 @@ declare 417 { declare 418 { int Tcl_IsChannelExisting(const char *channelName) } -declare 419 { - int Tcl_UniCharNcasecmp(const unsigned short *ucs, const unsigned short *uct, +declare 419 {deprecated {Use Tcl_UtfNcasecmp}} { + int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars) } -declare 420 { - int Tcl_UniCharCaseMatch(const unsigned short *uniStr, - const unsigned short *uniPattern, int nocase) +declare 420 {deprecated {Use Tcl_StringCaseMatch}} { + int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, + const Tcl_UniChar *uniPattern, int nocase) } declare 421 { Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key) @@ -2411,19 +2411,6 @@ declare 652 { void TclAppendUnicodeToObj(Tcl_Obj *objPtr, const int *unicode, int length) } -declare 653 { - int Tcl_Utf32Ncmp(const int *ucs, const int *uct, - unsigned long numChars) -} -declare 654 { - int Tcl_Utf32Ncasecmp(const int *ucs, const int *uct, - unsigned long numChars) -} -declare 655 { - int Tcl_Utf32CaseMatch(const int *uniStr, - const int *uniPattern, int nocase) -} - # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tcl.h b/generic/tcl.h index e716aae..d689011 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2144,7 +2144,7 @@ typedef struct Tcl_EncodingType { */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 4 +#define TCL_UTF_MAX 3 #endif /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index e478276..0a42a9a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -604,7 +604,7 @@ Tcl_RegsubObjCmd( numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); - strCmpFn = nocase ? Tcl_Utf32Ncasecmp : Tcl_Utf32Ncmp; + strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; wsrc = TclGetUnicodeFromObj(objv[0], &slen); wstring = TclGetUnicodeFromObj(objv[1], &wlen); @@ -2090,7 +2090,7 @@ StringMapCmd( } end = ustring1 + length1; - strCmpFn = (nocase ? Tcl_Utf32Ncasecmp : Tcl_Utf32Ncmp); + strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); /* * Force result to be Unicode diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 16bf942..05398d4 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1066,8 +1066,9 @@ EXTERN int Tcl_UniCharIsWordChar(int ch); TCL_DEPRECATED("Use Tcl_GetCharLength") int Tcl_UniCharLen(const unsigned short *uniStr); /* 353 */ -EXTERN int Tcl_UniCharNcmp(const unsigned short *ucs, - const unsigned short *uct, +TCL_DEPRECATED("Use Tcl_UtfNcmp") +int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, + const Tcl_UniChar *uct, unsigned long numChars); /* 354 */ EXTERN char * Tcl_Utf16ToUtfDString(const unsigned short *uniStr, @@ -1251,12 +1252,14 @@ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ EXTERN int Tcl_IsChannelExisting(const char *channelName); /* 419 */ -EXTERN int Tcl_UniCharNcasecmp(const unsigned short *ucs, - const unsigned short *uct, +TCL_DEPRECATED("Use Tcl_UtfNcasecmp") +int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, + const Tcl_UniChar *uct, unsigned long numChars); /* 420 */ -EXTERN int Tcl_UniCharCaseMatch(const unsigned short *uniStr, - const unsigned short *uniPattern, int nocase); +TCL_DEPRECATED("Use Tcl_StringCaseMatch") +int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, + const Tcl_UniChar *uniPattern, int nocase); /* 421 */ EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key); @@ -1922,15 +1925,6 @@ EXTERN int * TclGetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 652 */ EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr, const int *unicode, int length); -/* 653 */ -EXTERN int Tcl_Utf32Ncmp(const int *ucs, const int *uct, - unsigned long numChars); -/* 654 */ -EXTERN int Tcl_Utf32Ncasecmp(const int *ucs, const int *uct, - unsigned long numChars); -/* 655 */ -EXTERN int Tcl_Utf32CaseMatch(const int *uniStr, - const int *uniPattern, int nocase); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2319,7 +2313,7 @@ typedef struct TclStubs { int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ TCL_DEPRECATED_API("Use Tcl_GetCharLength") int (*tcl_UniCharLen) (const unsigned short *uniStr); /* 352 */ - int (*tcl_UniCharNcmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */ + TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 353 */ char * (*tcl_Utf16ToUtfDString) (const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ unsigned short * (*tcl_UtfToUtf16DString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ @@ -2385,8 +2379,8 @@ typedef struct TclStubs { void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */ void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ - int (*tcl_UniCharNcasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */ - int (*tcl_UniCharCaseMatch) (const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 420 */ + TCL_DEPRECATED_API("Use Tcl_UtfNcasecmp") int (*tcl_UniCharNcasecmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 419 */ + TCL_DEPRECATED_API("Use Tcl_StringCaseMatch") int (*tcl_UniCharCaseMatch) (const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* 420 */ Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, const void *key); /* 421 */ Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */ void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */ @@ -2619,9 +2613,6 @@ typedef struct TclStubs { Tcl_Obj * (*tclNewUnicodeObj) (const int *unicode, int numChars); /* 650 */ int * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 651 */ void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const int *unicode, int length); /* 652 */ - int (*tcl_Utf32Ncmp) (const int *ucs, const int *uct, unsigned long numChars); /* 653 */ - int (*tcl_Utf32Ncasecmp) (const int *ucs, const int *uct, unsigned long numChars); /* 654 */ - int (*tcl_Utf32CaseMatch) (const int *uniStr, const int *uniPattern, int nocase); /* 655 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3957,12 +3948,6 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclGetUnicodeFromObj) /* 651 */ #define TclAppendUnicodeToObj \ (tclStubsPtr->tclAppendUnicodeToObj) /* 652 */ -#define Tcl_Utf32Ncmp \ - (tclStubsPtr->tcl_Utf32Ncmp) /* 653 */ -#define Tcl_Utf32Ncasecmp \ - (tclStubsPtr->tcl_Utf32Ncasecmp) /* 654 */ -#define Tcl_Utf32CaseMatch \ - (tclStubsPtr->tcl_Utf32CaseMatch) /* 655 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4101,10 +4086,10 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_GetLongFromObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj -# undef Tcl_Utf32Ncmp +# undef Tcl_UniCharNcmp # undef Tcl_UtfNcmp # undef Tcl_UtfNcasecmp -# undef Tcl_Utf32Ncasecmp +# undef Tcl_UniCharNcasecmp # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) # define Tcl_ExprLong TclExprLong static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ @@ -4120,13 +4105,13 @@ extern const TclStubs *tclStubsPtr; if (result == TCL_OK) *ptr = (long)intValue; return result; } -# define Tcl_Utf32Ncmp(ucs,uct,n) \ +# define Tcl_UniCharNcmp(ucs,uct,n) \ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n)) # define Tcl_UtfNcmp(s1,s2,n) \ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n)) # define Tcl_UtfNcasecmp(s1,s2,n) \ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n)) -# define Tcl_Utf32Ncasecmp(ucs,uct,n) \ +# define Tcl_UniCharNcasecmp(ucs,uct,n) \ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n)) # endif #endif @@ -4163,12 +4148,6 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniCharDString Tcl_UtfToUtf16DString # undef Tcl_UtfToUniChar # define Tcl_UtfToUniChar Tcl_UtfToUtf16 -# undef Tcl_Utf32Ncmp -# define Tcl_Utf32Ncmp Tcl_UniCharNcmp -# undef Tcl_Utf32Ncasecmp -# define Tcl_Utf32Ncasecmp Tcl_UniCharNcasecmp -# undef Tcl_Utf32CaseMatch -# define Tcl_Utf32CaseMatch Tcl_UniCharCaseMatch #endif #if TCL_UTF_MAX > 3 || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 diff --git a/generic/tclInt.h b/generic/tclInt.h index fb35fc1..b6db913 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4687,7 +4687,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); #ifdef WORDS_BIGENDIAN # define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) #else /* !WORDS_BIGENDIAN */ -# define TclUniCharNcmp Tcl_Utf32Ncmp +# define TclUniCharNcmp Tcl_UniCharNcmp #endif /* WORDS_BIGENDIAN */ /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 76d875c..5a29477 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3402,7 +3402,7 @@ TclStringCmp( if (nocase) { s1 = (char *) TclGetUnicodeFromObj(value1Ptr, &s1len); s2 = (char *) TclGetUnicodeFromObj(value2Ptr, &s2len); - memCmpFn = (memCmpFn_t)Tcl_Utf32Ncasecmp; + memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp; } else { s1len = Tcl_GetCharLength(value1Ptr); s2len = Tcl_GetCharLength(value2Ptr); @@ -3427,7 +3427,7 @@ TclStringCmp( s1len *= sizeof(Tcl_UniChar); s2len *= sizeof(Tcl_UniChar); } else { - memCmpFn = (memCmpFn_t) Tcl_Utf32Ncmp; + memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; } } } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 5900257..9dded47 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -66,9 +66,6 @@ #undef Tcl_UniCharToUtfDString #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar -#undef Tcl_Utf32Ncmp -#undef Tcl_Utf32Ncasecmp -#undef Tcl_Utf32CaseMatch #undef TclAppendUnicodeToObj static void uniCodePanic() { @@ -87,9 +84,6 @@ static void uniCodePanic() { # define Tcl_UtfToUniChar (int (*)(const char *, int *)) uniCodePanic # define Tcl_UniCharToUtfDString (char *(*)(const int *, int, Tcl_DString *)) uniCodePanic # define Tcl_UtfToUniCharDString (int *(*)(const char *, int, Tcl_DString *)) uniCodePanic -# define Tcl_Utf32CaseMatch (int (*)(const int *, const int *, int)) uniCodePanic -# define Tcl_Utf32Ncmp (int (*)(const int *, const int *, unsigned long)) uniCodePanic -# define Tcl_Utf32Ncasecmp (int (*)(const int *, const int *, unsigned long)) uniCodePanic #else #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *)) uniCodePanic @@ -356,13 +350,13 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))utfNcasecmp #if TCL_UTF_MAX > 3 static int uniCharNcmp(const int *ucs, const int *uct, unsigned int n){ - return Tcl_Utf32Ncmp(ucs, uct, (unsigned long)n); + return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); } -#define Tcl_Utf32Ncmp (int(*)(const int*,const int*,unsigned long))uniCharNcmp +#define Tcl_UniCharNcmp (int(*)(const int*,const int*,unsigned long))uniCharNcmp static int uniCharNcasecmp(const int *ucs, const int *uct, unsigned int n){ - return Tcl_Utf32Ncasecmp(ucs, uct, (unsigned long)n); + return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); } -#define Tcl_Utf32Ncasecmp (int(*)(const int*,const int*,unsigned long))uniCharNcasecmp +#define Tcl_UniCharNcasecmp (int(*)(const int*,const int*,unsigned long))uniCharNcasecmp #else static int utf16Ncmp(const unsigned short *ucs, const unsigned short *uct, unsigned int n){ return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); @@ -520,7 +514,10 @@ tellOld( #endif /* !TCL_NO_DEPRECATED */ #if TCL_UTF_MAX > 3 || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +# define Tcl_UniCharCaseMatch 0 # define Tcl_UniCharLen 0 +# define XTcl_UniCharNcmp 0 +# define XTcl_UniCharNcasecmp 0 #endif /* @@ -1692,9 +1689,6 @@ const TclStubs tclStubs = { TclNewUnicodeObj, /* 650 */ TclGetUnicodeFromObj, /* 651 */ TclAppendUnicodeToObj, /* 652 */ - Tcl_Utf32Ncmp, /* 653 */ - Tcl_Utf32Ncasecmp, /* 654 */ - Tcl_Utf32CaseMatch, /* 655 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 1beadec..b194c1b 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1680,39 +1680,10 @@ Tcl_UniCharLen( *---------------------------------------------------------------------- */ -#if TCL_UTF_MAX > 3 -int -Tcl_Utf32Ncmp( - const int *ucs, /* Unicode string to compare to uct. */ - const int *uct, /* Unicode string ucs is compared to. */ - unsigned long numChars) /* Number of unichars to compare. */ -{ -#ifdef WORDS_BIGENDIAN - /* - * We are definitely on a big-endian machine; memcmp() is safe - */ - - return memcmp(ucs, uct, numChars*sizeof(int)); - -#else /* !WORDS_BIGENDIAN */ - /* - * We can't simply call memcmp() because that is not lexically correct. - */ - - for ( ; numChars != 0; ucs++, uct++, numChars--) { - if (*ucs != *uct) { - return (*ucs - *uct); - } - } - return 0; -#endif /* WORDS_BIGENDIAN */ -} -#endif /* TCL_UTF_MAX > 3 */ - int Tcl_UniCharNcmp( - const unsigned short *ucs, /* Unicode string to compare to uct. */ - const unsigned short *uct, /* Unicode string ucs is compared to. */ + const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ + const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ { #ifdef WORDS_BIGENDIAN @@ -1754,31 +1725,10 @@ Tcl_UniCharNcmp( *---------------------------------------------------------------------- */ -#if TCL_UTF_MAX > 3 -int -Tcl_Utf32Ncasecmp( - const int *ucs, /* Unicode string to compare to uct. */ - const int *uct, /* Unicode string ucs is compared to. */ - unsigned long numChars) /* Number of unichars to compare. */ -{ - for ( ; numChars != 0; numChars--, ucs++, uct++) { - if (*ucs != *uct) { - int lcs = Tcl_UniCharToLower(*ucs); - int lct = Tcl_UniCharToLower(*uct); - - if (lcs != lct) { - return (lcs - lct); - } - } - } - return 0; -} -#endif /* TCL_UTF_MAX > 3 */ - int Tcl_UniCharNcasecmp( - const unsigned short *ucs, /* Utf16 string to compare to uct. */ - const unsigned short *uct, /* Utf16 string ucs is compared to. */ + const Tcl_UniChar *ucs, /* Utf16 string to compare to uct. */ + const Tcl_UniChar *uct, /* Utf16 string ucs is compared to. */ unsigned long numChars) /* Number of Utf16 characters to compare. */ { for ( ; numChars != 0; numChars--, ucs++, uct++) { @@ -2126,184 +2076,16 @@ Tcl_UniCharIsWordChar( *---------------------------------------------------------------------- */ -#if TCL_UTF_MAX > 3 -int -Tcl_Utf32CaseMatch( - const int *uniStr, /* Unicode String. */ - const int *uniPattern, - /* Pattern, which may contain special - * characters. */ - int nocase) /* 0 for case sensitive, 1 for insensitive */ -{ - int ch1 = 0, p; - - while (1) { - p = *uniPattern; - - /* - * See if we're at the end of both the pattern and the string. If so, - * we succeeded. If we're at the end of the pattern but not at the end - * of the string, we failed. - */ - - if (p == 0) { - return (*uniStr == 0); - } - if ((*uniStr == 0) && (p != '*')) { - return 0; - } - - /* - * Check for a "*" as the next pattern character. It matches any - * substring. We handle this by skipping all the characters up to the - * next matching one in the pattern, and then calling ourselves - * recursively for each postfix of string, until either we match or we - * reach the end of the string. - */ - - if (p == '*') { - /* - * Skip all successive *'s in the pattern - */ - - while (*(++uniPattern) == '*') { - /* empty body */ - } - p = *uniPattern; - if (p == 0) { - return 1; - } - if (nocase) { - p = Tcl_UniCharToLower(p); - } - while (1) { - /* - * Optimization for matching - cruise through the string - * quickly if the next char in the pattern isn't a special - * character - */ - - if ((p != '[') && (p != '?') && (p != '\\')) { - if (nocase) { - while (*uniStr && (p != *uniStr) - && (p != Tcl_UniCharToLower(*uniStr))) { - uniStr++; - } - } else { - while (*uniStr && (p != *uniStr)) { - uniStr++; - } - } - } - if (Tcl_Utf32CaseMatch(uniStr, uniPattern, nocase)) { - return 1; - } - if (*uniStr == 0) { - return 0; - } - uniStr++; - } - } - - /* - * Check for a "?" as the next pattern character. It matches any - * single character. - */ - - if (p == '?') { - uniPattern++; - uniStr++; - continue; - } - - /* - * Check for a "[" as the next pattern character. It is followed by a - * list of characters that are acceptable, or by a range (two - * characters separated by "-"). - */ - - if (p == '[') { - int startChar, endChar; - - uniPattern++; - ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); - uniStr++; - while (1) { - if ((*uniPattern == ']') || (*uniPattern == 0)) { - return 0; - } - startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) - : *uniPattern); - uniPattern++; - if (*uniPattern == '-') { - uniPattern++; - if (*uniPattern == 0) { - return 0; - } - endChar = (nocase ? Tcl_UniCharToLower(*uniPattern) - : *uniPattern); - uniPattern++; - if (((startChar <= ch1) && (ch1 <= endChar)) - || ((endChar <= ch1) && (ch1 <= startChar))) { - /* - * Matches ranges of form [a-z] or [z-a]. - */ - break; - } - } else if (startChar == ch1) { - break; - } - } - while (*uniPattern != ']') { - if (*uniPattern == 0) { - uniPattern--; - break; - } - uniPattern++; - } - uniPattern++; - continue; - } - - /* - * If the next pattern character is '\', just strip off the '\' so we - * do exact matching on the character that follows. - */ - - if (p == '\\') { - if (*(++uniPattern) == '\0') { - return 0; - } - } - - /* - * There's no special character. Just make sure that the next bytes of - * each string match. - */ - - if (nocase) { - if (Tcl_UniCharToLower(*uniStr) != - Tcl_UniCharToLower(*uniPattern)) { - return 0; - } - } else if (*uniStr != *uniPattern) { - return 0; - } - uniStr++; - uniPattern++; - } -} -#endif /* TCL_UTF_MAX > 3 */ - +#if !defined(TCL_NO_DEPRECATED) && TCL_UTF_MAX == 3 && TCL_MAJOR_VERSION < 9 int Tcl_UniCharCaseMatch( - const unsigned short *uniStr, /* Unicode String. */ - const unsigned short *uniPattern, + const Tcl_UniChar *uniStr, /* Unicode String. */ + const Tcl_UniChar *uniPattern, /* Pattern, which may contain special * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { - unsigned short ch1 = 0, p; + Tcl_UniChar ch1 = 0, p; while (1) { p = *uniPattern; @@ -2391,7 +2173,7 @@ Tcl_UniCharCaseMatch( */ if (p == '[') { - unsigned short startChar, endChar; + Tcl_UniChar startChar, endChar; uniPattern++; ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); @@ -2461,6 +2243,7 @@ Tcl_UniCharCaseMatch( uniPattern++; } } +#endif /* defined(TCL_NO_DEPRECATED) */ /* *---------------------------------------------------------------------- -- cgit v0.12 From 203f7657fe5533ba1cf4e8fac23cc5155cf13f4a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Aug 2019 21:47:01 +0000 Subject: wrong length in tclMain.c, and wrong #endif --- generic/tclMain.c | 3 --- generic/tclPlatDecls.h | 2 +- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index ce0d6df..276922f 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -70,9 +70,6 @@ NewNativeObj( Tcl_DString ds; #ifdef UNICODE - if (length > 0) { - length *= sizeof(WCHAR); - } Tcl_DStringInit(&ds); Tcl_Char16ToUtfDString(string, length, &ds); #else diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index d1e0b9c..c4b01d0 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -128,6 +128,6 @@ extern const TclPlatStubs *tclPlatStubsPtr; #define Tcl_WinTCharToUtf(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ (char *)Tcl_Char16ToUtfDString((string), ((((len) + 2) >> 1) - 1), (dsPtr))) -#endif#endif +#endif #endif #endif /* _TCLPLATDECLS */ -- cgit v0.12 From 972ac8cc9d03192665f5f6eaaf49fc1b7c97d109 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Aug 2019 21:55:52 +0000 Subject: Protect Tcl_AToB() functions against NULL input --- generic/tclUtf.c | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index ec9000b..d48a51e 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -237,6 +237,9 @@ Tcl_UniCharToUtfDString( * UTF-8 string length in bytes will be <= Unicode string length * 4. */ + if (uniStr == NULL) { + return NULL; + } if (uniLength < 0) { uniLength = 0; w = uniStr; @@ -276,6 +279,9 @@ Tcl_Char16ToUtfDString( * UTF-8 string length in bytes will be <= Utf16 string length * 3. */ + if (uniStr == NULL) { + return NULL; + } if (uniLength < 0) { uniLength = 0; @@ -571,6 +577,9 @@ Tcl_UtfToUniCharDString( const char *p, *end; int oldLength; + if (src == NULL) { + return NULL; + } if (length < 0) { length = strlen(src); } @@ -623,6 +632,9 @@ Tcl_UtfToChar16DString( const char *p, *end; int oldLength; + if (src == NULL) { + return NULL; + } if (length < 0) { length = strlen(src); } -- cgit v0.12 From 92c04315ff11b03e5364e616f3d5efc0a5144d24 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 12 Aug 2019 20:47:01 +0000 Subject: Forgot some changes from tip-548 --- win/tclWin32Dll.c | 2 +- win/tclWinReg.c | 4 ++-- win/tclWinSerial.c | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 668412f..2b05bf3 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -463,7 +463,7 @@ TclWinDriveLetterForVolMountPoint( *--------------------------------------------------------------------------- */ -#if (TCL_UTF_MAX == 3) && !defined(TCL_NO_DEPRECATED) +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #undef Tcl_WinUtfToTChar WCHAR * Tcl_WinUtfToTChar( diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 02c8367..73208b9 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -228,7 +228,7 @@ Registry_Unload( * Delete the originally registered command. */ - cmd = Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); + cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); if (cmd != NULL) { Tcl_DeleteCommandFromToken(interp, cmd); } @@ -257,7 +257,7 @@ static void DeleteCmd( ClientData clientData) { - Tcl_Interp *interp = clientData; + Tcl_Interp *interp = (Tcl_Interp *)clientData; Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL); } diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 4411e89..d6fa567 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -2152,7 +2152,7 @@ SerialGetOptionProc( Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) { - char buf[4]; + char buf[TCL_UTF_MAX]; valid = 1; if (!GetCommState(infoPtr->handle, &dcb)) { -- cgit v0.12 From 4b48c76e1c40761ebe4173552178854265fb50c6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 12 Aug 2019 20:49:50 +0000 Subject: default TCL_UTF_MAX should still be 3 --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index 8f796cc..1c3115d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2144,7 +2144,7 @@ typedef struct Tcl_EncodingType { */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 4 +#define TCL_UTF_MAX 3 #endif /* -- cgit v0.12 From 29db2a676191a091fee12e255a0d990ecae20397 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Nov 2019 14:40:54 +0000 Subject: Some code cleanup. Build with zlib dll on Win32 when using makefile.vc (shared-build only) --- generic/tclIO.c | 6 +++--- generic/tclStringObj.c | 2 +- generic/tclZipfs.c | 2 +- win/makefile.vc | 20 +++++++++++++++++++- win/rules.vc | 6 +++--- 5 files changed, 27 insertions(+), 9 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 36b3fad..643b8f1 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4712,14 +4712,14 @@ Tcl_GetsObj( * Skip the raw bytes that make up the '\n'. */ - char tmp[TCL_UTF_MAX]; int rawRead; + char tmp[TCL_UTF_MAX]; bufPtr = gs.bufPtr; Tcl_ExternalToUtf(NULL, gs.encoding, RemovePoint(bufPtr), gs.rawRead, statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, &gs.state, tmp, - TCL_UTF_MAX, &rawRead, NULL, NULL); + sizeof(tmp), &rawRead, NULL, NULL); bufPtr->nextRemoved += rawRead; gs.rawRead -= rawRead; gs.bytesWrote--; @@ -6282,7 +6282,7 @@ ReadChars( Tcl_ExternalToUtf(NULL, encoding, src, srcLen, (statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE), - &statePtr->inputEncodingState, buffer, TCL_UTF_MAX + 1, + &statePtr->inputEncodingState, buffer, sizeof(buffer), &read, &decoded, &count); if (count == 2) { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 072b642..fdfac99 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2613,7 +2613,7 @@ AppendPrintfToObjVA( end = q; } - q = bytes + TCL_UTF_MAX; + q = bytes + 4; while ((bytes < end) && (bytes < q) && ((*bytes & 0xC0) == 0x80)) { bytes++; diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index f6b6711..393db5c 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -3178,7 +3178,7 @@ TclZipfs_TclLibrary(void) #ifdef _WIN32 HMODULE hModule; WCHAR wName[MAX_PATH + LIBRARY_SIZE]; - char dllName[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; + char dllName[(MAX_PATH + LIBRARY_SIZE) * 3]; #endif /* _WIN32 */ /* diff --git a/win/makefile.vc b/win/makefile.vc index 44597a3..ab0e4b5 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -303,6 +303,7 @@ COREOBJS = \ $(TMP_DIR)\tclZipfs.obj \ $(TMP_DIR)\tclZlib.obj +!if $(STATIC_BUILD) ZLIBOBJS = \ $(TMP_DIR)\adler32.obj \ $(TMP_DIR)\compress.obj \ @@ -315,6 +316,9 @@ ZLIBOBJS = \ $(TMP_DIR)\trees.obj \ $(TMP_DIR)\uncompr.obj \ $(TMP_DIR)\zutil.obj +!else +ZLIBOBJS = $(OUT_DIR)\zdll.lib +!endif TOMMATHOBJS = \ $(TMP_DIR)\bn_mp_add.obj \ @@ -446,7 +450,7 @@ TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs core: setup $(TCLLIB) $(TCLSTUBLIB) shell: setup $(TCLSH) -dlls: setup $(TCLREGLIB) $(TCLDDELIB) +dlls: setup $(TCLREGLIB) $(TCLDDELIB) $(OUT_DIR)\zlib1.dll all: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs tcltest: setup $(TCLTEST) dlls install: install-binaries install-libraries install-docs install-pkgs @@ -519,6 +523,19 @@ $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB) $(_VC_MANIFEST_EMBED_DLL) !endif +!if "$(MACHINE)" == "AMD64" +$(OUT_DIR)\zlib1.dll: $(COMPATDIR)\zlib\win64\zlib1.dll + $(COPY) $(COMPATDIR)\zlib\win64\zlib1.dll $(OUT_DIR)\zlib1.dll +$(OUT_DIR)\zdll.lib: $(COMPATDIR)\zlib\win64\zdll.lib + $(COPY) $(COMPATDIR)\zlib\win64\zdll.lib $(OUT_DIR)\zdll.lib +!else +$(OUT_DIR)\zlib1.dll: $(COMPATDIR)\zlib\win32\zlib1.dll + $(COPY) $(COMPATDIR)\zlib\win32\zlib1.dll $(OUT_DIR)\zlib1.dll +$(OUT_DIR)\zdll.lib: $(COMPATDIR)\zlib\win32\zdll.lib + $(COPY) $(COMPATDIR)\zlib\win32\zdll.lib $(OUT_DIR)\zdll.lib +!endif + + pkgs: @for /d %d in ($(PKGSDIR)\*) do \ @if exist "%~fd\win\makefile.vc" ( \ @@ -871,6 +888,7 @@ install-binaries: @$(CPY) "$(TCLLIB)" "$(BIN_INSTALL_DIR)\" !endif @$(CPY) "$(TCLIMPLIB)" "$(LIB_INSTALL_DIR)\" + @$(CPY) "$(OUT_DIR)\zlib1.dll" "$(BIN_INSTALL_DIR)\" !if exist($(TCLSH)) @echo Installing $(TCLSHNAME) @$(CPY) "$(TCLSH)" "$(BIN_INSTALL_DIR)\" diff --git a/win/rules.vc b/win/rules.vc index c35e3c6..e0225a2 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1190,8 +1190,8 @@ tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" !endif # $(DOING_TK) || $(NEED_TK) # Various output paths -PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX:t=).lib -PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX:t=).$(EXT) +PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib +PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) PRJLIB = $(OUT_DIR)\$(PRJLIBNAME) PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib @@ -1493,7 +1493,7 @@ RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ /DCOMMAVERSION=$(DOTVERSION:.=,),0 \ /DDOTVERSION=\"$(DOTVERSION)\" \ /DVERSION=\"$(VERSION)\" \ - /DSUFX=\"$(SUFX:t=)\" \ + /DSUFX=\"$(SUFX)\" \ /DPROJECT=\"$(PROJECT)\" \ /DPRJLIBNAME=\"$(PRJLIBNAME)\" -- cgit v0.12 From f8474f319cd5f760b58a607747e8c5d35443db8d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 11 Dec 2019 12:41:00 +0000 Subject: Implement "panic" as described in the TIP --- generic/tcl.h | 17 ++++++----------- generic/tclStubInit.c | 32 ++++++++++++++++++++++++-------- 2 files changed, 30 insertions(+), 19 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 8521041..1a70ae4 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2106,12 +2106,11 @@ typedef struct Tcl_EncodingType { /* * The maximum number of bytes that are necessary to represent a single - * Unicode character in UTF-8. The valid values are 4 and 6 - * (or perhaps 1 if we want to support a non-unicode enabled core). If 4, - * then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6, + * Unicode character in UTF-8. The valid values are 3 and 4 + * (or perhaps 1 if we want to support a non-unicode enabled core). If 3, + * then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If > 3, * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UCS-2 mode - * is the default and recommended mode. UCS-4 is experimental and not - * recommended. It works for the core, but most extensions expect UCS-2. + * is the default and recommended mode. */ #ifndef TCL_UTF_MAX @@ -2126,12 +2125,8 @@ typedef struct Tcl_EncodingType { #if TCL_UTF_MAX > 3 /* * int isn't 100% accurate as it should be a strict 4-byte value - * (perhaps wchar_t). 64-bit systems may have troubles. The size of this - * value must be reflected correctly in regcustom.h and - * in tclEncoding.c. - * XXX: Tcl is currently UCS-2 and planning UTF-16 for the Unicode - * XXX: string rep that Tcl_UniChar represents. Changing the size - * XXX: of Tcl_UniChar is /not/ supported. + * (perhaps wchar_t). ILP64/SILP64 systems may have troubles. The + * size of this value must be reflected correctly in regcustom.h. */ typedef int Tcl_UniChar; #else diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index c489608..e1fe23d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -71,6 +71,21 @@ #undef Tcl_UtfToUniCharDString #undef Tcl_UtfToUniChar +#if TCL_UTF_MAX > 3 +static void uniCodePanic() { + Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX); +} +# define Tcl_GetUnicode (int *(*)(Tcl_Obj *)) uniCodePanic +# define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, Tcl_UniChar *)) uniCodePanic +# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, Tcl_UniChar)) uniCodePanic +# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int)) uniCodePanic +# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int)) uniCodePanic +# define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long)) uniCodePanic +# define Tcl_UniCharCaseMatch (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, int)) uniCodePanic +# define Tcl_UniCharLen (int(*)(const Tcl_UniChar *)) uniCodePanic +# define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long)) uniCodePanic +#endif + #undef TclBN_mp_tc_and #undef TclBN_mp_tc_or #undef TclBN_mp_tc_xor @@ -409,10 +424,16 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ return result; } #define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj +#if TCL_UTF_MAX < 4 static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); } #define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcmp +static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ + return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); +} +#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcasecmp +#endif static int utfNcmp(const char *s1, const char *s2, unsigned int n){ return Tcl_UtfNcmp(s1, s2, (unsigned long)n); } @@ -421,10 +442,6 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n); } #define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))utfNcasecmp -static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ - return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); -} -#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcasecmp #endif /* TCL_WIDE_INT_IS_LONG */ @@ -519,15 +536,14 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig # define Tcl_SetExitProc 0 # define Tcl_SetPanicProc 0 # define Tcl_FindExecutable 0 -# define Tcl_GetUnicodeFromObj 0 # define Tcl_GetUnicode 0 +#if TCL_UTF_MAX < 4 # define Tcl_AppendUnicodeToObj 0 -# define Tcl_NewUnicodeObj 0 -# define Tcl_SetUnicodeObj 0 -# define Tcl_UniCharNcasecmp 0 # define Tcl_UniCharCaseMatch 0 # define Tcl_UniCharLen 0 +# define Tcl_UniCharNcasecmp 0 # define Tcl_UniCharNcmp 0 +#endif # undef Tcl_StringMatch # define Tcl_StringMatch 0 # define TclBN_reverse 0 -- cgit v0.12 From e3f42b0c1afa79ffc4221e09f7eba2845a66f3ae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 12 Dec 2019 08:23:58 +0000 Subject: Little doc tweak --- doc/Utf.3 | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/doc/Utf.3 b/doc/Utf.3 index b2a8389..09e6420 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -153,13 +153,12 @@ case-insensitive (1). .SH DESCRIPTION .PP These routines convert between UTF-8 strings and Unicode/Utf-16 characters. -An Unicode character represented as an unsigned, fixed-size -quantity. A UTF-8 character is a Unicode character represented as -a varying-length sequence of up to \fBTCL_UTF_MAX\fR bytes. A multibyte UTF-8 -sequence consists of a lead byte followed by some number of trail bytes. +A UTF-8 character is a Unicode character represented as a varying-length +sequence of up to \fB4\fR bytes. A multibyte UTF-8 sequence +consists of a lead byte followed by some number of trail bytes. .PP -\fBTCL_UTF_MAX\fR is the maximum number of bytes that it takes to -represent one Unicode character in the UTF-8 representation. +\fBTCL_UTF_MAX\fR is the maximum number of bytes that \fBTcl_UtfToUniChar\fR +can consume in a single call. .PP \fBTcl_UniCharToUtf\fR stores the character \fIch\fR as a UTF-8 string in starting at \fIbuf\fR. The return value is the number of bytes stored -- cgit v0.12 From 88e4842dfe272fa62dafad30ca1f11b396f06d71 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 17 Dec 2019 23:14:53 +0000 Subject: Put back 4 test-cases as they were in core-8-branch, but only for TCL_UTF_MAX=3 --- generic/tclTestObj.c | 35 ++++++++++++++++++++++++++++++++++- tests/stringObj.test | 17 +++++++++++++++++ 2 files changed, 51 insertions(+), 1 deletion(-) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 1446f86..e616433 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1174,6 +1174,7 @@ TeststringobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_UniChar *unicode; int varIndex, option, i, length; #define MAX_STRINGS 11 const char *index, *string, *strings[MAX_STRINGS+1]; @@ -1181,7 +1182,8 @@ TeststringobjCmd( Tcl_Obj **varPtr; static const char *const options[] = { "append", "appendstrings", "get", "get2", "length", "length2", - "set", "set2", "setlength", "maxchars", "appendself", NULL + "set", "set2", "setlength", "maxchars", "appendself", + "appendself2", NULL }; if (objc < 3) { @@ -1377,6 +1379,37 @@ TeststringobjCmd( Tcl_AppendToObj(varPtr[varIndex], string + i, length - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; + case 11: /* appendself2 */ + if (objc != 4) { + goto wrongNumArgs; + } + if (varPtr[varIndex] == NULL) { + SetVarToObj(varPtr, varIndex, Tcl_NewObj()); + } + + /* + * If the object bound to variable "varIndex" is shared, we must + * "copy on write" and append to a copy of the object. + */ + + if (Tcl_IsShared(varPtr[varIndex])) { + SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); + } + + unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length); + + if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { + return TCL_ERROR; + } + if ((i < 0) || (i > length)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "index value out of range", -1)); + return TCL_ERROR; + } + + Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i); + Tcl_SetObjResult(interp, varPtr[varIndex]); + break; } return TCL_OK; diff --git a/tests/stringObj.test b/tests/stringObj.test index cc9d123..8b10897 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -23,6 +23,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [llength [info commands testobj]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] +testConstraint tip389 [expr {[string length \U010000] == 2}] test stringObj-1.1 {string type registration} testobj { set t [testobj types] @@ -464,6 +465,22 @@ test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 3 } foo +test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj tip389} { + teststringobj set 1 foo + teststringobj appendself2 1 0 +} foofoo +test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj tip389} { + teststringobj set 1 foo + teststringobj appendself2 1 1 +} foooo +test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj tip389} { + teststringobj set 1 foo + teststringobj appendself2 1 2 +} fooo +test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj tip389} { + teststringobj set 1 foo + teststringobj appendself2 1 3 +} foo if {[testConstraint testobj]} { testobj freeallvars -- cgit v0.12 From 3254602d80de090afe1a7caebeb7dd7a6d42d3f2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 24 Dec 2019 14:23:42 +0000 Subject: Attempt to improve support for external libtommath --- unix/configure | 430 +++++++++++++++++++++++++++--------------------------- unix/configure.ac | 88 +++++------ 2 files changed, 259 insertions(+), 259 deletions(-) diff --git a/unix/configure b/unix/configure index 74b7343..8d79cc3 100755 --- a/unix/configure +++ b/unix/configure @@ -675,6 +675,12 @@ ZIP_PROG EXEEXT_FOR_BUILD CC_FOR_BUILD DTRACE +TOMMATH_INCLUDE +TOMMATH_SRCS +TOMMATH_OBJS +ZLIB_INCLUDE +ZLIB_SRCS +ZLIB_OBJS LDFLAGS_DEFAULT CFLAGS_DEFAULT INSTALL_STUB_LIB @@ -705,12 +711,6 @@ TCL_LIBS LIBOBJS AR RANLIB -TOMMATH_INCLUDE -TOMMATH_SRCS -TOMMATH_OBJS -ZLIB_INCLUDE -ZLIB_SRCS -ZLIB_OBJS TCLSH_PROG SHARED_BUILD EGREP @@ -771,7 +771,6 @@ enable_man_compression enable_man_suffix with_encoding enable_shared -with_system_libtommath enable_64bit enable_64bit_vis enable_rpath @@ -780,6 +779,7 @@ enable_load enable_symbols enable_langinfo enable_dll_unloading +with_system_libtommath with_tzdata enable_dtrace enable_zipfs @@ -4552,214 +4552,6 @@ if test "$TCLSH_PROG" = ""; then TCLSH_PROG='./${TCL_EXE}' fi -#------------------------------------------------------------------------ -# Add stuff for zlib -#------------------------------------------------------------------------ - -zlib_ok=yes -ac_fn_c_check_header_mongrel "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default" -if test "x$ac_cv_header_zlib_h" = xyes; then : - - ac_fn_c_check_type "$LINENO" "gz_header" "ac_cv_type_gz_header" "#include -" -if test "x$ac_cv_type_gz_header" = xyes; then : - -else - zlib_ok=no -fi - -else - - zlib_ok=no -fi - - -if test $zlib_ok = yes; then : - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5 -$as_echo_n "checking for library containing deflateSetHeader... " >&6; } -if ${ac_cv_search_deflateSetHeader+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_func_search_save_LIBS=$LIBS -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char deflateSetHeader (); -int -main () -{ -return deflateSetHeader (); - ; - return 0; -} -_ACEOF -for ac_lib in '' z; do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_c_try_link "$LINENO"; then : - ac_cv_search_deflateSetHeader=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext - if ${ac_cv_search_deflateSetHeader+:} false; then : - break -fi -done -if ${ac_cv_search_deflateSetHeader+:} false; then : - -else - ac_cv_search_deflateSetHeader=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5 -$as_echo "$ac_cv_search_deflateSetHeader" >&6; } -ac_res=$ac_cv_search_deflateSetHeader -if test "$ac_res" != no; then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - -else - - zlib_ok=no - -fi - -fi -if test $zlib_ok = no; then : - - ZLIB_OBJS=\${ZLIB_OBJS} - - ZLIB_SRCS=\${ZLIB_SRCS} - - ZLIB_INCLUDE=-I\${ZLIB_DIR} - - -fi - -$as_echo "#define HAVE_ZLIB 1" >>confdefs.h - - -#------------------------------------------------------------------------ -# Add stuff for libtommath - -libtommath_ok=yes - -# Check whether --with-system-libtommath was given. -if test "${with_system_libtommath+set}" = set; then : - withval=$with_system_libtommath; libtommath_ok=${withval} -fi - -if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then - ac_fn_c_check_header_mongrel "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default" -if test "x$ac_cv_header_tommath_h" = xyes; then : - - ac_fn_c_check_type "$LINENO" "mp_int" "ac_cv_type_mp_int" "#include -" -if test "x$ac_cv_type_mp_int" = xyes; then : - -else - libtommath_ok=no -fi - -else - - libtommath_ok=no -fi - - - if test $libtommath_ok = yes; then : - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing mp_log_u32" >&5 -$as_echo_n "checking for library containing mp_log_u32... " >&6; } -if ${ac_cv_search_mp_log_u32+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_func_search_save_LIBS=$LIBS -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char mp_log_u32 (); -int -main () -{ -return mp_log_u32 (); - ; - return 0; -} -_ACEOF -for ac_lib in '' tommath; do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_c_try_link "$LINENO"; then : - ac_cv_search_mp_log_u32=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext - if ${ac_cv_search_mp_log_u32+:} false; then : - break -fi -done -if ${ac_cv_search_mp_log_u32+:} false; then : - -else - ac_cv_search_mp_log_u32=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_mp_log_u32" >&5 -$as_echo "$ac_cv_search_mp_log_u32" >&6; } -ac_res=$ac_cv_search_mp_log_u32 -if test "$ac_res" != no; then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - -else - - libtommath_ok=no - -fi - -fi -fi -if test $libtommath_ok = yes; then : - - -$as_echo "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h - - -else - - TOMMATH_OBJS=\${TOMMATH_OBJS} - - TOMMATH_SRCS=\${TOMMATH_SRCS} - - TOMMATH_INCLUDE=-I\${TOMMATH_DIR} - - -fi - #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called @@ -10003,6 +9795,214 @@ fi $as_echo "$tcl_ok" >&6; } #------------------------------------------------------------------------ +# Add stuff for zlib +#------------------------------------------------------------------------ + +zlib_ok=yes +ac_fn_c_check_header_mongrel "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default" +if test "x$ac_cv_header_zlib_h" = xyes; then : + + ac_fn_c_check_type "$LINENO" "gz_header" "ac_cv_type_gz_header" "#include +" +if test "x$ac_cv_type_gz_header" = xyes; then : + +else + zlib_ok=no +fi + +else + + zlib_ok=no +fi + + +if test $zlib_ok = yes; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5 +$as_echo_n "checking for library containing deflateSetHeader... " >&6; } +if ${ac_cv_search_deflateSetHeader+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_func_search_save_LIBS=$LIBS +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char deflateSetHeader (); +int +main () +{ +return deflateSetHeader (); + ; + return 0; +} +_ACEOF +for ac_lib in '' z; do + if test -z "$ac_lib"; then + ac_res="none required" + else + ac_res=-l$ac_lib + LIBS="-l$ac_lib $ac_func_search_save_LIBS" + fi + if ac_fn_c_try_link "$LINENO"; then : + ac_cv_search_deflateSetHeader=$ac_res +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext + if ${ac_cv_search_deflateSetHeader+:} false; then : + break +fi +done +if ${ac_cv_search_deflateSetHeader+:} false; then : + +else + ac_cv_search_deflateSetHeader=no +fi +rm conftest.$ac_ext +LIBS=$ac_func_search_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5 +$as_echo "$ac_cv_search_deflateSetHeader" >&6; } +ac_res=$ac_cv_search_deflateSetHeader +if test "$ac_res" != no; then : + test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" + +else + + zlib_ok=no + +fi + +fi +if test $zlib_ok = no; then : + + ZLIB_OBJS=\${ZLIB_OBJS} + + ZLIB_SRCS=\${ZLIB_SRCS} + + ZLIB_INCLUDE=-I\${ZLIB_DIR} + + +fi + +$as_echo "#define HAVE_ZLIB 1" >>confdefs.h + + +#------------------------------------------------------------------------ +# Add stuff for libtommath + +libtommath_ok=yes + +# Check whether --with-system-libtommath was given. +if test "${with_system_libtommath+set}" = set; then : + withval=$with_system_libtommath; libtommath_ok=${withval} +fi + +if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then + ac_fn_c_check_header_mongrel "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default" +if test "x$ac_cv_header_tommath_h" = xyes; then : + + ac_fn_c_check_type "$LINENO" "mp_int" "ac_cv_type_mp_int" "#include +" +if test "x$ac_cv_type_mp_int" = xyes; then : + +else + libtommath_ok=no +fi + +else + + libtommath_ok=no +fi + + + if test $libtommath_ok = yes; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing mp_log_u32" >&5 +$as_echo_n "checking for library containing mp_log_u32... " >&6; } +if ${ac_cv_search_mp_log_u32+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_func_search_save_LIBS=$LIBS +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char mp_log_u32 (); +int +main () +{ +return mp_log_u32 (); + ; + return 0; +} +_ACEOF +for ac_lib in '' tommath; do + if test -z "$ac_lib"; then + ac_res="none required" + else + ac_res=-l$ac_lib + LIBS="-l$ac_lib $ac_func_search_save_LIBS" + fi + if ac_fn_c_try_link "$LINENO"; then : + ac_cv_search_mp_log_u32=$ac_res +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext + if ${ac_cv_search_mp_log_u32+:} false; then : + break +fi +done +if ${ac_cv_search_mp_log_u32+:} false; then : + +else + ac_cv_search_mp_log_u32=no +fi +rm conftest.$ac_ext +LIBS=$ac_func_search_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_mp_log_u32" >&5 +$as_echo "$ac_cv_search_mp_log_u32" >&6; } +ac_res=$ac_cv_search_mp_log_u32 +if test "$ac_res" != no; then : + test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" + +else + + libtommath_ok=no + +fi + +fi +fi +if test $libtommath_ok = yes; then : + + +$as_echo "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h + + +else + + TOMMATH_OBJS=\${TOMMATH_OBJS} + + TOMMATH_SRCS=\${TOMMATH_SRCS} + + TOMMATH_INCLUDE=-I\${TOMMATH_DIR} + + +fi + +#------------------------------------------------------------------------ # Check whether the timezone data is supplied by the OS or has # to be installed by Tcl. The default is autodetection, but can # be overridden on the configure command line either way. diff --git a/unix/configure.ac b/unix/configure.ac index a5cb12b..23eaad0 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -148,50 +148,6 @@ if test "$TCLSH_PROG" = ""; then TCLSH_PROG='./${TCL_EXE}' fi -#------------------------------------------------------------------------ -# Add stuff for zlib -#------------------------------------------------------------------------ - -zlib_ok=yes -AC_CHECK_HEADER([zlib.h],[ - AC_CHECK_TYPE([gz_header],[],[zlib_ok=no],[#include ])],[ - zlib_ok=no]) -AS_IF([test $zlib_ok = yes], [ - AC_SEARCH_LIBS([deflateSetHeader],[z],[],[ - zlib_ok=no - ])]) -AS_IF([test $zlib_ok = no], [ - AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) - AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}]) - AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}]) -]) -AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) - -#------------------------------------------------------------------------ -# Add stuff for libtommath - -libtommath_ok=yes -AC_ARG_WITH(system-libtommath, -AC_HELP_STRING([--with-system-libtommath], - [use external libtommath (default: true if available, false otherwise)]), - libtommath_ok=${withval}) -if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then - AC_CHECK_HEADER([tommath.h],[ - AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include ])],[ - libtommath_ok=no]) - AS_IF([test $libtommath_ok = yes], [ - AC_SEARCH_LIBS([mp_log_u32],[tommath],[],[ - libtommath_ok=no - ])]) -fi -AS_IF([test $libtommath_ok = yes], [ - AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath]) -], [ - AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}]) - AC_SUBST(TOMMATH_SRCS,[\${TOMMATH_SRCS}]) - AC_SUBST(TOMMATH_INCLUDE,[-I\${TOMMATH_DIR}]) -]) - #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called @@ -700,6 +656,50 @@ fi AC_MSG_RESULT([$tcl_ok]) #------------------------------------------------------------------------ +# Add stuff for zlib +#------------------------------------------------------------------------ + +zlib_ok=yes +AC_CHECK_HEADER([zlib.h],[ + AC_CHECK_TYPE([gz_header],[],[zlib_ok=no],[#include ])],[ + zlib_ok=no]) +AS_IF([test $zlib_ok = yes], [ + AC_SEARCH_LIBS([deflateSetHeader],[z],[],[ + zlib_ok=no + ])]) +AS_IF([test $zlib_ok = no], [ + AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) + AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}]) + AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}]) +]) +AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) + +#------------------------------------------------------------------------ +# Add stuff for libtommath + +libtommath_ok=yes +AC_ARG_WITH(system-libtommath, +AC_HELP_STRING([--with-system-libtommath], + [use external libtommath (default: true if available, false otherwise)]), + libtommath_ok=${withval}) +if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then + AC_CHECK_HEADER([tommath.h],[ + AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include ])],[ + libtommath_ok=no]) + AS_IF([test $libtommath_ok = yes], [ + AC_SEARCH_LIBS([mp_log_u32],[tommath],[],[ + libtommath_ok=no + ])]) +fi +AS_IF([test $libtommath_ok = yes], [ + AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath]) +], [ + AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}]) + AC_SUBST(TOMMATH_SRCS,[\${TOMMATH_SRCS}]) + AC_SUBST(TOMMATH_INCLUDE,[-I\${TOMMATH_DIR}]) +]) + +#------------------------------------------------------------------------ # Check whether the timezone data is supplied by the OS or has # to be installed by Tcl. The default is autodetection, but can # be overridden on the configure command line either way. -- cgit v0.12 From 54aabbf0531d892183d72597647df8e780d6deac Mon Sep 17 00:00:00 2001 From: gahr Date: Fri, 27 Dec 2019 12:11:38 +0000 Subject: Use AC_CHECK_LIB and put ltommath in MATH_LIBS to avoid polluting LIBS --- unix/configure.ac | 87 +++++++++++++++++++++++++++---------------------------- 1 file changed, 43 insertions(+), 44 deletions(-) diff --git a/unix/configure.ac b/unix/configure.ac index 23eaad0..b2370b7 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -148,6 +148,49 @@ if test "$TCLSH_PROG" = ""; then TCLSH_PROG='./${TCL_EXE}' fi +#------------------------------------------------------------------------ +# Add stuff for zlib +#------------------------------------------------------------------------ + +zlib_ok=yes +AC_CHECK_HEADER([zlib.h],[ + AC_CHECK_TYPE([gz_header],[],[zlib_ok=no],[#include ])],[ + zlib_ok=no]) +AS_IF([test $zlib_ok = yes], [ + AC_SEARCH_LIBS([deflateSetHeader],[z],[],[ + zlib_ok=no + ])]) +AS_IF([test $zlib_ok = no], [ + AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) + AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}]) + AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}]) +]) +AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) + +#------------------------------------------------------------------------ +# Add stuff for libtommath + +libtommath_ok=yes +AC_ARG_WITH(system-libtommath, +AC_HELP_STRING([--with-system-libtommath], + [use external libtommath (default: true if available, false otherwise)]), + libtommath_ok=${withval}) +if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then + AC_CHECK_HEADER([tommath.h],[ + AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include ])],[ + libtommath_ok=no]) + AS_IF([test $libtommath_ok = yes], [ + AC_CHECK_LIB([tommath],[mp_log_u32],[MATH_LIBS="$MATH_LIBS -ltommath"],[ + libtommath_ok=no])]) +fi +AS_IF([test $libtommath_ok = yes], [ + AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath]) +], [ + AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}]) + AC_SUBST(TOMMATH_SRCS,[\${TOMMATH_SRCS}]) + AC_SUBST(TOMMATH_INCLUDE,[-I\${TOMMATH_DIR}]) +]) + #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called @@ -656,50 +699,6 @@ fi AC_MSG_RESULT([$tcl_ok]) #------------------------------------------------------------------------ -# Add stuff for zlib -#------------------------------------------------------------------------ - -zlib_ok=yes -AC_CHECK_HEADER([zlib.h],[ - AC_CHECK_TYPE([gz_header],[],[zlib_ok=no],[#include ])],[ - zlib_ok=no]) -AS_IF([test $zlib_ok = yes], [ - AC_SEARCH_LIBS([deflateSetHeader],[z],[],[ - zlib_ok=no - ])]) -AS_IF([test $zlib_ok = no], [ - AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) - AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}]) - AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}]) -]) -AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) - -#------------------------------------------------------------------------ -# Add stuff for libtommath - -libtommath_ok=yes -AC_ARG_WITH(system-libtommath, -AC_HELP_STRING([--with-system-libtommath], - [use external libtommath (default: true if available, false otherwise)]), - libtommath_ok=${withval}) -if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then - AC_CHECK_HEADER([tommath.h],[ - AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include ])],[ - libtommath_ok=no]) - AS_IF([test $libtommath_ok = yes], [ - AC_SEARCH_LIBS([mp_log_u32],[tommath],[],[ - libtommath_ok=no - ])]) -fi -AS_IF([test $libtommath_ok = yes], [ - AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath]) -], [ - AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}]) - AC_SUBST(TOMMATH_SRCS,[\${TOMMATH_SRCS}]) - AC_SUBST(TOMMATH_INCLUDE,[-I\${TOMMATH_DIR}]) -]) - -#------------------------------------------------------------------------ # Check whether the timezone data is supplied by the OS or has # to be installed by Tcl. The default is autodetection, but can # be overridden on the configure command line either way. -- cgit v0.12 From 70b0310ff768715978d48ea90453e846d989d559 Mon Sep 17 00:00:00 2001 From: gahr Date: Fri, 27 Dec 2019 12:12:15 +0000 Subject: Make sure LDFLAGS are propagated to MAKE_LIB --- unix/tcl.m4 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/unix/tcl.m4 b/unix/tcl.m4 index e90ff7b..0d0716b 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1385,7 +1385,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - LDFLAGS="" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) @@ -1822,7 +1821,7 @@ dnl # preprocessing tests use only CPPFLAGS. AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [ LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' + MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS} ${LDFLAGS}' AS_IF([test "${SHLIB_SUFFIX}" = ".dll"], [ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)" -- cgit v0.12 From a5fd8b5d9c7e499c5fd12e6837e292c30d58a426 Mon Sep 17 00:00:00 2001 From: gahr Date: Fri, 27 Dec 2019 12:13:15 +0000 Subject: Regenerate configure --- unix/configure | 416 +++++++++++++++++++++++++++------------------------------ 1 file changed, 199 insertions(+), 217 deletions(-) diff --git a/unix/configure b/unix/configure index 8d79cc3..0321050 100755 --- a/unix/configure +++ b/unix/configure @@ -675,12 +675,6 @@ ZIP_PROG EXEEXT_FOR_BUILD CC_FOR_BUILD DTRACE -TOMMATH_INCLUDE -TOMMATH_SRCS -TOMMATH_OBJS -ZLIB_INCLUDE -ZLIB_SRCS -ZLIB_OBJS LDFLAGS_DEFAULT CFLAGS_DEFAULT INSTALL_STUB_LIB @@ -711,6 +705,12 @@ TCL_LIBS LIBOBJS AR RANLIB +TOMMATH_INCLUDE +TOMMATH_SRCS +TOMMATH_OBJS +ZLIB_INCLUDE +ZLIB_SRCS +ZLIB_OBJS TCLSH_PROG SHARED_BUILD EGREP @@ -771,6 +771,7 @@ enable_man_compression enable_man_suffix with_encoding enable_shared +with_system_libtommath enable_64bit enable_64bit_vis enable_rpath @@ -779,7 +780,6 @@ enable_load enable_symbols enable_langinfo enable_dll_unloading -with_system_libtommath with_tzdata enable_dtrace enable_zipfs @@ -4552,6 +4552,197 @@ if test "$TCLSH_PROG" = ""; then TCLSH_PROG='./${TCL_EXE}' fi +#------------------------------------------------------------------------ +# Add stuff for zlib +#------------------------------------------------------------------------ + +zlib_ok=yes +ac_fn_c_check_header_mongrel "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default" +if test "x$ac_cv_header_zlib_h" = xyes; then : + + ac_fn_c_check_type "$LINENO" "gz_header" "ac_cv_type_gz_header" "#include +" +if test "x$ac_cv_type_gz_header" = xyes; then : + +else + zlib_ok=no +fi + +else + + zlib_ok=no +fi + + +if test $zlib_ok = yes; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5 +$as_echo_n "checking for library containing deflateSetHeader... " >&6; } +if ${ac_cv_search_deflateSetHeader+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_func_search_save_LIBS=$LIBS +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char deflateSetHeader (); +int +main () +{ +return deflateSetHeader (); + ; + return 0; +} +_ACEOF +for ac_lib in '' z; do + if test -z "$ac_lib"; then + ac_res="none required" + else + ac_res=-l$ac_lib + LIBS="-l$ac_lib $ac_func_search_save_LIBS" + fi + if ac_fn_c_try_link "$LINENO"; then : + ac_cv_search_deflateSetHeader=$ac_res +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext + if ${ac_cv_search_deflateSetHeader+:} false; then : + break +fi +done +if ${ac_cv_search_deflateSetHeader+:} false; then : + +else + ac_cv_search_deflateSetHeader=no +fi +rm conftest.$ac_ext +LIBS=$ac_func_search_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5 +$as_echo "$ac_cv_search_deflateSetHeader" >&6; } +ac_res=$ac_cv_search_deflateSetHeader +if test "$ac_res" != no; then : + test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" + +else + + zlib_ok=no + +fi + +fi +if test $zlib_ok = no; then : + + ZLIB_OBJS=\${ZLIB_OBJS} + + ZLIB_SRCS=\${ZLIB_SRCS} + + ZLIB_INCLUDE=-I\${ZLIB_DIR} + + +fi + +$as_echo "#define HAVE_ZLIB 1" >>confdefs.h + + +#------------------------------------------------------------------------ +# Add stuff for libtommath + +libtommath_ok=yes + +# Check whether --with-system-libtommath was given. +if test "${with_system_libtommath+set}" = set; then : + withval=$with_system_libtommath; libtommath_ok=${withval} +fi + +if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then + ac_fn_c_check_header_mongrel "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default" +if test "x$ac_cv_header_tommath_h" = xyes; then : + + ac_fn_c_check_type "$LINENO" "mp_int" "ac_cv_type_mp_int" "#include +" +if test "x$ac_cv_type_mp_int" = xyes; then : + +else + libtommath_ok=no +fi + +else + + libtommath_ok=no +fi + + + if test $libtommath_ok = yes; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mp_log_u32 in -ltommath" >&5 +$as_echo_n "checking for mp_log_u32 in -ltommath... " >&6; } +if ${ac_cv_lib_tommath_mp_log_u32+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ltommath $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char mp_log_u32 (); +int +main () +{ +return mp_log_u32 (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_tommath_mp_log_u32=yes +else + ac_cv_lib_tommath_mp_log_u32=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tommath_mp_log_u32" >&5 +$as_echo "$ac_cv_lib_tommath_mp_log_u32" >&6; } +if test "x$ac_cv_lib_tommath_mp_log_u32" = xyes; then : + MATH_LIBS="$MATH_LIBS -ltommath" +else + + libtommath_ok=no +fi + +fi +fi +if test $libtommath_ok = yes; then : + + +$as_echo "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h + + +else + + TOMMATH_OBJS=\${TOMMATH_OBJS} + + TOMMATH_SRCS=\${TOMMATH_SRCS} + + TOMMATH_INCLUDE=-I\${TOMMATH_DIR} + + +fi + #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called @@ -5637,7 +5828,6 @@ fi SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - LDFLAGS="" if test $doRpath = yes; then : CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' @@ -6393,7 +6583,7 @@ fi if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then : LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' + MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS} ${LDFLAGS}' if test "${SHLIB_SUFFIX}" = ".dll"; then : INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' @@ -9795,214 +9985,6 @@ fi $as_echo "$tcl_ok" >&6; } #------------------------------------------------------------------------ -# Add stuff for zlib -#------------------------------------------------------------------------ - -zlib_ok=yes -ac_fn_c_check_header_mongrel "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default" -if test "x$ac_cv_header_zlib_h" = xyes; then : - - ac_fn_c_check_type "$LINENO" "gz_header" "ac_cv_type_gz_header" "#include -" -if test "x$ac_cv_type_gz_header" = xyes; then : - -else - zlib_ok=no -fi - -else - - zlib_ok=no -fi - - -if test $zlib_ok = yes; then : - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5 -$as_echo_n "checking for library containing deflateSetHeader... " >&6; } -if ${ac_cv_search_deflateSetHeader+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_func_search_save_LIBS=$LIBS -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char deflateSetHeader (); -int -main () -{ -return deflateSetHeader (); - ; - return 0; -} -_ACEOF -for ac_lib in '' z; do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_c_try_link "$LINENO"; then : - ac_cv_search_deflateSetHeader=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext - if ${ac_cv_search_deflateSetHeader+:} false; then : - break -fi -done -if ${ac_cv_search_deflateSetHeader+:} false; then : - -else - ac_cv_search_deflateSetHeader=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5 -$as_echo "$ac_cv_search_deflateSetHeader" >&6; } -ac_res=$ac_cv_search_deflateSetHeader -if test "$ac_res" != no; then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - -else - - zlib_ok=no - -fi - -fi -if test $zlib_ok = no; then : - - ZLIB_OBJS=\${ZLIB_OBJS} - - ZLIB_SRCS=\${ZLIB_SRCS} - - ZLIB_INCLUDE=-I\${ZLIB_DIR} - - -fi - -$as_echo "#define HAVE_ZLIB 1" >>confdefs.h - - -#------------------------------------------------------------------------ -# Add stuff for libtommath - -libtommath_ok=yes - -# Check whether --with-system-libtommath was given. -if test "${with_system_libtommath+set}" = set; then : - withval=$with_system_libtommath; libtommath_ok=${withval} -fi - -if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then - ac_fn_c_check_header_mongrel "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default" -if test "x$ac_cv_header_tommath_h" = xyes; then : - - ac_fn_c_check_type "$LINENO" "mp_int" "ac_cv_type_mp_int" "#include -" -if test "x$ac_cv_type_mp_int" = xyes; then : - -else - libtommath_ok=no -fi - -else - - libtommath_ok=no -fi - - - if test $libtommath_ok = yes; then : - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for library containing mp_log_u32" >&5 -$as_echo_n "checking for library containing mp_log_u32... " >&6; } -if ${ac_cv_search_mp_log_u32+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_func_search_save_LIBS=$LIBS -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char mp_log_u32 (); -int -main () -{ -return mp_log_u32 (); - ; - return 0; -} -_ACEOF -for ac_lib in '' tommath; do - if test -z "$ac_lib"; then - ac_res="none required" - else - ac_res=-l$ac_lib - LIBS="-l$ac_lib $ac_func_search_save_LIBS" - fi - if ac_fn_c_try_link "$LINENO"; then : - ac_cv_search_mp_log_u32=$ac_res -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext - if ${ac_cv_search_mp_log_u32+:} false; then : - break -fi -done -if ${ac_cv_search_mp_log_u32+:} false; then : - -else - ac_cv_search_mp_log_u32=no -fi -rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_mp_log_u32" >&5 -$as_echo "$ac_cv_search_mp_log_u32" >&6; } -ac_res=$ac_cv_search_mp_log_u32 -if test "$ac_res" != no; then : - test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" - -else - - libtommath_ok=no - -fi - -fi -fi -if test $libtommath_ok = yes; then : - - -$as_echo "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h - - -else - - TOMMATH_OBJS=\${TOMMATH_OBJS} - - TOMMATH_SRCS=\${TOMMATH_SRCS} - - TOMMATH_INCLUDE=-I\${TOMMATH_DIR} - - -fi - -#------------------------------------------------------------------------ # Check whether the timezone data is supplied by the OS or has # to be installed by Tcl. The default is autodetection, but can # be overridden on the configure command line either way. -- cgit v0.12 From 61ddd431cab6fcc9de99b5bcf22b95934a1d95cb Mon Sep 17 00:00:00 2001 From: gahr Date: Fri, 27 Dec 2019 12:53:48 +0000 Subject: Include LDFLAGS in TCL_LIB, since that's where MATH_LIBS come in --- unix/configure | 4 ++-- unix/tcl.m4 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/configure b/unix/configure index 0321050..6ce6281 100755 --- a/unix/configure +++ b/unix/configure @@ -6583,7 +6583,7 @@ fi if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then : LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS} ${LDFLAGS}' + MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' if test "${SHLIB_SUFFIX}" = ".dll"; then : INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' @@ -6629,7 +6629,7 @@ fi # it is already set when tclConfig.sh had been loaded by Tk. if test "x${TCL_LIBS}" = x; then : - TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}" + TCL_LIBS="${DL_LIBS} ${LIBS} ${LDFLAGS} ${MATH_LIBS}" fi diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 0d0716b..3758a10 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1821,7 +1821,7 @@ dnl # preprocessing tests use only CPPFLAGS. AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [ LIB_SUFFIX=${SHARED_LIB_SUFFIX} - MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS} ${LDFLAGS}' + MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' AS_IF([test "${SHLIB_SUFFIX}" = ".dll"], [ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)" @@ -1851,7 +1851,7 @@ dnl # preprocessing tests use only CPPFLAGS. # The trick here is that we don't want to change the value of TCL_LIBS if # it is already set when tclConfig.sh had been loaded by Tk. AS_IF([test "x${TCL_LIBS}" = x], [ - TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}"]) + TCL_LIBS="${DL_LIBS} ${LIBS} ${LDFLAGS} ${MATH_LIBS}"]) AC_SUBST(TCL_LIBS) # See if the compiler supports casting to a union type. -- cgit v0.12 From 54e9b9d2b392b33e0a518fe3cfc55598f63cd51b Mon Sep 17 00:00:00 2001 From: gahr Date: Mon, 30 Dec 2019 13:48:44 +0000 Subject: Fix equality check, reported by Emiliano --- unix/configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/configure.ac b/unix/configure.ac index b2370b7..b893d1a 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -175,7 +175,7 @@ AC_ARG_WITH(system-libtommath, AC_HELP_STRING([--with-system-libtommath], [use external libtommath (default: true if available, false otherwise)]), libtommath_ok=${withval}) -if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then +if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then AC_CHECK_HEADER([tommath.h],[ AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include ])],[ libtommath_ok=no]) -- cgit v0.12 From c24a2bec0132d005fae4d4f47ebeba49d1a7f9cd Mon Sep 17 00:00:00 2001 From: gahr Date: Mon, 30 Dec 2019 13:49:39 +0000 Subject: Regenerate configure --- unix/configure | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/configure b/unix/configure index 6ce6281..4a5ebe6 100755 --- a/unix/configure +++ b/unix/configure @@ -4661,7 +4661,7 @@ if test "${with_system_libtommath+set}" = set; then : withval=$with_system_libtommath; libtommath_ok=${withval} fi -if test x"${libtommath_ok}" == x -o x"${libtommath_ok}" != xno; then +if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then ac_fn_c_check_header_mongrel "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default" if test "x$ac_cv_header_tommath_h" = xyes; then : -- cgit v0.12 From cc211af4eafca77e7d1ede7371c88c6d6fc44a80 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Jan 2020 09:20:57 +0000 Subject: Start handling WUR (Warn Unused Result) in all tommath calls. WIP, not complete yet. --- generic/tclBasic.c | 37 ++++++++--- generic/tclExecute.c | 181 ++++++++++++++++++++++++++++++++++----------------- generic/tclObj.c | 25 ++++--- generic/tclStrToD.c | 127 +++++++++++++++++++++++------------- generic/tclTestObj.c | 14 ++-- 5 files changed, 260 insertions(+), 124 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b216e05..9f650d6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7675,10 +7675,16 @@ ExprIsqrtFunc( Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d))); } else { mp_int root; + mp_err err; - mp_init(&root); - mp_sqrt(&big, &root); + err = mp_init(&root); + if (err == MP_OKAY) { + err = mp_sqrt(&big, &root); + } mp_clear(&big); + if (err != MP_OKAY) { + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root)); } return TCL_OK; @@ -7724,10 +7730,17 @@ ExprSqrtFunc( if ((d >= 0.0) && TclIsInfinite(d) && (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) { mp_int root; + mp_err err; - mp_init(&root); - mp_sqrt(&big, &root); + err = mp_init(&root); + if (err == MP_OKAY) { + err = mp_sqrt(&big, &root); + } mp_clear(&big); + if (err != MP_OKAY) { + mp_clear(&root); + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root))); mp_clear(&root); } else { @@ -7893,7 +7906,9 @@ ExprAbsFunc( } goto unChanged; } else if (l == WIDE_MIN) { - mp_init_i64(&big, l); + if (mp_init_i64(&big, l) != MP_OKAY) { + return TCL_ERROR; + } goto tooLarge; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l)); @@ -7924,7 +7939,9 @@ ExprAbsFunc( if (mp_isneg((const mp_int *) ptr)) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: - (void)mp_neg(&big, &big); + if (mp_neg(&big, &big) != MP_OKAY) { + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); } else { unChanged: @@ -8260,15 +8277,19 @@ ExprRoundFunc( } if ((intPart >= (double)max) || (intPart <= (double)min)) { mp_int big; + mp_err err = MP_OKAY; if (Tcl_InitBignumFromDouble(interp, intPart, &big) != TCL_OK) { /* Infinity */ return TCL_ERROR; } if (fractPart <= -0.5) { - mp_sub_d(&big, 1, &big); + err = mp_sub_d(&big, 1, &big); } else if (fractPart >= 0.5) { - mp_add_d(&big, 1, &big); + err = mp_add_d(&big, 1, &big); + } + if (err != MP_OKAY) { + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8bc83cc..3d75d97 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -652,6 +652,7 @@ static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); #define DIVIDED_BY_ZERO ((Tcl_Obj *) -1) #define EXPONENT_OF_ZERO ((Tcl_Obj *) -2) #define GENERAL_ARITHMETIC_ERROR ((Tcl_Obj *) -3) +#define OUT_OF_MEMORY ((Tcl_Obj *) -4) /* * Declarations for local procedures to this file: @@ -1796,6 +1797,7 @@ TclIncrObj( ClientData ptr1, ptr2; int type1, type2; mp_int value, incr; + mp_err err; if (Tcl_IsShared(valuePtr)) { Tcl_Panic("%s called with shared object", "TclIncrObj"); @@ -1854,8 +1856,11 @@ TclIncrObj( Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); - mp_add(&value, &incr, &value); + err = mp_add(&value, &incr, &value); mp_clear(&incr); + if (err != MP_OKAY) { + return TCL_ERROR; + } Tcl_SetBignumObj(valuePtr, &value); return TCL_OK; } @@ -6149,6 +6154,9 @@ TEBCresume( } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { TRACE_ERROR(interp); goto gotError; + } else if (objResultPtr == OUT_OF_MEMORY) { + TRACE_APPEND(("OUT OF MEMORY\n")); + goto outOfMemory; } else if (objResultPtr == NULL) { TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); @@ -7593,6 +7601,13 @@ TEBCresume( CACHE_STACK_INFO(); goto gotError; + outOfMemory: + Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "ARITH", "OUTOFMEMORY", "out of memory", NULL); + CACHE_STACK_INFO(); + goto gotError; + /* * Exponentiation of zero by negative number in an expression. Control * only reaches this point by "goto exponOfZero". @@ -8032,6 +8047,7 @@ ExecuteExtendedBinaryMathOp( Tcl_Obj *objResultPtr; int invalid, zero; long shift; + mp_err err; (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); @@ -8093,9 +8109,14 @@ ExecuteExtendedBinaryMathOp( * Arguments are opposite sign; remainder is sum. */ - mp_init_i64(&big1, w1); - mp_add(&big2, &big1, &big2); - mp_clear(&big1); + err = mp_init_i64(&big1, w1); + if (err == MP_OKAY) { + err = mp_add(&big2, &big1, &big2); + mp_clear(&big1); + } + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } BIG_RESULT(&big2); } @@ -8108,21 +8129,30 @@ ExecuteExtendedBinaryMathOp( } Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); - mp_init(&bigRemainder); - mp_div(&big1, &big2, &bigResult, &bigRemainder); + err = mp_init_multi(&bigResult, &bigRemainder, NULL); + if (err == MP_OKAY) { + err = mp_div(&big1, &big2, &bigResult, &bigRemainder); + } if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { /* * Convert to Tcl's integer division rules. */ - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); + err = mp_sub_d(&bigResult, 1, &bigResult); + if (err == MP_OKAY) { + err = mp_add(&bigRemainder, &big2, &bigRemainder); + } + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } } - mp_copy(&bigRemainder, &bigResult); + err = mp_copy(&bigRemainder, &bigResult); mp_clear(&bigRemainder); mp_clear(&big1); mp_clear(&big2); + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } BIG_RESULT(&bigResult); case INST_LSHIFT: @@ -8248,11 +8278,16 @@ ExecuteExtendedBinaryMathOp( Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - mp_init(&bigResult); - if (opcode == INST_LSHIFT) { - mp_mul_2d(&big1, shift, &bigResult); - } else { - mp_signed_rsh(&big1, shift, &bigResult); + err = mp_init(&bigResult); + if (err == MP_OKAY) { + if (opcode == INST_LSHIFT) { + err = mp_mul_2d(&big1, shift, &bigResult); + } else { + err = mp_signed_rsh(&big1, shift, &bigResult); + } + } + if (err != MP_OKAY) { + return OUT_OF_MEMORY; } mp_clear(&big1); BIG_RESULT(&bigResult); @@ -8265,20 +8300,25 @@ ExecuteExtendedBinaryMathOp( Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); + err = mp_init(&bigResult); - switch (opcode) { - case INST_BITAND: - mp_and(&big1, &big2, &bigResult); - break; + if (err == MP_OKAY) { + switch (opcode) { + case INST_BITAND: + err = mp_and(&big1, &big2, &bigResult); + break; - case INST_BITOR: - mp_or(&big1, &big2, &bigResult); - break; + case INST_BITOR: + err = mp_or(&big1, &big2, &bigResult); + break; - case INST_BITXOR: - mp_xor(&big1, &big2, &bigResult); - break; + case INST_BITXOR: + err = mp_xor(&big1, &big2, &bigResult); + break; + } + } + if (err != MP_OKAY) { + return OUT_OF_MEMORY; } mp_clear(&big1); @@ -8341,8 +8381,8 @@ ExecuteExtendedBinaryMathOp( } else { Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); negativeExponent = mp_isneg(&big2); - mp_mod_2d(&big2, 1, &big2); - oddExponent = !mp_iszero(&big2); + err = mp_mod_2d(&big2, 1, &big2); + oddExponent = (err == MP_OKAY) && !mp_iszero(&big2); mp_clear(&big2); } @@ -8499,8 +8539,13 @@ ExecuteExtendedBinaryMathOp( return GENERAL_ARITHMETIC_ERROR; } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - mp_init(&bigResult); - mp_expt_u32(&big1, (unsigned int)w2, &bigResult); + err = mp_init(&bigResult); + if (err == MP_OKAY) { + err = mp_expt_u32(&big1, (unsigned int)w2, &bigResult); + } + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } mp_clear(&big1); BIG_RESULT(&bigResult); } @@ -8647,38 +8692,44 @@ ExecuteExtendedBinaryMathOp( overflowBasic: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); + err = mp_init(&bigResult); + if (err == MP_OKAY) { switch (opcode) { case INST_ADD: - mp_add(&big1, &big2, &bigResult); - break; + err = mp_add(&big1, &big2, &bigResult); + break; case INST_SUB: - mp_sub(&big1, &big2, &bigResult); - break; + err = mp_sub(&big1, &big2, &bigResult); + break; case INST_MULT: - mp_mul(&big1, &big2, &bigResult); - break; + err = mp_mul(&big1, &big2, &bigResult); + break; case INST_DIV: - if (mp_iszero(&big2)) { - mp_clear(&big1); - mp_clear(&big2); - mp_clear(&bigResult); - return DIVIDED_BY_ZERO; - } - mp_init(&bigRemainder); - mp_div(&big1, &big2, &bigResult, &bigRemainder); - /* TODO: internals intrusion */ - if (!mp_iszero(&bigRemainder) - && (bigRemainder.sign != big2.sign)) { - /* - * Convert to Tcl's integer division rules. - */ + if (mp_iszero(&big2)) { + mp_clear(&big1); + mp_clear(&big2); + mp_clear(&bigResult); + return DIVIDED_BY_ZERO; + } + err = mp_init(&bigRemainder); + if (err == MP_OKAY) { + err = mp_div(&big1, &big2, &bigResult, &bigRemainder); + } + /* TODO: internals intrusion */ + if (!mp_iszero(&bigRemainder) + && (bigRemainder.sign != big2.sign)) { + /* + * Convert to Tcl's integer division rules. + */ - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); + err = mp_sub_d(&bigResult, 1, &bigResult); + if (err == MP_OKAY) { + err = mp_add(&bigRemainder, &big2, &bigRemainder); + } + } + mp_clear(&bigRemainder); + break; } - mp_clear(&bigRemainder); - break; } mp_clear(&big1); mp_clear(&big2); @@ -8699,6 +8750,7 @@ ExecuteExtendedUnaryMathOp( Tcl_WideInt w; mp_int big; Tcl_Obj *objResultPtr; + mp_err err = MP_OKAY; (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type); @@ -8710,8 +8762,13 @@ ExecuteExtendedUnaryMathOp( } Tcl_TakeBignumFromObj(NULL, valuePtr, &big); /* ~a = - a - 1 */ - (void)mp_neg(&big, &big); - mp_sub_d(&big, 1, &big); + err = mp_neg(&big, &big); + if (err == MP_OKAY) { + err = mp_sub_d(&big, 1, &big); + } + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } BIG_RESULT(&big); case INST_UMINUS: switch (type) { @@ -8722,12 +8779,18 @@ ExecuteExtendedUnaryMathOp( if (w != WIDE_MIN) { WIDE_RESULT(-w); } - mp_init_i64(&big, w); + err = mp_init_i64(&big, w); + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } break; default: Tcl_TakeBignumFromObj(NULL, valuePtr, &big); } - (void)mp_neg(&big, &big); + err = mp_neg(&big, &big); + if (err != MP_OKAY) { + return OUT_OF_MEMORY; + } BIG_RESULT(&big); } diff --git a/generic/tclObj.c b/generic/tclObj.c index eb9334e..ea1360f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -182,10 +182,7 @@ static Tcl_ThreadDataKey pendingObjDataKey; *temp = bignum; \ (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ - } else { \ - if ((bignum).alloc > 0x7fff) { \ - mp_shrink(&(bignum)); \ - } \ + } else if (((bignum).alloc <= 0x7fff) || (mp_shrink(&(bignum))) == MP_OKAY) { \ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (bignum).dp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \ | ((bignum).alloc << 15) | ((bignum).used)); \ @@ -3338,14 +3335,20 @@ TclGetWideBitsFromObj( } if (objPtr->typePtr == &tclBignumType) { mp_int big; + mp_err err; Tcl_WideUInt value = 0, scratch; size_t numBytes; unsigned char *bytes = (unsigned char *) &scratch; Tcl_GetBignumFromObj(NULL, objPtr, &big); - mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); - mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes); + err = mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); + if (err == MP_OKAY) { + err = mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes); + } + if (err != MP_OKAY) { + return TCL_ERROR; + } while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } @@ -3585,7 +3588,9 @@ GetBignumFromObj( mp_int temp; TclUnpackBignum(objPtr, temp); - mp_init_copy(bignumValue, &temp); + if (mp_init_copy(bignumValue, &temp) != MP_OKAY) { + return TCL_ERROR; + } } else { TclUnpackBignum(objPtr, *bignumValue); /* Optimized TclFreeIntRep */ @@ -3604,8 +3609,10 @@ GetBignumFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - mp_init_i64(bignumValue, - objPtr->internalRep.wideValue); + if (mp_init_i64(bignumValue, + objPtr->internalRep.wideValue) != MP_OKAY) { + return TCL_ERROR; + } return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 8939fa0..94e06ce 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -534,6 +534,7 @@ TclParseNumber( * to avoid a compiler warning. */ int shift = 0; /* Amount to shift when accumulating binary */ int explicitOctal = 0; + mp_err err = MP_OKAY; #define ALL_BITS ((Tcl_WideUInt)-1) #define MOST_BITS (ALL_BITS >> 1) @@ -716,7 +717,7 @@ TclParseNumber( || (octalSignificandWide > ((Tcl_WideUInt)-1 >> shift)))) { octalSignificandOverflow = 1; - mp_init_u64(&octalSignificandBig, + err = mp_init_u64(&octalSignificandBig, octalSignificandWide); } } @@ -724,10 +725,17 @@ TclParseNumber( octalSignificandWide = (octalSignificandWide << shift) + (c - '0'); } else { - mp_mul_2d(&octalSignificandBig, shift, - &octalSignificandBig); - mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'), - &octalSignificandBig); + if (err == MP_OKAY) { + err = mp_mul_2d(&octalSignificandBig, shift, + &octalSignificandBig); + } + if (err == MP_OKAY) { + err = mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'), + &octalSignificandBig); + } + } + if (err != MP_OKAY) { + return TCL_ERROR; } } if (numSigDigs != 0) { @@ -833,17 +841,22 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > ((Tcl_WideUInt)-1 >> shift))) { significandOverflow = 1; - mp_init_u64(&significandBig, + err = mp_init_u64(&significandBig, significandWide); } } if (!significandOverflow) { significandWide = (significandWide << shift) + d; - } else { - mp_mul_2d(&significandBig, shift, &significandBig); - mp_add_d(&significandBig, (mp_digit) d, &significandBig); + } else if (err == MP_OKAY) { + err = mp_mul_2d(&significandBig, shift, &significandBig); + if (err == MP_OKAY) { + mp_add_d(&significandBig, (mp_digit) d, &significandBig); + } } } + if (err != MP_OKAY) { + return TCL_ERROR; + } numTrailZeros = 0; state = HEXADECIMAL; break; @@ -4557,6 +4570,7 @@ Tcl_InitBignumFromDouble( { double fract; int expt; + mp_err err; /* * Infinite values can't convert to bignum. @@ -4574,19 +4588,24 @@ Tcl_InitBignumFromDouble( fract = frexp(d, &expt); if (expt <= 0) { - mp_init(b); + err = mp_init(b); mp_zero(b); } else { Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits); int shift = expt - mantBits; - mp_init_i64(b, w); - if (shift < 0) { - mp_div_2d(b, -shift, b, NULL); + err = mp_init_i64(b, w); + if (err != MP_OKAY) { + /* just skip */ + } else if (shift < 0) { + err = mp_div_2d(b, -shift, b, NULL); } else if (shift > 0) { - mp_mul_2d(b, shift, b); + err = mp_mul_2d(b, shift, b); } } + if (err != MP_OKAY) { + return TCL_ERROR; + } return TCL_OK; } @@ -4612,6 +4631,7 @@ TclBignumToDouble( mp_int b; int bits, shift, i, lsb; double r; + mp_err err; /* @@ -4640,11 +4660,13 @@ TclBignumToDouble( * 'rounded to even'. */ - mp_init(&b); - if (shift == 0) { - mp_copy(a, &b); + err = mp_init(&b); + if (err != MP_OKAY) { + /* just skip */ + } else if (shift == 0) { + err = mp_copy(a, &b); } else if (shift > 0) { - mp_mul_2d(a, shift, &b); + err = mp_mul_2d(a, shift, &b); } else if (shift < 0) { lsb = mp_cnt_lsb(a); if (lsb == -1-shift) { @@ -4653,12 +4675,12 @@ TclBignumToDouble( * Round to even */ - mp_div_2d(a, -shift, &b, NULL); - if (mp_isodd(&b)) { + err = mp_div_2d(a, -shift, &b, NULL); + if ((err == MP_OKAY) && mp_isodd(&b)) { if (mp_isneg(&b)) { - mp_sub_d(&b, 1, &b); + err = mp_sub_d(&b, 1, &b); } else { - mp_add_d(&b, 1, &b); + err = mp_add_d(&b, 1, &b); } } } else { @@ -4667,13 +4689,15 @@ TclBignumToDouble( * Ordinary rounding */ - mp_div_2d(a, -1-shift, &b, NULL); - if (mp_isneg(&b)) { - mp_sub_d(&b, 1, &b); + err = mp_div_2d(a, -1-shift, &b, NULL); + if (err != MP_OKAY) { + /* just skip */ + } else if (mp_isneg(&b)) { + err = mp_sub_d(&b, 1, &b); } else { - mp_add_d(&b, 1, &b); + err = mp_add_d(&b, 1, &b); } - mp_div_2d(&b, 1, &b, NULL); + err = mp_div_2d(&b, 1, &b, NULL); } } @@ -4681,8 +4705,11 @@ TclBignumToDouble( * Accumulate the result, one mp_digit at a time. */ + if (err != MP_OKAY) { + return 0.0; + } r = 0.0; - for (i=b.used-1 ; i>=0 ; --i) { + for (i = b.used-1; i>=0; --i) { r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; } mp_clear(&b); @@ -4724,10 +4751,11 @@ TclCeil( { double r = 0.0; mp_int b; + mp_err err; - mp_init(&b); - if (mp_isneg(a)) { - mp_neg(a, &b); + err = mp_init(&b); + if ((err == MP_OKAY) && mp_isneg(a)) { + err = mp_neg(a, &b); r = -TclFloor(&b); } else { int bits = mp_count_bits(a); @@ -4737,19 +4765,26 @@ TclCeil( } else { int i, exact = 1, shift = mantBits - bits; - if (shift > 0) { - mp_mul_2d(a, shift, &b); + if (err != MP_OKAY) { + /* just skip */ + } else if (shift > 0) { + err = mp_mul_2d(a, shift, &b); } else if (shift < 0) { mp_int d; - mp_init(&d); - mp_div_2d(a, -shift, &b, &d); + err = mp_init(&d); + if (err == MP_OKAY) { + err = mp_div_2d(a, -shift, &b, &d); + } exact = mp_iszero(&d); mp_clear(&d); } else { - mp_copy(a, &b); + err = mp_copy(a, &b); + } + if ((err == MP_OKAY) && !exact) { + err = mp_add_d(&b, 1, &b); } - if (!exact) { - mp_add_d(&b, 1, &b); + if (err != MP_OKAY) { + return 0.0; } for (i=b.used-1 ; i>=0 ; --i) { r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; @@ -4781,10 +4816,11 @@ TclFloor( { double r = 0.0; mp_int b; + mp_err err; - mp_init(&b); - if (mp_isneg(a)) { - mp_neg(a, &b); + err = mp_init(&b); + if ((err == MP_OKAY) && mp_isneg(a)) { + err = mp_neg(a, &b); r = -TclCeil(&b); } else { int bits = mp_count_bits(a); @@ -4795,11 +4831,14 @@ TclFloor( int i, shift = mantBits - bits; if (shift > 0) { - mp_mul_2d(a, shift, &b); + err = mp_mul_2d(a, shift, &b); } else if (shift < 0) { - mp_div_2d(a, -shift, &b, NULL); + err = mp_div_2d(a, -shift, &b, NULL); } else { - mp_copy(a, &b); + err = mp_copy(a, &b); + } + if (err != MP_OKAY) { + return 0.0; } for (i=b.used-1 ; i>=0 ; --i) { r = ldexp(r, MP_DIGIT_BIT) + b.dp[i]; diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index e616433..0faf9a8 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -281,7 +281,8 @@ TestbignumobjCmd( } break; - case BIGNUM_ISEVEN: + case BIGNUM_ISEVEN: { + mp_err err; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); return TCL_ERROR; @@ -293,13 +294,18 @@ TestbignumobjCmd( &bignumValue) != TCL_OK) { return TCL_ERROR; } + err = mp_mod_2d(&bignumValue, 1, &bignumValue); + if (err == MP_OKAY && !mp_iszero(&bignumValue)) { + err = MP_ERR; + } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], !mp_isodd(&bignumValue)); + Tcl_SetIntObj(varPtr[varIndex], err == MP_OKAY); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(!mp_isodd(&bignumValue))); + SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(err == MP_OKAY)); } mp_clear(&bignumValue); - break; + } + break; case BIGNUM_RADIXSIZE: if (objc != 3) { -- cgit v0.12 From fc63e758a4d1537762b5a86ee42f762547a4931a Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 13 Jan 2020 16:49:42 +0000 Subject: Implement TIP 559 --- doc/SetResult.3 | 12 +----------- generic/tcl.decls | 7 ++++--- generic/tclDecls.h | 8 +++----- generic/tclResult.c | 30 ------------------------------ generic/tclStubInit.c | 2 +- 5 files changed, 9 insertions(+), 50 deletions(-) diff --git a/doc/SetResult.3 b/doc/SetResult.3 index 07e2344..1355d6b 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult, Tcl_TransferResult, Tcl_FreeResult \- manipulate Tcl result +Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult, Tcl_TransferResult \- manipulate Tcl result .SH SYNOPSIS .nf \fB#include \fR @@ -31,8 +31,6 @@ const char * \fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR) .sp \fBTcl_AppendElement\fR(\fIinterp, element\fR) -.sp -\fBTcl_FreeResult\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out @@ -177,14 +175,6 @@ single character or ends in the characters .QW " {" ) then no space is added. -.PP -\fBTcl_FreeResult\fR performs part of the work -of \fBTcl_ResetResult\fR. -It frees up the memory associated with \fIinterp\fR's result. -It also sets \fIinterp->freeProc\fR to zero, but does not -change \fIinterp->result\fR or clear error state. -\fBTcl_FreeResult\fR is most commonly used when a procedure -is about to replace one result value with another. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP \fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how diff --git a/generic/tcl.decls b/generic/tcl.decls index f852601..98cddd5 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -540,9 +540,10 @@ declare 145 { declare 146 { int Tcl_Flush(Tcl_Channel chan) } -declare 147 { - void Tcl_FreeResult(Tcl_Interp *interp) -} +# Removed in 9.0, TIP 559 +#declare 147 { +# void Tcl_FreeResult(Tcl_Interp *interp) +#} declare 148 { int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index be71893..d944676 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -434,8 +434,7 @@ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); -/* 147 */ -EXTERN void Tcl_FreeResult(Tcl_Interp *interp); +/* Slot 147 is reserved */ /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, @@ -1941,7 +1940,7 @@ typedef struct TclStubs { void (*reserved144)(void); Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ - void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ + void (*reserved147)(void); int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ void * (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ @@ -2754,8 +2753,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ #define Tcl_Flush \ (tclStubsPtr->tcl_Flush) /* 146 */ -#define Tcl_FreeResult \ - (tclStubsPtr->tcl_FreeResult) /* 147 */ +/* Slot 147 is reserved */ #define Tcl_GetAlias \ (tclStubsPtr->tcl_GetAlias) /* 148 */ #define Tcl_GetAliasObj \ diff --git a/generic/tclResult.c b/generic/tclResult.c index 3ca3c7b..69edd39 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -373,36 +373,6 @@ Tcl_AppendElement( /* *---------------------------------------------------------------------- * - * Tcl_FreeResult -- - * - * This function frees up the memory associated with an interpreter's - * result, resetting the interpreter's result object. Tcl_FreeResult is - * most commonly used when a function is about to replace one result - * value with another. - * - * Results: - * None. - * - * Side effects: - * Frees the memory associated with interp's result but does not change - * any part of the error dictionary (i.e., the errorinfo and errorcode - * remain the same). - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FreeResult( - Tcl_Interp *interp)/* Interpreter for which to free result. */ -{ - Interp *iPtr = (Interp *) interp; - - ResetObjResult(iPtr); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_ResetResult -- * * This function resets both the interpreter's string and object results. diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 01434b9..3ca9fe4 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -894,7 +894,7 @@ const TclStubs tclStubs = { 0, /* 144 */ Tcl_FirstHashEntry, /* 145 */ Tcl_Flush, /* 146 */ - Tcl_FreeResult, /* 147 */ + 0, /* 147 */ Tcl_GetAlias, /* 148 */ Tcl_GetAliasObj, /* 149 */ Tcl_GetAssocData, /* 150 */ -- cgit v0.12 From 9b0b0dc37dd6a3276ce3b0425e64e1bec8660aec Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 13 Jan 2020 17:00:21 +0000 Subject: Implement TIP 559 (deprecation part). --- generic/tcl.decls | 2 +- generic/tclDecls.h | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 528938d..e033961 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -523,7 +523,7 @@ declare 145 { declare 146 { int Tcl_Flush(Tcl_Channel chan) } -declare 147 { +declare 147 {deprecated {see TIP #559. Use Tcl_ResetResult}} { void Tcl_FreeResult(Tcl_Interp *interp) } declare 148 { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index ed1da85..08e46a6 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -478,7 +478,8 @@ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); /* 147 */ -EXTERN void Tcl_FreeResult(Tcl_Interp *interp); +TCL_DEPRECATED("see TIP #559. Use Tcl_ResetResult") +void Tcl_FreeResult(Tcl_Interp *interp); /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, @@ -2087,7 +2088,7 @@ typedef struct TclStubs { TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_FindExecutable) (const char *argv0); /* 144 */ Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ - void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ + TCL_DEPRECATED_API("see TIP #559. Use Tcl_ResetResult") void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ -- cgit v0.12 From d59509dee2c55942e56ff0f8b540d00c78a99b86 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Jan 2020 14:16:48 +0000 Subject: Proposed fix for [8cd2fe7474]: "unload" command Bug (when handling multiple libs) --- generic/tclLoad.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index f1bd248..dfa657e 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -871,7 +871,7 @@ Tcl_UnloadObjCmd( for (ipPrevPtr = ipPtr; ipPtr != NULL; ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->pkgPtr == defaultPtr) { ipPrevPtr->nextPtr = ipPtr->nextPtr; break; } -- cgit v0.12 From eb08a10e38e909d85338f6375638efa08bf0c639 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Jan 2020 08:51:38 +0000 Subject: Fix [8cd2fe7474]: "unload" command Bug (when handling multiple libs) --- generic/tclLoad.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index ac863b9..2891884 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -834,7 +834,7 @@ Tcl_UnloadObjCmd( for (ipPrevPtr = ipPtr; ipPtr != NULL; ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + if (ipPtr->pkgPtr == defaultPtr) { ipPrevPtr->nextPtr = ipPtr->nextPtr; break; } -- cgit v0.12 From 35ec25a6cf7c2686aa9b6b972403788937b6f6fd Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 17 Jan 2020 16:12:06 +0000 Subject: closes [5d989f9ba3]: avoid segfault by OOM if too many items to sort (would throw an error instead, and use system alloc for long elementArray due to size_t); added test cases covering that (in child process with limited address space, if "prlimit" available) --- generic/tclCmdIL.c | 22 ++++++++++++++++++++-- tests/cmdIL.test | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 53 insertions(+), 2 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b303bb6..630aa70 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3477,6 +3477,7 @@ Tcl_LsortObjCmd( int i, j, index, indices, length, nocase = 0, indexc; int sortMode = SORTMODE_ASCII; Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; + size_t elmArrSize; SortElement *elementArray, *elementPtr; SortInfo sortInfo; /* Information about this sort that needs to * be passed to the comparison function. */ @@ -3494,6 +3495,7 @@ Tcl_LsortObjCmd( * The subList array below holds pointers to temporary lists built during * the merge sort. Element i of the array holds a list of length 2**i. */ +# define MAXCALLOC 1024000 # define NUM_LISTS 30 SortElement *subList[NUM_LISTS+1]; @@ -3699,7 +3701,19 @@ Tcl_LsortObjCmd( * begins sorting it into the sublists as it appears. */ - elementArray = (SortElement *) ckalloc( length * sizeof(SortElement)); + elmArrSize = length * sizeof(SortElement); + if (elmArrSize <= MAXCALLOC) { + elementArray = (SortElement *) ckalloc(elmArrSize); + } else { + elementArray = (SortElement *) malloc(elmArrSize); + } + if (!elementArray) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no enough memory to proccess sort of %d items", length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + sortInfo.resultCode = TCL_ERROR; + goto done; + } for (i=0; i < length; i++){ if (indexc) { @@ -3802,7 +3816,11 @@ Tcl_LsortObjCmd( } done1: - ckfree((char *)elementArray); + if (elmArrSize <= MAXCALLOC) { + ckfree((char *)elementArray); + } else { + free((char *)elementArray); + } done: if (sortMode == SORTMODE_COMMAND) { diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 6fab269..b743b35 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -15,6 +15,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +testConstraint prlimit [expr {[testConstraint macOrUnix] && ![catch { exec prlimit -n }]}] test cmdIL-1.1 {Tcl_LsortObjCmd procedure} { list [catch {lsort} msg] $msg @@ -445,6 +446,38 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { } -result 0 -cleanup { rename test_lsort "" } +test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { + # test it in child process (with limited address space): + set pipe {} + if {[catch { + set pipe [open |[list [interpreter]] r+] + exec prlimit -p [pid $pipe] --as=80000000 + } msg]} { + catch {close $pipe} + tcltest::Skip "prlimit: set of limit is impossible, [regsub {^\s*([^\n]*).*$} $msg {\1}]" + } + # if no error (enough memory), or error by list creation - add it as skipped test: + if {![catch { + chan configure $pipe -buffering line + puts $pipe { + # test + set l [lrepeat 4000000 ""] + puts [llength [lsort $l]] + exit + } + set result [read $pipe] + close $pipe + set pipe {} + set result + } result] || [regexp {^(?:list creation failed|unable to alloc)} $result]} { + tcltest::Skip "prlimit: too small or too large AS-limit, result: $result" + } + set result + # expecting error no memory by sort +} -cleanup { + if {$pipe ne ""} { catch { close $pipe } } + unset -nocomplain pipe line result +} -result {no enough memory to proccess sort of 4000000 items} # Compiled version test cmdIL-6.1 {lassign command syntax} -body { -- cgit v0.12 From a3728e6d82a95897084c458b48661f468c14e724 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 17 Jan 2020 16:40:37 +0000 Subject: small amend (skip messages, avoid output on interactive shell) --- tests/cmdIL.test | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/tests/cmdIL.test b/tests/cmdIL.test index b743b35..fabedea 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -454,14 +454,15 @@ test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { exec prlimit -p [pid $pipe] --as=80000000 } msg]} { catch {close $pipe} - tcltest::Skip "prlimit: set of limit is impossible, [regsub {^\s*([^\n]*).*$} $msg {\1}]" + tcltest::Skip "prlimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]" } # if no error (enough memory), or error by list creation - add it as skipped test: if {![catch { chan configure $pipe -buffering line puts $pipe { - # test - set l [lrepeat 4000000 ""] + # create list and get length (avoid too long output in interactive shells): + llength [set l [lrepeat 4000000 ""]] + # test OOM: puts [llength [lsort $l]] exit } @@ -470,7 +471,7 @@ test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { set pipe {} set result } result] || [regexp {^(?:list creation failed|unable to alloc)} $result]} { - tcltest::Skip "prlimit: too small or too large AS-limit, result: $result" + tcltest::Skip "prlimit: wrong AS-limit, result: $result" } set result # expecting error no memory by sort -- cgit v0.12 From a3906f4953e88e646a9034649dbeb6db3624c99b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jan 2020 14:35:25 +0000 Subject: Don't deprecate Tcl_NewUnicodeObj/Tcl_SetUnicodeObj/Tcl_GetUnicodeFromObj, since that's not according to TIP #542. (Those are only deprecated when using TCL_UTF_MAX=4, not in the general case) --- generic/tcl.decls | 6 +++--- generic/tclDecls.h | 15 ++++++--------- generic/tclTestObj.c | 8 ++++++++ 3 files changed, 17 insertions(+), 12 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 0587088..5516f89 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1337,10 +1337,10 @@ declare 376 { declare 377 { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } -declare 378 {deprecated {Use Tcl_UniCharToUtfDString}} { +declare 378 { Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars) } -declare 379 {deprecated {Use Tcl_UniCharToUtfDString}} { +declare 379 { void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars) } @@ -1540,7 +1540,7 @@ declare 433 { } # introduced in 8.4a3 -declare 434 {deprecated {Use Tcl_UtfToUniCharDString}} { +declare 434 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 75b9c01..b2b7767 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1143,12 +1143,10 @@ EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp, EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 378 */ -TCL_DEPRECATED("Use Tcl_UniCharToUtfDString") -Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, +EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars); /* 379 */ -TCL_DEPRECATED("Use Tcl_UniCharToUtfDString") -void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, +EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 380 */ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); @@ -1304,8 +1302,7 @@ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length); /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ -TCL_DEPRECATED("Use Tcl_UtfToUniCharDString") -Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, +EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 435 */ TCL_DEPRECATED("") @@ -2334,8 +2331,8 @@ typedef struct TclStubs { int (*tcl_UniCharIsPunct) (int ch); /* 375 */ int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ - TCL_DEPRECATED_API("Use Tcl_UniCharToUtfDString") Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */ - TCL_DEPRECATED_API("Use Tcl_UniCharToUtfDString") void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ + Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */ + void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ @@ -2390,7 +2387,7 @@ typedef struct TclStubs { char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 431 */ int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ - TCL_DEPRECATED_API("Use Tcl_UtfToUniCharDString") Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ + Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */ diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index e616433..ced860e 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -25,6 +25,14 @@ #endif #include "tclStringRep.h" +#ifdef __GNUC__ +/* + * The rest of this file shouldn't warn about deprecated functions; they're + * there because we intend them to be so and know that this file is OK to + * touch those fields. + */ +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif /* * Forward declarations for functions defined later in this file: -- cgit v0.12 From e403afa147df4b621cd59679f6d3ab18e2b00f1f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jan 2020 15:27:47 +0000 Subject: Now that TIP #538 is integrated, make rules.vc work for both 8.6 and 8.7 without changes. --- win/rules.vc | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/win/rules.vc b/win/rules.vc index c0deb2a..5060805 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1323,6 +1323,11 @@ OPTDEFINES = $(OPTDEFINES) /DUSE_THREAD_ALLOC=1 !endif !if $(STATIC_BUILD) OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD +!elseif $(TCL_VERSION) > 86 +OPTDEFINES = $(OPTDEFINES) /DTCL_WITH_EXTERNAL_TOMMATH +!if "$(MACHINE)" == "AMD64" +OPTDEFINES = $(OPTDEFINES) /DMP_64BIT +!endif !endif !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED -- cgit v0.12 From 0f71efe445ad4662978569586156bba150cef23c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 Jan 2020 08:48:17 +0000 Subject: Don't run stack-3.1 test on OSX, it fail regulary. Don't really bother for Tcl 8.5 any more. --- tests/stack.test | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/stack.test b/tests/stack.test index 62c3e98..2cc9d47 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -12,6 +12,8 @@ package require tcltest 2 namespace import ::tcltest::* +testConstraint noOsx [expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(TRAVIS_OSX_IMAGE)]}] + # Note that a failure in this test results in a crash of the executable. # In order to avoid that, we do a basic check of the current stacksize. # This size can be changed with ulimit (ksh/bash/sh) or limit (csh/tcsh). @@ -68,7 +70,7 @@ test stack-2.1 {maxNestingDepth reached on infinite recursion} -constraints { # Make sure that there is enough stack to run regexp even if we're # close to the recursion limit. [Bug 947070] [Patch 746378] -test stack-3.1 {enough room for regexp near recursion limit} -body { +test stack-3.1 {enough room for regexp near recursion limit} -constraints noOsx -body { # do this in a sub process in case it segfaults exec [interpreter] << { interp recursionlimit {} 10000 -- cgit v0.12 From b77246e08bf5f354f35ac9a388296a3fcb5a2a95 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 Jan 2020 09:21:30 +0000 Subject: Enable test-cases stringObj-15.[5-8]: "nodep" restriction doesn't work in 9.0. --- tests/stringObj.test | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/tests/stringObj.test b/tests/stringObj.test index 3779bca..8b10897 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -24,7 +24,6 @@ testConstraint testobj [llength [info commands testobj]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] testConstraint tip389 [expr {[string length \U010000] == 2}] -testConstraint nodep [info exists tcl_precision] test stringObj-1.1 {string type registration} testobj { set t [testobj types] @@ -466,19 +465,19 @@ test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 3 } foo -test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { +test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj tip389} { teststringobj set 1 foo teststringobj appendself2 1 0 } foofoo -test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { +test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj tip389} { teststringobj set 1 foo teststringobj appendself2 1 1 } foooo -test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { +test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj tip389} { teststringobj set 1 foo teststringobj appendself2 1 2 } fooo -test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { +test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj tip389} { teststringobj set 1 foo teststringobj appendself2 1 3 } foo -- cgit v0.12 From ad096310ec004ae12fc9509dd5cb891146eb3520 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Jan 2020 08:29:26 +0000 Subject: Last unused internal stub entry from 258 to 259. --- generic/tclInt.decls | 31 +++++++++++++++---------------- generic/tclIntDecls.h | 9 ++++++--- generic/tclStubInit.c | 3 ++- 3 files changed, 23 insertions(+), 20 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 2b3b89d..93a436a 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -73,7 +73,7 @@ declare 11 { declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } -# Removed in 8.5 +# Removed in 8.5: #declare 13 { # int TclDoGlob(Tcl_Interp *interp, char *separators, # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) @@ -88,7 +88,7 @@ declare 14 { declare 16 { void TclExprFloatError(Tcl_Interp *interp, double value) } -# Removed in 8.4 +# Removed in 8.4: #declare 17 { # int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) #} @@ -123,7 +123,7 @@ declare 25 { # declare 26 { # char *TclGetCwd(Tcl_Interp *interp) # } -# Removed in 8.5 +# Removed in 8.5: #declare 27 { # int TclGetDate(char *p, unsigned long now, long zone, # unsigned long *timePtr) @@ -147,7 +147,7 @@ declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } -# Removed in Tcl 8.5 +# Removed in 8.5: #declare 33 { # TclCmdProcType TclGetInterpProc(void) #} @@ -184,9 +184,9 @@ declare 41 { declare 42 { char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 43 { -# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, +# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 44 { @@ -219,9 +219,9 @@ declare 50 { declare 51 { int TclInterpInit(Tcl_Interp *interp) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 52 { -# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, +# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 53 { @@ -272,7 +272,7 @@ declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 65 { # int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, # Tcl_Obj *const objv[], int flags) @@ -378,9 +378,9 @@ declare 92 { declare 93 { void TclProcDeleteProc(ClientData clientData) } -# Removed in Tcl 8.5: +# Removed in 8.5: #declare 94 { -# int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, +# int TclProcInterpProc(void *clientData, Tcl_Interp *interp, # int argc, const char **argv) #} # Replaced by Tcl_FSStat in 8.4: @@ -553,7 +553,7 @@ declare 138 { #declare 139 { # int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, # char *sym2, Tcl_PackageInitProc **proc1Ptr, -# Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr) +# Tcl_PackageInitProc **proc2Ptr, void **clientDataPtr) #} #declare 140 { # int TclLooksLikeInt(const char *bytes, int length) @@ -608,11 +608,11 @@ declare 153 { # moved to tclTest.c (static) in 8.3.2/8.4a2 #declare 154 { -# int TclTestChannelCmd(ClientData clientData, +# int TclTestChannelCmd(void *clientData, # Tcl_Interp *interp, int argc, char **argv) #} #declare 155 { -# int TclTestChannelEventCmd(ClientData clientData, +# int TclTestChannelEventCmd(void *clientData, # Tcl_Interp *interp, int argc, char **argv) #} @@ -945,10 +945,9 @@ declare 249 { int *decpt, int *signum, char **endPtr) } -declare 258 { +declare 259 { void TclUnusedStubEntry(void) } - ############################################################################## diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 6e74d36..fe23e77 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -1064,9 +1064,10 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, /* Slot 255 is reserved */ /* Slot 256 is reserved */ /* Slot 257 is reserved */ +/* Slot 258 is reserved */ #ifndef TclUnusedStubEntry_TCL_DECLARED #define TclUnusedStubEntry_TCL_DECLARED -/* 258 */ +/* 259 */ EXTERN void TclUnusedStubEntry(void); #endif @@ -1332,7 +1333,8 @@ typedef struct TclIntStubs { VOID *reserved255; VOID *reserved256; VOID *reserved257; - void (*tclUnusedStubEntry) (void); /* 258 */ + VOID *reserved258; + void (*tclUnusedStubEntry) (void); /* 259 */ } TclIntStubs; extern TclIntStubs *tclIntStubsPtr; @@ -2070,9 +2072,10 @@ extern TclIntStubs *tclIntStubsPtr; /* Slot 255 is reserved */ /* Slot 256 is reserved */ /* Slot 257 is reserved */ +/* Slot 258 is reserved */ #ifndef TclUnusedStubEntry #define TclUnusedStubEntry \ - (tclIntStubsPtr->tclUnusedStubEntry) /* 258 */ + (tclIntStubsPtr->tclUnusedStubEntry) /* 259 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b78febc..239cf60 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -558,7 +558,8 @@ TclIntStubs tclIntStubs = { NULL, /* 255 */ NULL, /* 256 */ NULL, /* 257 */ - TclUnusedStubEntry, /* 258 */ + NULL, /* 258 */ + TclUnusedStubEntry, /* 259 */ }; TclIntPlatStubs tclIntPlatStubs = { -- cgit v0.12 From 92c8a53689ae3aed2756704c0497352e686c3ae2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Jan 2020 12:55:41 +0000 Subject: Better error-handling in some libtommath calls. --- generic/tclBasic.c | 2 +- generic/tclObj.c | 9 ++++++++- generic/tclStrToD.c | 4 ++-- generic/tclTestObj.c | 30 +++++++++++++++--------------- generic/tclTomMathInterface.c | 19 +++++++------------ 5 files changed, 33 insertions(+), 31 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a03f131..68f32c2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7547,7 +7547,7 @@ ExprAbsFunc( if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: - mp_neg(&big, &big); + (void)mp_neg(&big, &big); Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); } else { unChanged: diff --git a/generic/tclObj.c b/generic/tclObj.c index eca456f..b5d6d84 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3392,7 +3392,14 @@ GetBignumFromObj( mp_int temp; UNPACK_BIGNUM(objPtr, temp); - mp_init_copy(bignumValue, &temp); + if (mp_init_copy(bignumValue, &temp) != MP_OKAY) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "insufficient memory to unpack bignum", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } } else { UNPACK_BIGNUM(objPtr, *bignumValue); objPtr->internalRep.twoPtrValue.ptr1 = NULL; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 16eca19..523e0cb 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1283,7 +1283,7 @@ TclParseNumber( } if (octalSignificandOverflow) { if (signum) { - mp_neg(&octalSignificandBig, &octalSignificandBig); + (void)mp_neg(&octalSignificandBig, &octalSignificandBig); } TclSetBignumIntRep(objPtr, &octalSignificandBig); } @@ -1330,7 +1330,7 @@ TclParseNumber( } if (significandOverflow) { if (signum) { - mp_neg(&significandBig, &significandBig); + (void)mp_neg(&significandBig, &significandBig); } TclSetBignumIntRep(objPtr, &significandBig); } diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index f741714..ba1dda6 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -160,7 +160,7 @@ TestbignumobjCmd( }; int index, varIndex; const char *string; - mp_int bignumValue, newValue; + mp_int bignumValue; Tcl_Obj **varPtr; if (objc < 3) { @@ -233,19 +233,16 @@ TestbignumobjCmd( &bignumValue) != TCL_OK) { return TCL_ERROR; } - if (mp_init(&newValue) != MP_OKAY - || (mp_mul_d(&bignumValue, 10, &newValue) != MP_OKAY)) { + if (mp_mul_d(&bignumValue, 10, &bignumValue) != MP_OKAY) { mp_clear(&bignumValue); - mp_clear(&newValue); Tcl_SetObjResult(interp, Tcl_NewStringObj("error in mp_mul_d", -1)); return TCL_ERROR; } - mp_clear(&bignumValue); if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetBignumObj(varPtr[varIndex], &newValue); + Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue)); } break; @@ -261,19 +258,16 @@ TestbignumobjCmd( &bignumValue) != TCL_OK) { return TCL_ERROR; } - if (mp_init(&newValue) != MP_OKAY - || (mp_div_d(&bignumValue, 10, &newValue, NULL) != MP_OKAY)) { + if (mp_div_d(&bignumValue, 10, &bignumValue, NULL) != MP_OKAY) { mp_clear(&bignumValue); - mp_clear(&newValue); Tcl_SetObjResult(interp, Tcl_NewStringObj("error in mp_div_d", -1)); return TCL_ERROR; } - mp_clear(&bignumValue); if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetBignumObj(varPtr[varIndex], &newValue); + Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue)); } break; @@ -289,10 +283,16 @@ TestbignumobjCmd( &bignumValue) != TCL_OK) { return TCL_ERROR; } + if (mp_mod_2d(&bignumValue, 1, &bignumValue) != MP_OKAY) { + mp_clear(&bignumValue); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("error in mp_mod_2d", -1)); + return TCL_ERROR; + } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], !mp_isodd(&bignumValue)); + Tcl_SetIntObj(varPtr[varIndex], mp_iszero(&bignumValue)); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(!mp_isodd(&bignumValue))); + SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iszero(&bignumValue))); } mp_clear(&bignumValue); break; diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index 2dc8c2d..21fd238 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -111,7 +111,6 @@ TclBNInitBignumFromLong( mp_int *a, long initVal) { - int status; unsigned long v; mp_digit *p; @@ -119,8 +118,7 @@ TclBNInitBignumFromLong( * Allocate enough memory to hold the largest possible long */ - status = mp_init(a); - if (status != MP_OKAY) { + if (mp_init(a) != MP_OKAY) { Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); } @@ -130,7 +128,7 @@ TclBNInitBignumFromLong( if (initVal < 0) { a->sign = MP_NEG; - v = -initVal; + v = -(unsigned long)initVal; } else { a->sign = MP_ZPOS; v = initVal; @@ -170,12 +168,11 @@ TclBNInitBignumFromWideInt( mp_int *a, /* Bignum to initialize */ Tcl_WideInt v) /* Initial value */ { - if (v < (Tcl_WideInt)0) { - TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)(-v)); - mp_neg(a, a); - } else { - TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v); + if (v < 0) { + (void)TclBNInitBignumFromWideUInt(a, -(Tcl_WideUInt)v); + return mp_neg(a, a); } + (void)TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v); return MP_OKAY; } @@ -200,15 +197,13 @@ TclBNInitBignumFromWideUInt( mp_int *a, /* Bignum to initialize */ Tcl_WideUInt v) /* Initial value */ { - int status; mp_digit *p; /* * Allocate enough memory to hold the largest possible Tcl_WideUInt. */ - status = mp_init(a); - if (status != MP_OKAY) { + if (mp_init(a) != MP_OKAY) { Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); } -- cgit v0.12 From b20939682db9de999efc420072a8d0379a36d6e7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 23 Jan 2020 15:40:08 +0000 Subject: Fix See also links in list commands --- doc/lappend.n | 5 +++-- doc/lassign.n | 4 +++- doc/lindex.n | 5 +++-- doc/linsert.n | 5 +++-- doc/list.n | 6 +++--- doc/llength.n | 5 +++-- doc/lmap.n | 5 ++++- doc/lpop.n | 5 +++-- doc/lrange.n | 5 +++-- doc/lremove.n | 4 +++- doc/lrepeat.n | 4 +++- doc/lreplace.n | 5 +++-- doc/lreverse.n | 5 +++-- doc/lsearch.n | 6 ++++-- doc/lset.n | 5 +++-- doc/lsort.n | 5 +++-- 16 files changed, 50 insertions(+), 29 deletions(-) diff --git a/doc/lappend.n b/doc/lappend.n index 66bea5f..89b6909 100644 --- a/doc/lappend.n +++ b/doc/lappend.n @@ -49,8 +49,9 @@ Using \fBlappend\fR to build up a list of numbers. 1 2 3 4 5 .CE .SH "SEE ALSO" -list(n), lindex(n), linsert(n), llength(n), lset(n), -lsort(n), lrange(n) +list(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS append, element, list, variable .\" Local variables: diff --git a/doc/lassign.n b/doc/lassign.n index 5620de6..67048ba 100644 --- a/doc/lassign.n +++ b/doc/lassign.n @@ -52,7 +52,9 @@ command in many shell languages like this: set ::argv [\fBlassign\fR $::argv argumentToReadOff] .CE .SH "SEE ALSO" -lindex(n), list(n), lrange(n), lset(n), set(n) +list(n), lappend(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS assign, element, list, multiple, set, variable '\"Local Variables: diff --git a/doc/lindex.n b/doc/lindex.n index be4f169..01e0d8b 100644 --- a/doc/lindex.n +++ b/doc/lindex.n @@ -115,8 +115,9 @@ set idx 3 \fI\(-> f\fR .CE .SH "SEE ALSO" -list(n), lappend(n), linsert(n), llength(n), lsearch(n), -lset(n), lsort(n), lrange(n), lreplace(n), +list(n), lappend(n), lassign(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, index, list diff --git a/doc/linsert.n b/doc/linsert.n index 91db726..3179256 100644 --- a/doc/linsert.n +++ b/doc/linsert.n @@ -45,8 +45,9 @@ set newList [\fBlinsert\fR $midList end-1 lazy] set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy] .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), llength(n), lsearch(n), -lset(n), lsort(n), lrange(n), lreplace(n), +list(n), lappend(n), lassign(n), lindex(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, insert, list diff --git a/doc/list.n b/doc/list.n index a182fc8..3fa1975 100644 --- a/doc/list.n +++ b/doc/list.n @@ -46,9 +46,9 @@ while \fBconcat\fR with the same arguments will return \fBa b c d e f {g h}\fR .CE .SH "SEE ALSO" -lappend(n), lindex(n), linsert(n), llength(n), lrange(n), -lrepeat(n), -lreplace(n), lsearch(n), lset(n), lsort(n) +lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, list, quoting '\"Local Variables: diff --git a/doc/llength.n b/doc/llength.n index 7e46064..26824a0 100644 --- a/doc/llength.n +++ b/doc/llength.n @@ -49,8 +49,9 @@ An empty list is not necessarily an empty string: 1,0 .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), lsearch(n), -lset(n), lsort(n), lrange(n), lreplace(n) +list(n), lappend(n), lassign(n), lindex(n), linsert(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, list, length '\" Local Variables: diff --git a/doc/lmap.n b/doc/lmap.n index 1a7858d..026e9d0 100644 --- a/doc/lmap.n +++ b/doc/lmap.n @@ -77,7 +77,10 @@ set prefix [\fBlmap\fR x $values {expr { # The value of prefix is "8 7 6 5 4" .CE .SH "SEE ALSO" -break(n), continue(n), for(n), foreach(n), while(n) +break(n), continue(n), for(n), foreach(n), while(n), +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS foreach, iteration, list, loop, map '\" Local Variables: diff --git a/doc/lpop.n b/doc/lpop.n index 0ce8ff8..631bc58 100644 --- a/doc/lpop.n +++ b/doc/lpop.n @@ -86,8 +86,9 @@ The indicated value becomes the new value of \fIx\fR. \fI\(-> {{a b} {c d}} {{e f} h}\fR .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lsort(n), lrange(n), lreplace(n), lset(n) +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, index, list, remove, pop, stack, queue diff --git a/doc/lrange.n b/doc/lrange.n index a4fd98b..0d4b261 100644 --- a/doc/lrange.n +++ b/doc/lrange.n @@ -71,8 +71,9 @@ elements to {elements to} .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lremove(n), lreplace(n), lsort(n), +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, list, range, sublist diff --git a/doc/lremove.n b/doc/lremove.n index b947863..59d261b 100644 --- a/doc/lremove.n +++ b/doc/lremove.n @@ -46,7 +46,9 @@ Removing the same element indicated in two different ways: a b d e .CE .SH "SEE ALSO" -list(n), lrange(n), lsearch(n), lsearch(n) +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, list, remove .\" Local variables: diff --git a/doc/lrepeat.n b/doc/lrepeat.n index 4719bfd..2e17f9c 100644 --- a/doc/lrepeat.n +++ b/doc/lrepeat.n @@ -32,7 +32,9 @@ is identical to \fBlist element ...\fR. \fI\(-> {a a} b c {a a} b c {a a} b c\fR .CE .SH "SEE ALSO" -list(n), lappend(n), linsert(n), llength(n), lset(n) +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, index, list '\" Local Variables: diff --git a/doc/lreplace.n b/doc/lreplace.n index 68cddfe..bc9d7ca 100644 --- a/doc/lreplace.n +++ b/doc/lreplace.n @@ -95,8 +95,9 @@ a b c d e f g h i .CE .VE TIP505 .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lrange(n), lremove(n), lsort(n), +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), +lreverse(n), lsearch(n), lset(n), lsort(n), string(n) .SH KEYWORDS element, list, replace diff --git a/doc/lreverse.n b/doc/lreverse.n index 4c2f762..2ed496a 100644 --- a/doc/lreverse.n +++ b/doc/lreverse.n @@ -25,8 +25,9 @@ input list, \fIlist\fR, except with the elements in the reverse order. \fI\(-> f e {c d} b a\fR .CE .SH "SEE ALSO" -list(n), lsearch(n), lsort(n) - +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, list, reverse '\" Local Variables: diff --git a/doc/lsearch.n b/doc/lsearch.n index 9172d96..f38afc9 100644 --- a/doc/lsearch.n +++ b/doc/lsearch.n @@ -227,8 +227,10 @@ The same thing for a flattened list: \fI\(-> {a abc b bcd}\fR .CE .SH "SEE ALSO" -foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), -lset(n), lsort(n), lrange(n), lreplace(n), +foreach(n), +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lset(n), lsort(n), string(n) .SH KEYWORDS binary search, linear search, diff --git a/doc/lset.n b/doc/lset.n index e425274..afc721f 100644 --- a/doc/lset.n +++ b/doc/lset.n @@ -136,8 +136,9 @@ The indicated return value also becomes the new value of \fIx\fR. \fI\(-> {{a b} {c d}} {{e f} {j h}}\fR .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lsort(n), lrange(n), lreplace(n), +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lsort(n) string(n) .SH KEYWORDS element, index, list, replace, set diff --git a/doc/lsort.n b/doc/lsort.n index 17a921a..2018e30 100644 --- a/doc/lsort.n +++ b/doc/lsort.n @@ -264,8 +264,9 @@ More complex sorting using a comparison function: {1 dingo} {2 banana} {0x2 carrot} {3 apple} .CE .SH "SEE ALSO" -list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), -lset(n), lrange(n), lreplace(n) +list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), +lreverse(n), lsearch(n), lset(n) .SH KEYWORDS element, list, order, sort '\" Local Variables: -- cgit v0.12 From bfed58b030fcbad9ec232ecc48a43e637022e307 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 25 Jan 2020 14:51:08 +0000 Subject: TIP #559 follow-up: Make sure that if Tcl_FreeResult() is used in an extension compiled with -DTCL_NO_DEPRECATED, this results in a link error. Do the same with deprecated funcions from other TIP's. --- generic/tclDecls.h | 15 +++++++++++++++ generic/tclResult.c | 6 ++---- generic/tclStubInit.c | 1 + 3 files changed, 18 insertions(+), 4 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 7386347..c487521 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4015,7 +4015,22 @@ extern const TclStubs *tclStubsPtr; #define Tcl_AddObjErrorInfo(interp, message, length) \ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) #ifdef TCL_NO_DEPRECATED +#undef Tcl_FreeResult +#undef Tcl_AppendResultVA +#undef Tcl_AppendStringsToObjVA +#undef Tcl_SetErrorCodeVA +#undef Tcl_VarEvalVA +#undef Tcl_PanicVA #undef Tcl_GetStringResult +#undef Tcl_GetDefaultEncodingDir +#undef Tcl_SetDefaultEncodingDir +#undef Tcl_UniCharLen +#undef Tcl_UniCharNcmp +#undef Tcl_EvalTokens +#undef Tcl_UniCharNcasecmp +#undef Tcl_UniCharCaseMatch +#undef Tcl_GetMathFuncInfo +#undef Tcl_ListMathFuncs #define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) #undef Tcl_Eval #define Tcl_Eval(interp, objPtr) \ diff --git a/generic/tclResult.c b/generic/tclResult.c index 5c2a81f..29c5aac 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -853,7 +853,6 @@ SetupAppendBuffer( Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; } -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -883,7 +882,6 @@ Tcl_FreeResult( { Interp *iPtr = (Interp *) interp; -#ifndef TCL_NO_DEPRECATED if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -893,10 +891,10 @@ Tcl_FreeResult( iPtr->freeProc = 0; } -#endif /* !TCL_NO_DEPRECATED */ ResetObjResult(iPtr); } - +#endif /* !TCL_NO_DEPRECATED */ + /* *---------------------------------------------------------------------- * diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 493a272..97ef2cc 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -255,6 +255,7 @@ mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *c) { # define Tcl_NewLongObj 0 # define Tcl_DbNewLongObj 0 # define Tcl_BackgroundError 0 +# define Tcl_FreeResult 0 #else mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) { -- cgit v0.12 From 7c48658c9f808152cc40f5afec9df0cb0b28bffe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 27 Jan 2020 10:31:36 +0000 Subject: =?UTF-8?q?Fix=20install-libraries-zipfs-static=20target:=20On=20W?= =?UTF-8?q?indows=20INSTALL=5FDATA=20makes=20no=20sense.=20Reported=20by?= =?UTF-8?q?=20Ren=C3=A9=20Zaumseil.=20Thanks!?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- win/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/Makefile.in b/win/Makefile.in index 75b6e07..33644cb 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -834,7 +834,7 @@ install-binaries: binaries install-libraries-zipfs-shared: libraries install-libraries-zipfs-static: install-libraries-zipfs-shared - $(INSTALL_DATA) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)" + $(COPY) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)" install-libraries: libraries install-tzdata install-msgs @for i in "$$($(CYGPATH) $(prefix)/lib)" "$(INCLUDE_INSTALL_DIR)" \ -- cgit v0.12 From 667676a5510ccdd2fa569d14ebaccada0090393b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 29 Jan 2020 13:02:06 +0000 Subject: Fix compiler warnings on Cygwin when using -DTCL_NO_DEPRECATED Use TCL_CHANNEL_VERSION_5 in stead of TCL_CHANNEL_VERSION_3 in tclZlib.c --- generic/tclStubInit.c | 2 +- generic/tclZlib.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 97ef2cc..6a588a5 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -504,7 +504,7 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ return result; } #define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj -#if TCL_UTF_MAX < 4 +#if TCL_UTF_MAX < 4 && !defined(TCL_NO_DEPRECATED) static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 8dbe807..49f1c39 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -204,7 +204,7 @@ static void ZlibTransformTimerRun(void *clientData); static const Tcl_ChannelType zlibChannelType = { "zlib", - TCL_CHANNEL_VERSION_3, + TCL_CHANNEL_VERSION_5, ZlibTransformClose, ZlibTransformInput, ZlibTransformOutput, -- cgit v0.12