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