path: root/tests/ttk/entry.test

#
# Tile package: entry widget tests
#

package require Tk 8.5
package require tcltest ; namespace import -force tcltest::*
loadTestedCommands

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 {
    ttk::entry .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 [ttk::entry .te -xscrollcommand [list .tsb set]] \
	-expand true -fill both
    pack [ttk::scrollbar .tsb -orient horizontal -command [list .te xview]] \
    	-expand false -fill x
}  -cleanup {destroy .te .tsb}

test entry-2.2 "Initial scroll position" -body {
    ttk::entry .e -font fixed -width 5 -xscrollcommand scroll
    .e insert end "0123456789"
    pack .e; update
    set scrollInfo
} -result {0 0.5} -cleanup { destroy .e }
# NOTE: result can vary depending on font.

# Bounding box / scrolling tests.
test entry-3.0 "Series 3 setup" -body {
    ttk::style theme use default
    variable fixed fixed
    variable cw [font measure $fixed a]
    variable ch [font metrics $fixed -linespace]
    variable bd 2	;# border + padding
    variable ux [font measure $fixed \u4e4e]

    pack [ttk::entry .e -font $fixed -width 20]
    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;
    .e insert end [string repeat "0" 40]
    update idletasks
    set result [.e xview]
} -result {0 0.5}

test entry-3.last "Series 3 cleanup" -body {
    destroy .e
}

# Selection tests:

test entry-4.0 "Selection test - setup" -body {
    ttk::entry .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 and sel.last gravity} -body {
    set result [list]
    .e delete 0 end
    .e insert 0 0123456789
    .e select range 2 6
    .e insert 2 XXX
    lappend result [.e index sel.first] [.e index sel.last]
    .e insert 6 YYY
    lappend result [.e index sel.first] [.e index sel.last] [.e get]
} -result {5 9 5 12 01XXX2YYY3456789}

# Self-destruct tests.

test entry-5.1 {widget deletion while active} -body {
    destroy .e
    pack [ttk::entry .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
    ttk::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 {}
    destroy .e
}

test entry-6.2 {-textvariable tests} -body {
    set result [list]
    ttk::entry .e -textvariable x
    set x "text"
    lappend result [.e get]
    unset x
    lappend result [.e get]
    .e insert end "newtext"
    lappend result [.e get] [set x]
} -result [list "text" "" "newtext" "newtext"] -cleanup {
    destroy .e
    unset -nocomplain x
}

test entry-7.1 {Bad style options} -body {
    ttk::style theme create entry-7.1 -settings {
	ttk::style configure TEntry -foreground BadColor
	ttk::style map TEntry -foreground {readonly AnotherBadColor}
	ttk::style map TEntry -font {readonly ABadFont}
	ttk::style map TEntry \
	    -selectbackground {{} BadColor} \
	    -selectforeground {{} BadColor} \
	    -insertcolor {{} BadColor}
    }
    pack [ttk::entry .e -text "Don't crash"]
    ttk::style theme use entry-7.1
    update
    .e selection range 0 end
    update
    .e state readonly;
    update
} -cleanup { destroy .e ; ttk::style theme use default }

test entry-8.1 "Unset linked variable" -body {
    variable foo "bar"
    pack [ttk::entry .e -textvariable foo]
    unset foo
    .e insert end "baz"
    list [.e cget -textvariable] [.e get] [set foo]
} -result [list foo "baz" "baz"] -cleanup { destroy .e }

test entry-8.2 "Unset linked variable by deleting namespace" -body {
    namespace eval ::test  { variable foo "bar" }
    pack [ttk::entry .e -textvariable ::test::foo]
    namespace delete ::test
    .e insert end "baz"		;# <== error here
    list [.e cget -textvariable] [.e get] [set foo]
} -returnCodes error -result "*parent namespace doesn't exist*" -match glob
# '-result [list ::test::foo "baz" "baz"]' would also be sensible,
# but Tcl namespaces don't work that way.

test entry-8.2a "Followup to test 8.2" -body {
    .e cget -textvariable
} -result ::test::foo -cleanup { destroy .e }
# For 8.2a, -result {} would also be sensible.

tcltest::cleanupTests