summaryrefslogtreecommitdiffstats
path: root/tests/ttk/entry.test
blob: 3ac918233436daf67c4b4c3742e0323d11d18d90 (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
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
#
# Tile package: entry widget tests
#

package require Tk 8.5
package require tcltest ; namespace import -force tcltest::*
loadTestedCommands

variable scrollInfo
proc scroll args {
    global scrollInfo
    set scrollInfo $args
}

# Some of the tests raise background errors;
# override default bgerror to catch them.
#
variable bgerror ""
proc bgerror {error} {
    variable bgerror $error
    variable bgerrorInfo $::errorInfo
    variable bgerrorCode $::errorCode
}

#
test entry-1.1 "Create entry widget" -body {
    ttk::entry .e
} -result .e

test entry-1.2 "Insert" -body {
    .e insert end abcde
    .e get
} -result abcde

test entry-1.3 "Selection" -body {
    .e selection range 1 3
    selection get
} -result bc

test entry-1.4 "Delete" -body {
    .e delete 1 3
    .e get
} -result ade

test entry-1.5 "Deletion - insert cursor" -body {
    .e insert end abcde
    .e icursor 0
    .e delete 0 end
    .e index insert
} -result 0

test entry-1.6 "Deletion - insert cursor at end" -body {
    .e insert end abcde
    .e icursor end
    .e delete 0 end
    .e index insert
} -result 0

test entry-1.7 "Deletion - insert cursor in the middle " -body {
    .e insert end abcde
    .e icursor 3
    .e delete 0 end
    .e index insert
} -result 0

test entry-1.done "Cleanup" -body { destroy .e }

# Scrollbar tests.

test entry-2.1 "Create entry before scrollbar" -body {
    pack [ttk::entry .te -xscrollcommand [list .tsb set]] \
	-expand true -fill both
    pack [ttk::scrollbar .tsb -orient horizontal -command [list .te xview]] \
    	-expand false -fill x
}  -cleanup {destroy .te .tsb}

test entry-2.2 "Initial scroll position" -body {
    ttk::entry .e -font fixed -width 5 -xscrollcommand scroll
    .e insert end "0123456789"
    pack .e; update
    set scrollInfo
} -result {0 0.5} -cleanup { destroy .e }
# NOTE: result can vary depending on font.

# Bounding box / scrolling tests.
test entry-3.0 "Series 3 setup" -body {
    ttk::style theme use default
    variable fixed fixed
    variable cw [font measure $fixed a]
    variable ch [font metrics $fixed -linespace]
    variable bd 2	;# border + padding
    variable ux [font measure $fixed \u4e4e]

    pack [ttk::entry .e -font $fixed -width 20]
    update
}

test entry-3.1 "bbox widget command" -body {
    .e delete 0 end
    .e bbox 0
} -result [list $bd $bd 0 $ch]

test entry-3.2 "xview" -body {
    .e delete 0 end;
    .e insert end [string repeat "0" 40]
    update idletasks
    set result [.e xview]
} -result {0 0.5}

test entry-3.last "Series 3 cleanup" -body {
    destroy .e
}

# Selection tests:

test entry-4.0 "Selection test - setup" -body {
    ttk::entry .e
    .e insert end asdfasdf
    .e selection range 0 end
}

test entry-4.1 "Selection test" -body {
    selection get
} -result asdfasdf

test entry-4.2 "Disable -exportselection" -body {
    .e configure -exportselection false
    selection get
} -returnCodes error -result "PRIMARY selection doesn't exist*" -match glob

test entry-4.3 "Reenable -exportselection" -body {
    .e configure -exportselection true
    selection get
} -result asdfasdf

test entry-4.4 "Force selection loss" -body {
    selection own .
    .e index sel.first
} -returnCodes error -result "selection isn't in widget .e"

test entry-4.5 "Allow selection changes if readonly" -body {
    .e delete 0 end
    .e insert end 0123456789
    .e selection range 0 end
    .e configure -state readonly
    .e selection range 2 4
    .e configure -state normal
    list [.e index sel.first] [.e index sel.last]
} -result {2 4}

test entry-4.6 "Disallow selection changes if disabled" -body {
    .e delete 0 end
    .e insert end 0123456789
    .e selection range 0 end
    .e configure -state disabled
    .e selection range 2 4
    .e configure -state normal
    list [.e index sel.first] [.e index sel.last]
} -result {0 10}

test entry-4.7 {sel.first and sel.last gravity} -body {
    set result [list]
    .e delete 0 end
    .e insert 0 0123456789
    .e select range 2 6
    .e insert 2 XXX
    lappend result [.e index sel.first] [.e index sel.last]
    .e insert 6 YYY
    lappend result [.e index sel.first] [.e index sel.last] [.e get]
} -result {5 9 5 12 01XXX2YYY3456789}

# Self-destruct tests.

test entry-5.1 {widget deletion while active} -body {
    destroy .e
    pack [ttk::entry .e]
    update
    .e config -xscrollcommand { destroy .e }
    update idletasks
    winfo exists .e
} -result 0

# TODO: test killing .e in -validatecommand, -invalidcommand, variable trace;


# -textvariable tests.

test entry-6.1 {Update linked variable in write trace} -body {
    proc override args {
	global x
	set x "Overridden!"
    }
    catch {destroy .e}
    set x ""
    trace variable x w override
    ttk::entry .e -textvariable x
    .e insert 0 "Some text"
    set result [list $x [.e get]]
    set result
} -result {Overridden! Overridden!} -cleanup {
    unset x
    rename override {}
    destroy .e
}

test entry-6.2 {-textvariable tests} -body {
    set result [list]
    ttk::entry .e -textvariable x
    set x "text"
    lappend result [.e get]
    unset x
    lappend result [.e get]
    .e insert end "newtext"
    lappend result [.e get] [set x]
} -result [list "text" "" "newtext" "newtext"] -cleanup {
    destroy .e
    unset -nocomplain x
}

test entry-7.1 {Bad style options} -body {
    ttk::style theme create entry-7.1 -settings {
	ttk::style configure TEntry -foreground BadColor
	ttk::style map TEntry -foreground {readonly AnotherBadColor}
	ttk::style map TEntry -font {readonly ABadFont}
	ttk::style map TEntry \
	    -selectbackground {{} BadColor} \
	    -selectforeground {{} BadColor} \
	    -insertcolor {{} BadColor}
    }
    pack [ttk::entry .e -text "Don't crash"]
    ttk::style theme use entry-7.1
    update
    .e selection range 0 end
    update
    .e state readonly;
    update
} -cleanup { destroy .e ; ttk::style theme use default }

test entry-8.1 "Unset linked variable" -body {
    variable foo "bar"
    pack [ttk::entry .e -textvariable foo]
    unset foo
    .e insert end "baz"
    list [.e cget -textvariable] [.e get] [set foo]
} -result [list foo "baz" "baz"] -cleanup { destroy .e }

test entry-8.2 "Unset linked variable by deleting namespace" -body {
    namespace eval ::test  { variable foo "bar" }
    pack [ttk::entry .e -textvariable ::test::foo]
    namespace delete ::test
    .e insert end "baz"		;# <== error here
    list [.e cget -textvariable] [.e get] [set foo]
} -returnCodes error -result "*parent namespace doesn't exist*" -match glob
# '-result [list ::test::foo "baz" "baz"]' would also be sensible,
# but Tcl namespaces don't work that way.

test entry-8.2a "Followup to test 8.2" -body {
    .e cget -textvariable
} -result ::test::foo -cleanup { destroy .e }
# For 8.2a, -result {} would also be sensible.

tcltest::cleanupTests