diff options
Diffstat (limited to 'tests/testutils.tcl')
| -rw-r--r-- | tests/testutils.tcl | 989 |
1 files changed, 989 insertions, 0 deletions
diff --git a/tests/testutils.tcl b/tests/testutils.tcl new file mode 100644 index 0000000..322e277 --- /dev/null +++ b/tests/testutils.tcl @@ -0,0 +1,989 @@ +# testutils.tcl -- +# +# This file is sourced by each test file when invoking "tcltest::loadTestedCommands". +# It implements the testutils mechanism which is used to import utility procs +# into test files that need them. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# +# DOCUMENTATION FOR TEST AUTHORS AND MAINTAINERS +# +# The testutils mechanism is documented in the separate file "testutils.GUIDE", +# which is placed in the same directory as this file "testutils.tcl". +# + +namespace eval ::tk::test { + # + # The namespace ::tk::test itself doesn't contain any procs or variables. + # The contents of this namespace exist solely in child namespaces that + # are defined hereafter. + # + # Each child namespace represents a functional area, also called "domain". + # +} + + +namespace eval ::tk::test::generic { + + proc assert {expr} { + if {! [uplevel 1 [list expr $expr]]} { + return -code error "assertion failed: \"[uplevel 1 [list subst -nocommands $expr]]\"" + } + } + + # controlPointerWarpTiming -- + # + # This proc 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 + } + } + + 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 + } + + 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 + } + + proc loadTkCommand {} { + variable TkLoadCmd + if {! [info exists TkLoadCmd]} { + foreach pkg [info loaded] { + if {[lindex $pkg 1] eq "Tk"} { + set TkLoadCmd [list load {*}$pkg] + break + } + } + } + return $TkLoadCmd + } + + # Suspend script execution for a given amount of time, but continue + # processing events. + proc pause {ms} { + variable _pause + + set num [incr _pause(count)] + set _pause($num) 1 + + after $ms [list unset [namespace current]::_pause($num)] + vwait [namespace current]::_pause($num) + } + + # 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 + } + } + } + + # testutils -- + # + # Takes care of exporting/importing/forgetting utility procs and any + # associated variables from a specific test domain (functional area). + # + # More information is available in the file "testutils.GUIDE" + # + # Arguments: + # subCmd : "export", "import" or "forget" + # args : a sequence of domains that need to be imported/forgotten, + # unused for "export" + # + proc testutils {subCmd args} { + variable importedDomains + variable importVars + + if {$subCmd ni [list export import forget]} { + return -code error "invalid subCmd \"$subCmd\". Usage: [lindex [info level 0] 0] export|import|forget ?domain domain ...?" + } + + set argc [llength $args] + if {$subCmd eq "export"} { + if {$argc != 0} { + return -code error "invalid #args. Usage: [lindex [info level 0] 0] export" + } + + # export all procs from the invoking domain namespace except "init" + uplevel 1 { + if {[info procs init] eq "init"} { + set exports [info procs] + namespace export {*}[lremove $exports [lsearch $exports "init"]] + unset exports + } else { + namespace export * + } + } + return + } + if {$argc < 1} { + return -code error "invalid #args. Usage: [lindex [info level 0] 0] import|forget domain ?domain ...?" + } + + # determine the requesting namespace + set ns [uplevel 1 {namespace current}] + + # import/forget domains + foreach domain $args { + if {! [namespace exists ::tk::test::$domain]} { + return -code error "testutils domain \"$domain\" doesn't exist" + } + + switch -- $subCmd { + import { + if {[info exists importedDomains($ns)] && ($domain in $importedDomains($ns))} { + return -code error "testutils domain \"$domain\" was already imported" + } else { + + # import procs + if {[catch { + uplevel 1 [list namespace import ::tk::test::${domain}::*] + } errMsg]} { + # revert import of procs already done + uplevel 1 [list namespace forget ::tk::test::${domain}::*] + return -code error "import from testutils domain \"$domain\" failed: $errMsg" + } + + # import associated namespace variables declared in the init proc + if {"init" in [namespace inscope ::tk::test::$domain {info procs init}]} { + if {[info exists importVars($ns,$domain)]} { + # + # Note [A1]: + # If test files inadvertently leave behind a variable with the same name + # as an upvar'ed namespace variable, its last value will serve as a new + # initial value in case that the init proc declares that variable without + # a value. Also, the result of "info exists varName" would be different + # between test files. + # + # The next unset prevents such artefacts. See also note [A2] below. + # + uplevel 1 [list unset -nocomplain {*}$importVars($ns,$domain)] + } + ::tk::test::${domain}::init + if {($ns ne "::") || (! [info exists importVars($ns,$domain)])} { + # + # Importing associated namespace variables into the global namespace where + # tests are normally executing, needs to be done only once because an upvar + # link cannot be removed from a namespace. For other requesting namespaces + # we need to reckon with deletion and re-creation of the namespace in the + # meantime. + # + if {[info exists importVars($ns,$domain)]} { + set associatedVars $importVars($ns,$domain) + } else { + set associatedVars [namespace inscope ::tk::test::$domain {info vars}] + } + foreach varName $associatedVars { + if {[catch { + uplevel 1 [list upvar #0 ::tk::test::${domain}::$varName $varName] + } errMsg]} { + # revert imported procs and partial variable import + uplevel 1 [list unset -nocomplain {*}$associatedVars] + uplevel 1 [list namespace forget ::tk::test::${domain}::*] + return -code error "import from testutils domain \"$domain\" failed: $errMsg" + } + } + set importVars($ns,$domain) $associatedVars + } + } + + # register domain as imported + lappend importedDomains($ns) $domain + } + } + forget { + if {(! [info exists importedDomains($ns)]) || ($domain ni $importedDomains($ns))} { + return -code error "testutils domain \"$domain\" was not imported" + } + + # remove imported utility procs from the namespace where tests are executing + uplevel 1 [list namespace forget ::tk::test::${domain}::*] + + # + # Some namespace variables are meant to persist across test files + # in the entire Tk test suite (notably the variable ImageNames, + # domain "image"). These variables are also not meant to be accessed + # from, and imported into the namespace where tests are executing, + # and they should not be cleaned up here. + # + + if {[info exists importVars($ns,$domain)]} { + # + # Remove imported namespace variables. + # + # Note [A2]: + # The upvar link in the namespace where tests are executing cannot be removed. + # Without specific attention, this can cause surprising behaviour upon + # re-initialization. See also note [A1] above. + # + uplevel 1 [list unset -nocomplain {*}$importVars($ns,$domain)] + } + set importedDomains($ns) [lremove $importedDomains($ns) [lsearch $importedDomains($ns) $domain]] + } + } + } + } + + testutils export +} + +# Import generic utility procs into the global namespace (in which tests are +# normally executing) as a standard policy. +::tk::test::generic::testutils import generic + +namespace eval ::tk::test::button { + proc bogusTrace args { + error "trace aborted" + } + testutils export +} + +namespace eval ::tk::test::child { + + # childTkInterp -- + # + # Create a new Tk application in a child interpreter, with + # a given name and class. + # + proc childTkInterp {name args} { + set index [lsearch $args "-safe"] + if {$index >= 0} { + set safe 1 + set options [lremove $args $index] + } else { + set safe 0 + set options $args + } + if {[llength $options] ni {0 2}} { + return -code error "invalid #args" + } + + set cmdArgs [list -name $name] + foreach {key value} $options { + if {$key ne "-class"} { + return -code error "invalid option \"$key\"" + } + lappend cmdArgs $key $value + } + + if {$safe} { + interp create -safe $name + } else { + interp create $name + } + + $name eval [list set argv $cmdArgs] + catch {eval [loadTkCommand] $name} + } + + # childTkProcess -- + # + # 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 + switch -- $subcmd { + create { + if {[info exists fd] && [string length $fd]} { + childTkProcess exit + } + set fd [open "|[list [::tcltest::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 \"[::tcltest::interpreter]\"" + } + if {$data ne "foo"} { + error "unexpected output from\ + background process: \"$data\"" + } + puts $fd [loadTkCommand] + flush $fd + fileevent $fd readable [namespace code {childTkProcess read}] + } + eval { + variable Data + variable Done + + set script [lindex $args 0] + set block 0 + if {[llength $args] == 2} { + set block [lindex $args 1] + } + + if {$block} { + fileevent $fd readable {} + } + puts $fd "[list catch $script 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 + } + exit { + # catch in case the child process has closed $fd + catch {puts $fd exit} + catch {close $fd} + set fd "" + } + read { + 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 + } + } + } + } + + testutils export +} + +namespace eval ::tk::test::colors { + # colorsFree -- + # + # Returns 1 if there appear to be free colormap entries in a window, 0 + # otherwise. + # + # Arguments: + # w : name of window in which to check. + # red, green, blue : intensities to use in a trial color allocation + # to see if there are colormap entries free. + # + proc colorsFree {w {red 31} {green 245} {blue 192}} { + lassign [winfo rgb $w [format "#%02x%02x%02x" $red $green $blue]] r g b + expr {($r/256 == $red) && ($g/256 == $green) && ($b/256 == $blue)} + } + + # eatColors -- + # + # Creates a toplevel window and allocates enough colors in it to use up all + # the slots in an 8-bit colormap. + # + # Arguments: + # w : name of toplevel window to create. + # + proc eatColors {w} { + catch {destroy $w} + toplevel $w + wm geom $w +0+0 + canvas $w.c -width 400 -height 200 -bd 0 + pack $w.c + for {set y 0} {$y < 8} {incr y} { + for {set x 0} {$x < 40} {incr x} { + set color [format #%02x%02x%02x [expr {$x*6}] [expr {$y*30}] 0] + $w.c create rectangle [expr {10*$x}] [expr {20*$y}] \ + [expr {10*$x + 10}] [expr {20*$y + 20}] -outline {} \ + -fill $color + } + } + update + } + + testutils export +} + +namespace eval ::tk::test::dialog { + + # 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 dialogType [file rootname [file tail [info script]]] + variable dialogIsNative [isNative $dialogType] + variable testDialog + variable testDialogFont + } + + proc Click {button} { + variable dialogType + variable testDialog + + switch -- $dialogType { + "fontchooser" { + if {$button ni "ok cancel apply"} { + return -code error "invalid button name \"$button\"" + } + $testDialog.$button invoke + } + "winDialog" { + switch -exact -- $button { + ok { set button 1 } + cancel { set button 2 } + } + testwinevent $testDialog $button WM_LBUTTONDOWN 1 0x000a000b + testwinevent $testDialog $button WM_LBUTTONUP 0 0x000a000b + } + default { + return -code error "invalid dialog type \"$dialogType\"" + } + } + } + + proc isNative {type} { + switch -- $type { + "choosedir" { + set cmd ::tk_chooseDirectory + } + "clrpick" { + set cmd ::tk_chooseColor + } + "filebox" { + set cmd ::tk_getOpenFile + } + "msgbox" { + set cmd ::tk_messageBox + } + "dialog" - + "fontchooser" - + "winDialog" { + return "N/A" + } + default { + return -code error "invalid dialog type \"$type\"" + } + } + return [expr {[info procs $cmd] eq ""}] + } + + proc PressButton {btn} { + event generate $btn <Enter> + event generate $btn <Button-1> -x 5 -y 5 + event generate $btn <ButtonRelease-1> -x 5 -y 5 + } + + proc SendButtonPress {parent btn buttonType} { + variable dialogType + switch -- $dialogType { + "choosedir" { + if {$parent eq "."} { + set w .__tk_choosedir + } else { + set w $parent.__tk_choosedir + } + upvar ::tk::dialog::file::__tk_choosedir data + } + "clrpick" { + set w .__tk__color + upvar ::tk::dialog::color::[winfo name $w] data + } + "filebox" { + if {$parent eq "."} { + set w .__tk_filedialog + } else { + set w $parent.__tk_filedialog + } + upvar ::tk::dialog::file::__tk_filedialog data + } + "msgbox" { + if {$parent eq "."} { + set w .__tk__messagebox + } else { + set w $parent.__tk__messagebox + } + } + default { + return -code error "invalid dialog type \"$dialogType\"" + } + } + + if {$dialogType eq "msgbox"} { + set button $w.$btn + } else { + set button $data($btn\Btn) + } + if {! [winfo ismapped $button]} { + update + } + + if {$buttonType eq "mouse"} { + PressButton $button + } else { + event generate $w <Enter> + focus $w + event generate $button <Enter> + event generate $w <Key> -keysym Return + } + } + + proc testDialog {stage {script ""}} { + variable testDialogCmd + variable testDialogResult + variable testDialogFont + variable iter_after + variable testDialog; # On MS Windows, this variable is set at the C level + # by SetTestDialog() in tkWinDialog.c + + switch -- $stage { + launch { + set iter_after 0 + set testDialog {} + if {$::tcl_platform(platform) eq "windows"} { + variable testDialogClass "#32770" + } + + after 1 $script + } + onDisplay { + set testDialogCmd $script + set testDialogResult {} + set testDialogFont {} + + if {$::tcl_platform(platform) eq "windows"} { + # Do not make the delay too short. The newer Vista dialogs take + # time to come up. + after 500 [list [namespace current]::testDialog onDisplay2] + } else { + testDialog onDisplay2 + } + vwait ::tk::test::dialog::testDialogResult + return $testDialogResult + } + onDisplay2 { + set doRepeat 0 + + if {$::tcl_platform(platform) eq "windows"} { + # On Vista and later, using the new file dialogs we have to + # find the window using its title as testDialog will not be + # set at the C level. + variable testDialogClass + if {[catch {testfindwindow "" $testDialogClass} testDialog]} { + set doRepeat 1 + } + } elseif {$testDialog eq ""} { + set doRepeat 1 + } + + if {$doRepeat} { + if {[incr iter_after] > 30} { + set testDialogResult ">30 iterations waiting for testDialog" + return + } + after 150 [list ::tk::test::dialog::testDialog onDisplay2] + return + } + set testDialogResult [uplevel #0 $testDialogCmd] + } + default { + return -code error "invalid parameter \"$stage\"" + } + } + } + + proc ToPressButton {parent btn} { + variable dialogIsNative + if {! $dialogIsNative} { + after 100 SendButtonPress $parent $btn mouse + } + } + + testutils export +} + + +namespace eval ::tk::test::entry { + + # 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 textVar + variable validationData + } + + # Handler for variable trace on namespace variable textVar + proc override args { + variable textVar 12345 + } + + # Procedures used by widget validation tests + proc validateCommand1 {W d i P s S v V} { + variable validationData [list $W $d $i $P $s $S $v $V] + return 1 + } + proc validateCommand2 {W d i P s S v V} { + variable validationData [list $W $d $i $P $s $S $v $V] + variable textVar mydata + return 1 + } + proc validateCommand3 {W d i P s S v V} { + variable validationData [list $W $d $i $P $s $S $v $V] + return 0 + } + proc validateCommand4 {W d i P s S v V} { + variable validationData [list $W $d $i $P $s $S $v $V] + .e delete 0 end; + .e insert end dovaldata + return 0 + } + + testutils export +} + +namespace eval ::tk::test::geometry { + proc getsize {w} { + update + return "[winfo reqwidth $w] [winfo reqheight $w]" + } + + testutils export +} + +namespace eval ::tk::test::image { + + proc imageCleanup {} { + variable ImageNames + foreach img [image names] { + if {$img ni $ImageNames} {image delete $img} + } + } + + 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 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 imageNames {} { + variable ImageNames + set r {} + foreach img [image names] { + if {$img ni $ImageNames} {lappend r $img} + } + return $r + } + + testutils export +} + +namespace eval ::tk::test::scroll { + + # 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 scrollInfo {} + } + + # Used as the scrolling command for widgets, set with "-[xy]scrollcommand". + # It saves the scrolling information in a namespace variable "scrollInfo". + proc setScrollInfo {args} { + variable scrollInfo $args + } + + testutils export +} + +namespace eval ::tk::test::select { + + # 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 selValue {} selInfo {} + variable abortCount + variable pass + } + + proc badHandler {path type offset count} { + variable selInfo + variable selValue + selection handle -type $type $path {} + lappend selInfo $path $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr {$numBytes+$offset}] + } + + proc badHandler2 {path type offset count} { + variable abortCount + variable selInfo + variable selValue + incr abortCount -1 + if {$abortCount == 0} { + selection handle -type $type $path {} + } + lappend selInfo $path $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr {$numBytes+$offset}] + } + + proc errHandler args { + error "selection handler aborted" + } + + proc errIncrHandler {type offset count} { + variable selInfo + variable selValue + variable pass + if {$offset == 4000} { + if {$pass == 0} { + # Just sizing the selection; don't do anything here. + set pass 1 + } else { + # Fetching the selection; wait long enough to cause a timeout. + after 6000 + } + } + lappend selInfo $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] + } + + proc handler {type offset count} { + variable selInfo + variable selValue + lappend selInfo $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr $numBytes+$offset] + } + + proc reallyBadHandler {path type offset count} { + variable selInfo + variable selValue + variable pass + if {$offset == 4000} { + if {$pass == 0} { + set pass 1 + } else { + selection handle -type $type $path {} + } + } + lappend selInfo $path $type $offset $count + set numBytes [expr {[string length $selValue] - $offset}] + if {$numBytes <= 0} { + return "" + } + string range $selValue $offset [expr {$numBytes+$offset}] + } + + proc selectionSetup {{path .f1} {display {}}} { + catch {destroy $path} + if {$display eq ""} { + frame $path + } else { + toplevel $path -screen $display + wm geom $path +0+0 + } + selection own $path + } + + testutils export +} + +namespace eval ::tk::test::text { + + # 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 fixedFont {Courier -12} + variable fixedWidth [font measure $fixedFont m] + variable fixedHeight [font metrics $fixedFont -linespace] + variable fixedAscent [font metrics $fixedFont -ascent] + } + + # full border size of the text widget, i.e. first x or y coordinate inside the text widget + # warning: -padx is supposed to be the same as -pady (same border size horizontally and + # vertically around the widget) + proc bo {{w .t}} { + return [expr {[$w cget -borderwidth] + [$w cget -highlightthickness] + [$w cget -padx]}] + } + + # x-coordinate of the first pixel of $n-th char (count starts at zero), left justified + proc xchar {n {w .t}} { + return [expr {[bo $w] + [xw $n]}] + } + + # x-width of $n chars, fixed width font + proc xw {n} { + variable fixedWidth + return [expr {$n * $fixedWidth}] + } + + # y-coordinate of the first pixel of $l-th display line (count starts at 1) + proc yline {l {w .t}} { + variable fixedHeight + return [expr {[bo $w] + ($l - 1) * $fixedHeight}] + } + + testutils export +} + +# EOF |