diff options
Diffstat (limited to 'tests/testutils.tcl')
| -rw-r--r-- | tests/testutils.tcl | 88 |
1 files changed, 85 insertions, 3 deletions
diff --git a/tests/testutils.tcl b/tests/testutils.tcl index 3eea930..adb32ef 100644 --- a/tests/testutils.tcl +++ b/tests/testutils.tcl @@ -141,6 +141,18 @@ namespace eval ::tk::test::generic { vwait [namespace current]::_pause($num) } + # resetWindows -- + # + # Restores a proper initial window setup for a test file, cleaning up from + # the state brought about by a previous testfile. + # + proc resetWindows {} { + deleteWindows + wm geometry . {} + raise . + update + } + # On macOS windows are not allowed to overlap the menubar at the top of the # screen or the dock. So tests which move a window and then check whether it # got moved to the requested location should use a y coordinate larger than the @@ -362,20 +374,29 @@ namespace eval ::tk::test::child { # childTkProcess -- # - # Create a new Tk application in a child process, and enable it to + # Create a new Tk application in a child process, and enable it to # evaluate scripts on our behalf. # # Suggestion: replace with child interp or thread ? # proc childTkProcess {subcmd args} { variable fd + variable interpCount switch -- $subcmd { create { if {[info exists fd] && [string length $fd]} { childTkProcess exit } + # Beware of bug #280189e35d. We prevent that bug by not relying + # on the automatic detection of duplicate interp names, as + # advertised by the manual page for "tk appname". Instead, we + # pass a unique appname to the executable that is being invoked + # below. + if {! [info exists interpCount]} { + set interpCount 1 + } set fd [open "|[list [::tcltest::interpreter] \ - -geometry +0+0 -name tktest] $args" r+] + -geometry +0+0 -name tktest[incr interpCount]] $args" r+] puts $fd "puts foo; flush stdout" flush $fd if {[gets $fd data] < 0} { @@ -627,7 +648,7 @@ namespace eval ::tk::test::dialog { variable testDialogFont variable iter_after variable testDialog; # On MS Windows, this variable is set at the C level - # by SetTestDialog() in tkWinDialog.c + # by SetTestDialog() in tkWinDialog.c switch -- $stage { launch { @@ -986,4 +1007,65 @@ namespace eval ::tk::test::text { testutils export } +namespace eval ::tk::test::timing { + + # init -- + # + # This is a reserved proc that is part of the mechanism that the proc + # testutils employs when making utility procs and associated namespace + # variables available to test files. + # + # Test authors should define and initialize namespace variables here if + # they need to be imported into the namespace in which tests are executing. + # This proc must not be exported. + # + # For more information, see the documentation in the file "testutils.GUIDE" + # + proc init {} { + variable dt + set dt(granularity) milliseconds + set dt(t0) [clock milliseconds] + } + + proc dt.get {} { + variable dt + set now [clock $dt(granularity)] + set result [expr {$now - $dt(t0)}] + set dt(t0) $now + return $result + } + + proc dt.reset {{granularity milliseconds}} { + if {$granularity ni "microseconds milliseconds seconds"} { + return -code error "invalid parameter \"$granularity\", expected \"microseconds\", \"milliseconds\" or \"seconds\"" + } + variable dt + set dt(granularity) $granularity + set dt(t0) [clock $dt(granularity)] + } + + # progress.* -- + # + # This set of procs monitors progress and total duration of a procedure + # in a loop. + # + # Derived from tests/ttk/ttk.test, see: + # + # https://core.tcl-lang.org/tk/file?ci=f94f84b254b0c5ad&name=tests/ttk/ttk.test&ln=335-340 + # + proc progress.init {{granularity milliseconds}} { + dt.reset $granularity + } + + proc progress.update {} { + puts -nonewline stderr "." ; flush stderr + } + + proc progress.end {} { + puts stderr " [dt.get] $::tk::test::timing::dt(granularity)" + } + + testutils export +} + # EOF |