Import Tix 8.4.3.5 (as of svn r86089)
This commit is contained in:
Zachary Ware
152
tests/library/CaseData.tcl
Normal file
152
tests/library/CaseData.tcl
Normal file
@@ -0,0 +1,152 @@
|
||||
# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
|
||||
#
|
||||
# $Id: CaseData.tcl,v 1.4 2004/03/28 02:44:57 hobbs Exp $
|
||||
#
|
||||
# CaseData.tcl --
|
||||
#
|
||||
# Contains data for test cases
|
||||
#
|
||||
# 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.
|
||||
#
|
||||
|
||||
# GetHomeDirs --
|
||||
#
|
||||
# Returns a list of user names (prefixed with tilde) and their
|
||||
# home directories
|
||||
#
|
||||
proc GetHomeDirs {} {
|
||||
set tryList {root ftp admin operator man john ioi}
|
||||
if [catch {
|
||||
lappend tryList [exec whoami]
|
||||
}] {
|
||||
catch {
|
||||
lappend tryList [exec logname]
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
set list {}
|
||||
foreach user $tryList {
|
||||
if [info exists done($user)] {
|
||||
continue
|
||||
}
|
||||
set expanded [tixFile tilde ~$user]
|
||||
if ![tixStrEq $expanded ~$user] {
|
||||
lappend list [list ~$user $expanded]
|
||||
}
|
||||
set done($user) 1
|
||||
}
|
||||
return $list
|
||||
}
|
||||
|
||||
# GetCases_FsNormDir --
|
||||
#
|
||||
# Returns a set of test cases for verifying whether a non-normalized
|
||||
# directory is properly notmalized
|
||||
#
|
||||
proc GetCases_FsNormDir {} {
|
||||
|
||||
if [tixStrEq [tix platform] unix] {
|
||||
# PATHNAME to TEST expected result Causes error for
|
||||
# file normalize?
|
||||
#----------------------------------------------------------------
|
||||
set list {
|
||||
{. "" 1}
|
||||
{foo "" 1}
|
||||
{~nosuchuser "" 1}
|
||||
{~nosuchuser/../ "" 1}
|
||||
{/ / 0}
|
||||
{/// / 0}
|
||||
{/./ / 0}
|
||||
{/./. / 0}
|
||||
{/./. / 0}
|
||||
{/././.././../ / 0}
|
||||
{/etc /etc 0}
|
||||
{/etc/../etc /etc 0}
|
||||
{/etc/../etc/./ /etc 0}
|
||||
{/etc/../etc/./ /etc 0}
|
||||
{/etc/../usr/./lib /usr/lib 0}
|
||||
}
|
||||
foreach userInfo [GetHomeDirs] {
|
||||
lappend list [list [lindex $userInfo 0] [lindex $userInfo 1] 0]
|
||||
}
|
||||
} else {
|
||||
set list [list \
|
||||
[list . "" 1] \
|
||||
[list foo "" 1] \
|
||||
[list .. "" 1] \
|
||||
[list ..\\foo "" 1] \
|
||||
[list ..\\dat\\. "" 1] \
|
||||
[list C: "" 1] \
|
||||
[list C:\\ C: 0] \
|
||||
[list c:\\ C: 0] \
|
||||
[list C:\\\\ C: 0] \
|
||||
[list C:\\ C: 0] \
|
||||
[list C:\\. C: 0] \
|
||||
[list C:\\Windows C:\\Windows 0] \
|
||||
[list C:\\Windows\\System C:\\Windows\\System 0] \
|
||||
[list C:\\Windows\\.. C: 0] \
|
||||
]
|
||||
}
|
||||
|
||||
return $list
|
||||
}
|
||||
|
||||
# GetCases_FSNorm --
|
||||
#
|
||||
# Returns a set of test cases for testing the tixFSNorm command.
|
||||
#
|
||||
proc GetCases_FSNorm {} {
|
||||
global tixPriv
|
||||
|
||||
if [tixStrEq [tix platform] unix] {
|
||||
# PATHNAME to TEST context <---------- Expected Result ----------------------------------->
|
||||
# path vpath(todo) files(todo) patterns(todo)
|
||||
#----------------------------------------------------------------
|
||||
set list {
|
||||
{. / / }
|
||||
{./ / / }
|
||||
{./////./ / / }
|
||||
{.. / / }
|
||||
{../ / / }
|
||||
{../.. / / }
|
||||
{../../../ / / }
|
||||
{/etc / /etc }
|
||||
{/etc///../etc/// / /etc }
|
||||
{/etc///../etc///.. / / }
|
||||
{/etc///../etc///../ / / }
|
||||
{/etc/. / /etc }
|
||||
{/./etc/. / /etc }
|
||||
{/./././etc/. / /etc }
|
||||
{/usr/./././local/./lib//// / /usr/local/lib }
|
||||
{./././././etc/ / /etc }
|
||||
{/etc/../etc / /etc }
|
||||
{/etc/../etc/../etc / /etc }
|
||||
{/etc/../etc/../ / / }
|
||||
{~foobar/foo / /~foobar }
|
||||
{~foobar/foo/ / /~foobar/foo }
|
||||
}
|
||||
} else {
|
||||
set p $tixPriv(WinPrefix)
|
||||
|
||||
set list [list \
|
||||
[list . $p\\C: $p\\C: ] \
|
||||
[list .\\. $p\\C: $p\\C: ] \
|
||||
[list .\\Windows $p\\C: $p\\C:\\Windows ] \
|
||||
[list .\\Windows\\..\\ $p\\C: $p\\C: ] \
|
||||
[list tmp\\ $p\\C: $p\\C:\\tmp ] \
|
||||
[list "no such file" $p\\C: $p\\C: ] \
|
||||
[list "autoexec.bat" $p\\C: $p\\C: ] \
|
||||
[list "ignore/slash\\dd" $p\\C: $p\\C:\\ignore/slash ] \
|
||||
[list "has space\\" $p\\C: "$p\\C:\\has space" ] \
|
||||
[list "has space" $p\\C: "$p\\C:" ] \
|
||||
]
|
||||
# ToDo:
|
||||
# (1) xx\xx\C: + .. should be xx\xx
|
||||
# (2) xx\xx\C: + D: should be xx\xx\D:
|
||||
}
|
||||
return $list
|
||||
}
|
||||
646
tests/library/TestLib.tcl
Normal file
646
tests/library/TestLib.tcl
Normal file
@@ -0,0 +1,646 @@
|
||||
# -*- 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
|
||||
56
tests/library/TestLib.txt
Normal file
56
tests/library/TestLib.txt
Normal file
@@ -0,0 +1,56 @@
|
||||
# -*- mode: text; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
|
||||
# $Id: TestLib.txt,v 1.2 2002/11/13 21:12:18 idiscovery Exp $
|
||||
|
||||
HIGH LEVEL INTERFACE FOR INTERACTIVE TESTING
|
||||
--------------------------------------------
|
||||
Click:
|
||||
|
||||
Simulates a the event when a user moves the mouse pointer into
|
||||
the widget (if the cursor is still outside of the widget), press
|
||||
the button and release it.
|
||||
|
||||
|
||||
Double:
|
||||
|
||||
Simulates a the event when a user moves the mouse pointer into
|
||||
the widget (if the cursor is still outside of the widget), double-click
|
||||
the button and release it.
|
||||
|
||||
|
||||
MESSAGE PRINTING
|
||||
----------------
|
||||
|
||||
PutP
|
||||
|
||||
Prints a progress message.
|
||||
|
||||
PutTitle
|
||||
|
||||
Prints the title of a test file
|
||||
|
||||
PutSubTitle
|
||||
|
||||
Print the title of a part of a test file
|
||||
|
||||
PutSubSubTitle
|
||||
|
||||
One more level than PutSubTitle
|
||||
|
||||
TestWarn
|
||||
|
||||
Print a warning message. This will be counted in the final report.
|
||||
|
||||
TestError {msg {printErrInfo 0} {abortMode cont}}
|
||||
|
||||
Print an error message. abortMode controls how the error affects
|
||||
other test cases:
|
||||
|
||||
cont: simply print the message and continue
|
||||
abortfile: skip other test cases in this file
|
||||
abortall: abort the all other tests and exit the test
|
||||
program.
|
||||
|
||||
printErrInfo specifies whether the "$errorInfo" variable should be
|
||||
printed.
|
||||
|
||||
|
||||
11
tests/library/load-init.tcl
Normal file
11
tests/library/load-init.tcl
Normal file
@@ -0,0 +1,11 @@
|
||||
# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
|
||||
#
|
||||
# $Id: load-init.tcl,v 1.2 2002/11/13 21:12:18 idiscovery Exp $
|
||||
#
|
||||
#
|
||||
#
|
||||
#
|
||||
|
||||
puts -nonewline "trying to load the Tix dynamic library ... "
|
||||
load ../../unix-tk4.1/libtix.so Tix
|
||||
puts "done"
|
||||
Reference in New Issue
Block a user