From 33b84014364cffbf3c994dc7298164257512d2c4 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 13 Jun 2018 10:49:25 +0000 Subject: Avoid valgrind "still reachable" reports stemming from early termination of threads. --- tests/async.test | 33 +++++++++++++++++++++++---------- 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/tests/async.test b/tests/async.test index fa3aae1..34c2fdc 100644 --- a/tests/async.test +++ b/tests/async.test @@ -156,19 +156,24 @@ test async-4.1 {async interrupting bytecode sequence} -constraints { } } -body { apply {{handle} { - global aresult - set aresult {Async event not delivered} - testasync marklater $handle - # allow plenty of time to pass in case valgrind is running - set start [clock seconds] - while { - [clock seconds] - $start < 180 && $aresult eq "Async event not delivered" - } { - nothing - } + global aresult + set aresult {Async event not delivered} + testasync marklater $handle + # allow plenty of time to pass in case valgrind is running + set start [clock seconds] + while { + [clock seconds] - $start < 180 && $aresult eq "Async event not delivered" + } { + # be less busy + after 100 + nothing + } return $aresult }} $hm } -result {test pattern} -cleanup { + # give other threads some time to go way so that valgrind doesn't pick up + # "still reachable" cases from early thread termination + after 100 testasync delete $hm } test async-4.2 {async interrupting straight bytecode sequence} -constraints { @@ -185,10 +190,15 @@ test async-4.2 {async interrupting straight bytecode sequence} -constraints { while { [clock seconds] - $start < 180 && $aresult eq "Async event not delivered" } { + # be less busy + after 100 } return $aresult }} $hm } -result {test pattern} -cleanup { + # give other threads some time to go way so that valgrind doesn't pick up + # "still reachable" cases from early thread termination + after 100 testasync delete $hm } test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { @@ -205,6 +215,9 @@ test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { return $aresult }]] $hm } -result {test pattern} -cleanup { + # give other threads some time to go way so that valgrind doesn't pick up + # "still reachable" cases from early thread termination + after 100 testasync delete $hm } -- cgit v0.12 From 83d92bd747f9da3b8e3413897e5e36cc63eb938e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 13 Jun 2018 15:59:15 +0000 Subject: Stop creating a stray child process. --- tests/main.test | 2 -- 1 file changed, 2 deletions(-) diff --git a/tests/main.test b/tests/main.test index 324b594..302f95e 100644 --- a/tests/main.test +++ b/tests/main.test @@ -1218,8 +1218,6 @@ namespace eval ::tcl::test::main { Bug 1775878 } -constraints { exec Tcltest - } -setup { - catch {set f [open "|[list [interpreter]]" w+]} } -body { exec [interpreter] << "testsetmainloop\nputs \\\npwd\ntestexitmainloop" >& result set f [open result] -- cgit v0.12 From 15f804e04ee653eb4556a7e2265ab0c76200f483 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 15 Jun 2018 13:17:17 +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 3d1cd56..dfc44c4 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 06fc5fb636829f99e0f6e8c20bc1cd07338a5515 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Jun 2018 18:31:24 +0000 Subject: Align common install locations in SC_PATH_TCLCONFIG and SC_PATH_TKCONFIG. Add FreeBSD (closes [d6d60efd35]) and OpenBSD 8.5 paths --- unix/tcl.m4 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 294ecf0..99e0cbd 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -93,8 +93,11 @@ AC_DEFUN([SC_PATH_TCLCONFIG], [ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ + `ls -d /usr/pkg/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ + `ls -d /usr/local/lib/tcl8.5 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tcl8.5 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" @@ -223,8 +226,11 @@ AC_DEFUN([SC_PATH_TKCONFIG], [ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ + `ls -d /usr/pkg/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ + `ls -d /usr/local/lib/tk8.5 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tk8.5 2>/dev/null` \ ; do if test -f "$i/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i; pwd)`" -- cgit v0.12 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 7bf68c2335062edb662417df9048b2c56244479f Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 16 Jun 2018 18:07:30 +0000 Subject: Add in basic github meta-files to reduce problems with issues being filed where we don't see them. --- .github/ISSUE_TEMPLATE.md | 3 +++ .github/PULL_REQUEST_TEMPLATE.md | 3 +++ 2 files changed, 6 insertions(+) create mode 100644 .github/ISSUE_TEMPLATE.md create mode 100644 .github/PULL_REQUEST_TEMPLATE.md diff --git a/.github/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md new file mode 100644 index 0000000..22d3860 --- /dev/null +++ b/.github/ISSUE_TEMPLATE.md @@ -0,0 +1,3 @@ +Important Note +========== +Please do not file issues with Tcl on Github. They are unlikely to be noticed in a timely fashion. Tcl issues are hosted in the [tcl fossil repository on core.tcl.tk](https://core.tcl.tk/tcl/tktnew); please post them there. diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md new file mode 100644 index 0000000..da07cd2 --- /dev/null +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -0,0 +1,3 @@ +Important Note +========== +Please do not file pull requests with Tcl on Github. They are unlikely to be noticed in a timely fashion. Tcl issues (including patches) are hosted in the [tcl fossil repository on core.tcl.tk](https://core.tcl.tk/tcl/tktnew); please post them there. -- 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 From e9c0ec1219e3c42df67c414bfda0bb5aab9a5bbb Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 18 Jun 2018 05:59:22 +0000 Subject: Plug leak in TclSetEnv. --- generic/tclEnv.c | 4 ++++ tests/pkgIndex.tcl | 8 ++++---- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 8cc4b74..c559c69 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -730,6 +730,10 @@ TclFinalizeEnvironment(void) ckfree(env.cache); env.cache = NULL; env.cacheSize = 0; + if ((env.ourEnviron != NULL)) { + ckfree(env.ourEnviron); + env.ourEnviron = NULL; + } #ifndef USE_PUTENV env.ourEnvironSize = 0; #endif diff --git a/tests/pkgIndex.tcl b/tests/pkgIndex.tcl index 48ab71b..0feb0eb 100644 --- a/tests/pkgIndex.tcl +++ b/tests/pkgIndex.tcl @@ -1,6 +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 -} +package ifneeded tcltests 0.1 " + source [list $dir]/tcltests.tcl + package provide tcltests 0.1 +" -- cgit v0.12 From 625aca976acac85e85a36f68a3727d2eec785922 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 18 Jun 2018 07:06:04 +0000 Subject: Full cleanup of env cache when in a PURIFY build. --- generic/tclEnv.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index c559c69..4a48f65 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -723,10 +723,18 @@ TclFinalizeEnvironment(void) * strings. This may leak more memory that strictly necessary, since some * of the strings may no longer be in the environment. However, * determining which ones are ok to delete is n-squared, and is pretty - * unlikely, so we don't bother. + * unlikely, so we don't bother. However, in the case of DPURIFY, just + * free all strings in the cache. */ + size_t i; + if (env.cache) { +#ifdef PURIFY + for (i = 0; i < env.cacheSize; i++) { + ckfree(env.cache[i]); + } +#endif ckfree(env.cache); env.cache = NULL; env.cacheSize = 0; -- cgit v0.12 From 155e8a1ad56291fb61f3578f3c7cda632556d1da Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 18 Jun 2018 08:09:32 +0000 Subject: Avoid valgrind "still reachable" reports stemming from early termination of threads. --- tests/async.test | 40 +++++++++++++++++++++++++++++----------- 1 file changed, 29 insertions(+), 11 deletions(-) diff --git a/tests/async.test b/tests/async.test index cb67cc2..e7fc45a 100644 --- a/tests/async.test +++ b/tests/async.test @@ -157,17 +157,24 @@ test async-4.1 {async interrupting bytecode sequence} -constraints { } } -body { apply {{handle} { - global aresult - set aresult {Async event not delivered} - testasync marklater $handle - for {set i 0} { - $i < 2500000 && $aresult eq "Async event not delivered" - } {incr i} { - nothing - } + global aresult + set aresult {Async event not delivered} + testasync marklater $handle + # allow plenty of time to pass in case valgrind is running + set start [clock seconds] + while { + [clock seconds] - $start < 180 && $aresult eq "Async event not delivered" + } { + # be less busy + after 100 + nothing + } return $aresult }} $hm } -result {test pattern} -cleanup { + # give other threads some time to go way so that valgrind doesn't pick up + # "still reachable" cases from early thread termination + after 100 testasync delete $hm } test async-4.2 {async interrupting straight bytecode sequence} -constraints { @@ -179,12 +186,20 @@ test async-4.2 {async interrupting straight bytecode sequence} -constraints { global aresult set aresult {Async event not delivered} testasync marklater $handle - for {set i 0} { - $i < 2500000 && $aresult eq "Async event not delivered" - } {incr i} {} + # allow plenty of time to pass in case valgrind is running + set start [clock seconds] + while { + [clock seconds] - $start < 180 && $aresult eq "Async event not delivered" + } { + # be less busy + after 100 + } return $aresult }} $hm } -result {test pattern} -cleanup { + # give other threads some time to go way so that valgrind doesn't pick up + # "still reachable" cases from early thread termination + after 100 testasync delete $hm } test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { @@ -201,6 +216,9 @@ test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { return $aresult }]] $hm } -result {test pattern} -cleanup { + # give other threads some time to go way so that valgrind doesn't pick up + # "still reachable" cases from early thread termination + after 100 testasync delete $hm } -- cgit v0.12 From 04004f3abcabe486568af1e7b026d03670b48ca8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Jun 2018 15:51:43 +0000 Subject: Unbreak build on Windows (and - most likely - some other platforms too) --- generic/tclEnv.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 4a48f65..40ced17 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -727,10 +727,9 @@ TclFinalizeEnvironment(void) * free all strings in the cache. */ - size_t i; - if (env.cache) { #ifdef PURIFY + int i; for (i = 0; i < env.cacheSize; i++) { ckfree(env.cache[i]); } @@ -738,11 +737,11 @@ TclFinalizeEnvironment(void) ckfree(env.cache); env.cache = NULL; env.cacheSize = 0; +#ifndef USE_PUTENV if ((env.ourEnviron != NULL)) { ckfree(env.ourEnviron); env.ourEnviron = NULL; } -#ifndef USE_PUTENV env.ourEnvironSize = 0; #endif } -- cgit v0.12 From 3c57d80efed172427e5aafa447365cb61439613c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Jun 2018 15:54:38 +0000 Subject: Fix [53cad613d8]: TIP 389 implementation makes Tk tests font-4.12 and font-4.15 fail. One more situation in which high surrogate causes problem --- generic/tclParse.c | 12 +++++------- generic/tclStringObj.c | 6 ++++++ generic/tclUtf.c | 7 +++++++ 3 files changed, 18 insertions(+), 7 deletions(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index fc7f77b..f26f933 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -991,15 +991,13 @@ 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; + count = Tcl_UniCharToUtf(result, dst); +#if TCL_UTF_MAX > 3 + if (!count) { + count = Tcl_UniCharToUtf(-1, dst); } #endif - return Tcl_UniCharToUtf(result, dst); + return count; } /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index a503392..1795d0c 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1996,6 +1996,12 @@ Tcl_AppendFormatToObj( goto error; } length = Tcl_UniCharToUtf(code, buf); +#if TCL_UTF_MAX > 3 + if (!length) { + /* Special case for handling upper surrogates. */ + length = Tcl_UniCharToUtf(-1, buf); + } +#endif segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 46ce4ef..c2963bf 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -189,6 +189,13 @@ Tcl_UniCharToUtf( buf[0] = (char) ((ch >> 18) | 0xF0); return 4; } + } else if (ch == -1) { + if (((buf[0] & 0xF8) == 0xF0) && ((buf[1] & 0xC0) == 0x80) + && ((buf[2] & 0xCF) == 0)) { + ch = 0xD7C0 + ((buf[0] & 0x07) << 8) + ((buf[1] & 0x3F) << 2) + + ((buf[2] & 0x30) >> 4); + goto three; + } #endif } -- cgit v0.12 From 03a3c09b1fc4fc80caec28b88b0fe09d612835b8 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Tue, 19 Jun 2018 11:47:08 +0000 Subject: new file: tools/valgrind_suppress. num-callers bumped from 8 to 24. Valgrind now issues no "still reachable" reports for cmdAH.test. --- tests/all.tcl | 23 ++++++++++++++--------- tests/pkgIndex.tcl | 2 +- tools/valgrind_suppress | 33 +++++++++++++++++++++++++++++++++ unix/Makefile.in | 4 +++- 4 files changed, 51 insertions(+), 11 deletions(-) create mode 100644 tools/valgrind_suppress diff --git a/tests/all.tcl b/tests/all.tcl index ad372db..d6434fb 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -14,18 +14,23 @@ package prefer latest package require Tcl 8.5- package require tcltest 2.2 namespace import tcltest::* -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 { +apply {args { + global auto_path + set testsdir [file dirname [file dirname [file normalize [ + info script]/...]]] + + configure {*}$args -testdir $testsdir + + if {[singleProcess]} { + interp debug {} -frame 1 + } + + set auto_path [lmap x $auto_path[set auto_path {}] { if {$x eq $testsdir} continue lindex $x - } -}} $testsdir {*}$auto_path] + }] +}} {*}$argv runAllTests proc exit args {} diff --git a/tests/pkgIndex.tcl b/tests/pkgIndex.tcl index 0feb0eb..854b943 100644 --- a/tests/pkgIndex.tcl +++ b/tests/pkgIndex.tcl @@ -1,6 +1,6 @@ #! /usr/bin/env tclsh package ifneeded tcltests 0.1 " - source [list $dir]/tcltests.tcl + source [list $dir/tcltests.tcl] package provide tcltests 0.1 " diff --git a/tools/valgrind_suppress b/tools/valgrind_suppress new file mode 100644 index 0000000..e8f0204 --- /dev/null +++ b/tools/valgrind_suppress @@ -0,0 +1,33 @@ +{ + TclpGetPwNam/getpwname_r/__nss_next2/calloc + Memcheck:Leak + match-leak-kinds: reachable + fun:calloc + ... + fun:__nss_next2 + ... + fun:TclpGetPwNam +} + +{ + TclpGetPwNam/getpwname_r/__nss_next2/malloc + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:__nss_next2 + ... + fun:TclpGetPwNam +} + +{ + TclpGetPwNam/getpwname_r/_nss_systemd_getpwnam_r/malloc + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:_nss_systemd_getpwnam_r + ... + fun:TclpGetPwNam +} + diff --git a/unix/Makefile.in b/unix/Makefile.in index 4277fad..060148f 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -262,7 +262,9 @@ GDB = gdb TRACE = strace TRACE_OPTS = VALGRIND = valgrind -VALGRINDARGS = --tool=memcheck --num-callers=8 --leak-resolution=high --leak-check=yes --show-reachable=yes -v +VALGRINDARGS = --tool=memcheck --num-callers=24 \ + --leak-resolution=high --leak-check=yes --show-reachable=yes -v \ + --suppressions=$(TOOL_DIR)/valgrind_suppress #-------------------------------------------------------------------------- # The information below should be usable as is. The configure script won't -- cgit v0.12 From 645241afc13d0aa6272925a04c3afa93ca93ef19 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 20 Jun 2018 08:03:22 +0000 Subject: Remove recent auto_path modification in tests/all.tcl and suppress more valgrind reports. --- tests/all.tcl | 20 +++++--------------- tools/valgrind_suppress | 20 ++++++++++++++++++++ 2 files changed, 25 insertions(+), 15 deletions(-) diff --git a/tests/all.tcl b/tests/all.tcl index d6434fb..250163b 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -15,22 +15,12 @@ package require Tcl 8.5- package require tcltest 2.2 namespace import tcltest::* -apply {args { - global auto_path - set testsdir [file dirname [file dirname [file normalize [ - info script]/...]]] +configure {*}$argv -testdir [file dirname [file dirname [file normalize [ + info script]/...]]] - configure {*}$args -testdir $testsdir - - if {[singleProcess]} { - interp debug {} -frame 1 - } - - set auto_path [lmap x $auto_path[set auto_path {}] { - if {$x eq $testsdir} continue - lindex $x - }] -}} {*}$argv +if {[singleProcess]} { + interp debug {} -frame 1 +} runAllTests proc exit args {} diff --git a/tools/valgrind_suppress b/tools/valgrind_suppress index e8f0204..84ed4cd 100644 --- a/tools/valgrind_suppress +++ b/tools/valgrind_suppress @@ -31,3 +31,23 @@ fun:TclpGetPwNam } +{ + TclCreatesocketAddress/getaddrinfo/calloc + Memcheck:Leak + match-leak-kinds: reachable + fun:calloc + ... + fun:getaddrinfo + fun:TclCreateSocketAddress +} + +{ + TclCreatesocketAddress/getaddrinfo/malloc + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:getaddrinfo + fun:TclCreateSocketAddress +} + -- cgit v0.12 From c911dc937fb03f387cc7ecd74b04a2e60ddb53b5 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 20 Jun 2018 19:06:40 +0000 Subject: Add valgrind suppression for dlopen and ensure that processes are reaped in http11.test. --- tests/http11.test | 7 +++++++ tools/valgrind_suppress | 10 ++++++++++ 2 files changed, 17 insertions(+) diff --git a/tests/http11.test b/tests/http11.test index c9ded0b..2e50837 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -666,6 +666,13 @@ test http11-4.3 "normal post request, check channel query length" -setup { # ------------------------------------------------------------------------- +# Eliminate valgrind "still reachable" reports on outstanding "Detached" +# structures in the detached list which stem from PipeClose2Proc not waiting +# around for background processes to complete, meaning that previous calls to +# Tcl_ReapDetachedProcs might not have had a chance to reap all processes. +after 10 +exec [info nameofexecutable] << {} + foreach p {create_httpd httpd_read halt_httpd meta check_crc} { if {[llength [info proc $p]]} {rename $p {}} } diff --git a/tools/valgrind_suppress b/tools/valgrind_suppress index 84ed4cd..3c733c2 100644 --- a/tools/valgrind_suppress +++ b/tools/valgrind_suppress @@ -51,3 +51,13 @@ fun:TclCreateSocketAddress } +{ + TclpDlopen/load + Memcheck:Leak + match-leak-kinds: reachable + fun:calloc + ... + fun:dlopen + fun:TclpDlopen +} + -- cgit v0.12 From 107fb1eb331d7f346dfbdf5e7655a28f4643899c Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 21 Jun 2018 22:16:29 +0000 Subject: Suppress more valgrind "still reachable" reports and ensure that threads are fully finalized in thread tests. --- tests/thread.test | 56 +++++++++++++++++++------------ tools/valgrind_suppress | 87 +++++++++++++++++++++++++++++++++++++++---------- 2 files changed, 106 insertions(+), 37 deletions(-) diff --git a/tests/thread.test b/tests/thread.test index cc4c871..a23670a 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -11,17 +11,22 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# when thread::release is used, -wait is passed in order allow the thread to +# be fully finalized, which avoids valgrind "still reachable" reports. if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.2 namespace import -force ::tcltest::* } +package require tcltests + ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the testthread command -testConstraint testthread [expr {[info commands testthread] != {}}] +testConstraint testthread [expr {[info commands testthread] ne {}}] # Some tests require the Thread package @@ -72,6 +77,17 @@ proc ThreadError {id info} { set threadSawError($id) true; # signal main thread to exit [vwait]. } +proc threadSuperKill id { + variable threadSuperKillScript + try { + thread::send $id $::threadSuperKillScript + } on error {tres topts} { + if {$tres ne {target thread died}} { + return -options $topts $tres + } + } +} + if {[testConstraint thread]} { thread::errorproc ThreadError } @@ -96,22 +112,22 @@ test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} { test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} { set serverthread [thread::create -preserved] set numthreads [llength [thread::names]] - thread::release $serverthread + thread::release -wait $serverthread set numthreads -} {2} +} 2 test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} { thread::create {set x 5} foreach try {0 1 2 4 5 6} { - # Try various ways to yield - update - after 10 - set l [llength [thread::names]] - if {$l == 1} { - break - } + # Try various ways to yield + update + after 10 + set l [llength [thread::names]] + if {$l == 1} { + break + } } set l -} {1} +} 1 test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { thread::create {{*}{}} update @@ -121,13 +137,13 @@ test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} { set serverthread [thread::create -preserved] set five [thread::send $serverthread {set x 5}] - thread::release $serverthread + thread::release -wait $serverthread set five } 5 test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} { set serverthread [thread::create -preserved {set z 5 ; thread::wait}] set five [thread::send $serverthread {set z}] - thread::release $serverthread + thread::release -wait $serverthread set five } 5 @@ -159,7 +175,7 @@ test thread-3.1 {TclThreadList} {thread} { set l2 [thread::names] set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]] foreach t $l1 { - thread::release $t + thread::release -wait $t } list $len $c } {1 0} @@ -887,7 +903,7 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread drainE # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::cancel $serverthread] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -929,7 +945,7 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::cancel $serverthread] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1029,7 +1045,7 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {interp cancel}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1071,7 +1087,7 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {interp cancel}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1111,7 +1127,7 @@ test thread-7.30 {cancel: send async thread cancel nested catch inside pure byte # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {thread::cancel [thread::id]}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1153,7 +1169,7 @@ test thread-7.31 {cancel: send async thread cancel nested catch pure inside-comm # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {thread::cancel [thread::id]}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ diff --git a/tools/valgrind_suppress b/tools/valgrind_suppress index 3c733c2..ede584a 100644 --- a/tools/valgrind_suppress +++ b/tools/valgrind_suppress @@ -1,63 +1,116 @@ { - TclpGetPwNam/getpwname_r/__nss_next2/calloc + TclCreatesocketAddress/getaddrinfo/calloc + Memcheck:Leak + match-leak-kinds: reachable + fun:calloc + ... + fun:getaddrinfo + fun:TclCreateSocketAddress +} + +{ + TclCreatesocketAddress/getaddrinfo/malloc + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:getaddrinfo + fun:TclCreateSocketAddress +} + +{ + TclpDlopen/load + Memcheck:Leak + match-leak-kinds: reachable + fun:calloc + ... + fun:dlopen + fun:TclpDlopen +} + +{ + TclpGetGrNam/__nss_next2/calloc Memcheck:Leak match-leak-kinds: reachable fun:calloc ... fun:__nss_next2 ... - fun:TclpGetPwNam + fun:TclpGetGrNam } { - TclpGetPwNam/getpwname_r/__nss_next2/malloc + TclpGetGrNam/__nss_next2/malloc Memcheck:Leak match-leak-kinds: reachable fun:malloc ... fun:__nss_next2 ... - fun:TclpGetPwNam + fun:TclpGetGrNam } { - TclpGetPwNam/getpwname_r/_nss_systemd_getpwnam_r/malloc + TclpGetGrNam/__nss_systemd_getfrname_r/malloc Memcheck:Leak match-leak-kinds: reachable fun:malloc ... - fun:_nss_systemd_getpwnam_r + fun:_nss_systemd_getgrnam_r ... - fun:TclpGetPwNam + fun:TclpGetGrNam } { - TclCreatesocketAddress/getaddrinfo/calloc + TclpGetPwNam/getpwname_r/__nss_next2/calloc Memcheck:Leak match-leak-kinds: reachable fun:calloc ... - fun:getaddrinfo - fun:TclCreateSocketAddress + fun:__nss_next2 + ... + fun:TclpGetPwNam } { - TclCreatesocketAddress/getaddrinfo/malloc + TclpGetPwNam/getpwname_r/__nss_next2/malloc Memcheck:Leak match-leak-kinds: reachable fun:malloc ... - fun:getaddrinfo - fun:TclCreateSocketAddress + fun:__nss_next2 + ... + fun:TclpGetPwNam } { - TclpDlopen/load + TclpGetPwNam/getpwname_r/_nss_systemd_getpwnam_r/malloc Memcheck:Leak match-leak-kinds: reachable - fun:calloc + fun:malloc ... - fun:dlopen - fun:TclpDlopen + fun:_nss_systemd_getpwnam_r + ... + fun:TclpGetPwNam +} + +{ + TclpThreadExit/pthread_exit/calloc + Memcheck:Leak + match-leak-kinds: reachable + fun:calloc + ... + fun:pthread_exit + fun:TclpThreadExit +} + +{ + TclpThreadExit/pthread_exit/malloc + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:pthread_exit + fun:TclpThreadExit } -- cgit v0.12 From 56ca35e8a95b8cfaac73104d3699c2b901298a2d Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 21 Jun 2018 22:21:31 +0000 Subject: Add custom exit procedure for tcltests executable. --- generic/tclInt.h | 1 + generic/tclTest.c | 16 ++++++++++++++++ generic/tclThreadTest.c | 7 +++++++ 3 files changed, 24 insertions(+) diff --git a/generic/tclInt.h b/generic/tclInt.h index 0a3285f..6fc2e85 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4532,6 +4532,7 @@ MODULE_SCOPE Tcl_PackageInitProc TclObjTest_Init; MODULE_SCOPE Tcl_PackageInitProc TclThread_Init; MODULE_SCOPE Tcl_PackageInitProc Procbodytest_Init; MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; +MODULE_SCOPE void *TclThreadTestFinalize(); /* *---------------------------------------------------------------- diff --git a/generic/tclTest.c b/generic/tclTest.c index 45cca5a..952f384 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -52,6 +52,7 @@ #define TCL_STORAGE_CLASS DLLEXPORT EXTERN int Tcltest_Init(Tcl_Interp *interp); EXTERN int Tcltest_SafeInit(Tcl_Interp *interp); +EXTERN TCL_NORETURN void Tcltest_Exit(ClientData clientData); /* * Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect @@ -563,6 +564,10 @@ Tcltest_Init( return TCL_ERROR; } + + /* Finalizer */ + Tcl_SetExitProc(Tcltest_Exit); + /* * Create additional commands and math functions for testing Tcl. */ @@ -790,6 +795,17 @@ Tcltest_SafeInit( return Procbodytest_SafeInit(interp); } +TCL_NORETURN void Tcltest_Exit( + ClientData clientData +) { + int status = PTR2INT(clientData); + Tcl_Finalize(); + TclThreadTestFinalize(); + TclpExit(status); + Tcl_Panic("OS exit failed!"); +} + + /* *---------------------------------------------------------------------- * diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 6fc0e52..3d63964 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -176,6 +176,13 @@ TclThread_Init( } +void * TclThreadTestFinalize() { + if (errorProcString != NULL) { + ckfree(errorProcString); + errorProcString= NULL; + } +} + /* *---------------------------------------------------------------------- * -- cgit v0.12 From 563bd6e4ddc1fab518dc16ebd1d39d05feffa6b0 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 21 Jun 2018 22:43:18 +0000 Subject: Fix function signature of TclThreadTestFinalize. --- generic/tclInt.h | 2 +- generic/tclThreadTest.c | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 6fc2e85..64004d8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4532,7 +4532,7 @@ MODULE_SCOPE Tcl_PackageInitProc TclObjTest_Init; MODULE_SCOPE Tcl_PackageInitProc TclThread_Init; MODULE_SCOPE Tcl_PackageInitProc Procbodytest_Init; MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; -MODULE_SCOPE void *TclThreadTestFinalize(); +MODULE_SCOPE void TclThreadTestFinalize(); /* *---------------------------------------------------------------- diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 3d63964..92cfa13 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -176,11 +176,12 @@ TclThread_Init( } -void * TclThreadTestFinalize() { +void TclThreadTestFinalize() { if (errorProcString != NULL) { ckfree(errorProcString); errorProcString= NULL; } + return; } /* -- cgit v0.12 From 94ec3d943104b645666e3f71feb61ac260a43fcf Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 22 Jun 2018 15:10:04 +0000 Subject: Add another suppress rule for valgrind, factor test code into tests/tcltests.tcl, and constrained a some tests in the valgrind case. --- tests/all.tcl | 2 +- tests/chanio.test | 4 ---- tests/io.test | 4 ---- tests/ioCmd.test | 16 +++++++++++++--- tests/platform.test | 6 +++++- tests/tcltest.test | 7 +++++++ tests/tcltests.tcl | 12 ++++++++---- tests/thread.test | 11 ----------- tools/valgrind_suppress | 10 ++++++++++ 9 files changed, 44 insertions(+), 28 deletions(-) diff --git a/tests/all.tcl b/tests/all.tcl index 250163b..4fce323 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -13,7 +13,7 @@ package prefer latest package require Tcl 8.5- package require tcltest 2.2 -namespace import tcltest::* +namespace import -force ::tcltest::* configure {*}$argv -testdir [file dirname [file dirname [file normalize [ info script]/...]]] diff --git a/tests/chanio.test b/tests/chanio.test index 86c1485..492c11e 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -39,14 +39,10 @@ namespace eval ::tcl::test::io { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testchannel [llength [info commands testchannel]] - testConstraint exec [llength [info commands exec]] testConstraint openpipe 1 - testConstraint fileevent [llength [info commands fileevent]] - testConstraint fcopy [llength [info commands fcopy]] testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] - testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # You need a *very* special environment to do some tests. In particular, # many file systems do not support large-files... diff --git a/tests/io.test b/tests/io.test index cdecb7b..cc1d986 100644 --- a/tests/io.test +++ b/tests/io.test @@ -36,14 +36,10 @@ namespace eval ::tcl::test::io { variable expected testConstraint testchannel [llength [info commands testchannel]] -testConstraint exec [llength [info commands exec]] testConstraint openpipe 1 -testConstraint fileevent [llength [info commands fileevent]] -testConstraint fcopy [llength [info commands fcopy]] testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] -testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] testConstraint testobj [llength [info commands testobj]] # You need a *very* special environment to do some tests. In diff --git a/tests/ioCmd.test b/tests/ioCmd.test index ae58025..948671e 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -21,10 +21,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +package require tcltests + # Custom constraints used in this file -testConstraint fcopy [llength [info commands fcopy]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] #---------------------------------------------------------------------- @@ -395,7 +395,7 @@ test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode } {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} -test iocmd-11.4 {I/O to command pipelines} unixOrPc { +test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrPc} { list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode } {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}} @@ -3833,6 +3833,16 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat rename track {} # cleanup + + +# Eliminate valgrind "still reachable" reports on outstanding "Detached" +# structures in the detached list which stem from PipeClose2Proc not waiting +# around for background processes to complete, meaning that previous calls to +# Tcl_ReapDetachedProcs might not have had a chance to reap all processes. +after 10 +exec [info nameofexecutable] << {} + + foreach file [list test1 test2 test3 test4] { removeFile $file } diff --git a/tests/platform.test b/tests/platform.test index 8ee0ec7..e5a4c90 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -10,6 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 +package require tcltests namespace eval ::tcl::test::platform { namespace import ::tcltest::testConstraint @@ -67,7 +68,10 @@ test platform-3.1 {CPU ID on Windows/UNIX} \ # format of string it produces consists of two non-empty words separated by a # hyphen. package require platform -test platform-4.1 {format of platform::identify result} -match regexp -body { +test platform-4.1 {format of platform::identify result} -constraints notValgrind -match regexp -body { + # [identify] may attempt to [exec] dpkg-architecture, which may not exist, + # in which case fork will not be followed by exec, and valgrind will issue + # "still reachable" reports. platform::identify } -result {^([^-]+-)+[^-]+$} test platform-4.2 {format of platform::generic result} -match regexp -body { diff --git a/tests/tcltest.test b/tests/tcltest.test index 17fa926..0bcf342 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -908,7 +908,9 @@ removeFile load.tcl # [interpreter] test tcltest-13.1 {interpreter} { + -constraints notValgrind -setup { + #to do: Why is $::tcltest::tcltest being saved and restored here? set old $::tcltest::tcltest set ::tcltest::tcltest tcltest } @@ -920,6 +922,11 @@ test tcltest-13.1 {interpreter} { } -result {tcltest tclsh tclsh} -cleanup { + # writing ::tcltest::tcltest triggers a trace that sets up the stdio + # constraint, which involves a call to [exec] that might fail after + # "fork" and before "exec", in which case the forked process will not + # have a chance to clean itself up before exiting, which causes + # valgrind to issue numerous "still reachable" reports. set ::tcltest::tcltest $old } } diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 8d42b70..2105279 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -1,7 +1,11 @@ #! /usr/bin/env tclsh -# Some tests require the "exec" command. -# Skip them if exec is not defined. -testConstraint exec [llength [info commands exec]] +package require tcltest 2.2 +namespace import -force ::tcltest::* -testConstraint notValgrind [expr {![testConstraint valgrind]}] +testConstraint exec [llength [info commands exec]] +testConstraint fcopy [llength [info commands fcopy]] +testConstraint fileevent [llength [info commands fileevent]] +testConstraint thread [ + expr {0 == [catch {package require Thread 2.7-}]}] +testConstraint notValgrind [expr {![testConstraint valgrind]}] diff --git a/tests/thread.test b/tests/thread.test index a23670a..eaaaa41 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -14,10 +14,6 @@ # when thread::release is used, -wait is passed in order allow the thread to # be fully finalized, which avoids valgrind "still reachable" reports. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.2 - namespace import -force ::tcltest::* -} package require tcltests @@ -28,13 +24,6 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testthread [expr {[info commands testthread] ne {}}] -# Some tests require the Thread package - -testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] - -# Some tests may not work under valgrind - -testConstraint notValgrind [expr {![testConstraint valgrind]}] set threadSuperKillScript { rename catch "" diff --git a/tools/valgrind_suppress b/tools/valgrind_suppress index ede584a..fb7f173 100644 --- a/tools/valgrind_suppress +++ b/tools/valgrind_suppress @@ -29,6 +29,16 @@ } { + TclpDlopen/load + Memcheck:Leak + match-leak-kinds: reachable + fun:malloc + ... + fun:dlopen + fun:TclpDlopen +} + +{ TclpGetGrNam/__nss_next2/calloc Memcheck:Leak match-leak-kinds: reachable -- cgit v0.12 From 6cbfdcc4a338d5b7348ee7e65a7710d13f9bc27e Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 23 Jun 2018 14:18:06 +0000 Subject: Add a test for no generation of a string representation when comparing with the empty string. --- tests/expr.test | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tests/expr.test b/tests/expr.test index fd11870..a265ac6 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -7196,6 +7196,15 @@ test expr-51.1 {test round-to-even on input} { expr 6.9294956446009195e15 } 6929495644600920.0 +test expr-52.1 { + comparison with empty string does not generate string representation +} { + set a [list one two three] + list [expr {$a eq {}}] [expr {$a < {}}] [expr {$a > {}}] [ + string match {*no string representation*} [ + ::tcl::unsupported::representation $a]] +} {0 0 1 1} + # cleanup -- cgit v0.12 From e2a79c2604e79b36ec065a7bb44ec57eaca5ed8a Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 24 Jun 2018 07:17:46 +0000 Subject: Fix for [3592747]: Let TclNRTailcallEval handle namespace problems. --- generic/tclBasic.c | 8 +------- tests/tailcall.test | 20 ++++++++++++++++++++ 2 files changed, 21 insertions(+), 7 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3ac3ffd..07f7e5c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8402,18 +8402,12 @@ TclNRTailcallObjCmd( if (objc > 1) { Tcl_Obj *listPtr, *nsObjPtr; Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; /* The tailcall data is in a Tcl list: the first element is the * namespace, the rest the command to be tailcalled. */ - listPtr = Tcl_NewListObj(objc, objv); - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) - || (nsPtr != ns1Ptr)) { - Tcl_Panic("Tailcall failed to find the proper namespace"); - } + listPtr = Tcl_NewListObj(objc, objv); TclListObjSetElement(interp, listPtr, 0, nsObjPtr); iPtr->varFramePtr->tailcallPtr = listPtr; diff --git a/tests/tailcall.test b/tests/tailcall.test index 26f3cbf..3751c35 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -688,6 +688,26 @@ if {[testConstraint testnrelevels]} { namespace delete testnre } +test tailcall-14.1 {in a deleted namespace} -body { + namespace eval ns { + proc p args { + tailcall [namespace current] $args + } + namespace delete [namespace current] + p + } +} -returnCodes 1 -result {namespace "::ns" not found} + +test tailcall-14.1-bc {{in a deleted namespace} {byte compiled}} -body { + namespace eval ns { + proc p args { + tailcall [namespace current] {*}$args + } + namespace delete [namespace current] + p + } +} -returnCodes 1 -result {namespace "::ns" not found} + # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 94f9cf81ed3e156bd372a3cac249974d1acb4e1d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 24 Jun 2018 20:26:27 +0000 Subject: Fix "string tolower" and friends for handling unpaired surrogates correctly. Also add test-cases for those situations. Various typo's in comments. --- doc/Utf.3 | 5 ++++- generic/tclCmdMZ.c | 3 +++ generic/tclDisassemble.c | 2 +- generic/tclExecute.c | 14 ++++++++++---- generic/tclParse.c | 1 + generic/tclUtf.c | 21 +++++++++++++++------ tests/utf.test | 15 +++++++++++++++ 7 files changed, 49 insertions(+), 12 deletions(-) diff --git a/doc/Utf.3 b/doc/Utf.3 index 160575b..922fd81 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -132,7 +132,10 @@ represent one Unicode character in the UTF-8 representation. .PP \fBTcl_UniCharToUtf\fR stores the character \fIch\fR as a UTF-8 string in starting at \fIbuf\fR. The return value is the number of bytes stored -in \fIbuf\fR. +in \fIbuf\fR. If ch is an upper surrogate (range U+D800 - U+DBFF), then +the return value will be 0 and nothing will be stored. If you still +want to produce UTF-8 output for it (even though knowing it's an illegal +code-point on its own), just call \fBTcl_UniCharToUtf\fR again using ch = -1. .PP \fBTcl_UtfToUniChar\fR reads one UTF-8 character starting at \fIsrc\fR and stores it as a Tcl_UniChar in \fI*chPtr\fR. The return value is the diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d64299e..0bd6cb4 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1447,6 +1447,9 @@ StringIndexCmd( char buf[4]; length = Tcl_UniCharToUtf(ch, buf); + if (!length) { + length = Tcl_UniCharToUtf(-1, buf); + } Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); } } diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index e9aaec4..a0d1258 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -894,7 +894,7 @@ PrintSourceToObj( Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ch); i += 10; } else -#elif TCL_UTF_MAX > 3 +#else /* If len == 0, this means we have a char > 0xffff, resulting in * TclUtfToUniChar producing a surrogate pair. We want to output * this pair as a single Unicode character. diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fda50b2..82de752 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4964,7 +4964,7 @@ TEBCresume( /* Decode index value operands. */ - /* + /* assert ( toIdx != TCL_INDEX_AFTER); * * Extra safety for legacy bytecodes: @@ -5223,9 +5223,15 @@ TEBCresume( * but creating the object as a string seems to be faster in * practical use. */ - - length = (ch != -1) ? Tcl_UniCharToUtf(ch, buf) : 0; - objResultPtr = Tcl_NewStringObj(buf, length); + if (ch == -1) { + objResultPtr = Tcl_NewObj(); + } else { + length = Tcl_UniCharToUtf(ch, buf); + if (!length) { + length = Tcl_UniCharToUtf(-1, buf); + } + objResultPtr = Tcl_NewStringObj(buf, length); + } } TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); diff --git a/generic/tclParse.c b/generic/tclParse.c index 581270c..00b83a1 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -981,6 +981,7 @@ TclParseBackslash( } count = Tcl_UniCharToUtf(result, dst); if (!count) { + /* Special case for handling upper surrogates. */ count = Tcl_UniCharToUtf(-1, dst); } return count; diff --git a/generic/tclUtf.c b/generic/tclUtf.c index ed10ab2..c8292a2 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -218,7 +218,7 @@ Tcl_UniCharToUtfDString( { const Tcl_UniChar *w, *wEnd; char *p, *string; - int oldLength; + int oldLength, len = 1; /* * UTF-8 string length in bytes will be <= Unicode string length * 4. @@ -231,9 +231,18 @@ Tcl_UniCharToUtfDString( p = string; wEnd = uniStr + uniLength; for (w = uniStr; w < wEnd; ) { - p += Tcl_UniCharToUtf(*w, p); + if (!len && ((*w & 0xFC00) != 0xDC00)) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + len = Tcl_UniCharToUtf(*w, p); + p += len; w++; } + if (!len) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); return string; @@ -899,7 +908,7 @@ Tcl_UtfToUpper( * char to dst if its size is <= the original char. */ - if (bytes < TclUtfCount(upChar)) { + if ((bytes < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -962,7 +971,7 @@ Tcl_UtfToLower( * char to dst if its size is <= the original char. */ - if (bytes < TclUtfCount(lowChar)) { + if ((bytes < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -1022,7 +1031,7 @@ Tcl_UtfToTitle( #endif titleChar = Tcl_UniCharToTitle(titleChar); - if (bytes < TclUtfCount(titleChar)) { + if ((bytes < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -1046,7 +1055,7 @@ Tcl_UtfToTitle( lowChar = Tcl_UniCharToLower(lowChar); } - if (bytes < TclUtfCount(lowChar)) { + if ((bytes < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { diff --git a/tests/utf.test b/tests/utf.test index 67a6778..e820359 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -158,6 +158,12 @@ test utf-8.3 {Tcl_UniCharAtIndex: index > 0} { test utf-8.4 {Tcl_UniCharAtIndex: index > 0} { string index \u4e4e\u25a\xff\u543 2 } "\uff" +test utf-8.5 {Tcl_UniCharAtIndex: upper surrogate} { + string index \ud842 0 +} "\ud842" +test utf-8.5 {Tcl_UniCharAtIndex: lower surrogate} { + string index \udc42 0 +} "\udc42" test utf-9.1 {Tcl_UtfAtIndex: index = 0} { string range abcd 0 2 @@ -263,6 +269,9 @@ test utf-11.4 {Tcl_UtfToUpper} { test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} { string toupper \u10d0\u1c90 } \u1c90\u1c90 +test utf-11.6 {Tcl_UtfToUpper low/high surrogate)} { + string toupper \udc24\ud824 +} \udc24\ud824 test utf-12.1 {Tcl_UtfToLower} { string tolower {} @@ -279,6 +288,9 @@ test utf-12.4 {Tcl_UtfToLower} { test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} { string tolower \u10d0\u1c90 } \u10d0\u10d0 +test utf-12.6 {Tcl_UtfToUpper low/high surrogate)} { + string tolower \udc24\ud824 +} \udc24\ud824 test utf-13.1 {Tcl_UtfToTitle} { string totitle {} @@ -298,6 +310,9 @@ test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { string totitle \u1c90\u10d0 } \u1c90\u10d0 +test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} { + string totitle \udc24\ud824 +} \udc24\ud824 test utf-14.1 {Tcl_UtfNcasecmp} { string compare -nocase a b -- cgit v0.12 From 0839047d8bed631eeb82c7c3e26b0f13461717e6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Jun 2018 07:22:19 +0000 Subject: Simplify ToUtf(), expecially for TCL_UTF_MAX>3 (with correct surrogate handling). Fix various typo's --- tests/iogt.test | 2 +- unix/tclUnixSock.c | 6 +++--- unix/tclUnixThrd.c | 6 +++--- win/tclWinInit.c | 19 +++++++++++-------- win/tclWinSock.c | 16 ++++++++-------- win/tclWinThrd.c | 8 ++++---- 6 files changed, 30 insertions(+), 27 deletions(-) diff --git a/tests/iogt.test b/tests/iogt.test index 1ed89f7..269a0ba 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -608,7 +608,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { variable copy 1 } } -constraints {testchannel knownBug} -body { - # This test to check the validity of aquired Tcl_Channel references is not + # This test to check the validity of acquired Tcl_Channel references is not # possible because even a backgrounded fcopy will immediately start to # copy data, without waiting for the event loop. This is done only in case # of an underflow on the read size!. So stacking transforms after the diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index e418ff0..90c72c0 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1099,7 +1099,7 @@ TcpGetHandleProc( * TcpAsyncCallback -- * * Called by the event handler that TcpConnect sets up internally for - * [socket -async] to get notified when the asyncronous connection + * [socket -async] to get notified when the asynchronous connection * attempt has succeeded or failed. * * ---------------------------------------------------------------------- @@ -1132,7 +1132,7 @@ TcpAsyncCallback( * * Remarks: * A single host name may resolve to more than one IP address, e.g. for - * an IPv4/IPv6 dual stack host. For handling asyncronously connecting + * an IPv4/IPv6 dual stack host. For handling asynchronously connecting * sockets in the background for such hosts, this function can act as a * coroutine. On the first call, it sets up the control variables for the * two nested loops over the local and remote addresses. Once the first @@ -1140,7 +1140,7 @@ TcpAsyncCallback( * event handler for that socket, and returns. When the callback occurs, * control is transferred to the "reenter" label, right after the initial * return and the loops resume as if they had never been interrupted. - * For syncronously connecting sockets, the loops work the usual way. + * For synchronously connecting sockets, the loops work the usual way. * * ---------------------------------------------------------------------- */ diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 0476d85..0609230 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -316,7 +316,7 @@ TclpInitUnlock(void) * in finalization; it is hidden during creation of the objects. * * This lock must be different than the initLock because the initLock is - * held during creation of syncronization objects. + * held during creation of synchronization objects. * * Results: * None. @@ -407,7 +407,7 @@ Tcl_GetAllocMutex(void) * None. * * Side effects: - * May block the current thread. The mutex is aquired when this returns. + * May block the current thread. The mutex is acquired when this returns. * Will allocate memory for a pthread_mutex_t and initialize this the * first time this Tcl_Mutex is used. * @@ -511,7 +511,7 @@ TclpFinalizeMutex( * None. * * Side effects: - * May block the current thread. The mutex is aquired when this returns. + * May block the current thread. The mutex is acquired when this returns. * Will allocate memory for a pthread_mutex_t and initialize this the * first time this Tcl_Mutex is used. * diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 8e567e3..ff5327d 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -112,7 +112,12 @@ static ProcessGlobalValue sourceLibraryDir = {0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL}; static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib); -static int ToUtf(const WCHAR *wSrc, char *dst); + +#if TCL_UTF_MAX < 4 +static void ToUtf(const WCHAR *wSrc, char *dst); +#else +#define ToUtf(wSrc, dst) WideCharToMultiByte(CP_UTF8, 0, wSrc, -1, dst, MAX_PATH * TCL_UTF_MAX, NULL, NULL) +#endif /* *--------------------------------------------------------------------------- @@ -435,7 +440,7 @@ InitializeSourceLibraryDir( * * ToUtf -- * - * Convert a char string to a UTF string. + * Convert a wchar string to a UTF string. * * Results: * None. @@ -446,21 +451,19 @@ InitializeSourceLibraryDir( *--------------------------------------------------------------------------- */ -static int +#if TCL_UTF_MAX < 4 +static void ToUtf( const WCHAR *wSrc, char *dst) { - char *start; - - start = dst; while (*wSrc != '\0') { dst += Tcl_UniCharToUtf(*wSrc, dst); wSrc++; } *dst = '\0'; - return (int) (dst - start); } +#endif /* *--------------------------------------------------------------------------- @@ -660,7 +663,7 @@ TclpSetVariables( * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this routine is - * case sensitive, on Windows this matches mioxed case. + * case sensitive, on Windows this matches mixed case. * * Results: * The return value is the index in environ of an entry with the name diff --git a/win/tclWinSock.c b/win/tclWinSock.c index da2e60a..e2479e81 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -686,7 +686,7 @@ WaitForConnect( } /* - * A non blocking socket waiting for an asyncronous connect + * A non blocking socket waiting for an asynchronous connect * returns directly the error EWOULDBLOCK */ @@ -1606,9 +1606,9 @@ TcpGetHandleProc( * * This might be called in 3 circumstances: * - By a regular socket command - * - By the event handler to continue an asynchroneous connect + * - By the event handler to continue an asynchronously connect * - By a blocking socket function (gets/puts) to terminate the - * connect synchroneously + * connect synchronously * * Results: * TCL_OK, if the socket was successfully connected or an asynchronous @@ -1620,7 +1620,7 @@ TcpGetHandleProc( * * Remarks: * A single host name may resolve to more than one IP address, e.g. for - * an IPv4/IPv6 dual stack host. For handling asyncronously connecting + * an IPv4/IPv6 dual stack host. For handling asynchronously connecting * sockets in the background for such hosts, this function can act as a * coroutine. On the first call, it sets up the control variables for the * two nested loops over the local and remote addresses. Once the first @@ -1628,7 +1628,7 @@ TcpGetHandleProc( * event handler for that socket, and returns. When the callback occurs, * control is transferred to the "reenter" label, right after the initial * return and the loops resume as if they had never been interrupted. - * For syncronously connecting sockets, the loops work the usual way. + * For synchronously connecting sockets, the loops work the usual way. * *---------------------------------------------------------------------- */ @@ -1718,7 +1718,7 @@ TcpConnect( continue; } /* - * For asyncroneous connect set the socket in nonblocking mode + * For asynchroneous connect set the socket in nonblocking mode * and activate connect notification */ if (async_connect) { @@ -1806,7 +1806,7 @@ TcpConnect( /* * Clear the tsd socket list pointer if we did not wait for - * the FD_CONNECT asyncroneously + * the FD_CONNECT asynchroneously */ tsdPtr->pendingTcpState = NULL; @@ -1868,7 +1868,7 @@ out: SetEvent(tsdPtr->socketListLock); } /* - * Error message on syncroneous connect + * Error message on synchroneous connect */ if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 8f3ddb9..0f83526 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -247,7 +247,7 @@ TclpThreadCreate( /* * The only purpose of this is to decrement the reference count so the - * OS resources will be reaquired when the thread closes. + * OS resources will be reacquired when the thread closes. */ CloseHandle(tHandle); @@ -405,7 +405,7 @@ TclpInitUnlock(void) * mutexes, condition variables, and thread local storage keys. * * This lock must be different than the initLock because the initLock is - * held during creation of syncronization objects. + * held during creation of synchronization objects. * * Results: * None. @@ -555,7 +555,7 @@ static void FinalizeConditionEvent(ClientData data); * None. * * Side effects: - * May block the current thread. The mutex is aquired when this returns. + * May block the current thread. The mutex is acquired when this returns. * *---------------------------------------------------------------------- */ @@ -655,7 +655,7 @@ TclpFinalizeMutex( * None. * * Side effects: - * May block the current thread. The mutex is aquired when this returns. + * May block the current thread. The mutex is acquired when this returns. * Will allocate memory for a HANDLE and initialize this the first time * this Tcl_Condition is used. * -- cgit v0.12 From ed5ed756bc5993edb110e13b90028646b413e92d Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 26 Jun 2018 14:22:08 +0000 Subject: Restore lost tests. --- tests/all.tcl | 2 +- tests/chanio.test | 11 ++++------- tests/io.test | 11 +++++------ tests/tcltests.tcl | 2 +- 4 files changed, 11 insertions(+), 15 deletions(-) diff --git a/tests/all.tcl b/tests/all.tcl index 4fce323..e14bd9c 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -13,7 +13,7 @@ package prefer latest package require Tcl 8.5- package require tcltest 2.2 -namespace import -force ::tcltest::* +namespace import ::tcltest::* configure {*}$argv -testdir [file dirname [file dirname [file normalize [ info script]/...]]] diff --git a/tests/chanio.test b/tests/chanio.test index 492c11e..6408f50 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -13,16 +13,11 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. +# TODO: This test is likely worthless. Confirm and remove if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 - namespace import -force ::tcltest::* } -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -testConstraint testbytestring [llength [info commands testbytestring]] - namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -35,9 +30,11 @@ namespace eval ::tcl::test::io { variable msg variable expected - ::tcltest::loadTestedCommands + loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] + package require tcltests + testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] testConstraint openpipe 1 testConstraint testfevent [llength [info commands testfevent]] diff --git a/tests/io.test b/tests/io.test index cc1d986..996e125 100644 --- a/tests/io.test +++ b/tests/io.test @@ -15,14 +15,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 - namespace import -force ::tcltest::* } -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -testConstraint testbytestring [llength [info commands testbytestring]] - namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -35,6 +29,11 @@ namespace eval ::tcl::test::io { variable msg variable expected + loadTestedCommands + catch [list package require -exact Tcltest [info patchlevel]] + package require tcltests + +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] testConstraint openpipe 1 testConstraint testfevent [llength [info commands testfevent]] diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 2105279..74d1b40 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -1,7 +1,7 @@ #! /usr/bin/env tclsh package require tcltest 2.2 -namespace import -force ::tcltest::* +namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] testConstraint fcopy [llength [info commands fcopy]] -- cgit v0.12 From 9da2aebeaebd1ccbfa806b0c3550774abc7ad778 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 26 Jun 2018 17:00:29 +0000 Subject: Use a thread exit handler, and not a custom exit proc for package cleanup. --- generic/tclInt.h | 1 - generic/tclTest.c | 16 ---------------- generic/tclThreadTest.c | 17 ++++++++--------- 3 files changed, 8 insertions(+), 26 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 64004d8..0a3285f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4532,7 +4532,6 @@ MODULE_SCOPE Tcl_PackageInitProc TclObjTest_Init; MODULE_SCOPE Tcl_PackageInitProc TclThread_Init; MODULE_SCOPE Tcl_PackageInitProc Procbodytest_Init; MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; -MODULE_SCOPE void TclThreadTestFinalize(); /* *---------------------------------------------------------------- diff --git a/generic/tclTest.c b/generic/tclTest.c index 952f384..45cca5a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -52,7 +52,6 @@ #define TCL_STORAGE_CLASS DLLEXPORT EXTERN int Tcltest_Init(Tcl_Interp *interp); EXTERN int Tcltest_SafeInit(Tcl_Interp *interp); -EXTERN TCL_NORETURN void Tcltest_Exit(ClientData clientData); /* * Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect @@ -564,10 +563,6 @@ Tcltest_Init( return TCL_ERROR; } - - /* Finalizer */ - Tcl_SetExitProc(Tcltest_Exit); - /* * Create additional commands and math functions for testing Tcl. */ @@ -795,17 +790,6 @@ Tcltest_SafeInit( return Procbodytest_SafeInit(interp); } -TCL_NORETURN void Tcltest_Exit( - ClientData clientData -) { - int status = PTR2INT(clientData); - Tcl_Finalize(); - TclThreadTestFinalize(); - TclpExit(status); - Tcl_Panic("OS exit failed!"); -} - - /* *---------------------------------------------------------------------- * diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 92cfa13..35b3fc3 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -174,15 +174,6 @@ TclThread_Init( Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL); return TCL_OK; } - - -void TclThreadTestFinalize() { - if (errorProcString != NULL) { - ckfree(errorProcString); - errorProcString= NULL; - } - return; -} /* *---------------------------------------------------------------------- @@ -1166,6 +1157,14 @@ ThreadExitProc( Tcl_MutexLock(&threadMutex); + if (self == errorThreadId) { + if (errorProcString) { /* Extra safety */ + ckfree(errorProcString); + errorProcString = NULL; + } + errorThreadId = 0; + } + if (threadEvalScript) { ckfree(threadEvalScript); threadEvalScript = NULL; -- cgit v0.12 From 7a9d97826e2df30fcf48191281dede724a99ff43 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 26 Jun 2018 19:45:22 +0000 Subject: Since Tcl is always compiled with -DUNICODE -D_UNICODE (on Windows) and we know TCL_UTF_MAX>=4, we can simplify things. No change in functionality. --- generic/tclIOSock.c | 2 +- win/tclWinConsole.c | 4 ---- win/tclWinDde.c | 31 -------------------------- win/tclWinError.c | 2 +- win/tclWinFile.c | 18 ++------------- win/tclWinInit.c | 64 ++++++++--------------------------------------------- win/tclWinPanic.c | 2 +- win/tclWinPipe.c | 2 +- win/tclWinReg.c | 7 ------ 9 files changed, 15 insertions(+), 117 deletions(-) diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 6abfa60..12e2900 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -11,7 +11,7 @@ #include "tclInt.h" -#if defined(_WIN32) && defined(UNICODE) +#if defined(_WIN32) /* * On Windows, we need to do proper Unicode->UTF-8 conversion. */ diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 92643cf..f8b67a3 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -1360,11 +1360,7 @@ TclWinOpenConsoleChannel( Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); -#ifdef UNICODE Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode"); -#else - Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding); -#endif return infoPtr->channel; } diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 381db65..52bcd42 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -18,15 +18,6 @@ #include #include -#ifndef UNICODE -# undef CP_WINUNICODE -# define CP_WINUNICODE CP_WINANSI -# undef Tcl_WinTCharToUtf -# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) -# undef Tcl_WinUtfToTChar -# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) -#endif - #if !defined(NDEBUG) /* test POKE server Implemented for debug mode only */ # undef CBF_FAIL_POKES @@ -1432,11 +1423,7 @@ DdeObjCmd( Initialize(); if (firstArg != 1) { -#ifdef UNICODE serviceName = Tcl_GetUnicodeFromObj(objv[firstArg], &length); -#else - serviceName = Tcl_GetStringFromObj(objv[firstArg], &length); -#endif } else { length = 0; } @@ -1449,11 +1436,7 @@ DdeObjCmd( } if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { -#ifdef UNICODE topicName = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 1], &length); -#else - topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length); -#endif if (length == 0) { topicName = NULL; } else { @@ -1467,11 +1450,7 @@ DdeObjCmd( serviceName = DdeSetServerName(interp, serviceName, flags, handlerPtr); if (serviceName != NULL) { -#ifdef UNICODE Tcl_SetObjResult(interp, Tcl_NewUnicodeObj((Tcl_UniChar *) serviceName, -1)); -#else - Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1)); -#endif } else { Tcl_ResetResult(interp); } @@ -1530,13 +1509,8 @@ DdeObjCmd( break; } case DDE_REQUEST: { -#ifdef UNICODE const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], &length); -#else - const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], - &length); -#endif if (length == 0) { Tcl_SetObjResult(interp, @@ -1590,13 +1564,8 @@ DdeObjCmd( break; } case DDE_POKE: { -#ifdef UNICODE const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], &length); -#else - const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], - &length); -#endif BYTE *dataString; if (length == 0) { diff --git a/win/tclWinError.c b/win/tclWinError.c index 5d4423b..bce81fa 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -391,7 +391,7 @@ tclWinDebugPanic( if (IsDebuggerPresent()) { WCHAR msgString[TCL_MAX_WARN_LEN]; - char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX]; + char buf[TCL_MAX_WARN_LEN * 3]; vsnprintf(buf, sizeof(buf), format, argList); msgString[TCL_MAX_WARN_LEN-1] = L'\0'; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 0595e6c..f1e4cc9 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -567,7 +567,6 @@ WinReadLinkDirectory( */ offset = 0; -#ifdef UNICODE if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == L'\\') { /* * Check whether this is a mounted volume. @@ -629,7 +628,6 @@ WinReadLinkDirectory( offset = 4; } } -#endif /* UNICODE */ Tcl_WinTCharToUtf((const TCHAR *) reparseBuffer->MountPointReparseBuffer.PathBuffer, @@ -800,7 +798,7 @@ tclWinDebugPanic( { #define TCL_MAX_WARN_LEN 1024 va_list argList; - char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX]; + char buf[TCL_MAX_WARN_LEN * 3]; WCHAR msgString[TCL_MAX_WARN_LEN]; va_start(argList, format); @@ -859,7 +857,7 @@ TclpFindExecutable( * ignore. */ { WCHAR wName[MAX_PATH]; - char name[MAX_PATH * TCL_UTF_MAX]; + char name[MAX_PATH * 3]; /* * Under Windows we ignore argv0, and return the path for the file used to @@ -871,17 +869,7 @@ TclpFindExecutable( Tcl_SetPanicProc(tclWinDebugPanic); } -#ifdef UNICODE GetModuleFileNameW(NULL, wName, MAX_PATH); -#else - GetModuleFileNameA(NULL, name, sizeof(name)); - - /* - * Convert to WCHAR to get out of ANSI codepage - */ - - MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH); -#endif WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); TclWinNoBackslash(name); TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL); @@ -1646,7 +1634,6 @@ NativeAccess( * what permissions the OS has set for a file. */ -#ifdef UNICODE { SECURITY_DESCRIPTOR *sdPtr = NULL; unsigned long size; @@ -1809,7 +1796,6 @@ NativeAccess( } } -#endif /* !UNICODE */ return 0; } diff --git a/win/tclWinInit.c b/win/tclWinInit.c index f04069b..2ce19ce 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -107,12 +107,6 @@ static ProcessGlobalValue sourceLibraryDir = {0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL}; static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib); - -#if TCL_UTF_MAX < 4 -static void ToUtf(const WCHAR *wSrc, char *dst); -#else -#define ToUtf(wSrc, dst) WideCharToMultiByte(CP_UTF8, 0, wSrc, -1, dst, MAX_PATH * TCL_UTF_MAX, NULL, NULL) -#endif /* *--------------------------------------------------------------------------- @@ -262,7 +256,7 @@ AppendEnvironment( { int pathc; WCHAR wBuf[MAX_PATH]; - char buf[MAX_PATH * TCL_UTF_MAX]; + char buf[MAX_PATH * 3]; Tcl_Obj *objPtr; Tcl_DString ds; const char **pathv; @@ -291,12 +285,8 @@ AppendEnvironment( * this is a unicode string. */ - if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) { - buf[0] = '\0'; - GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH); - } else { - ToUtf(wBuf, buf); - } + GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH); + WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL); if (buf[0] != '\0') { objPtr = Tcl_NewStringObj(buf, -1); @@ -355,14 +345,11 @@ InitializeDefaultLibraryDir( { HMODULE hModule = TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; - char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; + char name[(MAX_PATH + LIBRARY_SIZE) * 3]; char *end, *p; - if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { - GetModuleFileNameA(hModule, name, MAX_PATH); - } else { - ToUtf(wName, name); - } + GetModuleFileNameW(hModule, wName, MAX_PATH); + WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, MAX_PATH * 3, NULL, NULL); end = strrchr(name, '\\'); *end = '\0'; @@ -406,14 +393,11 @@ InitializeSourceLibraryDir( { HMODULE hModule = TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; - char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; + char name[(MAX_PATH + LIBRARY_SIZE) * 3]; char *end, *p; - if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { - GetModuleFileNameA(hModule, name, MAX_PATH); - } else { - ToUtf(wName, name); - } + GetModuleFileNameW(hModule, wName, MAX_PATH); + WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, MAX_PATH * 3, NULL, NULL); end = strrchr(name, '\\'); *end = '\0'; @@ -434,36 +418,6 @@ InitializeSourceLibraryDir( /* *--------------------------------------------------------------------------- * - * ToUtf -- - * - * Convert a wchar string to a UTF string. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -#if TCL_UTF_MAX < 4 -static void -ToUtf( - const WCHAR *wSrc, - char *dst) -{ - while (*wSrc != '\0') { - dst += Tcl_UniCharToUtf(*wSrc, dst); - wSrc++; - } - *dst = '\0'; -} -#endif - -/* - *--------------------------------------------------------------------------- - * * TclpSetInitialEncodings -- * * Based on the locale, determine the encoding of the operating system diff --git a/win/tclWinPanic.c b/win/tclWinPanic.c index d23ffcd..a71f506 100644 --- a/win/tclWinPanic.c +++ b/win/tclWinPanic.c @@ -35,7 +35,7 @@ Tcl_ConsolePanic( #define TCL_MAX_WARN_LEN 26000 va_list argList; WCHAR msgString[TCL_MAX_WARN_LEN]; - char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX]; + char buf[TCL_MAX_WARN_LEN * 3]; HANDLE handle = GetStdHandle(STD_ERROR_HANDLE); DWORD dummy; diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index a357412..2155a8d 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -941,7 +941,7 @@ TclpCreateProcess( PROCESS_INFORMATION procInfo; SECURITY_ATTRIBUTES secAtts; HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; - char execPath[MAX_PATH * TCL_UTF_MAX]; + char execPath[MAX_PATH * 3]; WinFile *filePtr; PipeInit(); diff --git a/win/tclWinReg.c b/win/tclWinReg.c index de48b9b..95ab499 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -22,13 +22,6 @@ #endif #include -#ifndef UNICODE -# undef Tcl_WinTCharToUtf -# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) -# undef Tcl_WinUtfToTChar -# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) -#endif /* !UNICODE */ - /* * Ensure that we can say which registry is being accessed. */ -- cgit v0.12 From da7eafc83b4c8797c24505fd5f2c629821c20c00 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Jul 2018 20:18:39 +0000 Subject: Micro-optimization in Tcl_GetString() and Tcl_GetStringFromObj() --- generic/tclObj.c | 69 ++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 45 insertions(+), 24 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index f93f583..16ef7c3 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1632,32 +1632,30 @@ Tcl_GetString( register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be returned. */ { - if (objPtr->bytes != NULL) { - return objPtr->bytes; - } - - /* - * Note we do not check for objPtr->typePtr == NULL. An invariant of - * a properly maintained Tcl_Obj is that at least one of objPtr->bytes - * and objPtr->typePtr must not be NULL. If broken extensions fail to - * maintain that invariant, we can crash here. - */ - - if (objPtr->typePtr->updateStringProc == NULL) { + if (objPtr->bytes == NULL) { /* - * Those Tcl_ObjTypes which choose not to define an updateStringProc - * must be written in such a way that (objPtr->bytes) never becomes - * NULL. This panic was added in Tcl 8.1. + * Note we do not check for objPtr->typePtr == NULL. An invariant + * of a properly maintained Tcl_Obj is that at least one of + * objPtr->bytes and objPtr->typePtr must not be NULL. If broken + * extensions fail to maintain that invariant, we can crash here. */ - Tcl_Panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length < 0 - || objPtr->bytes[objPtr->length] != '\0') { - Tcl_Panic("UpdateStringProc for type '%s' " - "failed to create a valid string rep", objPtr->typePtr->name); + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an + * updateStringProc must be written in such a way that + * (objPtr->bytes) never becomes NULL. + */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } } return objPtr->bytes; } @@ -1693,8 +1691,31 @@ Tcl_GetStringFromObj( * rep's byte array length should * be stored. * If NULL, no length is stored. */ { - (void) TclGetString(objPtr); + if (objPtr->bytes == NULL) { + /* + * Note we do not check for objPtr->typePtr == NULL. An invariant + * of a properly maintained Tcl_Obj is that at least one of + * objPtr->bytes and objPtr->typePtr must not be NULL. If broken + * extensions fail to maintain that invariant, we can crash here. + */ + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an + * updateStringProc must be written in such a way that + * (objPtr->bytes) never becomes NULL. + */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } + } if (lengthPtr != NULL) { *lengthPtr = objPtr->length; } -- cgit v0.12 From 6982ae0ca7a42a53c0fbdf2fddf9296537b7bfa0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Jul 2018 20:20:28 +0000 Subject: Make Tcl_GetUnicode() a macro. Mark many other stub-entries which are no longer are in use (because they were converted to macros) as deprecated, since they will be removed in Tcl 9.0 --- generic/tcl.decls | 48 +++++++++---------- generic/tclDecls.h | 126 +++++++++++++++++++++++++++++-------------------- generic/tclStringObj.c | 3 ++ generic/tclStubInit.c | 2 + 4 files changed, 105 insertions(+), 74 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index da551bb..60effc4 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -104,7 +104,7 @@ declare 20 { declare 21 { int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line) } -declare 22 { +declare 22 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) } declare 23 { @@ -119,7 +119,7 @@ declare 25 { Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line) } -declare 26 { +declare 26 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line) } declare 27 { @@ -152,7 +152,7 @@ declare 35 { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } -declare 36 { +declare 36 {deprecated {No longer in use, changed to macro}} { int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr) } @@ -198,7 +198,7 @@ declare 48 { int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]) } -declare 49 { +declare 49 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewBooleanObj(int boolValue) } declare 50 { @@ -207,13 +207,13 @@ declare 50 { declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) } -declare 52 { +declare 52 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewIntObj(int intValue) } declare 53 { Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[]) } -declare 54 { +declare 54 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewLongObj(long longValue) } declare 55 { @@ -222,7 +222,7 @@ declare 55 { declare 56 { Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length) } -declare 57 { +declare 57 {deprecated {No longer in use, changed to macro}} { void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) } declare 58 { @@ -235,13 +235,13 @@ declare 59 { declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) } -declare 61 { +declare 61 {deprecated {No longer in use, changed to macro}} { void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) } declare 62 { void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]) } -declare 63 { +declare 63 {deprecated {No longer in use, changed to macro}} { void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) } declare 64 { @@ -250,10 +250,10 @@ declare 64 { declare 65 { void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length) } -declare 66 { +declare 66 {deprecated {No longer in use, changed to macro}} { void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) } -declare 67 { +declare 67 {deprecated {No longer in use, changed to macro}} { void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, int length) } @@ -472,7 +472,7 @@ declare 129 { declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } -declare 131 { +declare 131 {deprecated {No longer in use, changed to macro}} { int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 132 { @@ -624,7 +624,7 @@ declare 173 { declare 174 { const char *Tcl_GetStringResult(Tcl_Interp *interp) } -declare 175 { +declare 175 {deprecated {No longer in use, changed to macro}} { const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, int flags) } @@ -635,7 +635,7 @@ declare 176 { declare 177 { int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) } -declare 178 { +declare 178 {deprecated {No longer in use, changed to macro}} { int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 179 { @@ -834,7 +834,7 @@ declare 235 { declare 236 { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } -declare 237 { +declare 237 {deprecated {No longer in use, changed to macro}} { const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags) } @@ -869,7 +869,7 @@ declare 245 { declare 246 {deprecated {}} { int Tcl_TellOld(Tcl_Channel chan) } -declare 247 { +declare 247 {deprecated {No longer in use, changed to macro}} { int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } @@ -890,14 +890,14 @@ declare 251 { declare 252 { int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan) } -declare 253 { +declare 253 {deprecated {No longer in use, changed to macro}} { int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags) } declare 254 { int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } -declare 255 { +declare 255 {deprecated {No longer in use, changed to macro}} { void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } @@ -909,7 +909,7 @@ declare 256 { declare 257 { void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName) } -declare 258 { +declare 258 {deprecated {No longer in use, changed to macro}} { int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags) } @@ -920,7 +920,7 @@ declare 259 { declare 260 { int Tcl_VarEval(Tcl_Interp *interp, ...) } -declare 261 { +declare 261 {deprecated {No longer in use, changed to macro}} { ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) } @@ -955,7 +955,7 @@ declare 270 { const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, const char **termPtr) } -declare 271 { +declare 271 {deprecated {No longer in use, changed to macro}} { const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, const char *version, int exact) } @@ -964,12 +964,12 @@ declare 272 { const char *name, const char *version, int exact, void *clientDataPtr) } -declare 273 { +declare 273 {deprecated {No longer in use, changed to macro}} { int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, const char *version) } # TIP #268: The internally used new Require function is in slot 573. -declare 274 { +declare 274 {deprecated {No longer in use, changed to macro}} { const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact) } @@ -1350,7 +1350,7 @@ declare 380 { declare 381 { int Tcl_GetUniChar(Tcl_Obj *objPtr, int index) } -declare 382 { +declare 382 {deprecated {No longer in use, changed to macro}} { Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) } declare 383 { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 592d945..3f7f343 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -119,7 +119,8 @@ EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line); /* 22 */ -EXTERN Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file, +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file, int line); /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, @@ -131,7 +132,8 @@ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line); /* 26 */ -EXTERN Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file, +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file, int line); /* 27 */ EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line); @@ -158,7 +160,8 @@ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 36 */ -EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 37 */ @@ -198,24 +201,28 @@ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 49 */ -EXTERN Tcl_Obj * Tcl_NewBooleanObj(int boolValue); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewBooleanObj(int boolValue); /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, int length); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* 52 */ -EXTERN Tcl_Obj * Tcl_NewIntObj(int intValue); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewIntObj(int intValue); /* 53 */ EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]); /* 54 */ -EXTERN Tcl_Obj * Tcl_NewLongObj(long longValue); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewLongObj(long longValue); /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj(void); /* 56 */ EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length); /* 57 */ -EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue); /* 58 */ EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length); /* 59 */ @@ -224,22 +231,26 @@ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* 61 */ -EXTERN void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); /* 62 */ EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 63 */ -EXTERN void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue); /* 64 */ EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, int length); /* 65 */ EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length); /* 66 */ -EXTERN void Tcl_AddErrorInfo(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message); /* 67 */ -EXTERN void Tcl_AddObjErrorInfo(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, int length); /* 68 */ EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp); @@ -422,7 +433,8 @@ EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script); EXTERN int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); /* 131 */ -EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 132 */ EXTERN void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc); @@ -549,7 +561,8 @@ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); /* 174 */ EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp); /* 175 */ -EXTERN const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName, +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName, int flags); /* 176 */ EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, @@ -558,7 +571,8 @@ EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, EXTERN int Tcl_GlobalEval(Tcl_Interp *interp, const char *command); /* 178 */ -EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 179 */ EXTERN int Tcl_HideCommand(Tcl_Interp *interp, @@ -713,7 +727,8 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp, /* 236 */ EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type); /* 237 */ -EXTERN const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName, +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 238 */ EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1, @@ -743,7 +758,8 @@ EXTERN int Tcl_StringMatch(const char *str, const char *pattern); TCL_DEPRECATED("") int Tcl_TellOld(Tcl_Channel chan); /* 247 */ -EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ @@ -764,13 +780,15 @@ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp, EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan); /* 253 */ -EXTERN int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags); /* 254 */ EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 255 */ -EXTERN void Tcl_UntraceVar(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); @@ -783,7 +801,8 @@ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp, EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName); /* 258 */ -EXTERN int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 259 */ @@ -793,7 +812,8 @@ EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, /* 260 */ EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...); /* 261 */ -EXTERN ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); @@ -825,17 +845,20 @@ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, const char **termPtr); /* 271 */ -EXTERN const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name, +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name, const char *version, int exact); /* 272 */ EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 273 */ -EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, const char *version); /* 274 */ -EXTERN const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name, +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact); /* 275 */ TCL_DEPRECATED("see TIP #422") @@ -1125,7 +1148,8 @@ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, int index); /* 382 */ -EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ @@ -1887,11 +1911,11 @@ typedef struct TclStubs { void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ - Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */ Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ - Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */ Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ @@ -1901,7 +1925,7 @@ typedef struct TclStubs { unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ - int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */ int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */ int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */ @@ -1914,25 +1938,25 @@ typedef struct TclStubs { int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */ int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ - Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */ Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ - Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ - Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */ - void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */ unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */ void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ - void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ - void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */ void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */ void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */ - void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */ - void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */ void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */ void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */ void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */ @@ -1996,7 +2020,7 @@ typedef struct TclStubs { const char * (*tcl_ErrnoMsg) (int err); /* 128 */ int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ - int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */ int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */ @@ -2048,10 +2072,10 @@ typedef struct TclStubs { Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ - const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */ - int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */ int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */ int (*tcl_Init) (Tcl_Interp *interp); /* 180 */ void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */ @@ -2110,7 +2134,7 @@ typedef struct TclStubs { void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */ void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */ void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */ - const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ const char * (*tcl_SignalId) (int sig); /* 239 */ const char * (*tcl_SignalMsg) (int sig); /* 240 */ @@ -2120,21 +2144,21 @@ typedef struct TclStubs { void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ - int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */ - int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */ - void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */ void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */ void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */ - int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */ int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */ - ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */ ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */ int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ @@ -2144,10 +2168,10 @@ typedef struct TclStubs { TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */ - const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ - int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ - const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ @@ -2255,7 +2279,7 @@ typedef struct TclStubs { void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ - Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ @@ -3974,9 +3998,11 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_DbNewLongObj #define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line) #undef Tcl_SetIntObj -#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj(objPtr, (int)(value)) +#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value)) #undef Tcl_SetLongObj -#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj(objPtr, (long)(value)) +#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value)) +#undef Tcl_GetUnicode +#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL) /* * Deprecated Tcl procedures: diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index bed23a0..3bb6112 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -606,6 +606,8 @@ Tcl_GetUniChar( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED +#undef Tcl_GetUnicode Tcl_UniChar * Tcl_GetUnicode( Tcl_Obj *objPtr) /* The object to find the unicode string @@ -613,6 +615,7 @@ Tcl_GetUnicode( { return Tcl_GetUnicodeFromObj(objPtr, NULL); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7ce0758..2bd4de9 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -34,6 +34,7 @@ #undef Tcl_DbNewLongObj #undef Tcl_NewObj #undef Tcl_NewStringObj +#undef Tcl_GetUnicode #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef Tcl_FindHashEntry @@ -402,6 +403,7 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig # define TclpGmtime 0 # define TclpLocaltime_unix 0 # define TclpGmtime_unix 0 +# define Tcl_GetUnicode 0 #else /* TCL_NO_DEPRECATED */ # define Tcl_SeekOld seekOld # define Tcl_TellOld tellOld -- cgit v0.12 From 367ce9ad482394057c4d895abb67ffe50f1ac015 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 5 Jul 2018 19:39:19 +0000 Subject: tclDictObj.c:366: warning: dereferencing type-punned pointer will break strict-aliasing rules Prevent this warning, which gcc 4.4 (a.o.) gives on this construct. void pointers work well already in whatever assignment. --- generic/tclDictObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 2eff1ff..32234a3 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -153,7 +153,7 @@ typedef struct Dict { * must be assignable as well as readable. */ -#define DICT(dictObj) (*((Dict **)&(dictObj)->internalRep.twoPtrValue.ptr1)) +#define DICT(dictObj) ((dictObj)->internalRep.twoPtrValue.ptr1) /* * The structure below defines the dictionary object type by means of -- cgit v0.12 From 51aecf205dab16072098f2f5119d6b9026f73e65 Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 9 Jul 2018 17:18:07 +0000 Subject: closes [270f78ca95b642fb]: fix the race condition for `file mkdir` if some worker deletes directory immediately after the succeded create inside 3rd worker. --- generic/tclFCmd.c | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 1363829..da15262 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -243,9 +243,13 @@ TclFileMakeDirsCmd( break; } for (j = 0; j < pobjc; j++) { + int errCount = 2; + target = Tcl_FSJoinPath(split, j + 1); Tcl_IncrRefCount(target); + createDir: + /* * Call Tcl_FSStat() so that if target is a symlink that points to * a directory we will create subdirectories in that directory. @@ -273,24 +277,24 @@ TclFileMakeDirsCmd( */ if (errno == EEXIST) { - if ((Tcl_FSStat(target, &statBuf) == 0) - && S_ISDIR(statBuf.st_mode)) { - /* - * It is a directory that wasn't there before, so keep - * going without error. - */ - - Tcl_ResetResult(interp); - } else { - errfile = target; - goto done; + /* Be aware other workers could delete it immediately after + * creation, so give this worker still one chance (repeat once), + * see [270f78ca95] for description of the race-condition. + * Don't repeat the create always (to avoid endless loop). */ + if (--errCount > 0) { + goto createDir; } - } else { - errfile = target; - goto done; + /* Already tried, with delete in-between directly after + * creation, so just continue (assume created successful). */ + goto nextPart; } + + /* return with error */ + errfile = target; + goto done; } + nextPart: /* * Forget about this sub-path. */ -- cgit v0.12 From 87e508c590246b8559502d220a5e2c7d618ef338 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 10 Jul 2018 08:19:08 +0000 Subject: amend to [1830f9f520e2abdd], fixed package.test if built without test - avoids test file error: package "Tcltest" isn't loaded statically --- tests/package.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/package.test b/tests/package.test index 2843701..69d9ddb 100644 --- a/tests/package.test +++ b/tests/package.test @@ -23,7 +23,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # Do all this in a slave interp to avoid garbaging the package list set i [interp create] tcltest::loadIntoSlaveInterpreter $i {*}$argv -load {} Tcltest $i +catch [list load {} Tcltest $i] interp eval $i { namespace import -force ::tcltest::* #package forget {*}[package names] -- cgit v0.12 From 885a163b3c4ec29beb88d95cf6ff60687aa25223 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 12 Jul 2018 14:17:57 +0000 Subject: win: closes [3f7af0e21e13f1f5] - avoid "permissions denied" by `file delete`, if file stat (TclpObjStat) used internally in other worker, for example by usage of `file mkdir` etc. --- win/tclWinFile.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 1536bc0..cbd8814 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -2093,7 +2093,8 @@ NativeStat( */ fileHandle = (tclWinProcs->createFileProc)(nativePath, GENERIC_READ, - FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, + FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, + NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL); if (fileHandle != INVALID_HANDLE_VALUE) { -- cgit v0.12 From 4a3f32b84a736f51135c5321007ba7c7fa8ed47e Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 16 Jul 2018 13:59:29 +0000 Subject: win: fixed test-cases (see [525ccacaef]) running under windows outside of temp-folder --- tests/cmdAH.test | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index e334dff..0377064 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -1040,7 +1040,7 @@ test cmdAH-20.7.1 { Tcl_FileObjCmd: atime (built-in Windows names with dir path and extension) } -constraints {win} -body { file atime [file join [temporaryDirectory] CON.txt] -} -result "could not get access time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error +} -match regexp -result {could not (?:get access time|read)} -returnCodes error if {[testConstraint unix] && [file exists /tmp]} { removeFile touch.me /tmp @@ -1281,7 +1281,7 @@ test cmdAH-24.14.1 { Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension) } -constraints {win} -body { file mtime [file join [temporaryDirectory] CON.txt] -} -result "could not get modification time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error +} -match regexp -result {could not (?:get modification time|read)} -returnCodes error # owned test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body { @@ -1345,7 +1345,12 @@ test cmdAH-27.4 { test cmdAH-27.4.1 { Tcl_FileObjCmd: size (built-in Windows names with dir path and extension) } -constraints {win} -body { - file size [file join [temporaryDirectory] con.txt] + try { + set res [file size [file join [temporaryDirectory] con.txt]] + } trap {POSIX ENOENT} {} { + set res 0 + } + set res } -result 0 catch {testsetplatform $platform} @@ -1447,8 +1452,13 @@ test cmdAH-28.13 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {w test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup { unset -nocomplain stat } -body { - file stat [file join [temporaryDirectory] CON.txt] stat - lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)} + try { + file stat [file join [temporaryDirectory] CON.txt] stat + set res [lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)}] + } trap {POSIX ENOENT} {} { + set res {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} + } + set res } -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} unset -nocomplain stat @@ -1498,7 +1508,12 @@ test cmdAH-29.6 { test cmdAH-29.6.1 { Tcl_FileObjCmd: type (built-in Windows names, with dir path and extension) } -constraints {win} -body { - file type [file join [temporaryDirectory] CON.txt] + try { + set res [file type [file join [temporaryDirectory] CON.txt]] + } trap {POSIX ENOENT} {} { + set res {characterSpecial} + } + set res } -result "characterSpecial" # Error conditions -- cgit v0.12 From 7fb72851e8562eb2e68ec94d10e1b88fb40b863e Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 20 Jul 2018 15:54:11 +0000 Subject: win: fixes x64-build within gcc-compile runtime env for (mingw64, etc): "$do64bit" may be "amd64|x64|yes", so it could find & copy wrong zlib.dll. --- win/configure | 2 +- win/configure.in | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/win/configure b/win/configure index be38dc3..03ad68a 100755 --- a/win/configure +++ b/win/configure @@ -4372,7 +4372,7 @@ if test "$tcl_ok" = "yes"; then ZLIB_DLL_FILE=\${ZLIB_DLL_FILE} - if test "$do64bit" = "yes"; then + if test "$do64bit" != "no"; then if test "$GCC" == "yes"; then diff --git a/win/configure.in b/win/configure.in index 5fc17a3..82351f1 100644 --- a/win/configure.in +++ b/win/configure.in @@ -128,7 +128,7 @@ AS_IF([test "${enable_shared+set}" = "set"], [ ]) AS_IF([test "$tcl_ok" = "yes"], [ AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}]) - AS_IF([test "$do64bit" = "yes"], [ + AS_IF([test "$do64bit" != "no"], [ AS_IF([test "$GCC" == "yes"],[ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a]) ], [ -- cgit v0.12 From d00a212e82abf97d0bc54b040a3d0a153980d537 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 20 Jul 2018 15:58:56 +0000 Subject: win: avoids warning by x64-build in function 'TclWinCPUID' - pointer targets in passing argument 1 of '__cpuid' differ in signedness [-Wpointer-sign] (int* vs unsigned int*) --- win/tclWin32Dll.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 6c973df..a85dd0c 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -640,7 +640,7 @@ TclWinCPUID( #if defined(HAVE_INTRIN_H) && defined(_WIN64) - __cpuid(regsPtr, index); + __cpuid((int *)regsPtr, index); status = TCL_OK; #elif defined(__GNUC__) -- cgit v0.12 From 814c867db47078736aae2dbe18cbc4191fe90aee Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 21 Jul 2018 18:45:09 +0000 Subject: Add a note in the 'clock' man page about the interpretation of impossible values on [clock scan] --- doc/clock.n | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/doc/clock.n b/doc/clock.n index 889a5da..6efa722 100644 --- a/doc/clock.n +++ b/doc/clock.n @@ -453,6 +453,19 @@ If this situation occurs, the first occurrence of the time is chosen. (For this reason, it is wise to have the input string contain the time zone when converting local times. This caveat does not apply to UTC times.) +.PP +If the interpretation of the groups yields an impossible time because +a field is out of range, enough of that field's unit will be added to +or subtracted from the time to bring it in range. Thus, if attempting to +scan or format day 0 of the month, one day will be subtracted from day +1 of the month, yielding the last day of the previous month. +.PP +If the interpretation of the groups yields an impossible time because +a Daylight Saving Time change skips over that time, or an ambiguous +time because a Daylight Saving Time change skips back so that the clock +observes the given time twice, and no time zone specifier (\fB%z\fR +or \fB%Z\fR) is present in the format, the time is interpreted as +if the clock had not changed. .SH "FORMAT GROUPS" .PP The following format groups are recognized by the \fBclock scan\fR and -- cgit v0.12 From 772d2da10b02fc06220a92d5f9d4f33b752a9553 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 22 Jul 2018 20:44:16 +0000 Subject: Fix for [ba921a8d98e02a96] - concatenating binary array with empty string yields the empty string. --- generic/tclStringObj.c | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 3bb6112..2cda2c4 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3065,24 +3065,22 @@ TclStringCat( * Result will be pure byte array. Pre-size it */ + int numBytes; ov = objv; oc = objc; do { Tcl_Obj *objPtr = *ov++; - if (objPtr->bytes == NULL) { - int numBytes; + Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ - Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ - if (numBytes) { - last = objc - oc; - if (length == 0) { - first = last; - } else if (numBytes > INT_MAX - length) { - goto overflow; - } - length += numBytes; + if (numBytes) { + last = objc - oc; + if (length == 0) { + first = last; + } else if (numBytes > INT_MAX - length) { + goto overflow; } + length += numBytes; } } while (--oc); } else if (allowUniChar && requestUniChar) { -- cgit v0.12 From 164a7f04c03e56a310d9386fd8ddbd6319c0c788 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 26 Jul 2018 15:51:28 +0000 Subject: New test for [Bug ba921a8d98]. --- tests/string.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/string.test b/tests/string.test index 868fc25..3f5fd81 100644 --- a/tests/string.test +++ b/tests/string.test @@ -2015,6 +2015,9 @@ test string-29.4 {string cat, many args} { list $r1 $r2 } {0 0} +test string-30.1 {[Bug ba921a8d98]} { + string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data] +} hellohello # cleanup -- cgit v0.12 From 7e727bed70653d181a190d921ea951707ad4078a Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 26 Jul 2018 15:57:38 +0000 Subject: closes [d051b77fc18d7340]: fixed segfault by integer overflow (if width by format like "%4000000000g" overflows to negative values by scan of length) --- generic/tclStringObj.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 996be77..462ef04 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1938,6 +1938,10 @@ Tcl_AppendFormatToObj( width = 0; if (isdigit(UCHAR(ch))) { width = strtoul(format, &end, 10); + if (width < 0) { + msg = overflow; + goto errorMsg; + } format = end; step = Tcl_UtfToUniChar(format, &ch); } else if (ch == '*') { -- cgit v0.12 From c7cdc550c4e27c7ab0e3d4537cff99167b4509fd Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 26 Jul 2018 16:46:47 +0000 Subject: test cases added to cover width overflow by format (should cause limit exceeded) --- tests/format.test | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/tests/format.test b/tests/format.test index d43b7eb..5797f2b 100644 --- a/tests/format.test +++ b/tests/format.test @@ -565,6 +565,20 @@ test format-19.3 {Bug 2830354} { string length [format %340f 0] } 340 +test format-19.4.1 {Bug d498578df4: width overflow should cause limit exceeded} \ +-constraints {longIs32bit} -body { + # in case of overflow into negative, it produces width -2 (and limit exceeded), + # in case of width will be unsigned, it will be outside limit (2GB for 32bit)... + # and it don't throw an error in case the bug is not fixed (and probably no segfault). + format %[expr {0xffffffff - 1}]g 0 +} -returnCodes error -result "max size for a Tcl value exceeded" + +test format-19.4.2 {Bug d498578df4: width overflow should cause limit exceeded} -body { + # limit should exceeds in any case, + # and it don't throw an error in case the bug is not fixed (and probably no segfault). + format %[expr {0xffffffffffffffff - 1}]g 0 +} -returnCodes error -result "max size for a Tcl value exceeded" + # cleanup catch {unset a} catch {unset b} -- cgit v0.12 From 2133e40e589348c5df1b721c1d0e0ac2f2385505 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 26 Jul 2018 18:07:34 +0000 Subject: amend to [d498578df4], still one test for [Bug ba921a8d98] with inplace by subst inside string (compiled as "strcat" instruction) --- tests/string.test | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tests/string.test b/tests/string.test index 3f5fd81..8fc5b0e 100644 --- a/tests/string.test +++ b/tests/string.test @@ -2015,9 +2015,12 @@ test string-29.4 {string cat, many args} { list $r1 $r2 } {0 0} -test string-30.1 {[Bug ba921a8d98]} { +test string-30.1.1 {[Bug ba921a8d98]: string cat} { string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data] } hellohello +test string-30.1.2 {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} { + set x "[set data [binary format a* hello]][encoding convertto $data][unset data]" +} hellohello # cleanup -- cgit v0.12 From 590288982511400f0dd0f244fb753b01a8bae140 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 26 Jul 2018 18:56:41 +0000 Subject: amend after merge: 8.6th provide additionally an error-code (so missing `errCode = "OVERFLOW"`) --- generic/tclStringObj.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 3139be4..493378c 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1878,6 +1878,7 @@ Tcl_AppendFormatToObj( width = strtoul(format, &end, 10); if (width < 0) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } format = end; -- cgit v0.12 From c1ae69114bfdfe97b4c12ad727e4d5accc0df85f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 31 Jul 2018 19:49:51 +0000 Subject: Remove some actually dead code --- generic/tcl.decls | 4 +++ generic/tclCmdAH.c | 57 ------------------------------------------ generic/tclIOUtil.c | 29 +++------------------- generic/tclInt.h | 2 +- generic/tclOODefineCmds.c | 63 ----------------------------------------------- 5 files changed, 9 insertions(+), 146 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index db1f892..b62cd28 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2370,6 +2370,10 @@ export { void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc) } export { + void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, + Tcl_Interp *interp) +} +export { const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version, int exact) } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index a48dfc7..7e117af 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -513,63 +513,6 @@ Tcl_ContinueObjCmd( } /* - *---------------------------------------------------------------------- - * - * Tcl_EncodingObjCmd -- - * - * This command manipulates encodings. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_EncodingObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int index; - - static const char *const optionStrings[] = { - "convertfrom", "convertto", "dirs", "names", "system", - NULL - }; - enum options { - ENC_CONVERTFROM, ENC_CONVERTTO, ENC_DIRS, ENC_NAMES, ENC_SYSTEM - }; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum options) index) { - case ENC_CONVERTTO: - return EncodingConverttoObjCmd(dummy, interp, objc, objv); - case ENC_CONVERTFROM: - return EncodingConvertfromObjCmd(dummy, interp, objc, objv); - case ENC_DIRS: - return EncodingDirsObjCmd(dummy, interp, objc, objv); - case ENC_NAMES: - return EncodingNamesObjCmd(dummy, interp, objc, objv); - case ENC_SYSTEM: - return EncodingSystemObjCmd(dummy, interp, objc, objv); - } - return TCL_OK; -} - -/* *----------------------------------------------------------------------------- * * TclInitEncodingCmd -- diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 19620e7..27acbbc 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -139,7 +139,6 @@ Tcl_FSRenameFileProc TclpObjRenameFile; Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; -Tcl_FSUnloadFileProc TclpUnloadFile; Tcl_FSLinkProc TclpObjLink; Tcl_FSListVolumesProc TclpObjListVolumes; @@ -3159,8 +3158,8 @@ Tcl_FSLoadFile( * present and set to true (any integer > 0) then the unlink is skipped. */ -int -TclSkipUnlink (Tcl_Obj* shlibFile) +static int +skipUnlink (Tcl_Obj* shlibFile) { /* Order of testing: * 1. On hpux we generally want to skip unlink in general @@ -3414,7 +3413,7 @@ Tcl_LoadFile( */ if ( - !TclSkipUnlink (copyToPtr) && + !skipUnlink (copyToPtr) && (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { Tcl_DecrRefCount(copyToPtr); @@ -3683,30 +3682,10 @@ Tcl_FSUnloadFile( } return TCL_ERROR; } - TclpUnloadFile(handle); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * Unloads a library given its handle - * - * This function was once filesystem-specific, but has been made portable by - * having TclpDlopen return a structure that includes procedure pointers. - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile( - Tcl_LoadHandle handle) -{ if (handle->unloadFileProcPtr != NULL) { handle->unloadFileProcPtr(handle); } + return TCL_OK; } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 0a3285f..432be7a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2934,7 +2934,7 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, int *objcPtr); -Tcl_Namespace * TclEnsureNamespace( +MODULE_SCOPE Tcl_Namespace * TclEnsureNamespace( Tcl_Interp *interp, Tcl_Namespace *namespacePtr); diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 648ad02..c924d2b 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1542,69 +1542,6 @@ TclOODefineMethodObjCmd( /* * ---------------------------------------------------------------------- * - * TclOODefineMixinObjCmd -- - * Implementation of the "mixin" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineMixinObjCmd( - ClientData clientData, - Tcl_Interp *interp, - const int objc, - Tcl_Obj *const *objv) -{ - int isInstanceMixin = (clientData != NULL); - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Class **mixins; - int i; - - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceMixin && !oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1)); - - for (i=1 ; iclassPtr, clsPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not mix a class into itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); - goto freeAndError; - } - mixins[i-1] = clsPtr; - } - - if (isInstanceMixin) { - TclOOObjectSetMixins(oPtr, objc-1, mixins); - } else { - TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins); - } - - TclStackFree(interp, mixins); - return TCL_OK; - - freeAndError: - TclStackFree(interp, mixins); - return TCL_ERROR; -} - -/* - * ---------------------------------------------------------------------- - * * TclOODefineRenameMethodObjCmd -- * Implementation of the "renamemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. -- cgit v0.12 From 40947c7d3eeb124dfd51a08dbdfc556a7a402bd6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 2 Aug 2018 22:37:00 +0000 Subject: Purge end-of-line spacing --- doc/NRE.3 | 2 +- doc/clock.n | 2 +- doc/process.n | 10 +++---- generic/tclAssembly.c | 2 +- generic/tclCmdIL.c | 4 +-- generic/tclCompCmdsGR.c | 4 +-- generic/tclCompCmdsSZ.c | 14 +++++----- generic/tclOOInt.h | 2 +- generic/tclPkg.c | 2 +- generic/tclProcess.c | 70 +++++++++++++++++++++++------------------------ generic/tclStringObj.c | 8 +++--- generic/tclUtil.c | 10 +++---- library/msgcat/msgcat.tcl | 8 +++--- tests/chanio.test | 4 +-- tests/env.test | 4 +-- tests/expr.test | 2 +- tests/msgcat.test | 24 ++++++++-------- tests/namespace.test | 2 +- tests/oo.test | 2 +- tests/package.test | 4 +-- tests/process.test | 4 +-- tests/string.test | 4 +-- tests/tcltest.test | 4 +-- unix/tclEpollNotfy.c | 2 +- win/makefile.vc | 2 +- win/nmakehlp.c | 12 ++++---- win/tclWinFile.c | 10 +++---- 27 files changed, 109 insertions(+), 109 deletions(-) diff --git a/doc/NRE.3 b/doc/NRE.3 index 6078a53..6024b6a 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -1,6 +1,6 @@ .\" .\" Copyright (c) 2008 by Kevin B. Kenny. -.\" Copyright (c) 2018 by Nathan Coulter. +.\" Copyright (c) 2018 by Nathan Coulter. .\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/doc/clock.n b/doc/clock.n index dd7115b..e8fb8f7 100644 --- a/doc/clock.n +++ b/doc/clock.n @@ -464,7 +464,7 @@ a Daylight Saving Time change skips over that time, or an ambiguous time because a Daylight Saving Time change skips back so that the clock observes the given time twice, and no time zone specifier (\fB%z\fR or \fB%Z\fR) is present in the format, the time is interpreted as -if the clock had not changed. +if the clock had not changed. .SH "FORMAT GROUPS" .PP The following format groups are recognized by the \fBclock scan\fR and diff --git a/doc/process.n b/doc/process.n index fbe307b..536b98b 100644 --- a/doc/process.n +++ b/doc/process.n @@ -24,11 +24,11 @@ Returns the list of subprocess PIDs. .TP \fB::tcl::process status\fR ?\fIswitches\fR? ?\fIpids\fR? . -Returns a dictionary mapping subprocess PIDs to their respective status. If -\fIpids\fR is specified as a list of PIDs then the command only returns the -status of the matching subprocesses if they exist, and raises an error +Returns a dictionary mapping subprocess PIDs to their respective status. If +\fIpids\fR is specified as a list of PIDs then the command only returns the +status of the matching subprocesses if they exist, and raises an error otherwise. For active processes, the status is an empty value. For terminated -processes, the status is a list with the following format: +processes, the status is a list with the following format: .QW "{code ?\fImsg errorCode\fR?}" , where: .RS @@ -45,7 +45,7 @@ is the human-readable error message, . uses the same format as the \fBerrorCode\fR global variable .RE -Note that \fBmsg\fR and \fBerrorCode\fR are only present for abnormally +Note that \fBmsg\fR and \fBerrorCode\fR are only present for abnormally terminated processes (i.e. those where \fBcode\fR is nonzero). Under the hood this command calls \fBTcl_WaitPid\fR with the \fBWNOHANG\fR flag set for non-blocking behavior, unless the \fB\-wait\fR switch is set (see below). diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 7368f97..6356a00 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -2253,7 +2253,7 @@ GetListIndexOperand( if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) { return TCL_ERROR; } - + /* Convert to an integer, advance to the next token and return. */ /* * NOTE: Indexing a list with an index before it yields the diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 3d058a4..3faaa5a 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3333,7 +3333,7 @@ Tcl_LsearchObjCmd( * sense in doing this when the match sense is inverted. */ - /* + /* * With -stride, lower, upper and i are kept as multiples of groupSize. */ @@ -4015,7 +4015,7 @@ Tcl_LsortObjCmd( /* * Do not shrink the actual memory block used; that doesn't * work with TclStackAlloc-allocated memory. [Bug 2918962] - * + * * TODO: Consider a pointer increment to replace this * array shift. */ diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 858a0c5..1209caf 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -34,7 +34,7 @@ static int IndexTailVarIfKnown(Tcl_Interp *interp, * TclGetIndexFromToken -- * * Parse a token to determine if an index value is known at - * compile time. + * compile time. * * Returns: * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. @@ -1553,7 +1553,7 @@ TclCompileLreplaceCmd( emptyPrefix = 0; } - + /* * [lreplace] raises an error when idx1 points after the list, but * only when the list is not empty. This is maximum stupidity. diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index cf088bb..9434e54 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1002,13 +1002,13 @@ TclCompileStringReplaceCmd( if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { return TCL_ERROR; } - + /* Bytecode to compute/push string argument being replaced */ valueTokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 1); /* - * Check for first index known and useful at compile time. + * Check for first index known and useful at compile time. */ tokenPtr = TokenAfter(valueTokenPtr); if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, @@ -1017,7 +1017,7 @@ TclCompileStringReplaceCmd( } /* - * Check for last index known and useful at compile time. + * Check for last index known and useful at compile time. */ tokenPtr = TokenAfter(tokenPtr); if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, @@ -1025,7 +1025,7 @@ TclCompileStringReplaceCmd( goto genericReplace; } - /* + /* * [string replace] is an odd bird. For many arguments it is * a conventional substring replacer. However it also goes out * of its way to become a no-op for many cases where it would be @@ -1108,12 +1108,12 @@ TclCompileStringReplaceCmd( * Finally we need, third: * * (first <= last) - * + * * Considered in combination with the constraints we already have, * we see that we can proceed when (first == TCL_INDEX_BEFORE) * or (last == TCL_INDEX_AFTER). These also permit simplification * of the prefix|replace|suffix construction. The other constraints, - * though, interfere with getting a guarantee that first <= last. + * though, interfere with getting a guarantee that first <= last. */ if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) { @@ -1141,7 +1141,7 @@ TclCompileStringReplaceCmd( /* FLOW THROUGH TO genericReplace */ } else { - /* + /* * When we have no replacement string to worry about, we may * have more luck, because the forbidden empty string replacements * are harmless when they are replaced by another empty string. diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index a43ab76..acbd2c5 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -597,7 +597,7 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); #define FOREACH(var,ary) \ for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \ continue; \ - } else if (var = (ary).list[i], 1) + } else if (var = (ary).list[i], 1) /* * A variation where the array is an array of structs. There's no issue with diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 223ef93..2c16458 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -577,7 +577,7 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ - int availStable, satisfies; + int availStable, satisfies; Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 604b7ce..a781386 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -1,7 +1,7 @@ /* * tclProcess.c -- * - * This file implements the "tcl::process" ensemble for subprocess + * This file implements the "tcl::process" ensemble for subprocess * management as defined by TIP #462. * * Copyright (c) 2017 Frederic Bonnet. @@ -13,14 +13,14 @@ #include "tclInt.h" /* - * Autopurge flag. Process-global because of the way Tcl manages child + * Autopurge flag. Process-global because of the way Tcl manages child * processes (see tclPipe.c). */ static int autopurge = 1; /* Autopurge flag. */ /* - * Hash tables that keeps track of all child process statuses. Keys are the + * Hash tables that keeps track of all child process statuses. Keys are the * child process ids and resolved pids, values are (ProcessInfo *). */ @@ -29,7 +29,7 @@ typedef struct ProcessInfo { int resolvedPid; /* Resolved process id. */ int purge; /* Purge eventualy. */ TclProcessWaitStatus status;/* Process status. */ - int code; /* Error code, exit status or signal + int code; /* Error code, exit status or signal number. */ Tcl_Obj *msg; /* Error message. */ Tcl_Obj *error; /* Error code. */ @@ -47,7 +47,7 @@ static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, int resolvedPid); static void FreeProcessInfo(ProcessInfo *info); static int RefreshProcessInfo(ProcessInfo *info, int options); -static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, +static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, int options, int *codePtr, Tcl_Obj **msgPtr, Tcl_Obj **errorObjPtr); static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); @@ -160,7 +160,7 @@ RefreshProcessInfo( * Refresh & store status. */ - info->status = WaitProcessStatus(info->pid, info->resolvedPid, + info->status = WaitProcessStatus(info->pid, info->resolvedPid, options, &info->code, &info->msg, &info->error); if (info->msg) Tcl_IncrRefCount(info->msg); if (info->error) Tcl_IncrRefCount(info->error); @@ -214,7 +214,7 @@ WaitProcessStatus( /* * No change. */ - + return TCL_PROCESS_UNCHANGED; } @@ -370,7 +370,7 @@ BuildProcessStatusObj( /* * Normal exit, return TCL_OK. */ - + return Tcl_NewIntObj(TCL_OK); } @@ -388,7 +388,7 @@ BuildProcessStatusObj( * * ProcessListObjCmd -- * - * This function implements the 'tcl::process list' Tcl command. + * This function implements the 'tcl::process list' Tcl command. * Refer to the user documentation for details on what it does. * * Results: @@ -423,10 +423,10 @@ ProcessListObjCmd( list = Tcl_NewListObj(0, NULL); Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); - Tcl_ListObjAppendElement(interp, list, + Tcl_ListObjAppendElement(interp, list, Tcl_NewIntObj(info->resolvedPid)); } Tcl_MutexUnlock(&infoTablesMutex); @@ -438,7 +438,7 @@ ProcessListObjCmd( * * ProcessStatusObjCmd -- * - * This function implements the 'tcl::process status' Tcl command. + * This function implements the 'tcl::process status' Tcl command. * Refer to the user documentation for details on what it does. * * Results: @@ -504,7 +504,7 @@ ProcessStatusObjCmd( dict = Tcl_NewDictObj(); Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); RefreshProcessInfo(info, options); @@ -513,7 +513,7 @@ ProcessStatusObjCmd( /* * Purge entry. */ - + Tcl_DeleteHashEntry(entry); entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); Tcl_DeleteHashEntry(entry); @@ -523,7 +523,7 @@ ProcessStatusObjCmd( * Add to result. */ - Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), BuildProcessStatusObj(info)); } } @@ -532,7 +532,7 @@ ProcessStatusObjCmd( /* * Only return statuses of provided processes. */ - + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); if (result != TCL_OK) { return result; @@ -552,10 +552,10 @@ ProcessStatusObjCmd( /* * Skip unknown process. */ - + continue; } - + info = (ProcessInfo *) Tcl_GetHashValue(entry); RefreshProcessInfo(info, options); @@ -563,7 +563,7 @@ ProcessStatusObjCmd( /* * Purge entry. */ - + Tcl_DeleteHashEntry(entry); entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); Tcl_DeleteHashEntry(entry); @@ -573,7 +573,7 @@ ProcessStatusObjCmd( * Add to result. */ - Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), BuildProcessStatusObj(info)); } } @@ -587,7 +587,7 @@ ProcessStatusObjCmd( * * ProcessPurgeObjCmd -- * - * This function implements the 'tcl::process purge' Tcl command. + * This function implements the 'tcl::process purge' Tcl command. * Refer to the user documentation for details on what it does. * * Results: @@ -632,7 +632,7 @@ ProcessPurgeObjCmd( */ Tcl_MutexLock(&infoTablesMutex); - for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); if (info->purge) { @@ -647,7 +647,7 @@ ProcessPurgeObjCmd( /* * Purge only provided processes. */ - + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); if (result != TCL_OK) { return result; @@ -665,7 +665,7 @@ ProcessPurgeObjCmd( /* * Skip unknown process. */ - + continue; } @@ -687,7 +687,7 @@ ProcessPurgeObjCmd( * * ProcessAutopurgeObjCmd -- * - * This function implements the 'tcl::process autopurge' Tcl command. + * This function implements the 'tcl::process autopurge' Tcl command. * Refer to the user documentation for details on what it does. * * Results: @@ -715,7 +715,7 @@ ProcessAutopurgeObjCmd( /* * Set given value. */ - + int flag; int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag); if (result != TCL_OK) { @@ -725,8 +725,8 @@ ProcessAutopurgeObjCmd( autopurge = !!flag; } - /* - * Return current value. + /* + * Return current value. */ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge)); @@ -821,9 +821,9 @@ TclProcessCreated( /* * Pid was reused, free old info and reuse structure. */ - + info = (ProcessInfo *) Tcl_GetHashValue(entry); - entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, + entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid)); if (entry2) Tcl_DeleteHashEntry(entry2); FreeProcessInfo(info); @@ -893,8 +893,8 @@ TclProcessWait( /* * Unknown process, just call WaitProcessStatus and return. */ - - result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, + + result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, msgObjPtr, errorObjPtr); if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); @@ -909,7 +909,7 @@ TclProcessWait( * so report no change. */ Tcl_MutexUnlock(&infoTablesMutex); - + return TCL_PROCESS_UNCHANGED; } @@ -919,7 +919,7 @@ TclProcessWait( * No change, stop there. */ Tcl_MutexUnlock(&infoTablesMutex); - + return TCL_PROCESS_UNCHANGED; } @@ -940,7 +940,7 @@ TclProcessWait( */ Tcl_DeleteHashEntry(entry); - entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(info->resolvedPid)); Tcl_DeleteHashEntry(entry); FreeProcessInfo(info); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c106f0e..f98180f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -490,7 +490,7 @@ TclCheckEmptyString( Tcl_DictObjSize(NULL, objPtr, &length); return length == 0; } - + if (objPtr->bytes == NULL) { return TCL_EMPTYSTRING_UNKNOWN; } @@ -3573,7 +3573,7 @@ TclStringFirst( start = 0; } if (ln == 0) { - /* We don't find empty substrings. Bizarre! + /* We don't find empty substrings. Bizarre! * Whenever this routine is turned into a proper substring * finder, change to `return start` after limits imposed. */ return -1; @@ -3970,7 +3970,7 @@ TclStringReplace( result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes); /* PANIC? */ Tcl_SetByteArrayLength(result, 0); - TclAppendBytesToByteArray(result, bytes, first); + TclAppendBytesToByteArray(result, bytes, first); TclAppendBytesToByteArray(result, iBytes, newBytes); TclAppendBytesToByteArray(result, bytes + first + count, numBytes - count - first); @@ -3992,7 +3992,7 @@ TclStringReplace( Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars); /* TODO: Is there an in-place option worth pursuing here? */ - + result = Tcl_NewUnicodeObj(ustring, first); if (insertPtr) { Tcl_AppendObjToObj(result, insertPtr); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 0ba6c8e..48602c4 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -120,7 +120,7 @@ static int FindElement(Tcl_Interp *interp, const char *string, /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a - * performance optimization in TclGetIntForIndex. The internal rep is + * performance optimization in TclGetIntForIndex. The internal rep is * stored directly in the wideValue, so no memory management is required * for it. This is a caching intrep, keeping the result of a parse * around. This type is only created from a pre-existing string, so an @@ -1673,7 +1673,7 @@ UtfWellFormedEnd( if (Tcl_UtfCharComplete(p, l - p)) { return bytes; } - /* + /* * Malformed utf-8 end, be sure we've NTS to safe compare of end-character, * avoid segfault by access violation out of range. */ @@ -3793,7 +3793,7 @@ GetEndOffsetFromObj( return TCL_OK; } - + /* *---------------------------------------------------------------------- * @@ -3976,12 +3976,12 @@ TclIndexEncode( /* usual case, the absolute index value encodes itself */ } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) { /* - * We parsed an end+offset index value. + * We parsed an end+offset index value. * idx holds the offset value in the range INT_MIN...INT_MAX. */ if (idx > 0) { /* - * All end+postive or end-negative expressions + * All end+postive or end-negative expressions * always indicate "after the end". */ idx = after; diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 598330d..129cd9c 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -49,7 +49,7 @@ namespace eval msgcat { namespace eval msgcat::mcutil { namespace export getsystemlocale getpreferences namespace ensemble create -prefix 0 - + # Map of language codes used in Windows registry to those of ISO-639 if {[info sharedlibextension] eq ".dll"} { variable WinRegToISO639 [dict create {*}{ @@ -292,7 +292,7 @@ proc msgcat::mcexists {args} { } } set src [lindex $args 0] - + if {![info exists ns]} { set ns [PackageNamespaceGet] } set loclist [PackagePreferences $ns] @@ -537,7 +537,7 @@ proc msgcat::mcpackagelocale {subcommand args} { set - preferences { # set a package locale or add a package locale set fSet [expr {$subcommand eq "set"}] - + # Check parameter if {$fSet && 1 < [llength $args] } { return -code error "wrong # args: should be\ @@ -1241,7 +1241,7 @@ proc ::msgcat::PackageNamespaceGet {} { } } } - + # Initialize the default locale proc msgcat::mcutil::getsystemlocale {} { global env diff --git a/tests/chanio.test b/tests/chanio.test index e7f51b3..300c54a 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -33,7 +33,7 @@ namespace eval ::tcl::test::io { loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] package require tcltests - + testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] testConstraint openpipe 1 @@ -5957,7 +5957,7 @@ test chan-io-48.3 {testing readability conditions} -setup { chan close $f } -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} unset path(bar) -removeFile bar +removeFile bar test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup { file delete $path(test1) diff --git a/tests/env.test b/tests/env.test index 2c077b1..8434943 100644 --- a/tests/env.test +++ b/tests/env.test @@ -399,8 +399,8 @@ test env-8.0 { # cleanup -rename getenv {} -rename envrestore {} +rename getenv {} +rename envrestore {} rename envprep {} rename encodingrestore {} rename encodingswitch {} diff --git a/tests/expr.test b/tests/expr.test index abaf31d..713681a 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -7164,7 +7164,7 @@ test expr-52.1 { list [expr {$a eq {}}] [expr {$a < {}}] [expr {$a > {}}] [ string match {*no string representation*} [ ::tcl::unsupported::representation $a]] -} {0 0 1 1} +} {0 0 1 1} diff --git a/tests/msgcat.test b/tests/msgcat.test index 12030fb..3dde124 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -999,7 +999,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { mcpackagelocale isset } -result {0} - + # Tests msgcat-13.*: [mcpackageconfig subcmds] test msgcat-13.1 {mcpackageconfig no subcommand} -body { @@ -1153,7 +1153,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { # Tests msgcat-15.*: tcloo coverage - + # There are 4 use-cases, where 3 must be tested now: # - namespace defined, in class definition, class defined oo, classless @@ -1210,7 +1210,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { } -body { bar::ObjCur method1 } -result con2bar - + test msgcat-15.4 {mc in classless object with explicite namespace eval}\ -setup { # full namespace is ::msgcat::test:bar @@ -1236,7 +1236,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { } -body { bar::ObjCur method1 } -result con2baz - + # Test msgcat-16.*: command mcpackagenamespaceget test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body { @@ -1298,7 +1298,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { # Test msgcat-17.*: mcn command - + test msgcat-17.1 {mcn no parameters} -body { mcn } -returnCodes 1\ @@ -1328,26 +1328,26 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { mcutil junk } -returnCodes 1\ -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale} - + test msgcat-18.3 {mcutil - partial argument} -body { mcutil getsystem } -returnCodes 1\ -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale} - + test msgcat-18.4 {mcutil getpreferences - no argument} -body { mcutil getpreferences } -returnCodes 1\ -result {wrong # args: should be "mcutil getpreferences locale"} - + test msgcat-18.5 {mcutil getpreferences - DE_de} -body { mcutil getpreferences DE_de } -result {de_de de {}} - + test msgcat-18.6 {mcutil getsystemlocale - wrong argument} -body { mcutil getsystemlocale DE_de } -returnCodes 1\ -result {wrong # args: should be "mcutil getsystemlocale"} - + # The result is system dependent # So just test if it runs # The environment variable version was test with test 0.x @@ -1355,8 +1355,8 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { mcutil getsystemlocale set ok ok } -result {ok} - - + + cleanupTests } namespace delete ::msgcat::test diff --git a/tests/namespace.test b/tests/namespace.test index b9e6ead..606139f 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -205,7 +205,7 @@ test namespace-7.8 {Bug ba1419303b4c} -setup { namespace delete ns1 } } -body { - # No segmentation fault given --enable-symbols=mem. + # No segmentation fault given --enable-symbols=mem. namespace delete ns1 } -result {} diff --git a/tests/oo.test b/tests/oo.test index 9a22438..85af233 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2153,7 +2153,7 @@ test oo-15.13.1 { } -cleanup { Cls destroy Cls2 destroy -} -result done +} -result done test oo-15.13.2 {OO: object cloning with target NS} -setup { oo::class create Super oo::class create Cls {superclass Super} diff --git a/tests/package.test b/tests/package.test index 69d9ddb..2dca06b 100644 --- a/tests/package.test +++ b/tests/package.test @@ -630,13 +630,13 @@ test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup { } -body { coroutine coro1 apply {{} { package ifneeded t 2.1 { - yield + yield package provide t 2.1 } package require t 2.1 }} list [catch {coro1} msg] $msg -} -match glob -result {0 2.1} +} -match glob -result {0 2.1} test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { diff --git a/tests/process.test b/tests/process.test index b88c50a..5aa8354 100644 --- a/tests/process.test +++ b/tests/process.test @@ -63,7 +63,7 @@ test process-4.1 {exec one child} -body { set statuses [tcl::process status -wait] set status [lindex [tcl::process status $pid] 1] expr { - [llength $list] eq 1 + [llength $list] eq 1 && [lindex $list 0] eq $pid && [dict size $statuses] eq 1 && [dict get $statuses $pid] eq $status @@ -139,7 +139,7 @@ test process-5.1 {exec one child} -body { set statuses [tcl::process status -wait] set status [lindex [tcl::process status $pid] 1] expr { - [llength $list] eq 1 + [llength $list] eq 1 && [lindex $list 0] eq $pid && [dict size $statuses] eq 1 && [dict get $statuses $pid] eq $status diff --git a/tests/string.test b/tests/string.test index 772415c..d169193 100644 --- a/tests/string.test +++ b/tests/string.test @@ -280,7 +280,7 @@ test string-3.17.$noComp {string equal, unicode} { } 1 test string-3.18.$noComp {string equal, unicode} { run {string equal \334 \u00fc} -} 0 +} 0 test string-3.19.$noComp {string equal, unicode} { run {string equal \334\334\334\374\374 \334\334\334\334\334} } 0 @@ -307,7 +307,7 @@ test string-3.24.$noComp {string equal -nocase with length} { } 1 test string-3.25.$noComp {string equal -nocase with length} { run {string equal -nocase -length 3 abcde Abxyz} -} 0 +} 0 test string-3.26.$noComp {string equal -nocase with length <= 0} { run {string equal -nocase -length -1 abcde AbCdEf} } 0 diff --git a/tests/tcltest.test b/tests/tcltest.test index 0bcf342..1487865 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -908,7 +908,7 @@ removeFile load.tcl # [interpreter] test tcltest-13.1 {interpreter} { - -constraints notValgrind + -constraints notValgrind -setup { #to do: Why is $::tcltest::tcltest being saved and restored here? set old $::tcltest::tcltest @@ -926,7 +926,7 @@ test tcltest-13.1 {interpreter} { # constraint, which involves a call to [exec] that might fail after # "fork" and before "exec", in which case the forked process will not # have a chance to clean itself up before exiting, which causes - # valgrind to issue numerous "still reachable" reports. + # valgrind to issue numerous "still reachable" reports. set ::tcltest::tcltest $old } } diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c index ca194c7..2abfd47 100644 --- a/unix/tclEpollNotfy.c +++ b/unix/tclEpollNotfy.c @@ -88,7 +88,7 @@ typedef struct { LIST_HEAD(PlatformReadyFileHandlerList, FileHandler); typedef struct ThreadSpecificData { - FileHandler *triggerFilePtr; + FileHandler *triggerFilePtr; FileHandler *firstFileHandlerPtr; /* Pointer to head of file handler list. */ struct PlatformReadyFileHandlerList firstReadyFileHandlerPtr; diff --git a/win/makefile.vc b/win/makefile.vc index ceeaa02..1aae9a3 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -55,7 +55,7 @@ # c:\tcl_src\win\>nmake -f makefile.vc release # c:\tcl_src\win\>nmake -f makefile.vc test # c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl -# c:\tcl_src\win\>nmake -f makefile.vc release OPTS=pdbs +# c:\tcl_src\win\>nmake -f makefile.vc release OPTS=pdbs # c:\tcl_src\win\>nmake -f makefile.vc release OPTS=symbols # diff --git a/win/nmakehlp.c b/win/nmakehlp.c index b759020..1655d48 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -686,10 +686,10 @@ SubstituteFile( BOOL FileExists(LPCTSTR szPath) { #ifndef INVALID_FILE_ATTRIBUTES - #define INVALID_FILE_ATTRIBUTES ((DWORD)-1) + #define INVALID_FILE_ATTRIBUTES ((DWORD)-1) #endif DWORD pathAttr = GetFileAttributes(szPath); - return (pathAttr != INVALID_FILE_ATTRIBUTES && + return (pathAttr != INVALID_FILE_ATTRIBUTES && !(pathAttr & FILE_ATTRIBUTE_DIRECTORY)); } @@ -740,7 +740,7 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) #if 0 /* This function is not available in Visual C++ 6 */ /* * Use numerics 0 -> FindExInfoStandard, - * 1 -> FindExSearchLimitToDirectories, + * 1 -> FindExSearchLimitToDirectories, * as these are not defined in Visual C++ 6 */ hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0); @@ -755,7 +755,7 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) do { int sublen; /* - * We need to check it is a directory despite the + * We need to check it is a directory despite the * FindExSearchLimitToDirectories in the above call. See SDK docs */ if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) @@ -786,7 +786,7 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) * that is used to confirm it is the correct directory. * The search path for the package directory is currently only * the parent and grandparent of the current working directory. - * If found, the command prints + * If found, the command prints * name_DIRPATH= * and returns 0. If not found, does not print anything and returns 1. */ @@ -794,7 +794,7 @@ static int LocateDependency(const char *keypath) { int i, ret; static char *paths[] = {"..", "..\\..", "..\\..\\.."}; - + for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) { ret = LocateDependencyHelper(paths[i], keypath); if (ret == 0) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index a88ef72..dfeeef1 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1440,9 +1440,9 @@ TclpGetUserHome( domain = Tcl_UtfFindFirst(name, '@'); if (domain == NULL) { const char *ptr; - + /* no domain - firstly check it's the current user */ - if ( (ptr = TclpGetUserName(&ds)) != NULL + if ( (ptr = TclpGetUserName(&ds)) != NULL && strcasecmp(name, ptr) == 0 ) { /* try safest and fastest way to get current user home */ @@ -1465,7 +1465,7 @@ TclpGetUserHome( Tcl_DStringInit(&ds); wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) { - /* + /* * user does not exists - if domain was not specified, * try again using current domain. */ @@ -1580,7 +1580,7 @@ NativeAccess( return 0; } - /* + /* * If it's not a directory (assume file), do several fast checks: */ if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) { @@ -2009,7 +2009,7 @@ NativeStat( */ fileHandle = CreateFile(nativePath, GENERIC_READ, - FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, + FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL); -- cgit v0.12 From de5637f8531520d3487ac143217d326570a4b0d8 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 3 Aug 2018 13:46:30 +0000 Subject: ioTrans.test: fixed cleanup - avoids `error deleting "tempchanfile": permission denied`: file seems to be locked/opened inside interp $idb --- tests/ioTrans.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 3bebc70..85e427a 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -1240,8 +1240,8 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces set res }] } -cleanup { - tempdone interp delete $idb + tempdone } -result {Owner lost} test iortrans-11.2 {delete interp of reflected transform} -setup { interp create slave -- cgit v0.12 From 8346cad0dd5a449892a1522020403d24f4186179 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Aug 2018 06:45:29 +0000 Subject: Fix harmless gcc warning --- generic/tclDate.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclDate.c b/generic/tclDate.c index e4dd000..717a1b3 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -1348,7 +1348,7 @@ yyparse (info) int yychar; /* The semantic value of the look-ahead symbol. */ -YYSTYPE yylval; +YYSTYPE yylval = {0}; /* Number of syntax errors so far. */ int yynerrs; -- cgit v0.12 From 6c78bf0adcb250437f1bb8dd19f13b7c2aa83848 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 8 Aug 2018 20:48:06 +0000 Subject: Repair breakage in recent refactoring of env.test --- tests/env.test | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/env.test b/tests/env.test index 2c077b1..e6ce44d 100644 --- a/tests/env.test +++ b/tests/env.test @@ -53,7 +53,7 @@ proc envprep {} { foreach name [array names env] { # Keep some environment variables that support operation of the tcltest # package. - if {[string toupper $name] ni $keep} { + if {[string toupper $name] ni [string toupper $keep]} { unset env($name) } } @@ -98,11 +98,11 @@ proc cleanup1 {} { } variable keep { - TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH - SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH + 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 - SECURITYSESSIONID LANG WINDIR TERM - CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432 + __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM + CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432 } variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { -- cgit v0.12 From e53f3cf9c69144d698f8b7899817243cd4d8d7e5 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 10 Aug 2018 15:03:14 +0000 Subject: Tighten up SaveResult.3, make installManPage more robust against newlines. --- doc/SaveResult.3 | 109 ++++++++++++++++++---------------------------------- unix/installManPage | 43 ++++++++++++++------- 2 files changed, 66 insertions(+), 86 deletions(-) diff --git a/doc/SaveResult.3 b/doc/SaveResult.3 index 6dd6cb6..1ddc1ad 100644 --- a/doc/SaveResult.3 +++ b/doc/SaveResult.3 @@ -1,6 +1,7 @@ '\" '\" Copyright (c) 1997 by Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) +'\" Copyright (c) 2018 Nathan Coulter. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -9,7 +10,9 @@ .so man.macros .BS .SH NAME -Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- save and restore an interpreter's state +Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, +Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- Save and restore the +state of an an interpreter. .SH SYNOPSIS .nf \fB#include \fR @@ -30,91 +33,53 @@ int .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in -Interpreter for which state should be saved. +The current interpreter. .AP int status in -Return code value to save as part of interpreter state. +The return code for the state. .AP Tcl_InterpState state in -Saved state token to be restored or discarded. +A token for saved state. .AP Tcl_SavedResult *savedPtr in -Pointer to location where interpreter result should be saved or restored. +A pointer to storage for saved state. .BE .SH DESCRIPTION .PP -These routines allows a C procedure to take a snapshot of the current -state of an interpreter so that it can be restored after a call -to \fBTcl_Eval\fR or some other routine that modifies the interpreter -state. There are two triplets of routines meant to work together. +These routines save the state of an interpreter before a call to a routine such +as \fBTcl_Eval\fR, and restore the state afterwards. .PP -The first triplet stores the snapshot of interpreter state in -an opaque token returned by \fBTcl_SaveInterpState\fR. That token -value may then be passed back to one of \fBTcl_RestoreInterpState\fR -or \fBTcl_DiscardInterpState\fR, depending on whether the interp -state is to be restored. So long as one of the latter two routines -is called, Tcl will take care of memory management. +\fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the +result of a script, including the resulting value, the return code passed as +\fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR. +It returns a token for the saved state. The interpreter result is not reset +and no interpreter state is changed. .PP -The second triplet stores the snapshot of only the interpreter -result (not its complete state) in memory allocated by the caller. -These routines are passed a pointer to \fBTcl_SavedResult\fR -that is used to store enough information to restore the interpreter result. -\fBTcl_SavedResult\fR can be allocated on the stack of the calling -procedure. These routines do not save the state of any error -information in the interpreter (e.g. the \fB\-errorcode\fR or -\fB\-errorinfo\fR return options, when an error is in progress). +\fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and +returns the \fIstatus\fR originally passed in the corresponding call to +\fBTcl_SaveInterpState\fR. .PP -Because the routines \fBTcl_SaveInterpState\fR, -\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR perform -a superset of the functions provided by the other routines, -any new code should only make use of the more powerful routines. -The older, weaker routines \fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, -and \fBTcl_DiscardResult\fR continue to exist only for the sake -of existing programs that may already be using them. +If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called +to release it. A token used to discard or restore state must not be used +again. .PP -\fBTcl_SaveInterpState\fR takes a snapshot of those portions of -interpreter state that make up the full result of script evaluation. -This include the interpreter result, the return code (passed in -as the \fIstatus\fR argument, and any return options, including -\fB\-errorinfo\fR and \fB\-errorcode\fR when an error is in progress. -This snapshot is returned as an opaque token of type \fBTcl_InterpState\fR. -The call to \fBTcl_SaveInterpState\fR does not itself change the -state of the interpreter. Unlike \fBTcl_SaveResult\fR, it does -not reset the interpreter. +\fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR are +deprecated. Instead use \fBTcl_SaveInterpState\fR, +\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR, which are more +capable. .PP -\fBTcl_RestoreInterpState\fR accepts a \fBTcl_InterpState\fR token -previously returned by \fBTcl_SaveInterpState\fR and restores the -state of the interp to the state held in that snapshot. The return -value of \fBTcl_RestoreInterpState\fR is the status value originally -passed to \fBTcl_SaveInterpState\fR when the snapshot token was -created. +\fBTcl_SaveResult\fR moves the string result and structured result of +\fIinterp\fR to the location \fIstatePtr\fR points to and returns the +interpreter result to its initial state. It does not save options such as +\fB\-errorcode\fR or \fB\-errorinfo\fR. .PP -\fBTcl_DiscardInterpState\fR is called to release a \fBTcl_InterpState\fR -token previously returned by \fBTcl_SaveInterpState\fR when that -snapshot is not to be restored to an interp. +\fBTcl_RestoreResult\fR clears any existing result or error in \fIinterp\fR and +moves the string result and structured result from \fIstatePtr\fR back to +\fIinterp\fR. \fIstatePtr\fR is then in an undefined state and cannot be used +until passed again to \fBTcl_SaveResult\fR. .PP -The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR -must eventually be passed to either \fBTcl_RestoreInterpState\fR -or \fBTcl_DiscardInterpState\fR to avoid a memory leak. Once -the \fBTcl_InterpState\fR token is passed to one of them, the -token is no longer valid and should not be used anymore. -.PP -\fBTcl_SaveResult\fR moves the string and value results -of \fIinterp\fR into the location specified by \fIstatePtr\fR. -\fBTcl_SaveResult\fR clears the result for \fIinterp\fR and -leaves the result in its normal empty initialized state. -.PP -\fBTcl_RestoreResult\fR moves the string and value results from -\fIstatePtr\fR back into \fIinterp\fR. Any result or error that was -already in the interpreter will be cleared. The \fIstatePtr\fR is left -in an uninitialized state and cannot be used until another call to -\fBTcl_SaveResult\fR. -.PP -\fBTcl_DiscardResult\fR releases the saved interpreter state -stored at \fBstatePtr\fR. The state structure is left in an -uninitialized state and cannot be used until another call to +\fBTcl_DiscardResult\fR releases the state stored at \fBstatePtr\fR, which is +then in an undefined state and cannot be used until passed again to \fBTcl_SaveResult\fR. .PP -Once \fBTcl_SaveResult\fR is called to save the interpreter -result, either \fBTcl_RestoreResult\fR or -\fBTcl_DiscardResult\fR must be called to properly clean up the -memory associated with the saved state. +If a saved result is not restored, \fBTcl_DiscardResult\fR must be called to +release it. .SH KEYWORDS result, state, interp diff --git a/unix/installManPage b/unix/installManPage index 1f1cbde..09a31dd 100755 --- a/unix/installManPage +++ b/unix/installManPage @@ -60,20 +60,35 @@ test -z "$SymOrLoc" && SymOrLoc="$Dir/" # Names=`sed -n ' # Look for a line that starts with .SH NAME - /^\.SH NAME/{ -# Read next line - n -# Remove all commas ... - s/,//g -# ... and backslash-escaped spaces. - s/\\\ //g -# Delete from \- to the end of line - s/ \\\-.*// -# Convert all non-space non-alphanum sequences -# to single underscores. - s/[^ A-Za-z0-9][^ A-Za-z0-9]*/_/g -# print the result and exit - p;q + /^\.SH NAME/,/^\./{ + + + /^\./!{ + + # Remove all commas... + s/,//g + + # ... and backslash-escaped spaces. + s/\\\ //g + + /\\\-.*/{ + # Delete from \- to the end of line + s/ \\\-.*// + h + s/.*/./ + x + } + + # Convert all non-space non-alphanum sequences + # to single underscores. + s/[^ A-Za-z0-9][^ A-Za-z0-9]*/_/g + p + g + /^\./{ + q + } + } + }' $ManPage` if test -z "$Names" ; then -- cgit v0.12 From 18c102aa7055571d742e867b44e765ac3ed0213c Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 10 Aug 2018 18:44:41 +0000 Subject: minor changes to documentation --- doc/SaveResult.3 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/doc/SaveResult.3 b/doc/SaveResult.3 index 1ddc1ad..51ccb23 100644 --- a/doc/SaveResult.3 +++ b/doc/SaveResult.3 @@ -33,7 +33,7 @@ int .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in -The current interpreter. +The interpreter for the operation. .AP int status in The return code for the state. .AP Tcl_InterpState state in @@ -65,18 +65,18 @@ deprecated. Instead use \fBTcl_SaveInterpState\fR, \fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR, which are more capable. .PP -\fBTcl_SaveResult\fR moves the string result and structured result of -\fIinterp\fR to the location \fIstatePtr\fR points to and returns the -interpreter result to its initial state. It does not save options such as -\fB\-errorcode\fR or \fB\-errorinfo\fR. +\fBTcl_SaveResult\fR moves the result of \fIinterp\fR to the location +\fIstatePtr\fR points to and returns the interpreter result to its initial +state. It does not save options such as \fB\-errorcode\fR or +\fB\-errorinfo\fR. .PP \fBTcl_RestoreResult\fR clears any existing result or error in \fIinterp\fR and -moves the string result and structured result from \fIstatePtr\fR back to -\fIinterp\fR. \fIstatePtr\fR is then in an undefined state and cannot be used -until passed again to \fBTcl_SaveResult\fR. +moves the result from \fIstatePtr\fR back to \fIinterp\fR. \fIstatePtr\fR is +then in an undefined state and must not be used until passed again to +\fBTcl_SaveResult\fR. .PP \fBTcl_DiscardResult\fR releases the state stored at \fBstatePtr\fR, which is -then in an undefined state and cannot be used until passed again to +then in an undefined state and must not be used until passed again to \fBTcl_SaveResult\fR. .PP If a saved result is not restored, \fBTcl_DiscardResult\fR must be called to -- cgit v0.12 From e5270637c01b6fbb0f016048fc9d9735f980421a Mon Sep 17 00:00:00 2001 From: pooryorick Date: Tue, 14 Aug 2018 05:43:17 +0000 Subject: Reposition the MODULE_SCOPE definition so that packages like tbcload don't get an error when they include tclPort.h. --- generic/tclInt.h | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 64e7c67..5379396 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -38,6 +38,23 @@ #define AVOID_HACKS_FOR_ITCL 1 + +/* + * Used to tag functions that are only to be visible within the module being + * built and not outside it (where this is supported by the linker). + * Also used in the platform-specific *Port.h files. + */ + +#ifndef MODULE_SCOPE +# ifdef __cplusplus +# define MODULE_SCOPE extern "C" +# else +# define MODULE_SCOPE extern +# endif +#endif + + + /* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only @@ -95,19 +112,6 @@ typedef int ptrdiff_t; #endif /* - * Used to tag functions that are only to be visible within the module being - * built and not outside it (where this is supported by the linker). - */ - -#ifndef MODULE_SCOPE -# ifdef __cplusplus -# define MODULE_SCOPE extern "C" -# else -# define MODULE_SCOPE extern -# endif -#endif - -/* * Macros used to cast between pointers and integers (e.g. when storing an int * in ClientData), on 64-bit architectures they avoid gcc warning about "cast * to/from pointer from/to integer of different size". -- cgit v0.12