summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.github/workflows/linux-build.yml1
-rw-r--r--.github/workflows/mac-build.yml1
-rw-r--r--.github/workflows/onefiledist.yml1
-rw-r--r--.github/workflows/win-build.yml1
-rw-r--r--generic/tcl.h2
-rwxr-xr-xgeneric/tclArithSeries.c46
-rw-r--r--generic/tclArithSeries.h2
-rw-r--r--generic/tclAssembly.c2
-rw-r--r--generic/tclCmdAH.c2
-rw-r--r--generic/tclCompile.c4
-rw-r--r--generic/tclEncoding.c66
-rw-r--r--generic/tclExecute.c5
-rw-r--r--generic/tclIOUtil.c1
-rw-r--r--generic/tclListObj.c63
-rw-r--r--generic/tclOOInt.h6
-rw-r--r--generic/tclUtil.c11
-rw-r--r--macosx/tclMacOSXFCmd.c2
-rw-r--r--tests-perf/listPerf.tcl13
-rw-r--r--tests/dstring.test18
-rw-r--r--tests/io.test536
-rw-r--r--tests/ioCmd.test8
-rw-r--r--tests/ooUtil.test6
-rw-r--r--win/tclWinFile.c2
-rw-r--r--win/tclWinReg.c8
24 files changed, 435 insertions, 372 deletions
diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml
index 52cec15..29aa98b 100644
--- a/.github/workflows/linux-build.yml
+++ b/.github/workflows/linux-build.yml
@@ -3,7 +3,6 @@ on:
push:
branches:
- "main"
- - "trunk"
- "core-8-branch"
tags:
- "core-**"
diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml
index c576390..462bd92 100644
--- a/.github/workflows/mac-build.yml
+++ b/.github/workflows/mac-build.yml
@@ -3,7 +3,6 @@ on:
push:
branches:
- "main"
- - "trunk"
- "core-8-branch"
tags:
- "core-**"
diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml
index f1cee16..5c90701 100644
--- a/.github/workflows/onefiledist.yml
+++ b/.github/workflows/onefiledist.yml
@@ -3,7 +3,6 @@ on:
push:
branches:
- "main"
- - "trunk"
- "core-8-branch"
tags:
- "core-**"
diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml
index a7ce43b..3809786 100644
--- a/.github/workflows/win-build.yml
+++ b/.github/workflows/win-build.yml
@@ -3,7 +3,6 @@ on:
push:
branches:
- "main"
- - "trunk"
- "core-8-branch"
tags:
- "core-**"
diff --git a/generic/tcl.h b/generic/tcl.h
index 371cae0..b3789c0 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2339,7 +2339,7 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
TclStubCall((void *)4))(argc, argv, appInitProc, interp)
#if !defined(_WIN32) || !defined(UNICODE)
#define Tcl_MainEx(argc, argv, appInitProc, interp) \
- (void)((const char *(*)(size_t, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \
+ (void)((const char *(*)(Tcl_Size, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \
TclStubCall((void *)5))(argc, argv, appInitProc, interp)
#endif
#define Tcl_StaticLibrary(interp, pkgName, initProc, safeInitProc) \
diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c
index 4571b4a..1019677 100755
--- a/generic/tclArithSeries.c
+++ b/generic/tclArithSeries.c
@@ -760,52 +760,6 @@ SetArithSeriesFromAny(
/*
*----------------------------------------------------------------------
*
- * TclArithSeriesObjCopy --
- *
- * Makes a "pure arithSeries" copy of an ArithSeries value. This provides for the C
- * level a counterpart of the [lrange $list 0 end] command, while using
- * internals details to be as efficient as possible.
- *
- * Results:
- *
- * Normally returns a pointer to a new Tcl_Obj, that contains the same
- * arithSeries value as *arithSeriesObj does. The returned Tcl_Obj has a
- * refCount of zero. If *arithSeriesObj does not hold an arithSeries,
- * NULL is returned, and if interp is non-NULL, an error message is
- * recorded there.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-TclArithSeriesObjCopy(
- Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *arithSeriesObj) /* List object for which an element array is
- * to be returned. */
-{
- Tcl_Obj *copyPtr;
- ArithSeries *arithSeriesRepPtr;
-
- arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
- if (NULL == arithSeriesRepPtr) {
- if (SetArithSeriesFromAny(interp, arithSeriesObj) != TCL_OK) {
- /* We know this is going to panic, but it's the message we want */
- return NULL;
- }
- }
-
- TclNewObj(copyPtr);
- TclInvalidateStringRep(copyPtr);
- DupArithSeriesInternalRep(arithSeriesObj, copyPtr);
- return copyPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclArithSeriesObjRange --
*
* Makes a slice of an ArithSeries value.
diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h
index 61538c4..8002239 100644
--- a/generic/tclArithSeries.h
+++ b/generic/tclArithSeries.h
@@ -34,8 +34,6 @@ typedef struct {
} ArithSeriesDbl;
-MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp,
- Tcl_Obj *arithSeriesPtr);
MODULE_SCOPE Tcl_Obj *TclArithSeriesObjIndex(Tcl_Interp *, Tcl_Obj *,
Tcl_WideInt index);
MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp,
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 910532e..4aa241a 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -2247,7 +2247,7 @@ static int
GetListIndexOperand(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
Tcl_Token** tokenPtrPtr, /* Current token from the parser */
- int* result) /* OUTPUT: Integer extracted from the token */
+ int* result) /* OUTPUT: encoded index derived from the token */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index ae1ba33..fbb7f89 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -2807,7 +2807,7 @@ EachloopCmd(
/* Values */
if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType.objType)) {
/* Special case for Arith Series */
- statePtr->aCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]);
+ statePtr->aCopyList[i] = Tcl_DuplicateObj(objv[2+i*2]);
if (statePtr->aCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 926c492..b974c30 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -720,8 +720,8 @@ const Tcl_ObjType tclByteCodeType = {
};
/*
- * subtCodeType provides the standard type managemnt procedures for the
- * substcode type, which represents substiution within a Tcl value.
+ * substCodeType provides the standard type management procedures for the
+ * substcode type, which represents substitution within a Tcl value.
*/
static const Tcl_ObjType substCodeType = {
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index d13c923..1a8fd84 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -10,7 +10,6 @@
*/
#include "tclInt.h"
-#include "tclIO.h"
typedef size_t (LengthProc)(const char *src);
@@ -1159,7 +1158,7 @@ Tcl_ExternalToUtfDString(
* Tcl_ExternalToUtfDStringEx --
*
* Convert a source buffer from the specified encoding into UTF-8.
- * The parameter flags controls the behavior, if any of the bytes in
+ * "flags" controls the behavior if any of the bytes in
* the source buffer are invalid or cannot be represented in utf-8.
* Possible flags values:
* target encoding. It should be composed by OR-ing the following:
@@ -2517,6 +2516,16 @@ UtfToUtfProc(
flags |= PTR2INT(clientData);
dstEnd = dst + dstLen - ((flags & ENCODING_UTF) ? TCL_UTF_MAX : 6);
+
+#if TCL_UTF_MAX < 4
+ /* Initialize the buffer so that some random data doesn't trick
+ * Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
+ * Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
+ * prior non-stateful nature, this call to memset can also be removed.
+ */
+ memset(dst, 0xff, dstLen);
+#endif
+
profile = ENCODING_PROFILE_GET(flags);
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
@@ -2564,10 +2573,10 @@ UtfToUtfProc(
} else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
/*
* Incomplete byte sequence.
- * Always check before using TclUtfToUCS4. Not doing can so
- * cause it run beyond the end of the buffer! If we happen such an
- * incomplete char its bytes are made to represent themselves
- * unless the user has explicitly asked to be told.
+ * Always check before using TclUtfToUCS4. Not doing so can cause it
+ * run beyond the end of the buffer! If we happen on such an incomplete
+ * char its bytes are made to represent themselves unless the user has
+ * explicitly asked to be told.
*/
if (flags & ENCODING_INPUT) {
@@ -2730,6 +2739,15 @@ Utf32ToUtfProc(
}
result = TCL_OK;
+#if TCL_UTF_MAX < 4
+ /* Initialize the buffer so that some random data doesn't trick
+ * Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
+ * Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
+ * prior non-stateful nature, this call to memset can also be removed.
+ */
+ memset(dst, 0xff, dstLen);
+#endif
+
/*
* Check alignment with utf-32 (4 == sizeof(UTF-32))
*/
@@ -2997,6 +3015,15 @@ Utf16ToUtfProc(
}
result = TCL_OK;
+#if TCL_UTF_MAX < 4
+ /* Initialize the buffer so that some random data doesn't trick
+ * Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
+ * Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
+ * prior non-stateful nature, this call to memset can also be removed.
+ */
+ memset(dst, 0xff, dstLen);
+#endif
+
/*
* Check alignment with utf-16 (2 == sizeof(UTF-16))
*/
@@ -3407,6 +3434,15 @@ TableToUtfProc(
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
+#if TCL_UTF_MAX < 4
+ /* Initialize the buffer so that some random data doesn't trick
+ * Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
+ * Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
+ * prior non-stateful nature, this call to memset can also be removed.
+ */
+ memset(dst, 0xff, dstLen);
+#endif
+
toUnicode = (const unsigned short *const *) dataPtr->toUnicode;
prefixBytes = dataPtr->prefixBytes;
pageZero = toUnicode[0];
@@ -3646,6 +3682,15 @@ Iso88591ToUtfProc(
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
+#if TCL_UTF_MAX < 4
+ /* Initialize the buffer so that some random data doesn't trick
+ * Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
+ * Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
+ * prior non-stateful nature, this call to memset can also be removed.
+ */
+ memset(dst, 0xff, dstLen);
+#endif
+
result = TCL_OK;
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
Tcl_UniChar ch = 0;
@@ -3883,6 +3928,15 @@ EscapeToUtfProc(
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
+#if TCL_UTF_MAX < 4
+ /* Initialize the buffer so that some random data doesn't trick
+ * Tcl_UniCharToUtf() into thinking it should combine surrogate pairs.
+ * Once TCL_UTF_MAX == 3 is removed and Tcl_UniCharToUtf restored to its
+ * prior non-stateful nature, this call to memset can also be removed.
+ */
+ memset(dst, 0xff, dstLen);
+#endif
+
state = PTR2INT(*statePtr);
if (flags & TCL_ENCODING_START) {
state = 0;
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 647e3db..9b733b3 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -113,9 +113,8 @@ typedef struct {
ByteCode *codePtr; /* Constant until the BC returns */
/* -----------------------------------------*/
Tcl_Obj **catchTop; /* These fields are used on return TO this */
- Tcl_Obj *auxObjList; /* this level: they record the state when a */
- CmdFrame cmdFrame; /* new codePtr was received for NR */
- /* execution. */
+ Tcl_Obj *auxObjList; /* level: they record the state when a new */
+ CmdFrame cmdFrame; /* codePtr was received for NR execution. */
Tcl_Obj *stack[1]; /* Start of the actual combined catch and obj
* stacks; the struct will be expanded as
* necessary */
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 5f9dccc..cec6ad3 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1734,6 +1734,7 @@ Tcl_FSEvalFileEx(
Tcl_CloseEx(interp,chan,0);
return result;
}
+
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 726b8dd..170dd69 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -304,8 +304,8 @@ ListSpanMerited(
Tcl_Size allocatedStorageLength) /* Length of the currently allocation */
{
/*
- * Possible optimizations for future consideration
- * - heuristic LIST_SPAN_THRESHOLD
+ * Possible optimizations for future consideration
+ * - heuristic LIST_SPAN_THRESHOLD
* - currently, information about the sharing (ref count) of existing
* storage is not passed. Perhaps it should be. For example if the
* existing storage has a "large" ref count, then it might make sense
@@ -828,7 +828,7 @@ ListStoreNew(
*
* ListStoreReallocate --
*
- * Reallocates the memory for a ListStore allocating extra for
+ * Reallocates the memory for a ListStore allocating extra for
* possible future growth.
*
* Results:
@@ -1386,7 +1386,7 @@ TclListObjCopy(
if (!TclHasInternalRep(listObj, &tclListType.objType)) {
if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) {
- return TclArithSeriesObjCopy(interp, listObj);
+ return Tcl_DuplicateObj(listObj);
}
if (SetListFromAny(interp, listObj) != TCL_OK) {
return NULL;
@@ -2656,6 +2656,7 @@ TclLindexFlat(
Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
* represent the indices in the list. */
{
+ int status;
Tcl_Size i;
/* Handle ArithSeries as special case */
@@ -2684,24 +2685,13 @@ TclLindexFlat(
for (i=0 ; i<indexCount && listObj ; i++) {
Tcl_Size index, listLen = 0;
- Tcl_Obj **elemPtrs = NULL, *sublistCopy;
+ Tcl_Obj **elemPtrs = NULL;
- /*
- * Here we make a private copy of the current sublist, so we avoid any
- * shimmering issues that might invalidate the elemPtr array below
- * while we are still using it. See test lindex-8.4.
- */
-
- sublistCopy = TclListObjCopy(interp, listObj);
- Tcl_DecrRefCount(listObj);
- listObj = NULL;
-
- if (sublistCopy == NULL) {
- /* The sublist is not a list at all => error. */
- break;
+ status = Tcl_ListObjLength(interp, listObj, &listLen);
+ if (status != TCL_OK) {
+ Tcl_DecrRefCount(listObj);
+ return NULL;
}
- LIST_ASSERT_TYPE(sublistCopy);
- ListObjGetElements(sublistCopy, listLen, elemPtrs);
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
@@ -2715,20 +2705,43 @@ TclLindexFlat(
if (TclGetIntForIndexM(
interp, indexArray[i], TCL_SIZE_MAX - 1, &index)
!= TCL_OK) {
- Tcl_DecrRefCount(sublistCopy);
+ Tcl_DecrRefCount(listObj);
return NULL;
}
}
+ Tcl_DecrRefCount(listObj);
TclNewObj(listObj);
+ Tcl_IncrRefCount(listObj);
} else {
+ Tcl_Obj *itemObj;
+ /*
+ * Must set the internal rep again because it may have been
+ * changed by TclGetIntForIndexM. See test lindex-8.4.
+ */
+ if (!TclHasInternalRep(listObj, &tclListType.objType)) {
+ status = SetListFromAny(interp, listObj);
+ if (status != TCL_OK) {
+ /* The list is not a list at all => error. */
+ Tcl_DecrRefCount(listObj);
+ return NULL;
+ }
+ }
+
+ ListObjGetElements(listObj, listLen, elemPtrs);
+ /* increment this reference count first before decrementing
+ * just in case they are the same Tcl_Obj
+ */
+ itemObj = elemPtrs[index];
+ Tcl_IncrRefCount(itemObj);
+ Tcl_DecrRefCount(listObj);
/* Extract the pointer to the appropriate element. */
- listObj = elemPtrs[index];
+ listObj = itemObj;
}
- Tcl_IncrRefCount(listObj);
+ } else {
+ Tcl_DecrRefCount(listObj);
+ listObj = NULL;
}
- Tcl_DecrRefCount(sublistCopy);
}
-
return listObj;
}
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index c3f6fc2..0e666e9 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -589,12 +589,12 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
/*
* A variation where the array is an array of structs. There's no issue with
* possible NULLs; every element of the array will be iterated over and the
- * varable set to a pointer to each of those elements in turn.
- * REQUIRES DECLARATION: Tcl_Size i;
+ * variable set to a pointer to each of those elements in turn.
+ * REQUIRES DECLARATION: Tcl_Size i; See [96551aca55] for more FOREACH_STRUCT details.
*/
#define FOREACH_STRUCT(var,ary) \
- for(i=0 ; var=&((ary).list[i]), i<(ary).num; i++)
+ if (i=0, (ary).num>0) for(; var=&((ary).list[i]), i<(ary).num; i++)
/*
* Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 07b497b..6112869 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -2808,6 +2808,9 @@ Tcl_DStringSetLength(
{
Tcl_Size newsize;
+ if (length < 0) {
+ length = 0;
+ }
if (length >= dsPtr->spaceAvl) {
/*
* There are two interesting cases here. In the first case, the user
@@ -3796,8 +3799,8 @@ TclIndexEncode(
}
/*
* We passed 2*INT_MAX as the "end value" to GetWideForIndex. The computed
- * index will in one of the following ranges that need to be distinguished
- * for encoding purposes in the following code.
+ * index will be in one of the following ranges that need to be
+ * distinguished for encoding purposes in the following code.
* (1) 0:INT_MAX when
* (a) objPtr was a pure non-negative numeric value in that range
* (b) objPtr was a numeric computation M+/-N with a result in that range
@@ -3846,7 +3849,7 @@ TclIndexEncode(
* error is raised. On 32-bit systems, indices in that range indicate
* the position after the end and so do not raise an error.
*/
- if ((sizeof(int) != sizeof(size_t)) &&
+ if ((sizeof(int) != sizeof(Tcl_Size)) &&
(wide > INT_MAX) && (wide < WIDE_MAX-1)) {
/* 2(a,b) on 64-bit systems*/
goto rangeerror;
@@ -3876,7 +3879,7 @@ TclIndexEncode(
* indices in that range indicate the position before the beginning
* and so do not raise an error.
*/
- if ((sizeof(int) != sizeof(size_t)) &&
+ if ((sizeof(int) != sizeof(Tcl_Size)) &&
(wide > (ENDVALUE - LIST_MAX)) && (wide <= INT_MAX)) {
/* 1(c), 4(a,b) on 64-bit systems */
goto rangeerror;
diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c
index a30c8fb..e4604dc 100644
--- a/macosx/tclMacOSXFCmd.c
+++ b/macosx/tclMacOSXFCmd.c
@@ -640,7 +640,7 @@ SetOSTypeFromAny(
int result = TCL_OK;
Tcl_DString ds;
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
- size_t length;
+ Tcl_Size length;
string = Tcl_GetStringFromObj(objPtr, &length);
Tcl_UtfToExternalDStringEx(NULL, encoding, string, length, TCL_ENCODING_PROFILE_TCL8, &ds, NULL);
diff --git a/tests-perf/listPerf.tcl b/tests-perf/listPerf.tcl
index 17f22e9..575c78e 100644
--- a/tests-perf/listPerf.tcl
+++ b/tests-perf/listPerf.tcl
@@ -3,8 +3,9 @@
#
# listPerf.tcl --
#
-# This file provides performance tests for list operations.
-#
+# This file provides performance tests for list operations. Run
+# tclsh listPerf.tcl help
+# for options.
# ------------------------------------------------------------------------
#
# See the file "license.terms" for information on usage and redistribution
@@ -77,7 +78,9 @@ namespace eval perf::list {
break
}
--* {
- error "Unknown option $arg"
+ puts stderr "Unknown option $arg"
+ print_usage
+ exit 1
}
default {
# Remaining will be passed back to the caller
@@ -383,6 +386,8 @@ namespace eval perf::list {
comment Create a list from two lists - real test of expansion speed
perf measure [list_describe $len "from a {*}list {*}list"] {list {*}$L {*}$L} [list len [expr {$len/2}]]
}
+
+ perf destroy
}
proc lappend_describe {share_mode len num iters} {
@@ -1217,7 +1222,7 @@ namespace eval perf::list {
set commands [lmap sel $selections {
if {$sel eq "help"} {
print_usage
- continue
+ exit 0
}
set cmd ::perf::list::${sel}_perf
if {$cmd ni [info commands ::perf::list::*_perf]} {
diff --git a/tests/dstring.test b/tests/dstring.test
index 23863d0..7c9d9f6 100644
--- a/tests/dstring.test
+++ b/tests/dstring.test
@@ -418,6 +418,24 @@ test dstring-4.2 {truncation} -constraints testdstring -setup {
} -cleanup {
testdstring free
} -result {{} 0}
+test dstring-4.3 {truncation} -constraints testdstring -setup {
+ testdstring free
+} -body {
+ testdstring append "xwvut" -1
+ # Pass a negative length to Tcl_DStringSetLength();
+ # if not caught, causing '\0' to be written out-of-bounds,
+ # try corrupting dsPtr->length which begins
+ # 2*sizeof(Tcl_Size) bytes before dsPtr->staticSpace[],
+ # so that the result is -256 (on little endian systems)
+ # rather than e.g. -8 or -16.
+ # (sizeof(Tcl_Size) does not seem to be available via Tcl,
+ # so assume sizeof(Tcl_Size) == sizeof(void*) for Tcl 9.)
+ testdstring trunc [expr {-2*([package vsatisfies $tcl_version 9.0-]
+ ? $tcl_platform(pointerSize) : 4)}]
+ list [testdstring get] [testdstring length]
+} -cleanup {
+ testdstring free
+} -result {{} 0}
test dstring-5.1 {copying to result} -constraints testdstring -setup {
testdstring free
diff --git a/tests/io.test b/tests/io.test
index 713cf30..5acd553 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -1184,7 +1184,7 @@ test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82"
close $f
set f [open $path(test1)]
- fconfigure $f -encoding shiftjis
+ fconfigure $f -encoding shiftjis -profile tcl8
set x [list [gets $f line] $line [eof $f]]
close $f
set x
@@ -1539,67 +1539,67 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} {
} "{} timeout {} timeout 牦 {} eof 0 {}"
test io-12.6 {ReadChars: too many chars read} {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) [encoding convertto utf-8 \
- [string repeat 뻯 20][string repeat . 20]]
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan)
- return
- }
- watch {}
- read {
- set n [lindex $args 1]
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ [string repeat 뻯 20][string repeat . 20]]
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8
while {![eof $c]} {
- read $c 15
+ read $c 15
}
close $c
} {}
test io-12.7 {ReadChars: too many chars read [bc5b790099]} {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) [encoding convertto utf-8 \
- [string repeat 뻯 10]....뻯]
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan)
- return
- }
- watch {}
- read {
- set n [lindex $args 1]
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ [string repeat 뻯 10]....뻯]
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8
while {![eof $c]} {
- read $c 7
+ read $c 7
}
close $c
} {}
@@ -1614,7 +1614,7 @@ test io-12.8 {ReadChars: multibyte chars split} {
close $f
scan [string index $in end] %c
} 160
-test io-12.9 {ReadChars: multibyte chars split} -body {
+test {io-12.9 profile tcl8} {ReadChars: multibyte chars split} -body {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat a 9]\xC2
@@ -1622,18 +1622,34 @@ test io-12.9 {ReadChars: multibyte chars split} -body {
set f [open $path(test1)]
fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 10
set in [read $f]
- close $f
+ read $f
scan [string index $in end] %c
} -cleanup {
catch {close $f}
} -result 194
-test io-12.10 {ReadChars: multibyte chars split} -body {
+test {io-12.10 strict} {ReadChars: multibyte chars split} -body {
+ set f [open $path(test1) w]
+ fconfigure $f -translation binary
+ puts -nonewline $f [string repeat a 9]\xC2
+ close $f
+ set f [open $path(test1)]
+ fconfigure $f -encoding utf-8 -profile strict -buffersize 10
+ set in [read $f]
+ close $f
+ scan [string index $in end] %c
+} -cleanup {
+ catch {close $f}
+} -returnCodes 1 -match glob -result {error reading "file*":\
+ invalid or incomplete multibyte or wide character}
+
+
+test {io-12.10 tcl8} {ReadChars: multibyte chars split} -body {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat a 9]\xC2
close $f
set f [open $path(test1)]
- fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 11
+ fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 10
set in [read $f]
close $f
scan [string index $in end] %c
@@ -1990,7 +2006,7 @@ test io-14.9 {reuse of stdio special channels} {stdio fileevent} {
file delete $path(test1)
set f [open $path(script) w]
puts $f {
- array set path [lindex $argv 0]
+ array set path [lindex $argv 0]
set f [open $path(test1) w]
puts $f hello
close $f
@@ -2337,7 +2353,7 @@ test io-27.6 {FlushChannel, async flushing, async close} \
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
- set x "$x$x"
+ set x "$x$x"
}
set f [open $path(output) w]
close $f
@@ -2351,9 +2367,9 @@ test io-27.6 {FlushChannel, async flushing, async close} \
vwait [namespace which -variable counter]
}
if {$counter == 1000} {
- set result "file size only [file size $path(output)]"
+ set result "file size only [file size $path(output)]"
} else {
- set result ok
+ set result ok
}
} ok
@@ -2427,9 +2443,9 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \
vwait [namespace which -variable counter]
}
if {$counter == 1000} {
- set result probably_broken
+ set result probably_broken
} else {
- set result ok
+ set result ok
}
} ok
test io-28.4 Tcl_Close testchannel {
@@ -4651,29 +4667,29 @@ test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup {
} -result {{} {} {} .......}
test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) .......
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan)
- return
- }
- watch {}
- read {
- set n [lindex $args 1]
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) .......
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
if {$n > 3} {set n 3}
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
} -body {
set c [chan create read [namespace which driver]]
@@ -4685,30 +4701,30 @@ test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup {
} -result {{} {} {} .......}
test io-33.13 {Tcl_GetsObj, [10dc6daa37]} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) [string repeat \
- [string repeat . 64]\n[string repeat . 25] 2]
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan)
- return
- }
- watch {}
- read {
- set n [lindex $args 1]
- if {$n > 65} {set n 65}
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [string repeat \
+ [string repeat . 64]\n[string repeat . 25] 2]
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ if {$n > 65} {set n 65}
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
} -body {
set c [chan create read [namespace which driver]]
@@ -5429,8 +5445,8 @@ test io-36.3 {Tcl_InputBlocked vs files, short read} {
} {0 abc 0 defghijklmnop 0 1}
test io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} {
proc in {f} {
- variable l
- variable x
+ variable l
+ variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
@@ -5465,8 +5481,8 @@ test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles
} {0 abc 0 defghijklmnop 0 1}
test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} {
proc in {f} {
- variable l
- variable x
+ variable l
+ variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
@@ -5863,7 +5879,7 @@ test io-39.23 {Tcl_GetChannelOption, server socket is not readable or
set l
} {{} auto}
test io-39.24 {Tcl_SetChannelOption, server socket is not readable or
- writable so we can't change -eofchar or -translation } {
+ writable so we can't change -eofchar or -translation } {
set l [list]
set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
fconfigure $sock -eofchar D -translation lf
@@ -6361,23 +6377,23 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent not
test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
- variable x 0
- after 100 {set x triggered}
- vwait [namespace which -variable x]
- set x
+ variable x 0
+ after 100 {set x triggered}
+ vwait [namespace which -variable x]
+ set x
}
} {triggered}
test io-46.3 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
- set x 0
- after 10 {lappend x timer}
- after 30
- set result $x
- update idletasks
- lappend result $x
- update
- lappend result $x
+ set x 0
+ after 10 {lappend x timer}
+ after 30
+ set result $x
+ update idletasks
+ lappend result $x
+ update
+ lappend result $x
}
} {0 0 {0 timer}}
@@ -6394,7 +6410,7 @@ test io-47.1 {fileevent vs multiple interpreters} {testfevent fileevent} {
lappend x [fileevent $f2 readable]
testfevent delete
lappend x [fileevent $f readable] [fileevent $f2 readable] \
- [fileevent $f3 readable]
+ [fileevent $f3 readable]
close $f
close $f2
close $f3
@@ -6410,11 +6426,11 @@ test io-47.2 {deleting fileevent on interpreter delete} {testfevent fileevent} {
testfevent share $f2
testfevent share $f3
testfevent cmd "fileevent $f2 readable {script 2}
- fileevent $f3 readable {script 3}"
+ fileevent $f3 readable {script 3}"
fileevent $f4 readable {script 4}
testfevent delete
set x [list [fileevent $f readable] [fileevent $f2 readable] \
- [fileevent $f3 readable] [fileevent $f4 readable]]
+ [fileevent $f3 readable] [fileevent $f4 readable]]
close $f
close $f2
close $f3
@@ -6432,7 +6448,7 @@ test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} {
fileevent $f readable {script 1}
fileevent $f2 readable {script 2}
testfevent cmd "fileevent $f3 readable {script 3}
- fileevent $f4 readable {script 4}"
+ fileevent $f4 readable {script 4}"
testfevent delete
set x [list [fileevent $f readable] [fileevent $f2 readable] \
[fileevent $f3 readable] [fileevent $f4 readable]]
@@ -6451,8 +6467,8 @@ test io-47.4 {file events on shared files and multiple interpreters} {testfevent
fileevent $f readable {script 2}
fileevent $f2 readable {script 3}
set x [list [fileevent $f2 readable] \
- [testfevent cmd "fileevent $f readable"] \
- [fileevent $f readable]]
+ [testfevent cmd "fileevent $f readable"] \
+ [fileevent $f readable]]
testfevent delete
close $f
close $f2
@@ -6466,7 +6482,7 @@ test io-47.5 {file events on shared files, deleting file events} {testfevent fil
fileevent $f readable {script 2}
testfevent cmd "fileevent $f readable {}"
set x [list [testfevent cmd "fileevent $f readable"] \
- [fileevent $f readable]]
+ [fileevent $f readable]]
testfevent delete
close $f
set x
@@ -7322,7 +7338,7 @@ test io-52.3 {TclCopyChannel} {fcopy} {
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7363,7 +7379,7 @@ test io-52.5 {TclCopyChannel, all} {fcopy} {
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7380,7 +7396,7 @@ test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} {
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7397,7 +7413,7 @@ test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} {
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7414,7 +7430,7 @@ test io-52.6 {TclCopyChannel} {fcopy} {
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7431,7 +7447,7 @@ test io-52.7 {TclCopyChannel} {fcopy} {
close $f1
close $f2
if {"$s1" == "$s2"} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7987,8 +8003,8 @@ proc doFcopy {in out {bytes 0} {error {}}} {
} elseif {[eof $in]} {
set fcopyTestDone 0
} else {
- # Delay next fcopy to wait for size>0 input bytes
- after 100 [list fcopy $in $out -size 1000 \
+ # Delay next fcopy to wait for size>0 input bytes
+ after 100 [list fcopy $in $out -size 1000 \
-command [namespace code [list doFcopy $in $out]]]
}
}
@@ -8003,9 +8019,9 @@ test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} {
proc Write {count} {
puts -nonewline "1234567890"
if {[incr count -1]} {
- after 10 [list Write $count]
+ after 10 [list Write $count]
} else {
- set ::ready 1
+ set ::ready 1
}
}
fconfigure stdout -buffering none
@@ -8347,21 +8363,21 @@ test io-53.12.1 {
} A
test io-53.13 {TclCopyChannel: read error reporting} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- return {initialize finalize watch read}
- }
- finalize {
- return
- }
- watch {}
- read {
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ return {initialize finalize watch read}
+ }
+ finalize {
+ return
+ }
+ watch {}
+ read {
error FAIL
- }
- }
+ }
+ }
}
set outFile [makeFile {} out]
} -body {
@@ -8377,21 +8393,21 @@ test io-53.13 {TclCopyChannel: read error reporting} -setup {
} -result {error reading "rc*": *} -returnCodes error -match glob
test io-53.14 {TclCopyChannel: write error reporting} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- return {initialize finalize watch write}
- }
- finalize {
- return
- }
- watch {}
- write {
- error FAIL
- }
- }
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ return {initialize finalize watch write}
+ }
+ finalize {
+ return
+ }
+ watch {}
+ write {
+ error FAIL
+ }
+ }
}
set inFile [makeFile {aaa} in]
} -body {
@@ -8407,35 +8423,35 @@ test io-53.14 {TclCopyChannel: write error reporting} -setup {
} -result {error writing "*": *} -returnCodes error -match glob
test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- variable blocked
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) [encoding convertto utf-8 \
- [string repeat a 100]]
- set blocked($chan) 1
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan) blocked($chan)
- return
- }
- watch {}
- read {
- if {$blocked($chan)} {
- set blocked($chan) [expr {!$blocked($chan)}]
- return -code error EAGAIN
- }
- set n [lindex $args 1]
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ variable buffer
+ variable index
+ variable blocked
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ [string repeat a 100]]
+ set blocked($chan) 1
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan) blocked($chan)
+ return
+ }
+ watch {}
+ read {
+ if {$blocked($chan)} {
+ set blocked($chan) [expr {!$blocked($chan)}]
+ return -code error EAGAIN
+ }
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8
@@ -8451,35 +8467,35 @@ test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup {
} -result 100
test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- variable blocked
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) [encoding convertto utf-8 \
- [string repeat a 100]]
- set blocked($chan) 1
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan) blocked($chan)
- return
- }
- watch {}
- read {
- if {$blocked($chan)} {
- set blocked($chan) [expr {!$blocked($chan)}]
- return -code error EAGAIN
- }
- set n [lindex $args 1]
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ variable buffer
+ variable index
+ variable blocked
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ [string repeat a 100]]
+ set blocked($chan) 1
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan) blocked($chan)
+ return
+ }
+ watch {}
+ read {
+ if {$blocked($chan)} {
+ set blocked($chan) [expr {!$blocked($chan)}]
+ return -code error EAGAIN
+ }
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8 -translation lf
@@ -8495,29 +8511,29 @@ test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup {
} -result 100
test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) [encoding convertto utf-8 \
- line\n[string repeat a 100]line\n]
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan)
- return
- }
- watch {}
- read {
- set n [lindex $args 1]
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ line\n[string repeat a 100]line\n]
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8 -translation lf -buffersize 107
@@ -9400,8 +9416,12 @@ test io-75.10 {
puts -nonewline $f A\xC0
flush $f
seek $f 0
- fconfigure $f -encoding utf-8 -profile strict -buffering none
+ fconfigure $f -encoding utf-8 -buffering none
} -body {
+ catch {read $f} errmsg
+ lappend res $errmsg
+ seek $f 0
+ chan configure $f -profile tcl8
set d [read $f]
binary scan $d H* hd
lappend res $hd
@@ -9410,8 +9430,8 @@ test io-75.10 {
close $f
removeFile io-75.10
unset result
-} -returnCodes 1 -match glob -result {error reading "file*":\
- invalid or incomplete multibyte or wide character}
+} -match glob -result {{error reading "file*":\
+ invalid or incomplete multibyte or wide character} 41c0}
# The current result returns the orphan byte as byte.
# This may be expected due to special utf-8 handling.
@@ -9428,7 +9448,7 @@ test io-75.11 {shiftjis encoding error read results in raw bytes} -setup {
flush $f
seek $f 0
fconfigure $f -encoding shiftjis -blocking 0 -eofchar {} -translation lf \
- -profile tcl8
+ -profile strict
} -body {
set d [read $f]
binary scan $d H* hd
@@ -9437,7 +9457,8 @@ test io-75.11 {shiftjis encoding error read results in raw bytes} -setup {
} -cleanup {
close $f
removeFile io-75.11
-} -match glob -result {4181ff41 0 {}}
+} -match glob -result {41 1 {error reading "file*":\
+ invalid or incomplete multibyte or wide character}}
test io-75.12 {
invalid utf-8 encoding read is not ignored because setting the encoding to
@@ -9514,8 +9535,8 @@ test io-75.14 {
lappend res [gets $chan]
close $chan
return $res
-} -returnCodes 1 -match glob -result {error reading "*":\
- invalid or incomplete multibyte or wide character}
+} -match glob -result {a b 1 {error reading "*":\
+ invalid or incomplete multibyte or wide character} cÀ d}
test io-75.15 {
invalid utf-8 encoding strict
@@ -9549,7 +9570,8 @@ test io-75.15 {
return $res
} -cleanup {
close $chan
-} -returnCodes 1 -match glob -result {error reading "*": invalid or incomplete multibyte or wide character}
+} -match glob -result {hello AB 1 {error reading "*": invalid or incomplete multibyte or wide character}\
+ 1 {error reading "*": invalid or incomplete multibyte or wide character} 43 44 c0 40 EF GHI}
# ### ### ### ######### ######### #########
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 366e3fb..529dae5 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -1367,7 +1367,7 @@ test iocmd-24.15 {chan write, EAGAIN means that writing is not allowed at this t
test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body {
set res {}
- proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
+ proc foo args {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
set c [chan create {r w} foo]
note [fconfigure $c]
close $c
@@ -1376,7 +1376,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body {
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -profile * -translation {auto *}}}
test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body {
set res {}
- proc foo {args} {oninit cget cgetall; onfinal; track; return ""}
+ proc foo args {oninit cget cgetall; onfinal; track; return ""}
set c [chan create {r w} foo]
note [fconfigure $c]
close $c
@@ -1385,9 +1385,9 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body {
} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -profile * -translation {auto *}}}
test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body {
set res {}
- proc foo {args} {
+ proc foo args {
oninit cget cgetall; onfinal; track
- return "-bar foo -snarf x"
+ return {-bar foo -snarf x}
}
set c [chan create {r w} foo]
note [fconfigure $c]
diff --git a/tests/ooUtil.test b/tests/ooUtil.test
index c8be9c8..f41c668 100644
--- a/tests/ooUtil.test
+++ b/tests/ooUtil.test
@@ -429,7 +429,7 @@ test ooUtil-5.1 {TIP 478: abstract} -setup {
parent destroy
} -result {1 1 1 123 456 ::y}
-test ooUtil-6.1 {TIP 478: classvarable} -setup {
+test ooUtil-6.1 {TIP 478: classvariable} -setup {
oo::class create parent
} -body {
oo::class create xyz {
@@ -459,7 +459,7 @@ test ooUtil-6.1 {TIP 478: classvarable} -setup {
} -cleanup {
parent destroy
} -result {{1 2} {1 2} {2 3}}
-test ooUtil-6.2 {TIP 478: classvarable error case} -setup {
+test ooUtil-6.2 {TIP 478: classvariable error case} -setup {
oo::class create parent
} -body {
oo::class create xyz {
@@ -475,7 +475,7 @@ test ooUtil-6.2 {TIP 478: classvarable error case} -setup {
} -returnCodes error -cleanup {
parent destroy
} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element}
-test ooUtil-6.3 {TIP 478: classvarable error case} -setup {
+test ooUtil-6.3 {TIP 478: classvariable error case} -setup {
oo::class create parent
} -body {
oo::class create xyz {
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index bcd0920..cf71974 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -2725,7 +2725,7 @@ TclpObjNormalizePath(
sizeof(WCHAR));
Tcl_DStringAppend(&dsNorm,
(const char *) nativeName,
- (int) (wcslen(nativeName)*sizeof(WCHAR)));
+ wcslen(nativeName)*sizeof(WCHAR));
}
}
}
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index 3732550..1ccb105 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -804,7 +804,7 @@ GetValue(
*/
length = Tcl_DStringLength(&data) * (2 / sizeof(WCHAR));
- Tcl_DStringSetLength(&data, (int) length * sizeof(WCHAR));
+ Tcl_DStringSetLength(&data, length * sizeof(WCHAR));
result = RegQueryValueExW(key, nativeValue,
NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
}
@@ -865,7 +865,7 @@ GetValue(
*/
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
- (BYTE *) Tcl_DStringValue(&data), (int) length));
+ (BYTE *) Tcl_DStringValue(&data), length));
}
Tcl_DStringFree(&data);
return result;
@@ -914,7 +914,7 @@ GetValueNames(
resultPtr = Tcl_NewObj();
Tcl_DStringInit(&buffer);
- Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(WCHAR)));
+ Tcl_DStringSetLength(&buffer, MAX_KEY_LENGTH * sizeof(WCHAR));
index = 0;
result = TCL_OK;
@@ -1221,7 +1221,7 @@ RecursiveDeleteKey(
}
Tcl_DStringInit(&subkey);
- Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(WCHAR)));
+ Tcl_DStringSetLength(&subkey, MAX_KEY_LENGTH * sizeof(WCHAR));
mode = saveMode;
while (result == ERROR_SUCCESS) {
generated by cgit v0.12 at 2026-01-04 22:58:16 (GMT)