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