1#
2# Tile package: entry widget tests
3#
4
5package require Tk 8.5
6package require tcltest ; namespace import -force tcltest::*
7loadTestedCommands
8
9variable scrollInfo
10proc scroll args {
11    global scrollInfo
12    set scrollInfo $args
13}
14
15# Some of the tests raise background errors;
16# override default bgerror to catch them.
17#
18variable bgerror ""
19proc bgerror {error} {
20    variable bgerror $error
21    variable bgerrorInfo $::errorInfo
22    variable bgerrorCode $::errorCode
23}
24
25#
26test entry-1.1 "Create entry widget" -body {
27    ttk::entry .e
28} -result .e
29
30test entry-1.2 "Insert" -body {
31    .e insert end abcde
32    .e get
33} -result abcde
34
35test entry-1.3 "Selection" -body {
36    .e selection range 1 3
37    selection get
38} -result bc
39
40test entry-1.4 "Delete" -body {
41    .e delete 1 3
42    .e get
43} -result ade
44
45test entry-1.5 "Deletion - insert cursor" -body {
46    .e insert end abcde
47    .e icursor 0
48    .e delete 0 end
49    .e index insert
50} -result 0
51
52test entry-1.6 "Deletion - insert cursor at end" -body {
53    .e insert end abcde
54    .e icursor end
55    .e delete 0 end
56    .e index insert
57} -result 0
58
59test entry-1.7 "Deletion - insert cursor in the middle " -body {
60    .e insert end abcde
61    .e icursor 3
62    .e delete 0 end
63    .e index insert
64} -result 0
65
66test entry-1.done "Cleanup" -body { destroy .e }
67
68# Scrollbar tests.
69
70test entry-2.1 "Create entry before scrollbar" -body {
71    pack [ttk::entry .te -xscrollcommand [list .tsb set]] \
72	-expand true -fill both
73    pack [ttk::scrollbar .tsb -orient horizontal -command [list .te xview]] \
74    	-expand false -fill x
75}  -cleanup {destroy .te .tsb}
76
77test entry-2.2 "Initial scroll position" -body {
78    ttk::entry .e -font fixed -width 5 -xscrollcommand scroll
79    .e insert end "0123456789"
80    pack .e; update
81    set scrollInfo
82} -result {0.0 0.5} -cleanup { destroy .e }
83# NOTE: result can vary depending on font.
84
85# Bounding box / scrolling tests.
86test entry-3.0 "Series 3 setup" -body {
87    ttk::style theme use default
88    variable fixed fixed
89    variable cw [font measure $fixed a]
90    variable ch [font metrics $fixed -linespace]
91    variable bd 2	;# border + padding
92    variable ux [font measure $fixed \u4e4e]
93
94    pack [ttk::entry .e -font $fixed -width 20]
95    update
96}
97
98test entry-3.1 "bbox widget command" -body {
99    .e delete 0 end
100    .e bbox 0
101} -result [list $bd $bd 0 $ch]
102
103test entry-3.2 "xview" -body {
104    .e delete 0 end;
105    .e insert end [string repeat "0" 40]
106    update idletasks
107    set result [.e xview]
108} -result {0.0 0.5}
109
110test entry-3.last "Series 3 cleanup" -body {
111    destroy .e
112}
113
114# Selection tests:
115
116test entry-4.0 "Selection test - setup" -body {
117    ttk::entry .e
118    .e insert end asdfasdf
119    .e selection range 0 end
120}
121
122test entry-4.1 "Selection test" -body {
123    selection get
124} -result asdfasdf
125
126test entry-4.2 "Disable -exportselection" -body {
127    .e configure -exportselection false
128    selection get
129} -returnCodes error -result "PRIMARY selection doesn't exist*" -match glob
130
131test entry-4.3 "Reenable -exportselection" -body {
132    .e configure -exportselection true
133    selection get
134} -result asdfasdf
135
136test entry-4.4 "Force selection loss" -body {
137    selection own .
138    .e index sel.first
139} -returnCodes error -result "selection isn't in widget .e"
140
141test entry-4.5 "Allow selection changes if readonly" -body {
142    .e delete 0 end
143    .e insert end 0123456789
144    .e selection range 0 end
145    .e configure -state readonly
146    .e selection range 2 4
147    .e configure -state normal
148    list [.e index sel.first] [.e index sel.last]
149} -result {2 4}
150
151test entry-4.6 "Disallow selection changes if disabled" -body {
152    .e delete 0 end
153    .e insert end 0123456789
154    .e selection range 0 end
155    .e configure -state disabled
156    .e selection range 2 4
157    .e configure -state normal
158    list [.e index sel.first] [.e index sel.last]
159} -result {0 10}
160
161test entry-4.7 {sel.first and sel.last gravity} -body {
162    set result [list]
163    .e delete 0 end
164    .e insert 0 0123456789
165    .e select range 2 6
166    .e insert 2 XXX
167    lappend result [.e index sel.first] [.e index sel.last]
168    .e insert 6 YYY
169    lappend result [.e index sel.first] [.e index sel.last] [.e get]
170} -result {5 9 5 12 01XXX2YYY3456789}
171
172# Self-destruct tests.
173
174test entry-5.1 {widget deletion while active} -body {
175    destroy .e
176    pack [ttk::entry .e]
177    update
178    .e config -xscrollcommand { destroy .e }
179    update idletasks
180    winfo exists .e
181} -result 0
182
183# TODO: test killing .e in -validatecommand, -invalidcommand, variable trace;
184
185
186# -textvariable tests.
187
188test entry-6.1 {Update linked variable in write trace} -body {
189    proc override args {
190	global x
191	set x "Overridden!"
192    }
193    catch {destroy .e}
194    set x ""
195    trace variable x w override
196    ttk::entry .e -textvariable x
197    .e insert 0 "Some text"
198    set result [list $x [.e get]]
199    set result
200} -result {Overridden! Overridden!} -cleanup {
201    unset x
202    rename override {}
203    destroy .e
204}
205
206test entry-6.2 {-textvariable tests} -body {
207    set result [list]
208    ttk::entry .e -textvariable x
209    set x "text"
210    lappend result [.e get]
211    unset x
212    lappend result [.e get]
213    .e insert end "newtext"
214    lappend result [.e get] [set x]
215} -result [list "text" "" "newtext" "newtext"] -cleanup {
216    destroy .e
217    unset -nocomplain x
218}
219
220test entry-7.1 {Bad style options} -body {
221    ttk::style theme create entry-7.1 -settings {
222	ttk::style configure TEntry -foreground BadColor
223	ttk::style map TEntry -foreground {readonly AnotherBadColor}
224	ttk::style map TEntry -font {readonly ABadFont}
225	ttk::style map TEntry \
226	    -selectbackground {{} BadColor} \
227	    -selectforeground {{} BadColor} \
228	    -insertcolor {{} BadColor}
229    }
230    pack [ttk::entry .e -text "Don't crash"]
231    ttk::style theme use entry-7.1
232    update
233    .e selection range 0 end
234    update
235    .e state readonly;
236    update
237} -cleanup { destroy .e ; ttk::style theme use default }
238
239test entry-8.1 "Unset linked variable" -body {
240    variable foo "bar"
241    pack [ttk::entry .e -textvariable foo]
242    unset foo
243    .e insert end "baz"
244    list [.e cget -textvariable] [.e get] [set foo]
245} -result [list foo "baz" "baz"] -cleanup { destroy .e }
246
247test entry-8.2 "Unset linked variable by deleting namespace" -body {
248    namespace eval ::test  { variable foo "bar" }
249    pack [ttk::entry .e -textvariable ::test::foo]
250    namespace delete ::test
251    .e insert end "baz"		;# <== error here
252    list [.e cget -textvariable] [.e get] [set foo]
253} -returnCodes error -result "*parent namespace doesn't exist*" -match glob
254# '-result [list ::test::foo "baz" "baz"]' would also be sensible,
255# but Tcl namespaces don't work that way.
256
257test entry-8.2a "Followup to test 8.2" -body {
258    .e cget -textvariable
259} -result ::test::foo -cleanup { destroy .e }
260# For 8.2a, -result {} would also be sensible.
261
262test entry-9.1 "Index range invariants" -setup {
263    # See bug#1721532 for discussion
264    proc entry-9.1-trace {n1 n2 op} {
265    	set ::V NO!
266    }
267    variable V
268    trace add variable V write entry-9.1-trace
269    ttk::entry .e -textvariable V
270} -body {
271    set result [list]
272    .e insert insert a ; lappend result [.e index insert] [.e index end]
273    .e insert insert b ; lappend result [.e index insert] [.e index end]
274    .e insert insert c ; lappend result [.e index insert] [.e index end]
275    .e insert insert d ; lappend result [.e index insert] [.e index end]
276    .e insert insert e ; lappend result [.e index insert] [.e index end]
277    set result
278} -result [list 1 3  2 3  3 3  3 3  3 3] -cleanup {
279    unset V
280    destroy .e
281}
282
283tcltest::cleanupTests
284