647 lines
19 KiB
Tcl
647 lines
19 KiB
Tcl
# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
|
|
#
|
|
# $Id: TestLib.tcl,v 1.3 2004/03/28 02:44:57 hobbs Exp $
|
|
#
|
|
# TestLib.tcl
|
|
#
|
|
# Procedures used by the Tix test suite.
|
|
#
|
|
# Copyright (c) 1996, Expert Interface Technologies
|
|
#
|
|
# See the file "license.terms" for information on usage and
|
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
#
|
|
set testapp(tix,w,normal) {
|
|
tixButtonBox tixComboBox tixControl tixDirList tixDirTree
|
|
tixExDirSelectBox tixExFileSelectBox tixFileSelectBox tixFileEntry
|
|
tixLabelEntry tixLabelFrame tixNoteBook tixOptionMenu
|
|
tixPanedWindow tixScrolledHList tixScrolledListBox
|
|
tixScrolledTList tixScrolledText tixScrolledWindow tixSelect
|
|
tixStdButtonBox tixTree
|
|
}
|
|
set testapp(tix,w,shell) {
|
|
tixBalloon tixDialogShell tixExFileSelectDialog tixFileSelectDialog
|
|
tixPopupMenu tixStdDialogShell
|
|
}
|
|
set testapp(tix,w,base) {
|
|
tixLabelWidget
|
|
tixPrimitive
|
|
tixScrolledWidget
|
|
tixShell
|
|
tixStackWindow
|
|
tixVResize tixVStack tixVTree
|
|
}
|
|
set testapp(tix,w,unsupported) {
|
|
tixMDIMenuBar
|
|
tixMDIWindow
|
|
tixMwmClient
|
|
tixResizeHandle
|
|
tixSimpleDialog
|
|
tixStatusBar
|
|
}
|
|
|
|
# testConfig(VERBOSE) is the "Verbosity level" of the test suite.
|
|
#
|
|
# 0 -- No messages except name of each test
|
|
# 10 -- Print number of each test block
|
|
# 15 -- Print number and name of each test block
|
|
# 20 -- Print all kinds of messages
|
|
# 30 -- level 20, plus when error occurs, print stack trace.
|
|
#
|
|
if [info exists env(TEST_VERBOSE)] {
|
|
if [catch {
|
|
set testConfig(VERBOSE) [expr "int($env(TEST_VERBOSE) + 0)"]
|
|
}] {
|
|
set testConfig(VERBOSE) 10
|
|
}
|
|
} else {
|
|
set testConfig(VERBOSE) 0
|
|
}
|
|
|
|
set testConfig(errCount) 0
|
|
|
|
#----------------------------------------------------------------------
|
|
#
|
|
# General assertion and evaluation
|
|
#
|
|
#----------------------------------------------------------------------
|
|
|
|
# -------------------------------------------------------------- Assert
|
|
#
|
|
# Evaulates an assertion. Output error message if assertion fails
|
|
#
|
|
proc Assert {cond {printErrInfo 0} {abortMode abortfile}} {
|
|
global errorInfo testConfig
|
|
if [info exists errorInfo] {
|
|
set errorInfo ""
|
|
}
|
|
uplevel 1 [list \
|
|
if !($cond) [list \
|
|
TestError "Failed Assertion \"$cond\"\n \
|
|
evaluated as \"[uplevel 1 subst -nocommand [list $cond]]\"\
|
|
:: [uplevel 1 subst [list $cond]]" $printErrInfo $abortMode
|
|
] \
|
|
]
|
|
}; # Assert
|
|
|
|
# ----------------------------------------------------------- TestAbort
|
|
#
|
|
# Aborts a single test file.
|
|
#
|
|
proc TestAbort {msg} {
|
|
error $msg
|
|
}; # TestAbort
|
|
|
|
# ---------------------------------------------------------------- test
|
|
#
|
|
# Try to evaluate a command.
|
|
#
|
|
proc test {cmd {result {}} {ret {}}} {
|
|
global testConfig
|
|
|
|
if [catch {set ret [uplevel 1 $cmd]} err] {
|
|
set done 0
|
|
foreach r $result {
|
|
if [regexp $r $err] {
|
|
if {$testConfig(VERBOSE) >= 20} {
|
|
puts "Passed (Error message is expected):"
|
|
puts " command = \"$cmd\""
|
|
puts " expected error = \"$result\""
|
|
puts " actual error = $err"
|
|
}
|
|
set done 1
|
|
break
|
|
}
|
|
}
|
|
if {!$done} {
|
|
error $err
|
|
}
|
|
} else {
|
|
if {$testConfig(VERBOSE) >= 20} {
|
|
puts "Passed (Execution OK):\n command = \"$cmd\""
|
|
}
|
|
}
|
|
return $ret
|
|
}; # test
|
|
|
|
# --------------------------------------------------------------- test1
|
|
#
|
|
# Try to evaluate a command and make sure its error result is the same
|
|
# as $result.
|
|
#
|
|
proc test1 {cmd {result {}}} {
|
|
global testConfig
|
|
|
|
set ret ""
|
|
if [catch {set ret [uplevel 1 $cmd]} err] {
|
|
if ![tixStrEq $err $result] {
|
|
error $err
|
|
} else {
|
|
if {$testConfig(VERBOSE) >= 20} {
|
|
puts "Passed (Error message is expected):"
|
|
puts " command = \"$cmd\""
|
|
puts " expected error = \"$result\""
|
|
}
|
|
}
|
|
} else {
|
|
if {$testConfig(VERBOSE) >= 20} {
|
|
puts "Passed (Execution OK):\n command = \"$cmd\""
|
|
}
|
|
}
|
|
return $ret
|
|
}; # test1
|
|
|
|
#----------------------------------------------------------------------
|
|
#
|
|
# Mouse event emulation routines
|
|
#
|
|
#----------------------------------------------------------------------
|
|
|
|
# ------------------------------------------------------------- GetRoot
|
|
#
|
|
# Converts window coordinates to root-window coordinates
|
|
#
|
|
proc GetRoot {w x y} {
|
|
upvar X X
|
|
upvar Y Y
|
|
|
|
set x0 [winfo rootx $w]
|
|
set y0 [winfo rooty $w]
|
|
|
|
set X [expr $x0 + $x]
|
|
set Y [expr $y0 + $y]
|
|
}; # GetRoot
|
|
|
|
# ---------------------------------------------------------- MouseEvent
|
|
#
|
|
# ? simulates mouse event ?
|
|
#
|
|
proc MouseEvent {w type x y args} {
|
|
set tags [bindtags $w]
|
|
GetRoot $w $x $y
|
|
|
|
lappend args %q
|
|
lappend args $w
|
|
lappend args %W
|
|
lappend args $w
|
|
lappend args %x
|
|
lappend args $x
|
|
lappend args %y
|
|
lappend args $y
|
|
lappend args %X
|
|
lappend args $X
|
|
lappend args %Y
|
|
lappend args $Y
|
|
|
|
set found 0
|
|
foreach t $tags {
|
|
set cmd [string trim [bind $t $type]]
|
|
|
|
if {$cmd != ""} {
|
|
set found 1
|
|
}
|
|
foreach {sub val} $args {
|
|
regsub -all $sub $cmd $val cmd
|
|
}
|
|
uplevel #0 $cmd
|
|
}
|
|
if {$found == 0} {
|
|
global testConfig
|
|
if $testConfig(VERBOSE) {
|
|
puts "(testlib warning): $w has no bindings for $type"
|
|
}
|
|
}
|
|
return $found
|
|
}; # MouseEvent
|
|
|
|
# ------------------------------------------------------ KeyboardString
|
|
#
|
|
# Send a string to the widget via a list of key strokes.
|
|
#
|
|
# NOTE: To ensure that an entry widget content is exactly $string, you
|
|
# need to first erase old contents with "$entry delete 0 end"
|
|
#
|
|
proc KeyboardString {w string} {
|
|
set tags [bindtags $w]
|
|
|
|
lappend args %q
|
|
lappend args $w
|
|
lappend args %W
|
|
lappend args $w
|
|
|
|
set found 0
|
|
|
|
foreach c [split $string ""] {
|
|
foreach t $tags {
|
|
set cmd [string trim [bind $t <KeyPress>]]
|
|
|
|
if {$cmd != ""} {
|
|
set found 1
|
|
}
|
|
set list $args
|
|
lappend list %A
|
|
lappend list [list $c]
|
|
|
|
foreach {sub val} $list {
|
|
regsub -all $sub $cmd $val cmd
|
|
}
|
|
|
|
# This is really weird: If our char is '\', the lappend line
|
|
# makes it a quoted \\, but the previous regsub converts it
|
|
# back to a single quote. So we use regsub again to make it
|
|
# a \\ again. But that's not enough, because uplevel will
|
|
# change it back to a single quote and will eventually mess
|
|
# us up. Hence we use 4 slashes here!
|
|
#
|
|
regsub -all {[\\]} $cmd {\\\\} cmd
|
|
uplevel #0 $cmd
|
|
}
|
|
}
|
|
if {$found == 0} {
|
|
puts "warning: widget $w has no bindings for $type"
|
|
}
|
|
return $found
|
|
}; # KeyboardString
|
|
|
|
# ------------------------------------------------------- KeyboardEvent
|
|
#
|
|
# Send a special keyboard event to the widget. E.g., <Return>, <space>,
|
|
# <Escape>, <BackSpace> etc. To send ASCII character strings, use
|
|
# KeyboardString
|
|
#
|
|
proc KeyboardEvent {w type} {
|
|
set tags [bindtags $w]
|
|
|
|
lappend args %q
|
|
lappend args $w
|
|
lappend args %W
|
|
lappend args $w
|
|
|
|
set found 0
|
|
foreach t $tags {
|
|
set cmd [string trim [bind $t $type]]
|
|
|
|
if {$cmd != ""} {
|
|
set found 1
|
|
}
|
|
foreach {sub val} $args {
|
|
regsub -all $sub $cmd $val cmd
|
|
}
|
|
uplevel #0 $cmd
|
|
}
|
|
if {$found == 0} {
|
|
puts "warning: widget $w has no bindings for $type"
|
|
}
|
|
return $found
|
|
}; # KeyboardEvent
|
|
|
|
# ----------------------------------------------------- Event-Initialize
|
|
#
|
|
# Initialize event data; called from Driver.tcl/Driver:Test
|
|
#
|
|
proc Event-Initialize {} {
|
|
global app
|
|
|
|
set app(X) -1000
|
|
set app(Y) -1000
|
|
set app(curWid) {}
|
|
}; # Event-Initialize
|
|
|
|
# ------------------------------------------------------------ InWidget
|
|
#
|
|
# test if point is within window
|
|
#
|
|
proc InWidget {w} {
|
|
global app
|
|
|
|
set a [tixWithinWindow $w $app(X) $app(Y)]
|
|
# insert debug print here
|
|
return $a
|
|
}; # InWidget
|
|
|
|
# --------------------------------------------------------------- Leave
|
|
#
|
|
# simulate <Leave> event
|
|
#
|
|
proc Leave {w {x -10} {y -10} args} {
|
|
global app
|
|
|
|
eval MouseEvent $w <Leave> $x $y $args
|
|
}; # Leave
|
|
|
|
# ------------------------------------------------------------ B1-Leave
|
|
#
|
|
# simulate <Leave> event (?identical to Leave?)
|
|
#
|
|
proc B1-Leave {w {x -10} {y -10} args} {
|
|
global app
|
|
|
|
eval MouseEvent $w <Leave> $x $y $args
|
|
}; # B1-Leave
|
|
|
|
# ---------------------------------------------------------- RecordRoot
|
|
#
|
|
# Converts event coordinates to root-window coordinates and records them
|
|
#
|
|
proc RecordRoot {w x y} {
|
|
global app
|
|
|
|
GetRoot $w $x $y
|
|
set app(X) $X
|
|
set app(Y) $Y
|
|
}; # RecordRoot
|
|
|
|
# --------------------------------------------------------------- Enter
|
|
#
|
|
# simulate <Enter> event
|
|
#
|
|
proc Enter {w {x -1} {y -1} args} {
|
|
global app
|
|
|
|
if {$y == -1} {
|
|
set x [expr [winfo width $w] / 2]
|
|
set y [expr [winfo height $w] / 2]
|
|
}
|
|
|
|
if {$app(curWid) != {} && [winfo exists $app(curWid)]} {
|
|
Leave $app(curWid)
|
|
}
|
|
RecordRoot $w $x $y
|
|
|
|
eval MouseEvent $w <Enter> $x $y $args
|
|
set app(curWid) $w
|
|
}; # Enter
|
|
|
|
# ---------------------------------------------------------------- Drag
|
|
#
|
|
# simulate <Drag> event
|
|
#
|
|
proc Drag {w {x -1} {y -1} args} {
|
|
global app
|
|
|
|
if {$y == -1} {
|
|
set x [expr [winfo width $w] / 2]
|
|
set y [expr [winfo height $w] / 2]
|
|
}
|
|
|
|
if {![InWidget $w]} {
|
|
B1-Leave $w $x $y
|
|
}
|
|
|
|
eval MouseEvent $w <B1-Motion> $x $y $args
|
|
}; # Drag
|
|
|
|
# ------------------------------------------------------------- Release
|
|
#
|
|
# simulate <ButtonRelease-1> event
|
|
#
|
|
proc Release {w {x -1} {y -1} args} {
|
|
global app
|
|
|
|
if {$y == -1} {
|
|
set x [expr [winfo width $w] / 2]
|
|
set y [expr [winfo height $w] / 2]
|
|
}
|
|
eval MouseEvent $w <ButtonRelease-1> $x $y $args
|
|
}; # Release
|
|
|
|
# ------------------------------------------------------------ HoldDown
|
|
#
|
|
# simulate <ButtonPress-1> event (assumming button was not already down)
|
|
#
|
|
proc HoldDown {w {x -1} {y -1} args} {
|
|
global app
|
|
|
|
if {$y == -1} {
|
|
set x [expr [winfo width $w] / 2]
|
|
set y [expr [winfo height $w] / 2]
|
|
}
|
|
if {![InWidget $w]} {
|
|
Enter $w $x $y
|
|
}
|
|
|
|
if {![eval MouseEvent $w <ButtonPress-1> $x $y $args]} {
|
|
eval MouseEvent $w <1> $x $y $args
|
|
}
|
|
}; # HoldDown
|
|
|
|
# --------------------------------------------------------------- Click
|
|
#
|
|
# simulate <ButtonRelease-1> event
|
|
#
|
|
proc Click {w {x -1} {y -1} args} {
|
|
global app
|
|
|
|
if {$y == -1} {
|
|
set x [expr [winfo width $w] / 2]
|
|
set y [expr [winfo height $w] / 2]
|
|
}
|
|
eval HoldDown $w $x $y $args
|
|
eval MouseEvent $w <ButtonRelease-1> $x $y $args
|
|
}; # Click
|
|
|
|
# -------------------------------------------------------------- Double
|
|
#
|
|
# simulate <Double-1> event
|
|
#
|
|
proc Double {w {x -1} {y -1} args} {
|
|
global app
|
|
|
|
if {$y == -1} {
|
|
set x [expr [winfo width $w] / 2]
|
|
set y [expr [winfo height $w] / 2]
|
|
}
|
|
eval MouseEvent $w <Double-1> $x $y $args
|
|
}; # Double
|
|
|
|
# --------------------------------------------------- ClickListboxEntry
|
|
#
|
|
# Simulate the event where a listbox entry is clicked.
|
|
#
|
|
# Args:
|
|
# w pathname of listbox
|
|
# index index of entry to be clicked.
|
|
# mode "single" ==> single click, "double" ==> double click
|
|
#
|
|
proc ClickListboxEntry {w index {mode single}} {
|
|
$w see $index
|
|
set bbox [$w bbox $index]
|
|
set x1 [lindex $bbox 0]
|
|
set y1 [lindex $bbox 1]
|
|
|
|
if {$mode == "single"} {
|
|
Click $w $x1 $y1
|
|
} else {
|
|
Double $w $x1 $y1
|
|
}
|
|
}; # ClickListboxEntry
|
|
|
|
# ----------------------------------------------------- ClickHListEntry
|
|
#
|
|
# Simulate the event where an HList entry is clicked.
|
|
#
|
|
# Args:
|
|
# w pathname of HList
|
|
# index index of entry to be clicked.
|
|
# mode "single" ==> single click, "double" ==> double click
|
|
#
|
|
proc ClickHListEntry {w index {mode single}} {
|
|
$w see $index
|
|
update
|
|
set bbox [$w info bbox $index]
|
|
set x1 [lindex $bbox 0]
|
|
set y1 [lindex $bbox 1]
|
|
|
|
if {$mode == "single"} {
|
|
Click $w $x1 $y1
|
|
} else {
|
|
Double $w $x1 $y1
|
|
}
|
|
}; # ClickHListEntry
|
|
|
|
# ------------------------------------------------- InvokeComboBoxByKey
|
|
#
|
|
# Simulate the event when the user types in a string into the
|
|
# entry subwidget of a ComboBox widget and then type Return
|
|
#
|
|
proc InvokeComboBoxByKey {w string} {
|
|
set ent [$w subwidget entry]
|
|
$ent delete 0 end
|
|
KeyboardString $ent $string
|
|
KeyboardEvent $ent <Return>
|
|
update
|
|
}; # InvokeComboBoxByKey
|
|
|
|
# ---------------------------------------------------- SetComboBoxByKey
|
|
#
|
|
# Simulate the event when the user types in a string into the
|
|
# entry subwidget of a ComboBox widget, *without* a subsequent
|
|
# Return keystroke.
|
|
#
|
|
proc SetComboBoxByKey {w string} {
|
|
set ent [$w subwidget entry]
|
|
$ent delete 0 end
|
|
KeyboardString $ent $string
|
|
update
|
|
}; # SetComboBoxByKey
|
|
|
|
#----------------------------------------------------------------------
|
|
#
|
|
# main routines
|
|
#
|
|
#----------------------------------------------------------------------
|
|
|
|
# ---------------------------------------------------------------- Done
|
|
proc Done {args} {
|
|
global testConfig
|
|
|
|
if {$testConfig(VERBOSE) >= 20} {
|
|
puts "--------------------- done ----------------------------"
|
|
}
|
|
}; # Done
|
|
|
|
# ---------------------------------------------------------------- Wait
|
|
proc Wait {msecs} {
|
|
global Test:timer
|
|
set Test:timer 0
|
|
after $msecs uplevel #0 set Test:timer 1
|
|
tkwait variable Test:timer
|
|
}; # Wait
|
|
|
|
#----------------------------------------------------------------------
|
|
#
|
|
# Messages
|
|
#
|
|
#----------------------------------------------------------------------
|
|
|
|
# ---------------------------------------------------------------- PutP
|
|
proc PutP {msg} {
|
|
puts $msg
|
|
}; # PutP
|
|
|
|
# ----------------------------------------------------------- TestError
|
|
#
|
|
# Handle an error
|
|
#
|
|
proc TestError {msg {printErrInfo 0} {abortMode cont}} {
|
|
global testConfig
|
|
puts " $msg"
|
|
case $abortMode {
|
|
cont {
|
|
if {$printErrInfo || $testConfig(VERBOSE) >= 30} {
|
|
global errorInfo
|
|
puts "\$errorInfo = $errorInfo"
|
|
}
|
|
return
|
|
}
|
|
abortfile {
|
|
return -code 1234
|
|
}
|
|
abortall {
|
|
global errorInfo
|
|
puts "Aborting all test files because of error:"
|
|
puts $errorInfo
|
|
exit 1
|
|
}
|
|
}
|
|
}; # TestError
|
|
|
|
# ----------------------------------------------------------- TestBlock
|
|
#
|
|
# Performs a block of test. A block is mainly used to group
|
|
# together tests that are dependent on each other. TestBlocks
|
|
# may be nested.
|
|
#
|
|
# Args:
|
|
# name: Textual name of the test. E.g.: button-1.1
|
|
# description: Short description of the test. "Pressing button"
|
|
# printErrInfo: If an error occurs, should the errorInfo be printed
|
|
# to the console. (Normally only a one-liner error
|
|
# message is printed).
|
|
# aMode:
|
|
# cont -- skip this block and go to the next block
|
|
# abortfile -- skip all other blocks in this file
|
|
# abortall -- skip all the Tix tests.
|
|
#
|
|
proc TestBlock {name description script {printErrInfo 0} {aMode cont}} {
|
|
global testConfig
|
|
|
|
# without this, we get a failure in the "Clicking a button" test of
|
|
# general/event0.tcl because, Click-->HoldDown-->InWidget returns
|
|
# true and so the Enter command never gets invoked.
|
|
#
|
|
Event-Initialize
|
|
|
|
set code [catch {uplevel 1 $script} result]
|
|
|
|
if {$testConfig(VERBOSE) >= 15} {
|
|
set des "($description)"
|
|
} else {
|
|
set des ""
|
|
}
|
|
|
|
if {$code != 0} {
|
|
incr testConfig(errCount)
|
|
puts stdout "---- $name FAILED $des"
|
|
puts "Script is"
|
|
foreach line [split $script \n] {
|
|
regsub "^\[[format %s \ \n\t]\]*" $line "" line
|
|
puts " $line"
|
|
}
|
|
puts "Error message:"
|
|
TestError $result $printErrInfo $aMode
|
|
puts stdout "----"
|
|
} elseif $testConfig(VERBOSE) {
|
|
puts stdout "++++ $name PASSED $des"
|
|
}
|
|
}; # TestBlock
|
|
|
|
#----------------------------------------------------------------------
|
|
#
|
|
# general initialization
|
|
#
|
|
#----------------------------------------------------------------------
|
|
|
|
# place main window in predictable spot
|
|
wm geometry . +0+0
|