From 93bf87ed859e04b2fc9b197239ad6838e761e85d Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 10 Mar 2023 13:32:47 +0000 Subject: Make test less fragile to changing set of options. --- tests/io.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/io.test b/tests/io.test index 6d556da..181d028 100644 --- a/tests/io.test +++ b/tests/io.test @@ -5620,7 +5620,7 @@ test io-39.16a {Tcl_SetChannelOption: -encoding (invalid shortening to "-e"), er fconfigure $f -e foobar } -cleanup { close $f -} -returnCodes 1 -result {bad option "-e": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} +} -returnCodes 1 -match glob -result {bad option "-e": should be one of *} test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio fileevent} { set f [open "|[list [interpreter] $path(cat)]" r+] fconfigure $f -encoding binary -- cgit v0.12 From 5533596329b2aaf620858427a86c7e299cc10b66 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 11 Mar 2023 16:47:42 +0000 Subject: Add testencoding Tcl_ExternalToUtf/Tcl_UtfToExternal for raw testing of corresponding C functions --- generic/tclTest.c | 159 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 157 insertions(+), 2 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 06d5064..92e7f7a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1980,6 +1980,156 @@ static void SpecialFree( } /* + *------------------------------------------------------------------------ + * + * UtfTransformFn -- + * + * Implements a direct call into Tcl_UtfToExternal and Tcl_ExternalToUtf + * as otherwise there is no script level command that directly exercises + * these functions (i/o command cannot test all combinations) + * The arguments at the script level are roughly those of the above + * functions: + * encodingname srcbytes flags state dstlen ?srcreadvar? ?dstwrotevar? ?dstcharsvar? + * + * Results: + * TCL_OK or TCL_ERROR. This any errors running the test, NOT the + * result of Tcl_UtfToExternal or Tcl_ExternalToUtf. + * + * Side effects: + * The result in the interpreter is a list of the return code from the + * Tcl_UtfToExternal/Tcl_ExternalToUtf functions, the encoding state, and + * the encoded binary string. If any of the srcreadvar, dstwrotevar and + * dstcharsvar are specified and not empty, they are treated as names + * of variables where the *srcRead, *dstWrote and *dstChars output + * from the functions are stored. + *------------------------------------------------------------------------ + */ +typedef int +UtfTransformFn(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, + char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); +static int UtfExtWrapper( + Tcl_Interp *interp, UtfTransformFn *transformer, int objc, Tcl_Obj *const objv[]) +{ + Tcl_Encoding encoding; + int encStateValue; /* Assumes Tcl_EncodingState points to integer!!! */ + Tcl_EncodingState encState; + int flags; + Tcl_Size srcLen, bufLen; + const unsigned char *bytes; + unsigned char *bufPtr; + int srcRead, dstLen, dstWrote, dstChars; + Tcl_Obj *srcReadVar, *dstWroteVar, *dstCharsVar; + int result; + + if (objc < 7 || objc > 10) { + Tcl_WrongNumArgs(interp, + 2, + objv, + "encoding srcbytes flags state dstlen ?srcreadvar? ?dstwrotevar? ?dstcharsvar?"); + return TCL_ERROR; + } + if (Tcl_GetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[4], &flags) != TCL_OK) { + return TCL_ERROR; + } + /* Assumes state is integer if not "" */ + if (Tcl_GetIntFromObj(interp, objv[5], &encStateValue) == TCL_OK) { + encState = (Tcl_EncodingState)&encStateValue; + } else if (Tcl_GetCharLength(objv[5]) == 0) { + encState = NULL; + } else { + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[6], &dstLen) != TCL_OK) { + return TCL_ERROR; + } + srcReadVar = NULL; + dstWroteVar = NULL; + dstCharsVar = NULL; + if (objc > 7) { + /* Has caller requested srcRead? */ + if (Tcl_GetCharLength(objv[7])) { + srcReadVar = objv[7]; + } + if (objc > 8) { + /* Ditto for dstWrote */ + if (Tcl_GetCharLength(objv[8])) { + dstWroteVar = objv[8]; + } + if (objc > 9) { + if (Tcl_GetCharLength(objv[9])) { + dstCharsVar = objv[9]; + } + } + } + } + + bufLen = dstLen + 4; /* 4 -> overflow detection */ + bufPtr = ckalloc(bufLen); + memmove(bufPtr + dstLen, "\xAB\xCD\xEF\x00", 4); /* overflow detection */ + bytes = Tcl_GetByteArrayFromObj(objv[3], &srcLen); /* Last! to avoid shimmering */ + result = (*transformer)(interp, encoding, bytes, srcLen, flags, + &encState, bufPtr, dstLen, + srcReadVar ? &srcRead : NULL, + &dstWrote, + dstCharsVar ? &dstChars : NULL); + if (memcmp(bufPtr + bufLen - 4, "\xAB\xCD\xEF\x00", 4)) { + Tcl_SetResult(interp, + "Tcl_ExternalToUtf wrote past output buffer", + TCL_STATIC); + result = TCL_ERROR; + } else { + Tcl_Obj *resultObjs[3]; + switch (result) { + case TCL_OK: + resultObjs[0] = Tcl_NewStringObj("ok", -1); + break; + case TCL_CONVERT_MULTIBYTE: + resultObjs[0] = Tcl_NewStringObj("multibyte", -1); + break; + case TCL_CONVERT_SYNTAX: + resultObjs[0] = Tcl_NewStringObj("syntax", -1); + break; + case TCL_CONVERT_UNKNOWN: + resultObjs[0] = Tcl_NewStringObj("unknown", -1); + break; + case TCL_CONVERT_NOSPACE: + resultObjs[0] = Tcl_NewStringObj("nospace", -1); + break; + default: + resultObjs[0] = Tcl_NewIntObj(result); + break; + } + result = TCL_OK; + resultObjs[1] = + encState ? Tcl_NewIntObj(encStateValue) : Tcl_NewObj(); + resultObjs[2] = Tcl_NewByteArrayObj(bufPtr, dstWrote); + if (srcReadVar) { + if (Tcl_ObjSetVar2(interp, srcReadVar, NULL, Tcl_NewIntObj(srcRead), 0) == NULL) { + result = TCL_ERROR; + } + } + if (dstWroteVar) { + if (Tcl_ObjSetVar2(interp, dstWroteVar, NULL, Tcl_NewIntObj(dstWrote), 0) == NULL) { + result = TCL_ERROR; + } + } + if (dstCharsVar) { + if (Tcl_ObjSetVar2(interp, dstCharsVar, NULL, Tcl_NewIntObj(dstChars), 0) == NULL) { + result = TCL_ERROR; + } + } + Tcl_SetObjResult(interp, Tcl_NewListObj(3, resultObjs)); + } + + ckfree(bufPtr); + Tcl_FreeEncoding(encoding); /* Free returned reference */ + return result; +} + +/* *---------------------------------------------------------------------- * * TestencodingCmd -- @@ -2008,10 +2158,10 @@ TestencodingObjCmd( const char *string; TclEncoding *encodingPtr; static const char *const optionStrings[] = { - "create", "delete", "nullength", NULL + "create", "delete", "nullength", "Tcl_ExternalToUtf", "Tcl_UtfToExternal", NULL }; enum options { - ENC_CREATE, ENC_DELETE, ENC_NULLENGTH + ENC_CREATE, ENC_DELETE, ENC_NULLENGTH, ENC_EXTTOUTF, ENC_UTFTOEXT } index; if (objc < 2) { @@ -2080,6 +2230,11 @@ TestencodingObjCmd( Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_GetEncodingNulLength(encoding))); Tcl_FreeEncoding(encoding); + break; + case ENC_EXTTOUTF: + return UtfExtWrapper(interp,Tcl_ExternalToUtf,objc,objv); + case ENC_UTFTOEXT: + return UtfExtWrapper(interp,Tcl_UtfToExternal,objc,objv); } return TCL_OK; } -- cgit v0.12 From 8c5fc11b5ac89e8e6fd57484c9221a5e70c3c145 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Mar 2023 10:49:18 +0000 Subject: Always output 2 hex characters in "unexpected byte sequence" exception message. make testcases io-38.3/chan-io-38.3 independant from system encoding --- generic/tclCmdAH.c | 2 +- tests/chanio.test | 2 +- tests/io.test | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 4f743cc..c2424d6 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -656,7 +656,7 @@ EncodingConvertfromObjCmd( char buf[TCL_INTEGER_SPACE]; sprintf(buf, "%u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" - "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); + "u: '\\x%02X'", result, UCHAR(bytesPtr[result]))); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, NULL); Tcl_DStringFree(&ds); diff --git a/tests/chanio.test b/tests/chanio.test index 2915fc5..6814224 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -4982,7 +4982,7 @@ test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} -setup { test chan-io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { # This test crashes the interp if Bug #427196 is not fixed set chan [open [info script] r] - chan configure $chan -buffersize 10 + chan configure $chan -buffersize 10 -encoding utf-8 set var [chan read $chan 2] chan configure $chan -buffersize 32 append var [chan read $chan] diff --git a/tests/io.test b/tests/io.test index e762bba..3c0ec2e 100644 --- a/tests/io.test +++ b/tests/io.test @@ -5476,7 +5476,7 @@ test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { # This test crashes the interp if Bug #427196 is not fixed set chan [open [info script] r] - fconfigure $chan -buffersize 10 + fconfigure $chan -buffersize 10 -encoding utf-8 set var [read $chan 2] fconfigure $chan -buffersize 32 append var [read $chan] -- cgit v0.12 From b7f151f1268d4b49953da193f135d52e6e52f841 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Mar 2023 11:24:24 +0000 Subject: Make test-output more readable when it contains non-printable characters (stolen from TIP #656 impl, thanks Ashok!) tcltest -> 2.5.6 --- library/manifest.txt | 2 +- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 39 ++++++++++++++++++++++++++++++++++++--- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 5 files changed, 42 insertions(+), 9 deletions(-) diff --git a/library/manifest.txt b/library/manifest.txt index cc1e223..5a999f4 100644 --- a/library/manifest.txt +++ b/library/manifest.txt @@ -12,7 +12,7 @@ apply {{dir} { 0 tcl::idna 1.0.1 {cookiejar idna.tcl} 0 platform 1.0.19 {platform platform.tcl} 0 platform::shell 1.1.4 {platform shell.tcl} - 1 tcltest 2.5.5 {tcltest tcltest.tcl} + 1 tcltest 2.5.6 {tcltest tcltest.tcl} } { if {$isafe && !$safe} continue package ifneeded $package $version [list source [file join $dir {*}$file]] diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 18b05e5..9903e32 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded tcltest 2.5.5 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.5.6 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 7344f9f..19b7d64 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.5.5 + variable Version 2.5.6 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -1134,6 +1134,39 @@ proc tcltest::SafeFetch {n1 n2 op} { } } + +# tcltest::Asciify -- +# +# Transforms the passed string to contain only printable ascii characters. +# Useful for printing to terminals. Non-printables are mapped to +# \x, \u or \U sequences. +# +# Arguments: +# s - string to transform +# +# Results: +# The transformed strings +# +# Side effects: +# None. + +proc tcltest::Asciify {s} { + set print "" + foreach c [split $s ""] { + set i [scan $c %c] + if {[string is print $c] && ($i <= 127) && ($i > 0)} { + append print $c + } elseif {$i <= 0xFF} { + append print \\x[format %02X $i] + } elseif {$i <= 0xFFFF} { + append print \\u[format %04X $i] + } else { + append print \\U[format %08X $i] + } + } + return $print +} + # tcltest::ConstraintInitializer -- # # Get or set a script that when evaluated in the tcltest namespace @@ -2221,9 +2254,9 @@ proc tcltest::test {name description args} { if {$scriptCompare} { puts [outputChannel] "---- Error testing result: $scriptMatch" } else { - puts [outputChannel] "---- Result was:\n$actualAnswer" + puts [outputChannel] "---- Result was:\n[Asciify $actualAnswer]" puts [outputChannel] "---- Result should have been\ - ($match matching):\n$result" + ($match matching):\n[Asciify $result]" } } if {$errorCodeFailure} { diff --git a/unix/Makefile.in b/unix/Makefile.in index 1b2718e..da057d8 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1071,9 +1071,9 @@ install-libraries: libraries @echo "Installing package msgcat 1.7.1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ "$(MODULE_INSTALL_DIR)/8.7/msgcat-1.7.1.tm" - @echo "Installing package tcltest 2.5.5 as a Tcl Module" + @echo "Installing package tcltest 2.5.6 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ - "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.5.tm" + "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.6.tm" @echo "Installing package platform 1.0.19 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \ "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.19.tm" diff --git a/win/Makefile.in b/win/Makefile.in index 6d7bb7d..202b860 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -889,8 +889,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.7.1 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/8.7/msgcat-1.7.1.tm"; - @echo "Installing package tcltest 2.5.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.5.tm"; + @echo "Installing package tcltest 2.5.6 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.6.tm"; @echo "Installing package platform 1.0.19 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.19.tm"; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12 From 8bf2e2ace2224e4066dfe647f47b531591fe8666 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Mar 2023 11:32:52 +0000 Subject: Forgot that \x00 is not printable anyway --- library/tcltest/tcltest.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 19b7d64..6cb7d92 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1154,7 +1154,7 @@ proc tcltest::Asciify {s} { set print "" foreach c [split $s ""] { set i [scan $c %c] - if {[string is print $c] && ($i <= 127) && ($i > 0)} { + if {[string is print $c] && ($i <= 127)} { append print $c } elseif {$i <= 0xFF} { append print \\x[format %02X $i] -- cgit v0.12