1#
2# Tile package: entry widget tests
3#
4
5package require tk
6package require tcltest 2.2
7namespace import -force tcltest::*
8loadTestedCommands
9
10testConstraint failsOnUbuntu [expr {![info exists ::env(CI)] || ![string match Linux $::tcl_platform(os)]}]
11testConstraint failsOnXQuarz [expr {$tcl_platform(os) ne "Darwin" || [tk windowingsystem] ne "x11" }]
12
13variable scrollInfo
14proc scroll args {
15    global scrollInfo
16    set scrollInfo $args
17}
18
19# Some of the tests raise background errors;
20# override default bgerror to catch them.
21#
22variable bgerror ""
23proc bgerror {error} {
24    variable bgerror $error
25    variable bgerrorInfo $::errorInfo
26    variable bgerrorCode $::errorCode
27}
28
29#
30test entry-1.1 "Create entry widget" -body {
31    ttk::entry .e
32} -result .e
33
34test entry-1.2 "Insert" -body {
35    .e insert end abcde
36    .e get
37} -result abcde
38
39test entry-1.3 "Selection" -body {
40    .e selection range 1 3
41    selection get
42} -result bc
43
44test entry-1.4 "Delete" -body {
45    .e delete 1 3
46    .e get
47} -result ade
48
49test entry-1.5 "Deletion - insert cursor" -body {
50    .e insert end abcde
51    .e icursor 0
52    .e delete 0 end
53    .e index insert
54} -result 0
55
56test entry-1.6 "Deletion - insert cursor at end" -body {
57    .e insert end abcde
58    .e icursor end
59    .e delete 0 end
60    .e index insert
61} -result 0
62
63test entry-1.7 "Deletion - insert cursor in the middle " -body {
64    .e insert end abcde
65    .e icursor 3
66    .e delete 0 end
67    .e index insert
68} -result 0
69
70test entry-1.8 "Index is between 0 and end" -body {
71    .e delete 0 end
72    .e insert end abcde
73    set res [list [.e index -1] [.e index -4] [.e index 999]]
74} -result {0 0 5}
75
76test entry-1.done "Cleanup" -body { destroy .e }
77
78# Scrollbar tests.
79
80test entry-2.1 "Create entry before scrollbar" -body {
81    pack [ttk::entry .te -xscrollcommand [list .tsb set]] \
82	-expand true -fill both
83    pack [ttk::scrollbar .tsb -orient horizontal -command [list .te xview]] \
84    	-expand false -fill x
85}  -cleanup {destroy .te .tsb}
86
87test entry-2.1.1 "Create entry before scrollbar - scrollbar catches up" -constraints {failsOnUbuntu failsOnXQuarz} -body {
88    pack [ttk::entry .te -xscrollcommand [list .tsb set]] \
89	-expand true -fill both
90    .te insert end [string repeat "abc" 50]
91    catch {update} ; # error triggers because the -xscrollcommand callback
92                     # errors out: invalid command name ".tsb"
93    pack [ttk::scrollbar .tsb -orient horizontal -command [list .te xview]] \
94    	-expand false -fill x
95    update ; # no error
96    set res [expr [lindex [.tsb get] 1] < 1] ; # scrollbar did update
97} -result 1 -cleanup {destroy .te .tsb}
98
99test entry-2.2 "Initial scroll position" -body {
100    ttk::entry .e -font fixed -width 5 -xscrollcommand scroll
101    .e insert end "0123456789"
102    pack .e;
103    set timeout [after 500 {set $scrollInfo "timeout"}]
104    vwait scrollInfo
105    set scrollInfo
106} -cleanup {
107    destroy .e
108    after cancel $timeout
109} -result {0.0 0.5}
110# NOTE: result can vary depending on font.
111
112# Bounding box / scrolling tests.
113test entry-3.0 "Series 3 setup" -body {
114    ttk::style theme use default
115    variable fixed TkFixedFont
116    variable cw [font measure $fixed a]
117    variable ch [font metrics $fixed -linespace]
118    variable bd 2	;# border + padding
119    variable ux [font measure $fixed 乎]
120
121    pack [ttk::entry .e -font $fixed -width 20]
122    update
123}
124
125test entry-3.1 "bbox widget command" -body {
126    .e delete 0 end
127    .e bbox 0
128} -result [list $bd $bd 0 $ch]
129
130test entry-3.2 "xview" -body {
131    .e delete 0 end;
132    .e insert end [string repeat "0" 40]
133    set result [.e xview]
134} -result {0.0 0.5}
135
136test entry-3.3 "xview" -body {
137    .e delete 0 end;
138    .e insert end abcdefghijklmnopqrstuvwxyz
139    .e xview end
140    set result [.e index @0]
141} -result 7
142
143test entry-3.4 "xview" -body {
144    .e delete 0 end;
145    .e insert end abcdefghijklmnopqrstuvwxyz
146    .e xview moveto 1.0
147    set result [.e index @0]
148} -result 7
149
150test entry-3.5 "xview" -body {
151    .e delete 0 end;
152    .e insert end abcdefghijklmnopqrstuvwxyz
153    .e xview scroll 5 units
154    set result [.e index @0]
155} -result 5
156
157test entry-3.6 "xview" -body {
158    .e delete 0 end;
159    .e insert end [string repeat abcdefghijklmnopqrstuvwxyz 5]
160    .e xview scroll 2 pages
161    set result [.e index @0]
162} -result 40
163
164test entry-3.last "Series 3 cleanup" -body {
165    destroy .e
166}
167
168# Selection tests:
169
170test entry-4.0 "Selection test - setup" -body {
171    ttk::entry .e
172    .e insert end asdfasdf
173    .e selection range 0 end
174}
175
176test entry-4.1 "Selection test" -body {
177    selection get
178} -result asdfasdf
179
180test entry-4.2 "Disable -exportselection" -body {
181    .e configure -exportselection false
182    selection get
183} -returnCodes error -result "PRIMARY selection doesn't exist*" -match glob
184
185test entry-4.3 "Reenable -exportselection" -body {
186    .e configure -exportselection true
187    selection get
188} -result asdfasdf
189
190test entry-4.4 "Force selection loss" -body {
191    selection own .
192    .e index sel.first
193} -returnCodes error -result "selection isn't in widget .e"
194
195test entry-4.5 "Allow selection changes if readonly" -body {
196    .e delete 0 end
197    .e insert end 0123456789
198    .e selection range 0 end
199    .e configure -state readonly
200    .e selection range 2 4
201    .e configure -state normal
202    list [.e index sel.first] [.e index sel.last]
203} -result {2 4}
204
205test entry-4.6 "Disallow selection changes if disabled" -body {
206    .e delete 0 end
207    .e insert end 0123456789
208    .e selection range 0 end
209    .e configure -state disabled
210    .e selection range 2 4
211    .e configure -state normal
212    list [.e index sel.first] [.e index sel.last]
213} -result {0 10}
214
215test entry-4.7 {sel.first and sel.last gravity} -body {
216    set result [list]
217    .e delete 0 end
218    .e insert 0 0123456789
219    .e select range 2 6
220    .e insert 2 XXX
221    lappend result [.e index sel.first] [.e index sel.last]
222    .e insert 6 YYY
223    lappend result [.e index sel.first] [.e index sel.last] [.e get]
224} -result {5 9 5 12 01XXX2YYY3456789}
225
226# Self-destruct tests.
227
228test entry-5.1 {widget deletion while active} -body {
229    destroy .e
230    pack [ttk::entry .e]
231    update
232    .e config -xscrollcommand { destroy .e }
233    update idletasks
234    winfo exists .e
235} -result 0
236
237# TODO: test killing .e in -validatecommand, -invalidcommand, variable trace;
238
239
240# -textvariable tests.
241
242test entry-6.1 {Update linked variable in write trace} -body {
243    proc override args {
244	global x
245	set x "Overridden!"
246    }
247    catch {destroy .e}
248    set x ""
249    trace variable x w override
250    ttk::entry .e -textvariable x
251    .e insert 0 "Some text"
252    set result [list $x [.e get]]
253    set result
254} -result {Overridden! Overridden!} -cleanup {
255    unset x
256    rename override {}
257    destroy .e
258}
259
260test entry-6.2 {-textvariable tests} -body {
261    set result [list]
262    ttk::entry .e -textvariable x
263    set x "text"
264    lappend result [.e get]
265    unset x
266    lappend result [.e get]
267    .e insert end "newtext"
268    lappend result [.e get] [set x]
269} -result [list "text" "" "newtext" "newtext"] -cleanup {
270    destroy .e
271    unset -nocomplain x
272}
273
274test entry-7.1 {Bad style options} -body {
275    ttk::style theme create entry-7.1 -settings {
276	ttk::style configure TEntry -foreground BadColor
277	ttk::style map TEntry -foreground {readonly AnotherBadColor}
278	ttk::style map TEntry -font {readonly ABadFont}
279	ttk::style map TEntry \
280	    -selectbackground {{} BadColor} \
281	    -selectforeground {{} BadColor} \
282	    -insertcolor {{} BadColor}
283    }
284    pack [ttk::entry .e -text "Don't crash"]
285    ttk::style theme use entry-7.1
286    update
287    .e selection range 0 end
288    update
289    .e state readonly;
290    update
291} -cleanup { destroy .e ; ttk::style theme use default }
292
293test entry-8.1 "Unset linked variable" -body {
294    variable foo "bar"
295    pack [ttk::entry .e -textvariable foo]
296    unset foo
297    .e insert end "baz"
298    list [.e cget -textvariable] [.e get] [set foo]
299} -result [list foo "baz" "baz"] -cleanup { destroy .e }
300
301test entry-8.2 "Unset linked variable by deleting namespace" -body {
302    namespace eval ::test  { variable foo "bar" }
303    pack [ttk::entry .e -textvariable ::test::foo]
304    namespace delete ::test
305    .e insert end "baz"		;# <== error here
306    list [.e cget -textvariable] [.e get] [set foo]
307} -returnCodes error -result "*parent namespace doesn't exist*" -match glob
308# '-result [list ::test::foo "baz" "baz"]' would also be sensible,
309# but Tcl namespaces don't work that way.
310
311test entry-8.2a "Followup to test 8.2" -body {
312    .e cget -textvariable
313} -result ::test::foo -cleanup { destroy .e }
314# For 8.2a, -result {} would also be sensible.
315
316test entry-9.1 "Index range invariants" -setup {
317    # See bug#1721532 for discussion
318    proc entry-9.1-trace {n1 n2 op} {
319    	set ::V NO!
320    }
321    variable V
322    trace add variable V write entry-9.1-trace
323    ttk::entry .e -textvariable V
324} -body {
325    set result [list]
326    .e insert insert a ; lappend result [.e index insert] [.e index end]
327    .e insert insert b ; lappend result [.e index insert] [.e index end]
328    .e insert insert c ; lappend result [.e index insert] [.e index end]
329    .e insert insert d ; lappend result [.e index insert] [.e index end]
330    .e insert insert e ; lappend result [.e index insert] [.e index end]
331    set result
332} -result [list 1 3  2 3  3 3  3 3  3 3] -cleanup {
333    unset V
334    destroy .e
335}
336
337test entry-10.1 {configuration option: "-placeholder"} -setup {
338    pack [ttk::entry .e]
339} -body {
340    .e configure -placeholder {Some text}
341    .e cget -placeholder
342} -cleanup {
343    destroy .e
344} -result {Some text}
345
346test entry-10.2 {configuration option: "-placeholderforeground"} -setup {
347    pack [ttk::entry .e]
348} -body {
349    .e configure -placeholder {Some text} -placeholderforeground red
350    .e cget -placeholderforeground
351} -cleanup {
352    destroy .e
353} -result {red}
354
355test entry-10.3 {styling option: "-placeholderforeground"} -setup {
356    pack [ttk::entry .e]
357} -body {
358    set current [ttk::style configure TEntry -placeholderforeground]
359    ttk::style configure TEntry -placeholderforeground blue
360    set res [ttk::style configure TEntry -placeholderforeground]
361    ttk::style configure TEntry -placeholderforeground $current
362    set res
363} -cleanup {
364    destroy .e
365} -result {blue}
366
367test entry-11.1 {Bug [2830360fff] - Don't loose invalid at focus events} -setup {
368    pack [ttk::entry .e]
369    update
370} -body {
371    .e state invalid
372    set res [.e state]
373    event generate .e <FocusOut>
374    lappend res [.e state]
375} -result {invalid invalid} -cleanup {
376    destroy .e
377}
378
379test entry-12.1 "style command" -body {
380    ttk::entry .w
381    list [.w cget -style] [.w style] [winfo class .w]
382} -cleanup {
383    destroy .w
384} -result {{} TEntry TEntry}
385test entry-12.2 "style command" -body {
386    ttk::style configure customStyle.TEntry
387    ttk::entry .w -style customStyle.TEntry
388    list [.w cget -style] [.w style] [winfo class .w]
389} -cleanup {
390    destroy .w
391} -result {customStyle.TEntry customStyle.TEntry TEntry}
392
393tcltest::cleanupTests
394