URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tix/] [tests/] [library/] [TestLib.tcl] - Blame information for rev 1771

Go to most recent revision | Details | Compare with Previous | View Log


# TestLib.tcl --
#
#       Implements the 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 the name of the tests
#       10 -- Print out the number of each test block
#       15 -- Print out the number and name of each test block
#       20 -- Print out all kinds of messages
#       30 -- level 20, plus when an error occurs, prints out the 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 the assertion is false
#
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
        ] \
    ]
}
 
# TestAbort --
#
#       Aborts a single test file.
#
proc TestAbort {msg} {
    error $msg
}
 
# 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
}
 
# 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
}
 
#----------------------------------------------------------------------
#
#       Mouse event emulation routines
#
#----------------------------------------------------------------------
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]
}
 
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
        }
        tixForEach {sub val} $args {
            regsub -all $sub $cmd $val cmd
        }
        uplevel #0 $cmd
    }
    if {$found == 0} {
        global testConfig
        if $testConfig(VERBOSE) {
            puts "(testlib warning): widget $w has no bindings for $type"
        }
    }
    return $found
}
 
# KeyboardString --
#
#       Send a string to the widget via a list of key strokes. This does
#       NOT ensure that an entry widget has the exact content as $string.
#       You need to call $entry delete 0 end first!
#
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]
 
            tixForEach {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 makes 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 quad-slashes here!
            #
            regsub -all {[\\]} $cmd {\\\\} cmd
            uplevel #0 $cmd
        }
    }
    if {$found == 0} {
        puts "warning: widget $w has no bindings for $type"
    }
    return $found
 
}
 
# 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
        }
        tixForEach {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
}
 
proc Event-Initialize {} {
    global app
 
    set app(X)      -1000
    set app(Y)      -1000
    set app(curWid) {}
}
 
proc InWidget {w} {
    global app
 
    return [tixWithinWindow $w $app(X) $app(Y)]
}
 
proc Leave {w {x -10} {y -10} args} {
    global app
 
    eval MouseEvent $w <Leave> $x $y $args
}
 
proc B1-Leave {w {x -10} {y -10} args} {
    global app
 
    eval MouseEvent $w <Leave> $x $y $args
}
 
proc RecordRoot {w x y} {
    global app
 
    GetRoot $w $x $y
    set app(X) $X
    set app(Y) $Y
}
 
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
}
 
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
}
 
# Release --
#
#       Release mouse button 1 in a widget
#
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
}
 
# Assumming the button was not originally 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
    }
}
 
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
}
 
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
}
 
# ClickListboxEntry --
#
#       Simulate the event where a listbox entry is clicked.
# Args:
#       w:widget        pathname of listbox
#       index:LbIndex   index of entry to be clicked.
#       mode:string     "single" or "double" indicating whether a single or
#                       double click is desired.
#
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
    }
}
 
# ClickHListEntry --
#
#       Simulate the event where an HList entry is clicked.
# Args:
#       w:widget        pathname of HList
#       index:HLIndex   index of entry to be clicked.
#       mode:string     "single" or "double" indicating whether a single or
#                       double click is desired.
#
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
    }
}
 
# 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
}
 
# 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
}
 
#----------------------------------------------------------------------
#
#                       main routines
#
#----------------------------------------------------------------------
 
proc Done {args} {
    global testConfig
 
    if {$testConfig(VERBOSE) >= 20} {
        puts "------------------------done--------------------------------"
    }
}
 
proc Wait {msecs} {
    global Test:timer
    set Test:timer 0
    after $msecs uplevel #0 set Test:timer 1
    tkwait variable Test:timer
}
 
proc TestPuts {msg} {
    puts $msg
}
 
#----------------------------------------------------------------------
#
#                       Messages
#
#----------------------------------------------------------------------
proc PutP {msg} {
    puts $msg
}
proc PutTitle {msg} {
    puts $msg
}
proc PutSubTitle {msg} {
    puts $msg
}
proc PutSubSubTitle {msg} {
    puts $msg
}
proc TestWarn {msg} {
    puts "Warning: $msg"
}
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 the unrecoverable error:"
            puts $errorInfo
            exit 1
        }
    }
}
 
# 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).
#       abortMode:      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} {abortMode cont}} {
    global testConfig
 
    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 $abortMode
        puts stdout "----"
    } elseif $testConfig(VERBOSE) {
        puts stdout "++++ $name PASSED $des"
    }
}
 
#----------------------------------------------------------------------
#
#                       general initialization
#
#----------------------------------------------------------------------
 
# init the event emulation
#
 
# some window managers don't put the main window at a default place, this
# may be quite annoying for the user
#
wm geometry . +0+0
 

Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tix/] [tests/] [library/] [TestLib.tcl] - Blame information for rev 1771

Line No.	Rev	Author	Line
1	578	markom	`# TestLib.tcl --`
2			`#`
3			`# Implements the procedures used by the Tix test suite.`
4			`#`
5			`# Copyright (c) 1996, Expert Interface Technologies`
6			`#`
7			`# See the file "license.terms" for information on usage and redistribution`
8			`# of this file, and for a DISCLAIMER OF ALL WARRANTIES.`
9			`#`
10
11			`set testapp(tix,w,normal) {`
12			`tixButtonBox tixComboBox tixControl tixDirList tixDirTree`
13			`tixExDirSelectBox tixExFileSelectBox tixFileSelectBox tixFileEntry`
14			`tixLabelEntry tixLabelFrame tixNoteBook tixOptionMenu`
15			`tixPanedWindow tixScrolledHList tixScrolledListBox`
16			`tixScrolledTList tixScrolledText tixScrolledWindow tixSelect`
17			`tixStdButtonBox tixTree`
18			`}`
19			`set testapp(tix,w,shell) {`
20			`tixBalloon tixDialogShell tixExFileSelectDialog tixFileSelectDialog`
21			`tixPopupMenu tixStdDialogShell`
22			`}`
23			`set testapp(tix,w,base) {`
24			`tixLabelWidget`
25			`tixPrimitive`
26			`tixScrolledWidget`
27			`tixShell`
28			`tixStackWindow`
29			`tixVResize tixVStack tixVTree`
30			`}`
31			`set testapp(tix,w,unsupported) {`
32			`tixMDIMenuBar`
33			`tixMDIWindow`
34			`tixMwmClient`
35			`tixResizeHandle`
36			`tixSimpleDialog`
37			`tixStatusBar`
38			`}`
39
40			`# testConfig(VERBOSE) is the "Verbosity level" of the test suite.`
41			`#`
42			`# 0 -- No messages except the name of the tests`
43			`# 10 -- Print out the number of each test block`
44			`# 15 -- Print out the number and name of each test block`
45			`# 20 -- Print out all kinds of messages`
46			`# 30 -- level 20, plus when an error occurs, prints out the stack trace.`
47			`#`
48			`if [info exists env(TEST_VERBOSE)] {`
49			`if [catch {`
50			`set testConfig(VERBOSE) [expr "int($env(TEST_VERBOSE) + 0)"]`
51			`}] {`
52			`set testConfig(VERBOSE) 10`
53			`}`
54			`} else {`
55			`set testConfig(VERBOSE) 0`
56			`}`
57
58			`set testConfig(errCount) 0`
59
60			`#----------------------------------------------------------------------`
61			`#`
62			`# General assertion and evaluation`
63			`#`
64			`#----------------------------------------------------------------------`
65
66			`# Assert --`
67			`#`
68			`# Evaulates an assertion. Output error message if the assertion is false`
69			`#`
70			`proc Assert {cond {printErrInfo 0} {abortMode abortfile}} {`
71			`global errorInfo testConfig`
72			`if [info exists errorInfo] {`
73			`set errorInfo ""`
74			`}`
75			`uplevel 1 [list \`
76			`if !($cond) [list \`
77			`TestError "Failed Assertion \"$cond\"\n evaluated as \"[uplevel 1 subst -nocommand [list $cond]]\" :: [uplevel 1 subst [list $cond]]" $printErrInfo $abortMode`
78			`] \`
79			`]`
80			`}`
81
82			`# TestAbort --`
83			`#`
84			`# Aborts a single test file.`
85			`#`
86			`proc TestAbort {msg} {`
87			`error $msg`
88			`}`
89
90			`# test --`
91			`#`
92			`# Try to evaluate a command.`
93			`#`
94			`proc test {cmd {result {}} {ret {}}} {`
95			`global testConfig`
96
97			`if [catch {set ret [uplevel 1 $cmd]} err] {`
98			`set done 0`
99			`foreach r $result {`
100			`if [regexp $r $err] {`
101			`if {$testConfig(VERBOSE) >= 20} {`
102			`puts "Passed (Error message is expected):"`
103			`puts " command = \"$cmd\""`
104			`puts " expected error = \"$result\""`
105			`puts " actual error = $err"`
106			`}`
107			`set done 1`
108			`break`
109			`}`
110			`}`
111			`if {!$done} {`
112			`error $err`
113			`}`
114			`} else {`
115			`if {$testConfig(VERBOSE) >= 20} {`
116			`puts "Passed (Execution OK):\n command = \"$cmd\""`
117			`}`
118			`}`
119			`return $ret`
120			`}`
121
122			`# test1 --`
123			`#`
124			`# Try to evaluate a command and make sure its error result is the same`
125			`# as $result.`
126			`#`
127			`proc test1 {cmd {result {}}} {`
128			`global testConfig`
129
130			`set ret ""`
131			`if [catch {set ret [uplevel 1 $cmd]} err] {`
132			`if ![tixStrEq $err $result] {`
133			`error $err`
134			`} else {`
135			`if {$testConfig(VERBOSE) >= 20} {`
136			`puts "Passed (Error message is expected):"`
137			`puts " command = \"$cmd\""`
138			`puts " expected error = \"$result\""`
139			`}`
140			`}`
141			`} else {`
142			`if {$testConfig(VERBOSE) >= 20} {`
143			`puts "Passed (Execution OK):\n command = \"$cmd\""`
144			`}`
145			`}`
146			`return $ret`
147			`}`
148
149			`#----------------------------------------------------------------------`
150			`#`
151			`# Mouse event emulation routines`
152			`#`
153			`#----------------------------------------------------------------------`
154			`proc GetRoot {w x y} {`
155			`upvar X X`
156			`upvar Y Y`
157
158			`set x0 [winfo rootx $w]`
159			`set y0 [winfo rooty $w]`
160
161			`set X [expr $x0 + $x]`
162			`set Y [expr $y0 + $y]`
163			`}`
164
165			`proc MouseEvent {w type x y args} {`
166			`set tags [bindtags $w]`
167			`GetRoot $w $x $y`
168
169			`lappend args %q`
170			`lappend args $w`
171			`lappend args %W`
172			`lappend args $w`
173			`lappend args %x`
174			`lappend args $x`
175			`lappend args %y`
176			`lappend args $y`
177			`lappend args %X`
178			`lappend args $X`
179			`lappend args %Y`
180			`lappend args $Y`
181
182			`set found 0`
183			`foreach t $tags {`
184			`set cmd [string trim [bind $t $type]]`
185
186			`if {$cmd != ""} {`
187			`set found 1`
188			`}`
189			`tixForEach {sub val} $args {`
190			`regsub -all $sub $cmd $val cmd`
191			`}`
192			`uplevel #0 $cmd`
193			`}`
194			`if {$found == 0} {`
195			`global testConfig`
196			`if $testConfig(VERBOSE) {`
197			`puts "(testlib warning): widget $w has no bindings for $type"`
198			`}`
199			`}`
200			`return $found`
201			`}`
202
203			`# KeyboardString --`
204			`#`
205			`# Send a string to the widget via a list of key strokes. This does`
206			`# NOT ensure that an entry widget has the exact content as $string.`
207			`# You need to call $entry delete 0 end first!`
208			`#`
209			`proc KeyboardString {w string} {`
210			`set tags [bindtags $w]`
211
212			`lappend args %q`
213			`lappend args $w`
214			`lappend args %W`
215			`lappend args $w`
216
217			`set found 0`
218
219			`foreach c [split $string ""] {`
220			`foreach t $tags {`
221			`set cmd [string trim [bind $t <KeyPress>]]`
222
223			`if {$cmd != ""} {`
224			`set found 1`
225			`}`
226			`set list $args`
227			`lappend list %A`
228			`lappend list [list $c]`
229
230			`tixForEach {sub val} $list {`
231			`regsub -all $sub $cmd $val cmd`
232			`}`
233
234			`# This is really weird. If our char is '\', the lappend line`
235			`# makes it a quoted \\, but the previous regsub makes it back`
236			`# to a single quote. So we use regsub again to make it a \\`
237			`# again. But that's not enough, because uplevel will change it`
238			`# back to a single quote and will eventually mess us up. Hence`
239			`# we use quad-slashes here!`
240			`#`
241			`regsub -all {[\\]} $cmd {\\\\} cmd`
242			`uplevel #0 $cmd`
243			`}`
244			`}`
245			`if {$found == 0} {`
246			`puts "warning: widget $w has no bindings for $type"`
247			`}`
248			`return $found`
249
250			`}`
251
252			`# KeyboardEvent --`
253			`#`
254			`# Send a special keyboard event to the widget. E.g., <Return>`
255			`# <space>, <Escape>, <BackSpace> etc. To send ascii character`
256			`# strings, use KeyboardString`
257			`#`
258			`proc KeyboardEvent {w type} {`
259			`set tags [bindtags $w]`
260
261			`lappend args %q`
262			`lappend args $w`
263			`lappend args %W`
264			`lappend args $w`
265
266			`set found 0`
267			`foreach t $tags {`
268			`set cmd [string trim [bind $t $type]]`
269
270			`if {$cmd != ""} {`
271			`set found 1`
272			`}`
273			`tixForEach {sub val} $args {`
274			`regsub -all $sub $cmd $val cmd`
275			`}`
276			`uplevel #0 $cmd`
277			`}`
278			`if {$found == 0} {`
279			`puts "warning: widget $w has no bindings for $type"`
280			`}`
281			`return $found`
282			`}`
283
284			`proc Event-Initialize {} {`
285			`global app`
286
287			`set app(X) -1000`
288			`set app(Y) -1000`
289			`set app(curWid) {}`
290			`}`
291
292			`proc InWidget {w} {`
293			`global app`
294
295			`return [tixWithinWindow $w $app(X) $app(Y)]`
296			`}`
297
298			`proc Leave {w {x -10} {y -10} args} {`
299			`global app`
300
301			`eval MouseEvent $w <Leave> $x $y $args`
302			`}`
303
304			`proc B1-Leave {w {x -10} {y -10} args} {`
305			`global app`
306
307			`eval MouseEvent $w <Leave> $x $y $args`
308			`}`
309
310			`proc RecordRoot {w x y} {`
311			`global app`
312
313			`GetRoot $w $x $y`
314			`set app(X) $X`
315			`set app(Y) $Y`
316			`}`
317
318			`proc Enter {w {x -1} {y -1} args} {`
319			`global app`
320
321			`if {$y == -1} {`
322			`set x [expr [winfo width $w] / 2]`
323			`set y [expr [winfo height $w] / 2]`
324			`}`
325
326			`if {$app(curWid) != {} && [winfo exists $app(curWid)]} {`
327			`Leave $app(curWid)`
328			`}`
329			`RecordRoot $w $x $y`
330
331			`eval MouseEvent $w <Enter> $x $y $args`
332			`set app(curWid) $w`
333			`}`
334
335			`proc Drag {w {x -1} {y -1} args} {`
336			`global app`
337
338			`if {$y == -1} {`
339			`set x [expr [winfo width $w] / 2]`
340			`set y [expr [winfo height $w] / 2]`
341			`}`
342
343			`if {![InWidget $w]} {`
344			`B1-Leave $w $x $y`
345			`}`
346
347			`eval MouseEvent $w <B1-Motion> $x $y $args`
348			`}`
349
350			`# Release --`
351			`#`
352			`# Release mouse button 1 in a widget`
353			`#`
354			`proc Release {w {x -1} {y -1} args} {`
355			`global app`
356
357			`if {$y == -1} {`
358			`set x [expr [winfo width $w] / 2]`
359			`set y [expr [winfo height $w] / 2]`
360			`}`
361			`eval MouseEvent $w <ButtonRelease-1> $x $y $args`
362			`}`
363
364			`# Assumming the button was not originally down`
365			`#`
366			`proc HoldDown {w {x -1} {y -1} args} {`
367			`global app`
368
369			`if {$y == -1} {`
370			`set x [expr [winfo width $w] / 2]`
371			`set y [expr [winfo height $w] / 2]`
372			`}`
373			`if {![InWidget $w]} {`
374			`Enter $w $x $y`
375			`}`
376
377			`if {![eval MouseEvent $w <ButtonPress-1> $x $y $args]} {`
378			`eval MouseEvent $w <1> $x $y $args`
379			`}`
380			`}`
381
382			`proc Click {w {x -1} {y -1} args} {`
383			`global app`
384
385			`if {$y == -1} {`
386			`set x [expr [winfo width $w] / 2]`
387			`set y [expr [winfo height $w] / 2]`
388			`}`
389			`eval HoldDown $w $x $y $args`
390			`eval MouseEvent $w <ButtonRelease-1> $x $y $args`
391			`}`
392
393			`proc Double {w {x -1} {y -1} args} {`
394			`global app`
395
396			`if {$y == -1} {`
397			`set x [expr [winfo width $w] / 2]`
398			`set y [expr [winfo height $w] / 2]`
399			`}`
400			`eval MouseEvent $w <Double-1> $x $y $args`
401			`}`
402
403			`# ClickListboxEntry --`
404			`#`
405			`# Simulate the event where a listbox entry is clicked.`
406			`# Args:`
407			`# w:widget pathname of listbox`
408			`# index:LbIndex index of entry to be clicked.`
409			`# mode:string "single" or "double" indicating whether a single or`
410			`# double click is desired.`
411			`#`
412			`proc ClickListboxEntry {w index {mode single}} {`
413			`$w see $index`
414			`set bbox [$w bbox $index]`
415			`set x1 [lindex $bbox 0]`
416			`set y1 [lindex $bbox 1]`
417
418			`if {$mode == "single"} {`
419			`Click $w $x1 $y1`
420			`} else {`
421			`Double $w $x1 $y1`
422			`}`
423			`}`
424
425			`# ClickHListEntry --`
426			`#`
427			`# Simulate the event where an HList entry is clicked.`
428			`# Args:`
429			`# w:widget pathname of HList`
430			`# index:HLIndex index of entry to be clicked.`
431			`# mode:string "single" or "double" indicating whether a single or`
432			`# double click is desired.`
433			`#`
434			`proc ClickHListEntry {w index {mode single}} {`
435			`$w see $index`
436			`update`
437			`set bbox [$w info bbox $index]`
438			`set x1 [lindex $bbox 0]`
439			`set y1 [lindex $bbox 1]`
440
441			`if {$mode == "single"} {`
442			`Click $w $x1 $y1`
443			`} else {`
444			`Double $w $x1 $y1`
445			`}`
446			`}`
447
448			`# InvokeComboBoxByKey --`
449			`#`
450			`# Simulate the event when the user types in a string into the`
451			`# entry subwidget of a ComboBox widget and then type Return`
452			`#`
453			`proc InvokeComboBoxByKey {w string} {`
454			`set ent [$w subwidget entry]`
455			`$ent delete 0 end`
456			`KeyboardString $ent $string`
457			`KeyboardEvent $ent <Return>`
458			`update`
459			`}`
460
461			`# SetComboBoxByKey --`
462			`#`
463			`# Simulate the event when the user types in a string into the`
464			`# entry subwidget of a ComboBox widget, without a subsequent`
465			`# Return keystroke.`
466			`#`
467			`proc SetComboBoxByKey {w string} {`
468			`set ent [$w subwidget entry]`
469			`$ent delete 0 end`
470			`KeyboardString $ent $string`
471			`update`
472			`}`
473
474			`#----------------------------------------------------------------------`
475			`#`
476			`# main routines`
477			`#`
478			`#----------------------------------------------------------------------`
479
480			`proc Done {args} {`
481			`global testConfig`
482
483			`if {$testConfig(VERBOSE) >= 20} {`
484			`puts "------------------------done--------------------------------"`
485			`}`
486			`}`
487
488			`proc Wait {msecs} {`
489			`global Test:timer`
490			`set Test:timer 0`
491			`after $msecs uplevel #0 set Test:timer 1`
492			`tkwait variable Test:timer`
493			`}`
494
495			`proc TestPuts {msg} {`
496			`puts $msg`
497			`}`
498
499			`#----------------------------------------------------------------------`
500			`#`
501			`# Messages`
502			`#`
503			`#----------------------------------------------------------------------`
504			`proc PutP {msg} {`
505			`puts $msg`
506			`}`
507			`proc PutTitle {msg} {`
508			`puts $msg`
509			`}`
510			`proc PutSubTitle {msg} {`
511			`puts $msg`
512			`}`
513			`proc PutSubSubTitle {msg} {`
514			`puts $msg`
515			`}`
516			`proc TestWarn {msg} {`
517			`puts "Warning: $msg"`
518			`}`
519			`proc TestError {msg {printErrInfo 0} {abortMode cont}} {`
520			`global testConfig`
521			`puts " $msg"`
522			`case $abortMode {`
523			`cont {`
524			`if {$printErrInfo \|\| $testConfig(VERBOSE) >= 30} {`
525			`global errorInfo`
526			`puts "\$errorInfo = $errorInfo"`
527			`}`
528			`return`
529			`}`
530			`abortfile {`
531			`return -code 1234`
532			`}`
533			`abortall {`
534			`global errorInfo`
535			`puts "Aborting all test files because of the unrecoverable error:"`
536			`puts $errorInfo`
537			`exit 1`
538			`}`
539			`}`
540			`}`
541
542			`# TestBlock --`
543			`#`
544			`# Performs a block of test. A block is mainly used to group`
545			`# together tests that are dependent on each other. TestBlocks`
546			`# may be nested.`
547			`#`
548			`# Args:`
549			`# name: Textual name of the test. E.g.: button-1.1`
550			`# description: Short description of the test. "Pressing button"`
551			`# printErrInfo: If an error occurs, should the errorInfo be printed`
552			`# to the console. (Normally only a one-liner error`
553			`# message is printed).`
554			`# abortMode: cont -- skip this block and go to the next block`
555			`# abortfile -- skip all other blocks in this file`
556			`# abortall -- skip all the Tix tests.`
557			`#`
558			`proc TestBlock {name description script {printErrInfo 0} {abortMode cont}} {`
559			`global testConfig`
560
561			`set code [catch {uplevel 1 $script} result]`
562
563			`if {$testConfig(VERBOSE) >= 15} {`
564			`set des "($description)"`
565			`} else {`
566			`set des ""`
567			`}`
568
569			`if {$code != 0} {`
570			`incr testConfig(errCount)`
571			`puts stdout "---- $name FAILED $des"`
572			`puts "Script is"`
573			`foreach line [split $script \n] {`
574			`regsub "^\[[format %s \ \n\t]\]*" $line "" line`
575			`puts " $line"`
576			`}`
577			`puts "Error message:"`
578			`TestError $result $printErrInfo $abortMode`
579			`puts stdout "----"`
580			`} elseif $testConfig(VERBOSE) {`
581			`puts stdout "++++ $name PASSED $des"`
582			`}`
583			`}`
584
585			`#----------------------------------------------------------------------`
586			`#`
587			`# general initialization`
588			`#`
589			`#----------------------------------------------------------------------`
590
591			`# init the event emulation`
592			`#`
593
594			`# some window managers don't put the main window at a default place, this`
595			`# may be quite annoying for the user`
596			`#`
597			`wm geometry . +0+0`
598