blob: 0d318b9c1ee3575fe6e859c6c56315f6ba897f08 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
# This script displays provides visual tests for many of Tk's features.
# Each test displays a window with various information in it, along
# with instructions about how the window should appear. You can look
# at the window to make sure it appears as expected. Individual tests
# are kept in separate ".tcl" files in this directory.
#
# TESTFILE INITIALIZATION
#
package require tcltest 2.2; # needed in mode -singleproc 0
# Load the main script main.tcl, which takes care of:
# - setup for the application and the root window
# - importing commands from the tcltest namespace
# - loading of the testutils mechanism along with its utility procs
# - loading of Tk specific test constraints (additionally to constraints
# provided by the package tcltest)
source [file join [tcltest::configure -testdir] main.tcl]
# Ensure a pristine initial window state
resetWindows
set testNum 1
#
# LOCAL UTILITY PROCS
#
proc end {} {
cleanupTests
set ::EndOfVisualTests 1
}
# lpr --
#
# Print the contents of a canvas
#
proc lpr {c args} {
exec lpr <<[eval [list $c postscript] $args]
}
proc runTest {file} {
global testNum
test "2.$testNum" "testing $file" {userInteraction} {
uplevel #0 [list source [file join [testsDirectory] $file]]
concat ""
} {}
incr testNum
}
#
# COMMON TEST SETUP
#
set auto_path ". $auto_path"
wm title . "Visual Tests for Tk"
#
# TESTS
#
# Each menu entry invokes a visual test file
test 1.1 {running visual tests} -constraints userInteraction -body {
#-------------------------------------------------------
# The code below create the main window, consisting of a
# menu bar and a message explaining the basic operation
# of the program.
#-------------------------------------------------------
frame .menu -relief raised -borderwidth 1
message .msg -font {Times 18} -relief raised -width 4i \
-borderwidth 1 -text "This application provides a collection of visual tests for the Tk toolkit. Each menu entry invokes a test, which displays information on the screen. You can then verify visually that the information is being displayed in the correct way. The tests under the \"Postscript\" menu exercise the Postscript-generation capabilities of canvas widgets."
pack .menu -side top -fill x
pack .msg -side bottom -expand yes -fill both
#-------------------------------------------------------
# The code below creates all the menus, which invoke procedures
# to create particular demonstrations of various widgets.
#-------------------------------------------------------
menubutton .menu.file -text "File" -menu .menu.file.m
menu .menu.file.m
.menu.file.m add command -label "Quit" -command end
menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m
menu .menu.group1.m
.menu.group1.m add command -label "Canvas arcs" -command {runTest arc.tcl}
.menu.group1.m add command -label "Beveled borders in text widgets" \
-command {runTest bevel.tcl}
.menu.group1.m add command -label "Colormap management" \
-command {runTest cmap.tcl}
.menu.group1.m add command -label "Label/button geometry" \
-command {runTest butGeom.tcl}
.menu.group1.m add command -label "Label/button colors" \
-command {runTest butGeom2.tcl}
menubutton .menu.ps -text "Canvas Postscript" -menu .menu.ps.m
menu .menu.ps.m
.menu.ps.m add command -label "Rectangles and other graphics" \
-command {runTest canvPsGrph.tcl}
.menu.ps.m add command -label "Text" \
-command {runTest canvPsText.tcl}
.menu.ps.m add command -label "Bitmaps" \
-command {runTest canvPsBmap.tcl}
.menu.ps.m add command -label "Images" \
-command {runTest canvPsImg.tcl}
.menu.ps.m add command -label "Arcs" \
-command {runTest canvPsArc.tcl}
pack .menu.file .menu.group1 .menu.ps -side left -padx 1m
# Set up for keyboard-based menu traversal
bind . <FocusIn> {
if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} {
focus .menu
}
}
tk_menuBar .menu .menu.file .menu.group1 .menu.ps
# Set up a class binding to allow objects to be deleted from a canvas
# by clicking with mouse button 1:
bind Canvas <Button-1> {%W delete [%W find closest %x %y]}
concat ""
} -result {}
#
# TESTFILE CLEANUP
#
if {![testConstraint userInteraction]} {
cleanupTests
} else {
vwait EndOfVisualTests
}
|
