From 41a61597547eca28506fbb85f2737413dc8f2162 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 16 Jun 2018 17:55:31 +0000 Subject: new package tcltests exclude some exec.test tests when running under valgrind --- tests/all.tcl | 9 +++++++++ tests/exec.test | 25 +++++++++++++++---------- tests/ioCmd.test | 1 - tests/pkgIndex.tcl | 6 ++++++ 4 files changed, 30 insertions(+), 11 deletions(-) create mode 100644 tests/pkgIndex.tcl diff --git a/tests/all.tcl b/tests/all.tcl index 69a16ba..ad372db 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -18,5 +18,14 @@ configure {*}$argv -testdir [file dir [info script]] if {[singleProcess]} { interp debug {} -frame 1 } + +set testsdir [file dirname [file dirname [file normalize [info script]/...]]] +lappend auto_path $testsdir {*}[apply {{testsdir args} { + lmap x $args { + if {$x eq $testsdir} continue + lindex $x + } +}} $testsdir {*}$auto_path] + runAllTests proc exit args {} diff --git a/tests/exec.test b/tests/exec.test index 5542f3d..6570e57 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -11,9 +11,14 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. +# There is no point in running Valgrind on cases where [exec] forks but then +# fails and the child process doesn't go through full cleanup. + package require tcltest 2 namespace import -force ::tcltest::* +package require tcltests + # All tests require the "exec" command. # Skip them if exec is not defined. testConstraint exec [llength [info commands exec]] @@ -325,11 +330,11 @@ test exec-8.2 {long input and output} {exec} { # Commands that return errors. -test exec-9.1 {commands returning errors} {exec} { +test exec-9.1 {commands returning errors} {exec notValgrind} { set x [catch {exec gorp456} msg] list $x [string tolower $msg] [string tolower $errorCode] } {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}} -test exec-9.2 {commands returning errors} {exec} { +test exec-9.2 {commands returning errors} {exec notValgrind} { string tolower [list [catch {exec [interpreter] echo foo | foo123} msg] $msg $errorCode] } {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}} test exec-9.3 {commands returning errors} -constraints {exec stdio} -body { @@ -339,7 +344,7 @@ test exec-9.4 {commands returning errors} -constraints {exec stdio} -body { exec [interpreter] $path(exit) 43 | [interpreter] $path(echo) "foo bar" } -returnCodes error -result {foo bar child process exited abnormally} -test exec-9.5 {commands returning errors} -constraints {exec stdio} -body { +test exec-9.5 {commands returning errors} -constraints {exec stdio notValgrind} -body { exec gorp456 | [interpreter] echo a b c } -returnCodes error -result {couldn't execute "gorp456": no such file or directory} test exec-9.6 {commands returning errors} -constraints {exec} -body { @@ -428,13 +433,13 @@ test exec-10.19 {errors in exec invocation} -constraints {exec} -body { exec cat >@ $f } -returnCodes error -result "channel \"$f\" wasn't opened for writing" close $f -test exec-10.20 {errors in exec invocation} -constraints {exec} -body { +test exec-10.20 {errors in exec invocation} -constraints {exec notValgrind} -body { exec ~non_existent_user/foo/bar } -returnCodes error -result {user "non_existent_user" doesn't exist} -test exec-10.21 {errors in exec invocation} -constraints {exec} -body { +test exec-10.21 {errors in exec invocation} -constraints {exec notValgrind} -body { exec [interpreter] true | ~xyzzy_bad_user/x | false } -returnCodes error -result {user "xyzzy_bad_user" doesn't exist} -test exec-10.22 {errors in exec invocation} -constraints exec -body { +test exec-10.22 {errors in exec invocation} -constraints {exec notValgrind} -body { exec echo test > ~non_existent_user/foo/bar } -returnCodes error -result {user "non_existent_user" doesn't exist} # Commands in background. @@ -510,7 +515,7 @@ test exec-13.1 {setting errorCode variable} {exec} { test exec-13.2 {setting errorCode variable} {exec} { list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode] } {1 {posix enoent {no such file or directory}}} -test exec-13.3 {setting errorCode variable} {exec} { +test exec-13.3 {setting errorCode variable} {exec notValgrind} { set x [catch {exec _weird_cmd_} msg] list $x [string tolower $msg] [lindex $errorCode 0] \ [string tolower [lrange $errorCode 2 end]] @@ -548,7 +553,7 @@ test exec-14.2 {-keepnewline switch} -constraints {exec} -body { test exec-14.3 {unknown switch} -constraints {exec} -body { exec -gorp } -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --} -test exec-14.4 {-- switch} -constraints {exec} -body { +test exec-14.4 {-- switch} -constraints {exec notValgrind} -body { exec -- -gorp } -returnCodes error -result {couldn't execute "-gorp": no such file or directory} test exec-14.5 {-ignorestderr switch} {exec} { @@ -662,7 +667,7 @@ test exec-18.2 {exec cat deals with weird file names} -body { # Note that this test cannot be adapted to work on Windows; that platform has # no kernel support for an analog of O_APPEND. OTOH, that means we can assume # that there is a POSIX shell... -test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup { +test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind} -setup { set tmpfile [makeFile {0} tmpfile.exec-19.1] } -body { # Note that we have to allow for the current contents of the temporary @@ -675,7 +680,7 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup { {for a in a b c; do sleep 1; echo $a; done} >>$tmpfile & exec /bin/sh -c \ {for a in d e f; do sleep 1; echo $a >&2; done} 2>>$tmpfile & - # The above four shell invokations take about 3 seconds to finish, so allow + # The above four shell invocations take about 3 seconds to finish, so allow # 5s (in case the machine is busy) after 5000 # Check that no bytes have got lost through mixups with overlapping diff --git a/tests/ioCmd.test b/tests/ioCmd.test index cab4e97..ae58025 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -3781,7 +3781,6 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { # Use constraints to skip this test while valgrinding so this expected leak # doesn't prevent a finding of "leak-free". # -testConstraint notValgrind [expr {![testConstraint valgrind]}] test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body { #puts <<$tcltest::mainThread>>main diff --git a/tests/pkgIndex.tcl b/tests/pkgIndex.tcl new file mode 100644 index 0000000..48ab71b --- /dev/null +++ b/tests/pkgIndex.tcl @@ -0,0 +1,6 @@ +#! /usr/bin/env tclsh + +package ifneeded tcltests 0.1 { + source [file dirname [file dirname [file normalize [info script]/...]]]/tcltests.tcl + package provide tcltests 0.1 +} -- cgit v0.12 From 983854ad7b59ba90d6686bdd6f6f0fd3014a6912 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 16 Jun 2018 22:56:07 +0000 Subject: Add tests/tcltests.tcl as a place to store common code for tests. --- tests/tcltests.tcl | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 tests/tcltests.tcl diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl new file mode 100644 index 0000000..f7597b5 --- /dev/null +++ b/tests/tcltests.tcl @@ -0,0 +1,3 @@ +#! /usr/bin/env tclsh + +testConstraint notValgrind [expr {![testConstraint valgrind]}] -- cgit v0.12 From dd713ee96ec9cda48ba5f801193a70b6eb49d4a1 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 16 Jun 2018 22:57:36 +0000 Subject: Add tests/tcltests.tcl as a place to store common code for tests. --- tests/tcltests.tcl | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 tests/tcltests.tcl diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl new file mode 100644 index 0000000..f7597b5 --- /dev/null +++ b/tests/tcltests.tcl @@ -0,0 +1,3 @@ +#! /usr/bin/env tclsh + +testConstraint notValgrind [expr {![testConstraint valgrind]}] -- cgit v0.12 From 2b739c838a2b0f6dc7e64fad24eeb661d1a437ba Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 17 Jun 2018 08:47:29 +0000 Subject: Remove dependencies between tests in env.test. --- tests/env.test | 399 +++++++++++++++++++++++++++++++---------------------- tests/tcltests.tcl | 4 + 2 files changed, 236 insertions(+), 167 deletions(-) diff --git a/tests/env.test b/tests/env.test index 0dd4f98..2c077b1 100644 --- a/tests/env.test +++ b/tests/env.test @@ -16,49 +16,96 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } -# Some tests require the "exec" command. -# Skip them if exec is not defined. -testConstraint exec [llength [info commands exec]] +package require tcltests + +# [exec] is required here to see the actual environment received by child +# processes. +proc getenv {} { + global printenvScript + catch {exec [interpreter] $printenvScript} out + if {$out eq "child process exited abnormally"} { + set out {} + } + return $out +} + + +proc envrestore {} { + # Restore the environment variables at the end of the test. + global env + variable env2 + + foreach name [array names env] { + unset env($name) + } + array set env $env2 + return +} + + +proc envprep {} { + # Save the current environment variables at the start of the test. + global env + variable keep + variable env2 + + set env2 [array get env] + foreach name [array names env] { + # Keep some environment variables that support operation of the tcltest + # package. + if {[string toupper $name] ni $keep} { + unset env($name) + } + } + return +} + + +proc encodingrestore {} { + variable sysenc + encoding system $sysenc + return +} + + +proc encodingswitch encoding { + variable sysenc + # Need to run [getenv] in known encoding, so save the current one here... + set sysenc [encoding system] + encoding system $encoding + return +} + + +proc setup1 {} { + global env + envprep + encodingswitch iso8859-1 +} + +proc setup2 {} { + global env + setup1 + set env(NAME1) {test string} + set env(NAME2) {new value} + set env(XYZZY) {garbage} +} + + +proc cleanup1 {} { + encodingrestore + envrestore +} -# -# These tests will run on any platform (and indeed crashed on the Mac). So put -# them before you test for the existance of exec. -# -test env-1.1 {propagation of env values to child interpreters} -setup { - catch {interp delete child} - catch {unset env(test)} -} -body { - interp create child - set env(test) garbage - child eval {set env(test)} -} -cleanup { - interp delete child - unset env(test) -} -result {garbage} -# -# This one crashed on Solaris under Tcl8.0, so we only want to make sure it -# runs. -# -test env-1.2 {lappend to env value} -setup { - catch {unset env(test)} -} -body { - set env(test) aaaaaaaaaaaaaaaa - append env(test) bbbbbbbbbbbbbb - unset env(test) +variable keep { + TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH + SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH + DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING + SECURITYSESSIONID LANG WINDIR TERM + CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432 } -test env-1.3 {reflection of env by "array names"} -setup { - catch {interp delete child} - catch {unset env(test)} -} -body { - interp create child - child eval {set env(test) garbage} - expr {"test" in [array names env]} -} -cleanup { - interp delete child - catch {unset env(test)} -} -result {1} -set printenvScript [makeFile { +variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { encoding system iso8859-1 proc lrem {listname name} { upvar $listname list @@ -70,7 +117,7 @@ set printenvScript [makeFile { } proc mangle s { regsub -all {\[|\\|\]} $s {\\&} s - regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar &]} s + regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar {&}]} s return [subst -novariables $s] } proc manglechar c { @@ -84,161 +131,154 @@ set printenvScript [makeFile { lrem names ComSpec lrem names "" } - foreach name { - TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY - SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH - DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING - __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432 - } { + foreach name @keep@ { lrem names $name } foreach p $names { - puts "[mangle $p]=[mangle $env($p)]" + puts [mangle $p]=[mangle $env($p)] } exit -} printenv] +}] printenv] -# [exec] is required here to see the actual environment received by child -# processes. -proc getenv {} { - global printenvScript tcltest - catch {exec [interpreter] $printenvScript} out - if {$out eq "child process exited abnormally"} { - set out {} - } - return $out -} -# Save the current environment variables at the start of the test. - -set env2 [array get env] -foreach name [array names env] { - # Keep some environment variables that support operation of the tcltest - # package. - if {[string toupper $name] ni { - TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH - SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH - DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING - SECURITYSESSIONID LANG WINDIR TERM - CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432 - }} { - unset env($name) - } +test env-1.1 {propagation of env values to child interpreters} -setup { + catch {interp delete child} + catch {unset env(test)} +} -body { + interp create child + set env(test) garbage + child eval {set env(test)} +} -cleanup { + interp delete child + unset env(test) +} -result {garbage} + + +# This one crashed on Solaris under Tcl8.0, so we only want to make sure it +# runs. +test env-1.2 {lappend to env value} -setup { + catch {unset env(test)} +} -body { + set env(test) aaaaaaaaaaaaaaaa + append env(test) bbbbbbbbbbbbbb + unset env(test) } -# Need to run 'getenv' in known encoding, so save the current one here... -set sysenc [encoding system] -test env-2.1 {adding environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { - getenv +test env-1.3 {reflection of env by "array names"} -setup { + catch {interp delete child} + catch {unset env(test)} +} -body { + interp create child + child eval {set env(test) garbage} + expr {"test" in [array names env]} } -cleanup { - encoding system $sysenc -} -result {} -test env-2.2 {adding environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + interp delete child + catch {unset env(test)} +} -result 1 + + +test env-2.1 { + adding environment variables +} -constraints exec -setup setup1 -body { + getenv +} -cleanup cleanup1 -result {} + + +test env-2.2 { + adding environment variables +} -constraints exec -setup setup1 -body { set env(NAME1) "test string" getenv -} -cleanup { - encoding system $sysenc -} -result {NAME1=test string} -test env-2.3 {adding environment variables} -setup { - encoding system iso8859-1 +} -cleanup cleanup1 -result {NAME1=test string} + + +test env-2.3 {adding environment variables} -constraints exec -setup { + setup1 set env(NAME1) "test string" -} -constraints {exec} -body { +} -body { set env(NAME2) "more" getenv -} -cleanup { - encoding system $sysenc -} -result {NAME1=test string +} -cleanup cleanup1 -result {NAME1=test string NAME2=more} -test env-2.4 {adding environment variables} -setup { - encoding system iso8859-1 + + +test env-2.4 { + adding environment variables +} -constraints exec -setup { + setup1 set env(NAME1) "test string" set env(NAME2) "more" -} -constraints {exec} -body { +} -body { set env(XYZZY) "garbage" getenv -} -cleanup { - encoding system $sysenc +} -cleanup { cleanup1 } -result {NAME1=test string NAME2=more XYZZY=garbage} -set env(NAME1) "test string" -set env(NAME2) "new value" -set env(XYZZY) "garbage" -test env-3.1 {changing environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + +test env-3.1 { + changing environment variables +} -constraints exec -setup setup2 -body { set result [getenv] unset env(NAME2) set result } -cleanup { - encoding system $sysenc + cleanup1 } -result {NAME1=test string NAME2=new value XYZZY=garbage} -unset -nocomplain env(NAME2) -test env-4.1 {unsetting environment variables: default} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + +test env-4.1 { + unsetting environment variables +} -constraints exec -setup setup2 -body { + unset -nocomplain env(NAME2) getenv -} -cleanup { - encoding system $sysenc -} -result {NAME1=test string +} -cleanup cleanup1 -result {NAME1=test string XYZZY=garbage} -test env-4.2 {unsetting environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { - unset env(NAME1) - getenv -} -cleanup { - unset env(XYZZY) - encoding system $sysenc -} -result {XYZZY=garbage} -unset -nocomplain env(NAME1) env(XYZZY) -test env-4.3 {setting international environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + +# env-4.2 is deleted + +test env-4.3 { + setting international environment variables +} -constraints exec -setup setup1 -body { set env(\ua7) \ub6 getenv -} -cleanup { - encoding system $sysenc -} -result {\u00a7=\u00b6} -test env-4.4 {changing international environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { +} -cleanup cleanup1 -result {\u00a7=\u00b6} + + +test env-4.4 { + changing international environment variables +} -constraints exec -setup setup1 -body { set env(\ua7) \ua7 getenv -} -cleanup { - encoding system $sysenc -} -result {\u00a7=\u00a7} -test env-4.5 {unsetting international environment variables} -setup { - encoding system iso8859-1 +} -cleanup cleanup1 -result {\u00a7=\u00a7} + + +test env-4.5 { + unsetting international environment variables +} -constraints exec -setup { + setup1 set env(\ua7) \ua7 } -body { set env(\ub6) \ua7 unset env(\ua7) getenv -} -constraints {exec} -cleanup { - unset env(\ub6) - encoding system $sysenc -} -result {\u00b6=\u00a7} +} -cleanup cleanup1 -result {\u00b6=\u00a7} -test env-5.0 {corner cases - set a value, it should exist} -body { +test env-5.0 { + corner cases - set a value, it should exist +} -setup setup1 -body { set env(temp) a set env(temp) -} -cleanup { - unset env(temp) -} -result {a} -test env-5.1 {corner cases - remove one elem at a time} -setup { - set x [array get env] -} -body { +} -cleanup cleanup1 -result a + + +test env-5.1 { + corner cases - remove one elem at a time +} -setup setup1 -body { # When no environment variables exist, the env var will contain no # entries. The "array names" call synchs up the C-level environ array with # the Tcl level env array. Make sure an empty Tcl array is created. @@ -246,9 +286,9 @@ test env-5.1 {corner cases - remove one elem at a time} -setup { unset env($e) } array size env -} -cleanup { - array set env $x -} -result {0} +} -cleanup cleanup1 -result 0 + + test env-5.2 {corner cases - unset the env array} -setup { interp create i } -body { @@ -262,42 +302,54 @@ test env-5.2 {corner cases - unset the env array} -setup { } -cleanup { interp delete i } -result {0} + + test env-5.3 {corner cases: unset the env in master should unset child} -setup { + setup1 interp create i } -body { # Variables deleted in a master interp should be deleted in child interp # too. - i eval { set env(THIS_SHOULD_EXIST) a} + i eval {set env(THIS_SHOULD_EXIST) a} set result [set env(THIS_SHOULD_EXIST)] unset env(THIS_SHOULD_EXIST) lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}] } -cleanup { + cleanup1 interp delete i } -result {a 1} + + test env-5.4 {corner cases - unset the env array} -setup { + setup1 interp create i } -body { # The info exists command should be in synch with the env array. # Know Bug: 1737 - i eval { set env(THIS_SHOULD_EXIST) a} + i eval {set env(THIS_SHOULD_EXIST) a} set result [info exists env(THIS_SHOULD_EXIST)] lappend result [set env(THIS_SHOULD_EXIST)] lappend result [info exists env(THIS_SHOULD_EXIST)] } -cleanup { + cleanup1 interp delete i } -result {1 a 1} -test env-5.5 {corner cases - cannot have null entries on Windows} -constraints win -body { + + +test env-5.5 { + corner cases - cannot have null entries on Windows +} -constraints win -body { set env() a catch {set env()} -} -result 1 +} -cleanup cleanup1 -result 1 -test env-6.1 {corner cases - add lots of env variables} -body { +test env-6.1 {corner cases - add lots of env variables} -setup setup1 -body { set size [array size env] for {set i 0} {$i < 100} {incr i} { set env(BOGUS$i) $i } expr {[array size env] - $size} -} -result 100 +} -cleanup cleanup1 -result 100 test env-7.1 {[219226]: whole env array should not be unset by read} -body { set n [array size env] @@ -310,16 +362,20 @@ test env-7.1 {[219226]: whole env array should not be unset by read} -body { return $n } -result 0 -test env-7.2 {[219226]: links to env elements should not be removed by read} -body { +test env-7.2 { + [219226]: links to env elements should not be removed by read +} -setup setup1 -body { apply {{} { set ::env(test7_2) ok upvar env(test7_2) elem set ::env(PATH) return $elem }} -} -result ok +} -cleanup cleanup1 -result ok -test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy trace} -body { +test env-7.3 { + [9b4702]: testing existence of env(some_thing) should not destroy trace +} -setup setup1 -body { apply {{} { catch {unset ::env(test7_3)} proc foo args { @@ -330,16 +386,25 @@ test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy set ::env(not_yet_existent) "Now I'm here"; return [info exists ::env(test7_3)] }} -} -result 1 +} -cleanup cleanup1 -result 1 -# Restore the environment variables at the end of the test. +test env-8.0 { + memory usage - valgrind does not report reachable memory +} -body { + set res [set env(__DUMMY__) {i'm with dummy}] + unset env(__DUMMY__) + return $res +} -result {i'm with dummy} + -foreach name [array names env] { - unset env($name) -} -array set env $env2 # cleanup +rename getenv {} +rename envrestore {} +rename envprep {} +rename encodingrestore {} +rename encodingswitch {} + removeFile $printenvScript ::tcltest::cleanupTests return diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index f7597b5..8d42b70 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -1,3 +1,7 @@ #! /usr/bin/env tclsh +# Some tests require the "exec" command. +# Skip them if exec is not defined. +testConstraint exec [llength [info commands exec]] + testConstraint notValgrind [expr {![testConstraint valgrind]}] -- cgit v0.12 From 8047a470ef35faeafe18de166f773a78097b3fc2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 17 Jun 2018 16:07:09 +0000 Subject: Fix [53cad613d8a4de166e680f09a6c6399ebddbc17c|53cad613d8]: TIP 389 implementation makes Tk tests font-4.12 and font-4.15 fail. (Fix it in 8.6 too, for benefit of androwish) --- generic/tclParse.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/generic/tclParse.c b/generic/tclParse.c index f2cf322..fc7f77b 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -991,6 +991,14 @@ TclParseBackslash( if (readPtr != NULL) { *readPtr = count; } +#if TCL_UTF_MAX >= 4 + if ((result & 0xFC00) == 0xD800) { + dst[2] = (char) ((result | 0x80) & 0xBF); + dst[1] = (char) (((result >> 6) | 0x80) & 0xBF); + dst[0] = (char) ((result >> 12) | 0xE0); + return 3; + } +#endif return Tcl_UniCharToUtf(result, dst); } -- cgit v0.12