Add TclGetUniChar() to the compatibility set

7 files changed, 80 insertions, 3 deletions

diff --git a/generic/tcl.decls b/generic/tcl.decls
index f6a4c05..3b5c8a9 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2466,6 +2466,9 @@ declare 671 {
 declare 672 {
     Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, int first, int last)
 }
+declare 673 {
+    int TclGetUniChar(Tcl_Obj *objPtr, int index)
+}
 
 
 # ----- BASELINE -- FOR -- 8.7.0 ----- #
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 1beb732..29a73cf 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -310,7 +310,7 @@ Tcl_RegexpObjCmd(
 	    eflags = 0;
 	} else if (offset > stringLength) {
 	    eflags = TCL_REG_NOTBOL;
-	} else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') {
+	} else if (TclGetUniChar(objPtr, offset-1) == '\n') {
 	    eflags = 0;
 	} else {
 	    eflags = TCL_REG_NOTBOL;
@@ -1412,7 +1412,7 @@ StringIndexCmd(
     }
 
     if ((index >= 0) && (index < length)) {
-	int ch = Tcl_GetUniChar(objv[1], index);
+	int ch = TclGetUniChar(objv[1], index);
 
 	if (ch == -1) {
 	    return TCL_OK;
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index fdf8673..ac90006 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -1971,6 +1971,8 @@ EXTERN int		TclGetCharLength(Tcl_Obj *objPtr);
 EXTERN const char *	TclUtfAtIndex(const char *src, int index);
 /* 672 */
 EXTERN Tcl_Obj *	TclGetRange(Tcl_Obj *objPtr, int first, int last);
+/* 673 */
+EXTERN int		TclGetUniChar(Tcl_Obj *objPtr, int index);
 
 typedef struct {
     const struct TclPlatStubs *tclPlatStubs;
@@ -2679,6 +2681,7 @@ typedef struct TclStubs {
     int (*tclGetCharLength) (Tcl_Obj *objPtr); /* 670 */
     const char * (*tclUtfAtIndex) (const char *src, int index); /* 671 */
     Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, int first, int last); /* 672 */
+    int (*tclGetUniChar) (Tcl_Obj *objPtr, int index); /* 673 */
 } TclStubs;
 
 extern const TclStubs *tclStubsPtr;
@@ -4048,6 +4051,8 @@ extern const TclStubs *tclStubsPtr;
 	(tclStubsPtr->tclUtfAtIndex) /* 671 */
 #define TclGetRange \
 	(tclStubsPtr->tclGetRange) /* 672 */
+#define TclGetUniChar \
+	(tclStubsPtr->tclGetUniChar) /* 673 */
 
 #endif /* defined(USE_TCL_STUBS) */
 
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 965d821..1f72d63 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5329,7 +5329,7 @@ TEBCresume(
 		    valuePtr->bytes+index, 1);
 	} else {
 	    char buf[4] = "";
-	    int ch = Tcl_GetUniChar(valuePtr, index);
+	    int ch = TclGetUniChar(valuePtr, index);
 
 	    /*
 	     * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1)
diff --git a/generic/tclInt.h b/generic/tclInt.h
index b6cf3b4..cc13c61 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3335,6 +3335,8 @@ MODULE_SCOPE int    TclZipfs_Init(Tcl_Interp *interp);
 #   define Tcl_UtfAtIndex TclUtfAtIndex
 #   undef Tcl_GetRange
 #   define Tcl_GetRange TclGetRange
+#   undef Tcl_GetUniChar
+#   define Tcl_GetUniChar TclGetUniChar
 #else
 #   define tclUniCharStringType tclStringType
 #   define TclGetUnicodeFromObj_ Tcl_GetUnicodeFromObj
@@ -3351,6 +3353,8 @@ MODULE_SCOPE int    TclZipfs_Init(Tcl_Interp *interp);
 #   define TclUtfAtIndex Tcl_UtfAtIndex
 #   undef TclGetRange
 #   define TclGetRange Tcl_GetRange
+#   undef TclGetUniChar
+#   define TclGetUniChar Tcl_GetUniChar
 #endif
 
 
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 6032dbb..e8777cd 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -747,12 +747,70 @@ TclCheckEmptyString(
  *----------------------------------------------------------------------
  */
 
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
+#undef Tcl_GetUniChar
 int
 Tcl_GetUniChar(
     Tcl_Obj *objPtr,		/* The object to get the Unicode charater
 				 * from. */
     int index)			/* Get the index'th Unicode character. */
 {
+    String *stringPtr;
+    int ch, length;
+
+    if (index < 0) {
+	return -1;
+    }
+
+    /*
+     * Optimize the case where we're really dealing with a bytearray object
+     * we don't need to convert to a string to perform the indexing operation.
+     */
+
+    if (TclIsPureByteArray(objPtr)) {
+	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
+	if (index >= length) {
+		return -1;
+	}
+
+	return (int) bytes[index];
+    }
+
+    /*
+     * OK, need to work with the object as a string.
+     */
+
+    SetUTF16StringFromAny(NULL, objPtr);
+    stringPtr = GET_STRING(objPtr);
+
+    if (index >= stringPtr->numChars) {
+	return -1;
+    }
+    ch = stringPtr->unicode[index];
+    /* See: bug [11ae2be95dac9417] */
+    if ((ch & 0xF800) == 0xD800) {
+	if (ch & 0x400) {
+	    if ((index > 0)
+		    && ((stringPtr->unicode[index-1] & 0xFC00) == 0xD800)) {
+		ch = -1; /* low surrogate preceded by high surrogate */
+	    }
+	} else if ((++index < stringPtr->numChars)
+		&& ((stringPtr->unicode[index] & 0xFC00) == 0xDC00)) {
+	    /* high surrogate followed by low surrogate */
+	    ch = (((ch & 0x3FF) << 10) |
+			(stringPtr->unicode[index] & 0x3FF)) + 0x10000;
+	}
+    }
+    return ch;
+}
+#endif
+
+int
+TclGetUniChar(
+    Tcl_Obj *objPtr,		/* The object to get the Unicode charater
+				 * from. */
+    int index)			/* Get the index'th Unicode character. */
+{
     UniCharString *stringPtr;
     int ch, length;
 
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 2046938..fc78f74 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -49,6 +49,7 @@
 #undef Tcl_UniCharLen
 #undef Tcl_UniCharNcmp
 #undef Tcl_GetRange
+#undef Tcl_GetUniChar
 #undef Tcl_DumpActiveMemory
 #undef Tcl_ValidateAllMemory
 #undef Tcl_FindHashEntry
@@ -79,6 +80,10 @@
 #undef TclWinConvertError
 #undef Tcl_GetCharLength
 #undef Tcl_UtfAtIndex
+#undef TclNumUtfChars
+#undef TclGetCharLength
+#undef TclUtfAtIndex
+#undef TclGetUniChar
 #if defined(_WIN32) || defined(__CYGWIN__)
 #define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError
 #define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError
@@ -100,6 +105,7 @@ static void uniCodePanic(void) {
 #   define Tcl_UniCharNcasecmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic
 #   define Tcl_UniCharCaseMatch (int(*)(const unsigned short *, const unsigned short *, int))(void *)uniCodePanic
 #   define Tcl_GetRange (Tcl_Obj *(*)(Tcl_Obj *, int, int))(void *)uniCodePanic
+#   define Tcl_GetUniChar (int(*)(Tcl_Obj *, int))(void *)uniCodePanic
 #endif
 
 #define TclUtfCharComplete UtfCharComplete
@@ -1960,6 +1966,7 @@ const TclStubs tclStubs = {
     TclGetCharLength, /* 670 */
     TclUtfAtIndex, /* 671 */
     TclGetRange, /* 672 */
+    TclGetUniChar, /* 673 */
 };
 
 /* !END!: Do not edit above this line. */