summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclExecute.c4
-rw-r--r--generic/tclInt.h2
-rw-r--r--generic/tclObj.c2
-rw-r--r--generic/tclStringObj.c45
-rw-r--r--generic/tclStubInit.c9
-rw-r--r--generic/tclTestObj.c24
-rw-r--r--generic/tclUtf.c4
-rw-r--r--generic/tclUtil.c2
-rw-r--r--tests/stringObj.test26
9 files changed, 73 insertions, 45 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f09f75c..0456146 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5592,8 +5592,8 @@ TEBCresume(
* both.
*/
- if (TclHasInternalRep(valuePtr, &tclStringType)
- || TclHasInternalRep(value2Ptr, &tclStringType)) {
+ if (TclHasInternalRep(valuePtr, &tclUniCharStringType)
+ || TclHasInternalRep(value2Ptr, &tclUniCharStringType)) {
Tcl_UniChar *ustring1, *ustring2;
ustring1 = TclGetUnicodeFromObj_(valuePtr, &length);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3aa2626..6804996 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2768,6 +2768,7 @@ MODULE_SCOPE const Tcl_ObjType tclListType;
MODULE_SCOPE const Tcl_ObjType tclDictType;
MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
+MODULE_SCOPE const Tcl_ObjType tclUniCharStringType;
MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType;
MODULE_SCOPE const Tcl_ObjType tclRegexpType;
MODULE_SCOPE Tcl_ObjType tclCmdNameType;
@@ -3333,6 +3334,7 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp);
# undef Tcl_UtfAtIndex
# define Tcl_UtfAtIndex TclUtfAtIndex
#else
+# define tclUniCharStringType tclStringType
# define TclGetUnicodeFromObj_ Tcl_GetUnicodeFromObj
# define TclNewUnicodeObj Tcl_NewUnicodeObj
# define TclAppendUnicodeToObj Tcl_AppendUnicodeToObj
diff --git a/generic/tclObj.c b/generic/tclObj.c
index a06b8fd..7596880 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -387,7 +387,9 @@ TclInitObjSubsystem(void)
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
+#if (TCL_UTF_MAX) > 3 && !defined(TCL_NO_DEPRECATED)
Tcl_RegisterObjType(&tclStringType);
+#endif
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 17c7067..627fadc 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -69,7 +69,7 @@ static void SetUnicodeObj(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, int numChars);
static int UnicodeLength(const Tcl_UniChar *unicode);
static void UpdateStringOfString(Tcl_Obj *objPtr);
-#if TCL_UTF_MAX > 3
+#if (TCL_UTF_MAX) > 3 && !defined(TCL_NO_DEPRECATED)
static void DupUTF16StringInternalRep(Tcl_Obj *objPtr,
Tcl_Obj *copyPtr);
static int SetUTF16StringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
@@ -88,7 +88,7 @@ static void UpdateStringOfUTF16String(Tcl_Obj *objPtr);
#if TCL_UTF_MAX < 4
-#define uniCharStringType tclStringType
+#define tclUniCharStringType tclStringType
#define GET_UNICHAR_STRING GET_STRING
#define UniCharString String
#define UNICHAR_STRING_MAXCHARS STRING_MAXCHARS
@@ -110,6 +110,8 @@ const Tcl_ObjType tclStringType = {
#else
+#define tclStringType xxx
+#ifndef TCL_NO_DEPRECATED
const Tcl_ObjType tclStringType = {
"string", /* name */
FreeStringInternalRep, /* freeIntRepPro */
@@ -117,8 +119,9 @@ const Tcl_ObjType tclStringType = {
UpdateStringOfUTF16String, /* updateStringProc */
SetUTF16StringFromAny /* setFromAnyProc */
};
+#endif
-static const Tcl_ObjType uniCharStringType = {
+const Tcl_ObjType tclUniCharStringType = {
"utf32string", /* name */
FreeStringInternalRep, /* freeIntRepPro */
DupStringInternalRep, /* dupIntRepProc */
@@ -170,6 +173,7 @@ typedef struct {
((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr))
+#ifndef TCL_NO_DEPRECATED
static void
DupUTF16StringInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have
@@ -243,6 +247,7 @@ UpdateStringOfUTF16String(
objPtr->length = Tcl_DStringLength(&ds);
Tcl_DStringFree(&ds);
}
+#endif
#endif
@@ -545,7 +550,7 @@ TclNewUnicodeObj(
return objPtr;
}
-#if TCL_UTF_MAX > 3
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
Tcl_Obj *
Tcl_NewUnicodeObj(
const unsigned short *unicode, /* The unicode string used to initialize the
@@ -644,7 +649,7 @@ TclGetCharLength(
return numChars;
}
-#if TCL_UTF_MAX > 3
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
#undef Tcl_GetCharLength
int
Tcl_GetCharLength(
@@ -889,7 +894,7 @@ TclGetUnicodeFromObj_(
return stringPtr->unicode;
}
-#if TCL_UTF_MAX > 3
+#if TCL_UTF_MAX > 3 && !defined(TCL_NO_DEPRECATED)
unsigned short *
Tcl_GetUnicodeFromObj(
Tcl_Obj *objPtr, /* The object to find the unicode string
@@ -1327,6 +1332,7 @@ Tcl_AttemptSetObjLength(
*---------------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
void
Tcl_SetUnicodeObj(
Tcl_Obj *objPtr, /* The object to set the string of. */
@@ -1366,6 +1372,7 @@ Tcl_SetUnicodeObj(
TclInvalidateStringRep(objPtr);
stringPtr->allocated = numChars;
}
+#endif
static int
UnicodeLength(
@@ -1403,7 +1410,7 @@ SetUnicodeObj(
uniCharStringCheckLimits(numChars);
stringPtr = uniCharStringAlloc(numChars);
SET_UNICHAR_STRING(objPtr, stringPtr);
- objPtr->typePtr = &uniCharStringType;
+ objPtr->typePtr = &tclUniCharStringType;
stringPtr->maxChars = numChars;
memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar));
@@ -1591,7 +1598,7 @@ TclAppendUnicodeToObj(
}
}
-#if TCL_UTF_MAX > 3
+#if TCL_UTF_MAX > 3 && !defined(TCL_NO_DEPRECATED)
void
Tcl_AppendUnicodeToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
@@ -1736,7 +1743,7 @@ Tcl_AppendObjToObj(
* If appendObjPtr is not of the "String" type, don't convert it.
*/
- if (TclHasInternalRep(appendObjPtr, &uniCharStringType)) {
+ if (TclHasInternalRep(appendObjPtr, &tclUniCharStringType)) {
Tcl_UniChar *unicode =
TclGetUnicodeFromObj_(appendObjPtr, &numChars);
@@ -1757,7 +1764,7 @@ Tcl_AppendObjToObj(
bytes = TclGetStringFromObj(appendObjPtr, &length);
numChars = stringPtr->numChars;
- if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &uniCharStringType)) {
+ if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclUniCharStringType)) {
UniCharString *appendStringPtr = GET_UNICHAR_STRING(appendObjPtr);
appendNumChars = appendStringPtr->numChars;
@@ -3166,7 +3173,7 @@ TclGetStringStorage(
{
UniCharString *stringPtr;
- if (!TclHasInternalRep(objPtr, &uniCharStringType) || objPtr->bytes == NULL) {
+ if (!TclHasInternalRep(objPtr, &tclUniCharStringType) || objPtr->bytes == NULL) {
return TclGetStringFromObj(objPtr, (int *)sizePtr);
}
@@ -3214,7 +3221,7 @@ TclStringRepeat(
*/
if (!binary) {
- if (TclHasInternalRep(objPtr, &uniCharStringType)) {
+ if (TclHasInternalRep(objPtr, &tclUniCharStringType)) {
UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode) {
unichar = 1;
@@ -3385,7 +3392,7 @@ TclStringCat(
binary = 0;
if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) {
forceUniChar = 1;
- } else if ((objPtr->typePtr) && (objPtr->typePtr != &uniCharStringType)) {
+ } else if ((objPtr->typePtr) && (objPtr->typePtr != &tclUniCharStringType)) {
/* Prevent shimmer of non-string types. */
allowUniChar = 0;
}
@@ -3393,7 +3400,7 @@ TclStringCat(
} else {
/* assert (objPtr->typePtr != NULL) -- stork! */
binary = 0;
- if (TclHasInternalRep(objPtr, &uniCharStringType)) {
+ if (TclHasInternalRep(objPtr, &tclUniCharStringType)) {
/* Have a pure Unicode value; ask to preserve it */
requestUniChar = 1;
} else {
@@ -3746,8 +3753,8 @@ TclStringCmp(
s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len);
s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
memCmpFn = memcmp;
- } else if (TclHasInternalRep(value1Ptr, &uniCharStringType)
- && TclHasInternalRep(value2Ptr, &uniCharStringType)) {
+ } else if (TclHasInternalRep(value1Ptr, &tclUniCharStringType)
+ && TclHasInternalRep(value2Ptr, &tclUniCharStringType)) {
/*
* Do a unicode-specific comparison if both of the args are of
* String type. If the char length == byte length, we can do a
@@ -4556,7 +4563,7 @@ DupStringInternalRep(
copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0;
SET_UNICHAR_STRING(copyPtr, copyStringPtr);
- copyPtr->typePtr = &uniCharStringType;
+ copyPtr->typePtr = &tclUniCharStringType;
}
/*
@@ -4581,7 +4588,7 @@ SetStringFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr) /* The object to convert. */
{
- if (!TclHasInternalRep(objPtr, &uniCharStringType)) {
+ if (!TclHasInternalRep(objPtr, &tclUniCharStringType)) {
UniCharString *stringPtr = uniCharStringAlloc(0);
/*
@@ -4601,7 +4608,7 @@ SetStringFromAny(
stringPtr->maxChars = 0;
stringPtr->hasUnicode = 0;
SET_UNICHAR_STRING(objPtr, stringPtr);
- objPtr->typePtr = &uniCharStringType;
+ objPtr->typePtr = &tclUniCharStringType;
}
return TCL_OK;
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 9757ad2..7c8c219 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -87,6 +87,15 @@
#define TclUtfNext UtfNext
#define TclUtfPrev UtfPrev
+#if TCL_UTF_MAX > 3 && defined(TCL_NO_DEPRECATED)
+#define Tcl_GetUnicodeFromObj 0
+#define Tcl_AppendUnicodeToObj 0
+#define Tcl_NewUnicodeObj 0
+#define Tcl_SetUnicodeObj 0
+#define Tcl_UtfAtIndex 0
+#define Tcl_GetCharLength 0
+#endif
+
static int TclUtfCharComplete(const char *src, int length) {
if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) {
return length < 3;
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 9884a9a..223eb98 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -1264,10 +1264,14 @@ TeststringobjCmd(
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
- Tcl_ConvertToType(NULL, varPtr[varIndex],
- Tcl_GetObjType("string"));
- strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
- length = (int) strPtr->allocated;
+ const Tcl_ObjType *objType = Tcl_GetObjType("string");
+ if (objType != NULL) {
+ Tcl_ConvertToType(NULL, varPtr[varIndex], objType);
+ strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
+ length = (int) strPtr->allocated;
+ } else {
+ length = -1;
+ }
} else {
length = -1;
}
@@ -1318,10 +1322,14 @@ TeststringobjCmd(
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
- Tcl_ConvertToType(NULL, varPtr[varIndex],
- Tcl_GetObjType("string"));
- strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
- length = strPtr->maxChars;
+ const Tcl_ObjType *objType = Tcl_GetObjType("string");
+ if (objType != NULL) {
+ Tcl_ConvertToType(NULL, varPtr[varIndex],objType);
+ strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
+ length = strPtr->maxChars;
+ } else {
+ length = -1;
+ }
} else {
length = -1;
}
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index cfd9915..2a335d7 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -850,7 +850,7 @@ TclNumUtfChars(
return i;
}
-#if TCL_UTF_MAX > 3
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
#undef Tcl_NumUtfChars
int
Tcl_NumUtfChars(
@@ -1245,7 +1245,7 @@ TclUtfAtIndex(
return src;
}
-#if TCL_UTF_MAX > 3
+#if (TCL_UTF_MAX > 3) && !defined(TCL_NO_DEPRECATED)
#undef Tcl_UtfAtIndex
const char *
Tcl_UtfAtIndex(
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 9cc82cb..3537ecc 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -2591,7 +2591,7 @@ TclStringMatchObj(
trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj));
*/
- if (TclHasInternalRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) {
+ if (TclHasInternalRep(strObj, &tclUniCharStringType) || (strObj->typePtr == NULL)) {
Tcl_UniChar *udata, *uptn;
udata = TclGetUnicodeFromObj_(strObj, &length);
diff --git a/tests/stringObj.test b/tests/stringObj.test
index c11bf7f..0aa9a47 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -27,7 +27,7 @@ testConstraint testdstring [llength [info commands testdstring]]
testConstraint tip389 [expr {[string length \U010000] == 2}]
testConstraint utf32 [expr {[string length [format %c 0x10000]] == 1}]
-test stringObj-1.1 {string type registration} testobj {
+test stringObj-1.1 {string type registration} {testobj deprecated} {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first >= 0}]
@@ -58,27 +58,27 @@ test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} testob
lappend result [testobj refcount 1]
} {{} 512 foo string 2}
-test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} {testobj utf32} {
+test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} {testobj utf32 deprecated} {
testobj freeallvars
teststringobj set 1 test
teststringobj setlength 1 3
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {3 3 tes}
-test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} testobj {
+test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} {testobj deprecated} {
testobj freeallvars
teststringobj set 1 abcdef
teststringobj setlength 1 10
list [teststringobj length 1] [teststringobj length2 1]
} {10 10}
-test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} {testobj utf32} {
+test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} {testobj utf32 deprecated} {
testobj freeallvars
teststringobj set 1 abcdef
teststringobj append 1 xyzq -1
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {10 10 abcdefxyzq}
-test stringObj-4.4 {Tcl_SetObjLength procedure, "expty string", length 0} testobj {
+test stringObj-4.4 {Tcl_SetObjLength procedure, "expty string", length 0} {testobj deprecated} {
testobj freeallvars
testobj newobj 1
teststringobj setlength 1 0
@@ -98,7 +98,7 @@ test stringObj-5.2 {Tcl_AppendToObj procedure, length calculation} testobj {
teststringobj append 1 123 -1
teststringobj get 1
} {x y bbCC123}
-test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {testobj utf32} {
+test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {testobj utf32 deprecated} {
testobj freeallvars
teststringobj set 1 xyz
teststringobj setlength 1 15
@@ -136,13 +136,13 @@ test stringObj-6.4 {Tcl_AppendStringsToObj procedure, counting space} testobj {
teststringobj appendstrings 1 { 123 } abcdefg
list [teststringobj length 1] [teststringobj get 1]
} {15 {abc 123 abcdefg}}
-test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} {testobj utf32} {
+test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} {testobj utf32 deprecated} {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 123 abcdefg
list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1]
} {10 10 123abcdefg}
-test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testobj {
+test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj deprecated} {
testobj freeallvars
teststringobj set 1 abc
teststringobj setlength 1 10
@@ -151,7 +151,7 @@ test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testob
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {10 10 ab34567890}
-test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj utf32} {
+test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj utf32 deprecated} {
testobj freeallvars
teststringobj set 1 abc
teststringobj setlength 1 10
@@ -160,7 +160,7 @@ test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testo
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {11 11 ab34567890x}
-test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} testobj {
+test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} {testobj deprecated} {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 {}
@@ -173,14 +173,14 @@ test stringObj-6.9 {Tcl_AppendStringToObj, pure unicode} testobj {
teststringobj get 1
} adcfoobarsoom
-test stringObj-7.1 {SetStringFromAny procedure} {testobj utf32} {
+test stringObj-7.1 {SetStringFromAny procedure} {testobj utf32 deprecated} {
testobj freeallvars
teststringobj set2 1 [list a b]
teststringobj append 1 x -1
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {4 4 {a bx}}
-test stringObj-7.2 {SetStringFromAny procedure, null object} testobj {
+test stringObj-7.2 {SetStringFromAny procedure, null object} {testobj deprecated} {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 {}
@@ -198,7 +198,7 @@ test stringObj-7.4 {SetStringFromAny called with string obj} testobj {
[string length $x] [testobj objtype $x]
} {6 string 6 string}
-test stringObj-8.1 {DupStringInternalRep procedure} {testobj utf32} {
+test stringObj-8.1 {DupStringInternalRep procedure} {testobj utf32 deprecated} {
testobj freeallvars
teststringobj set 1 {}
teststringobj append 1 abcde -1
generated by cgit v0.12 at 2024-11-17 05:55:51 (GMT)