diff options
Diffstat (limited to 'tests/constraints.tcl')
| -rw-r--r-- | tests/constraints.tcl | 397 |
1 files changed, 70 insertions, 327 deletions
diff --git a/tests/constraints.tcl b/tests/constraints.tcl index 8327734..660fe47 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -1,273 +1,17 @@ -if {[namespace exists tk::test]} { - deleteWindows - wm geometry . {} - raise . - return -} - -package require tk -tk appname tktest -wm title . tktest -# If the main window isn't already mapped (e.g. because the tests are -# being run automatically) , specify a precise size for it so that the -# user won't have to position it manually. - -if {![winfo ismapped .]} { - wm geometry . +0+0 - update -} - -package require tcltest 2.2 - -namespace eval tk { - namespace eval test { - - namespace export loadTkCommand - proc loadTkCommand {} { - set tklib {} - foreach pair [info loaded {}] { - foreach {lib pfx} $pair break - if {$pfx eq "Tk"} { - set tklib $lib - break - } - } - return [list load $tklib Tk] - } - - namespace eval bg { - # Manage a background process. - # Replace with child interp or thread? - namespace import ::tcltest::interpreter - namespace import ::tk::test::loadTkCommand - namespace export setup cleanup do - - proc cleanup {} { - variable fd - # catch in case the background process has closed $fd - catch {puts $fd exit} - catch {close $fd} - set fd "" - } - proc setup args { - variable fd - if {[info exists fd] && [string length $fd]} { - cleanup - } - set fd [open "|[list [interpreter] \ - -geometry +0+0 -name tktest] $args" r+] - puts $fd "puts foo; flush stdout" - flush $fd - if {[gets $fd data] < 0} { - error "unexpected EOF from \"[interpreter]\"" - } - if {$data ne "foo"} { - error "unexpected output from\ - background process: \"$data\"" - } - puts $fd [loadTkCommand] - flush $fd - fileevent $fd readable [namespace code Ready] - } - proc Ready {} { - variable fd - variable Data - variable Done - set x [gets $fd] - if {[eof $fd]} { - fileevent $fd readable {} - set Done 1 - } elseif {$x eq "**DONE**"} { - set Done 1 - } else { - append Data $x - } - } - proc do {cmd {block 0}} { - variable fd - variable Data - variable Done - if {$block} { - fileevent $fd readable {} - } - puts $fd "[list catch $cmd msg]; update; puts \$msg;\ - puts **DONE**; flush stdout" - flush $fd - set Data {} - if {$block} { - while {![eof $fd]} { - set line [gets $fd] - if {$line eq "**DONE**"} { - break - } - append Data $line - } - } else { - set Done 0 - vwait [namespace which -variable Done] - } - return $Data - } - } - - proc Export {internal as external} { - uplevel 1 [list namespace import $internal] - uplevel 1 [list rename [namespace tail $internal] $external] - uplevel 1 [list namespace export $external] - } - Export bg::setup as setupbg - Export bg::cleanup as cleanupbg - Export bg::do as dobg - - namespace export deleteWindows - proc deleteWindows {} { - destroy {*}[winfo children .] - # This update is needed to avoid intermittent failures on macOS in unixEmbed.test - # with the (GitHub Actions) CI runner. - # Reason for the failures is unclear but could have to do with window ids being deleted - # after the destroy command returns. The detailed mechanism of such delayed deletions - # is not understood, but it appears that this update prevents the test failures. - update - } - - namespace export fixfocus - proc fixfocus {} { - catch {destroy .focus} - toplevel .focus - wm geometry .focus +0+0 - entry .focus.e - .focus.e insert 0 "fixfocus" - pack .focus.e - update - focus -force .focus.e - destroy .focus - } - - namespace export imageInit imageFinish imageCleanup imageNames - variable ImageNames - proc imageInit {} { - variable ImageNames - if {![info exists ImageNames]} { - set ImageNames [lsearch -all -inline -glob -not [lsort [image names]] ::tk::icons::indicator*] - } - imageCleanup - if {[lsort [image names]] ne $ImageNames} { - return -code error "IMAGE NAMES mismatch: [image names] != $ImageNames" - } - } - proc imageFinish {} { - variable ImageNames - set imgs [lsearch -all -inline -glob -not [lsort [image names]] ::tk::icons::indicator*] - if {$imgs ne $ImageNames} { - return -code error "images remaining: [image names] != $ImageNames" - } - imageCleanup - } - proc imageCleanup {} { - variable ImageNames - foreach img [image names] { - if {$img ni $ImageNames} {image delete $img} - } - } - proc imageNames {} { - variable ImageNames - set r {} - foreach img [image names] { - if {$img ni $ImageNames} {lappend r $img} - } - return $r - } - - # - # CONTROL TIMING ASPECTS OF POINTER WARPING - # - # The proc [controlPointerWarpTiming] is intended to ensure that the (mouse) - # pointer has actually been moved to its new position after a Tk test issued: - # - # [event generate $w $event -warp 1 ...] - # - # It takes care of the following timing details of pointer warping: - # - # a. Allow pointer warping to happen if it was scheduled for execution at - # idle time. This happens synchronously if $w refers to the - # whole screen or if the -when option to [event generate] is "now". - # - # b. Work around a race condition associated with OS notification of - # mouse motion on Windows. - # - # When calling [event generate $w $event -warp 1 ...], the following - # sequence occurs: - # - At some point in the processing of this command, either via a - # synchronous execution path, or asynchronously at idle time, Tk calls - # an OS function* to carry out the mouse cursor motion. - # - Tk has previously registered a callback function** with the OS, for - # the OS to call in order to notify Tk when a mouse move is completed. - # - Tk doesn't wait for the callback function to receive the notification - # from the OS, but continues processing. This suits most use cases - # because usually the notification arrives fast enough (within a few tens - # of microseconds). However ... - # - A problem arises if Tk performs some processing, immediately following - # up on [event generate $w $event -warp 1 ...], and that processing - # relies on the mouse pointer having actually moved. If such processing - # happens just before the notification from the OS has been received, - # Tk will be using not yet updated info (e.g. mouse coordinates). - # - # Hickup, choke etc ... ! - # - # * the function SendInput() of the Win32 API - # ** the callback function is TkWinChildProc() - # - # This timing issue can be addressed by putting the Tk process on hold - # (do nothing at all) for a somewhat extended amount of time, while - # letting the OS complete its job in the meantime. This is what is - # accomplished by calling [after ms]. - # - # ---- - # For the history of this issue please refer to Tk ticket [69b48f427e], - # specifically the comment on 2019-10-27 14:24:26. - # - # - # Beware: there are cases, not (yet) exercised by the Tk test suite, where - # [controlPointerWarpTiming] doesn't ensure the new position of the pointer. - # For example, when issued under Tk8.7+, if the value for the -when option - # to [event generate $w] is not "now", and $w refers to a Tk window, i.e. not - # the whole screen. - # - proc controlPointerWarpTiming {{duration 50}} { - update idletasks ;# see a. above - if {[tk windowingsystem] eq "win32"} { - after $duration ;# see b. above - } - } - namespace export controlPointerWarpTiming - - # 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 - # height of the menubar (normally 23 pixels) and an x coordinate larger than the - # width of the dock, if it happens to be on the left. - # The C-level command "testmenubarheight" deals with this issue but it may - # not be available on each platform. Therefore, provide a fallback here. - if {[llength [info commands testmenubarheight]] == 0} { - if {[tk windowingsystem] ne "aqua"} { - # Windows may overlap the menubar - proc testmenubarheight {} { - return 0 - } - } else { - # Windows may not overlap the menubar - proc testmenubarheight {} { - return 30 ; # arbitrary value known to be larger than the menubar height - } - } - namespace export testmenubarheight - } - } -} - -namespace import -force tk::test::* +# constraints.tcl -- +# +# This file is sourced by each test file when invoking "tcltest::loadTestedCommands". +# It defines test constraints that are used by several test files in the +# Tk test suite. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. namespace import -force tcltest::testConstraint + +# +# WINDOWING SYSTEM AND DISPLAY +# testConstraint notAqua [expr {[tk windowingsystem] ne "aqua"}] testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}] testConstraint x11 [expr {[tk windowingsystem] eq "x11"}] @@ -275,42 +19,35 @@ testConstraint nonwin [expr {[tk windowingsystem] ne "win32"}] testConstraint aquaOrWin32 [expr { ([tk windowingsystem] eq "win32") || [testConstraint aqua] }] -testConstraint userInteraction 0 -testConstraint nonUnixUserInteraction [expr { - [testConstraint userInteraction] || - ([testConstraint unix] && [testConstraint notAqua]) -}] testConstraint haveDISPLAY [expr {[info exists env(DISPLAY)] && [testConstraint x11]}] testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)] -testConstraint deprecated [expr {![::tk::build-info no-deprecate]}] - # constraint for running a test on all windowing system except aqua # where the test fails due to a known bug testConstraint aquaKnownBug [expr {[testConstraint notAqua] || [testConstraint knownBug]}] -# constraints for testing facilities defined in the tktest executable... -testConstraint testbitmap [llength [info commands testbitmap]] -testConstraint testborder [llength [info commands testborder]] -testConstraint testcbind [llength [info commands testcbind]] -testConstraint testclipboard [llength [info commands testclipboard]] -testConstraint testcolor [llength [info commands testcolor]] -testConstraint testcursor [llength [info commands testcursor]] -testConstraint testembed [llength [info commands testembed]] -testConstraint testfont [llength [info commands testfont]] -testConstraint testImageType [expr {"test" in [image types]}] -testConstraint testmakeexist [llength [info commands testmakeexist]] -testConstraint testmenubar [llength [info commands testmenubar]] -testConstraint testmetrics [llength [info commands testmetrics]] -testConstraint testmovemouse [llength [info commands testmovemouse]] -testConstraint testobjconfig [llength [info commands testobjconfig]] -testConstraint testpressbutton [llength [info commands testpressbutton]] -testConstraint testsend [llength [info commands testsend]] -testConstraint testtext [llength [info commands testtext]] -testConstraint testwinevent [llength [info commands testwinevent]] -testConstraint testwrapper [llength [info commands testwrapper]] +# constraint based on whether our display is secure +testutils import child +childTkProcess create +set app [childTkProcess eval {tk appname}] +testConstraint secureserver 0 +if {[llength [info commands send]]} { + testConstraint secureserver 1 + if {[catch {send $app set a 0} msg] == 1} { + if {[string match "X server insecure *" $msg]} { + testConstraint secureserver 0 + } + } +} +childTkProcess exit +testutils forget child -# constraints about what sort of fonts are available +testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}] +testConstraint failsOnXQuartz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }] + +# +# FONTS +# testConstraint fonts 1 destroy .e entry .e -width 0 -font {Helvetica -12} -bd 1 -highlightthickness 1 @@ -345,13 +82,10 @@ unset fs # in the other one). The following constraints are useful in this kind of # situation. testConstraint haveTimesFamilyFont [expr { - [string tolower [font actual {-family times} -family]] == "times" + [string tolower [font actual {-family times} -family]] eq "times" }] testConstraint haveFixedFamilyFont [expr { - [string tolower [font actual {-family fixed} -family]] == "fixed" -}] -testConstraint haveCourierFamilyFont [expr { - [string tolower [font actual {-family courier} -family]] == "courier" + [string tolower [font actual {-family fixed} -family]] eq "fixed" }] # Although unexpected, some systems may have a very limited set of fonts available. @@ -386,7 +120,9 @@ testConstraint haveBigFontTwiceLargerThanTextFont [expr { }] unset fixedFont bigFont -# constraints for the visuals available +# +# VISUALS +# testConstraint pseudocolor8 [expr { ([catch { toplevel .t -visual {pseudocolor 8} -colormap new @@ -403,30 +139,37 @@ testConstraint defaultPseudocolor8 [expr { ([winfo visual .] eq "pseudocolor") && ([winfo depth .] == 8) }] -# constraint based on whether our display is secure -setupbg -set app [dobg {tk appname}] -testConstraint secureserver 0 -if {[llength [info commands send]]} { - testConstraint secureserver 1 - if {[catch {send $app set a 0} msg] == 1} { - if {[string match "X server insecure *" $msg]} { - testConstraint secureserver 0 - } - } -} -cleanupbg -eval tcltest::configure $argv -namespace import -force tcltest::test -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile -namespace import -force tcltest::makeDirectory -namespace import -force tcltest::removeDirectory -namespace import -force tcltest::interpreter -namespace import -force tcltest::testsDirectory -namespace import -force tcltest::cleanupTests +# +# VARIOUS +# +testConstraint userInteraction 0 +testConstraint nonUnixUserInteraction [expr { + [testConstraint userInteraction] || + ([testConstraint unix] && [testConstraint notAqua]) +}] + +testConstraint deprecated [expr {![::tk::build-info no-deprecate]}] + +# constraints for testing facilities defined in the tktest executable +testConstraint testbitmap [llength [info commands testbitmap]] +testConstraint testborder [llength [info commands testborder]] +testConstraint testcbind [llength [info commands testcbind]] +testConstraint testclipboard [llength [info commands testclipboard]] +testConstraint testcolor [llength [info commands testcolor]] +testConstraint testcursor [llength [info commands testcursor]] +testConstraint testembed [llength [info commands testembed]] +testConstraint testfont [llength [info commands testfont]] +testConstraint testImageType [expr {"test" in [image types]}] +testConstraint testmakeexist [llength [info commands testmakeexist]] +testConstraint testmenubar [llength [info commands testmenubar]] +testConstraint testmetrics [llength [info commands testmetrics]] +testConstraint testmovemouse [llength [info commands testmovemouse]] +testConstraint testobjconfig [llength [info commands testobjconfig]] +testConstraint testpressbutton [llength [info commands testpressbutton]] +testConstraint testsend [llength [info commands testsend]] +testConstraint testtext [llength [info commands testtext]] +testConstraint testwinevent [llength [info commands testwinevent]] +testConstraint testwrapper [llength [info commands testwrapper]] -deleteWindows -wm geometry . {} -raise . +# EOF |