#
# Tile package: entry widget tests
#
package require Tk
package require tcltest ; namespace import -force tcltest::*
lappend auto_path .
package require tile
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 {
tentry .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 [tentry .te -xscrollcommand [list .tsb set]] \
-expand true -fill both
pack [tscrollbar .tsb -orient horizontal -command [list .te xview]] \
-expand false -fill x
} -cleanup {destroy .te .tsb}
test entry-2.2 "Initial scroll position" -body {
tentry .e -font fixed -width 5 -xscrollcommand scroll
.e insert end "0123456789"
pack .e; update
set scrollInfo
} -result {0 0.6} -cleanup { destroy .e }
# NOTE: result can be 0.5 or 0.6 depending on font.
# *should* be 0.6 always.
# Bounding box / scrolling tests.
test entry-3.0 "Series 3 setup" -body {
variable fixed fixed
variable cw [font measure $fixed a]
variable ch [font metrics $fixed -linespace]
variable bd 4 ;# highlight + border + padding
variable ux [font measure $fixed \u4e4e]
pack [tentry .e -font $fixed]
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;
update
.e insert end [string repeat "M" 42]
set result [list [.e xview]]
update
lappend result [.e xview]
} -result {{0 0.5} {0 0.5}}
test entry-3.last "Series 3 cleanup" -body {
destroy .e
}
# Selection tests:
test entry-4.0 "Selection test - setup" -body {
tentry .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, sel.last, and anchor gravity} -body {
set result [list]
.e delete 0 end
.e insert 0 0123456789
.e select from 2
.e select to 6
.e insert 2 XXX
lappend result [.e index sel.first] [.e index sel.last]
.e select to 8
lappend result [.e index sel.first] [.e index sel.last]
} -result {5 9 5 8}
# Self-destruct tests.
test entry-5.1 {widget deletion while active} -body {
destroy .e
pack [tentry .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
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 {} }
## Combobox tests.
# Only a few here, doesn't deserve its own file yet.
#
test combobox-1.0 "Combobox tests -- setup" -body {
tcombobox .cb
} -result .cb
test combobox-1.1 "Bad -values list" -body {
.cb configure -values "bad \{list"
} -result "unmatched open brace in list" -returnCodes 1
tcltest::cleanupTests
tcltest::cleanupTests