blob: 443687a3cb0b12c60a6a4cbb4c59af7a638efafb (
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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
package require Tk 8.5
package require tcltest ; namespace import -force tcltest::*
loadTestedCommands
testConstraint coreScrollbar [expr {[tk windowingsystem] eq "aqua"}]
# Before 2019 the code in library/ttk/scrollbar.tcl would replace the
# constructor of ttk::scrollbar with the constructor of tk::scrollbar
# unless the -class or -style options were specified..
# Now there is an implementation of ttk::scrollbar for macOS. The
# tests are left in place, though, except that scrollbar-swapout-1
# test was changed to expect the class to be TScrollbar instead of
# Scrollbar.
test scrollbar-swapout-1 "Don't use core scrollbars on OSX..." \
-constraints {
coreScrollbar
} -body {
ttk::scrollbar .sb -command "yadda"
list [winfo class .sb] [.sb cget -command]
} -result [list TScrollbar yadda] -cleanup {
destroy .sb
}
test scrollbar-swapout-2 "... regardless of whether -style ..." \
-constraints {
coreScrollbar
} -body {
ttk::style layout Vertical.Custom.TScrollbar \
[ttk::style layout Vertical.TScrollbar] ; # See #1833339
ttk::scrollbar .sb -command "yadda" -style Custom.TScrollbar
list [winfo class .sb] [.sb cget -command] [.sb cget -style]
} -result [list TScrollbar yadda Custom.TScrollbar] -cleanup {
destroy .sb
}
test scrollbar-swapout-3 "... or -class is specified." -constraints {
coreScrollbar
} -body {
ttk::scrollbar .sb -command "yadda" -class Custom.TScrollbar
list [winfo class .sb] [.sb cget -command]
} -result [list Custom.TScrollbar yadda] -cleanup {
destroy .sb
}
test scrollbar-1.0 "Setup" -body {
ttk::scrollbar .tsb
} -result .tsb
test scrollbar-1.1 "Set method" -body {
.tsb set 0.2 0.4
.tsb get
} -result [list 0.2 0.4]
test scrollbar-1.2 "Set orientation" -body {
.tsb configure -orient vertical
pack .tsb -side right -anchor e -expand 1 -fill y
wm geometry . 200x200
update
set w [winfo width .tsb] ; set h [winfo height .tsb]
expr {$h > $w}
} -result 1
test scrollbar-1.3 "Change orientation" -body {
.tsb configure -orient horizontal
pack .tsb -side bottom -anchor s -expand 1 -fill x
wm geometry . 200x200
update
set w [winfo width .tsb] ; set h [winfo height .tsb]
expr {$h < $w}
} -result 1
test scrollbar-10.1.1 {<MouseWheel> event on scrollbar} -constraints {notAqua} -setup {
destroy .t .s
} -body {
pack [text .t -yscrollcommand {.s set}] -side left
for {set i 1} {$i < 100} {incr i} {.t insert end "Line $i\n"}
pack [ttk::scrollbar .s -command {.t yview}] -fill y -expand 1 -side left
update
focus -force .s
event generate .s <MouseWheel> -delta -120
after 200 {set eventprocessed 1} ; vwait eventprocessed
.t index @0,0
} -cleanup {
destroy .t .s
} -result {5.0}
test scrollbar-10.1.2 {<MouseWheel> event on scrollbar} -constraints {aqua} -setup {
destroy .t .s
} -body {
pack [text .t -yscrollcommand {.s set}] -side left
for {set i 1} {$i < 100} {incr i} {.t insert end "Line $i\n"}
pack [ttk::scrollbar .s -command {.t yview}] -fill y -expand 1 -side left
update
focus -force .s
event generate .s <MouseWheel> -delta -4
after 200 {set eventprocessed 1} ; vwait eventprocessed
.t index @0,0
} -cleanup {
destroy .t .s
} -result {5.0}
test scrollbar-10.2.1 {<Shift-MouseWheel> event on horizontal scrollbar} -constraints {notAqua} -setup {
destroy .t .s
} -body {
pack [text .t -xscrollcommand {.s set} -wrap none] -side top
for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "}
pack [ttk::scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top
update
focus -force .s
event generate .s <Shift-MouseWheel> -delta -120
after 200 {set eventprocessed 1} ; vwait eventprocessed
.t index @0,0
} -cleanup {
destroy .t .s
} -result {1.4}
test scrollbar-10.2.2 {<Shift-MouseWheel> event on horizontal scrollbar} -constraints {aqua} -setup {
destroy .t .s
} -body {
pack [text .t -xscrollcommand {.s set} -wrap none] -side top
for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "}
pack [ttk::scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top
update
focus -force .s
event generate .s <Shift-MouseWheel> -delta -4
after 200 {set eventprocessed 1} ; vwait eventprocessed
.t index @0,0
} -cleanup {
destroy .t .s
} -result {1.4}
test scrollbar-10.2.3 {<MouseWheel> event on horizontal scrollbar} -constraints {notAqua} -setup {
destroy .t .s
} -body {
pack [text .t -xscrollcommand {.s set} -wrap none] -side top
for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "}
pack [ttk::scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top
update
focus -force .s
event generate .s <MouseWheel> -delta -120
after 200 {set eventprocessed 1} ; vwait eventprocessed
.t index @0,0
} -cleanup {
destroy .t .s
} -result {1.4}
test scrollbar-10.2.4 {<MouseWheel> event on horizontal scrollbar} -constraints {aqua} -setup {
destroy .t .s
} -body {
pack [text .t -xscrollcommand {.s set} -wrap none] -side top
for {set i 1} {$i < 100} {incr i} {.t insert end "Char $i "}
pack [ttk::scrollbar .s -command {.t xview} -orient horizontal] -fill x -expand 1 -side top
update
focus -force .s
event generate .s <MouseWheel> -delta -4
after 200 {set eventprocessed 1} ; vwait eventprocessed
.t index @0,0
} -cleanup {
destroy .t .s
} -result {1.4}
#
# Scale tests:
#
test scale-1.0 "Self-destruction" -body {
trace variable v w { destroy .s ;# }
ttk::scale .s -variable v
pack .s ; update
.s set 1 ; update
} -returnCodes 1 -match glob -result "*"
test scale-2.1 "-state option" -setup {
ttk::scale .s
set res ""
} -body {
# defaults
lappend res [.s instate disabled] [.s cget -state]
# set -state: instate returns accordingly
.s configure -state disabled
lappend res [.s instate disabled] [.s cget -state]
# back to normal
.s configure -state normal
lappend res [.s instate disabled] [.s cget -state]
# use state command: -state does NOT reflect it
.s state disabled
lappend res [.s instate disabled] [.s cget -state]
# further use state command
.s state readonly
lappend res [.s state] [.s cget -state]
} -cleanup {
destroy .s
unset -nocomplain res
} -result {0 normal 1 disabled 0 normal 1 normal {disabled readonly} normal}
tcltest::cleanupTests
|
