path: root/tests/ttk/validate.test

#
# Entry widget validation tests
# Derived from core test suite entry-19.1 through entry-19.20
#

#
# TESTFILE INITIALIZATION
#

package require tcltest 2.2; # needed in mode -singleproc 0

# Load the main script main.tcl, which takes care of:
# - setup for the application and the root window
# - importing commands from the tcltest namespace
# - loading of the testutils mechanism along with its utility procs
# - loading of Tk specific test constraints (additionally to constraints
#   provided by the package tcltest)
source [file join [file dirname [tcltest::configure -testdir]] main.tcl]

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import entry

#
# LOCAL TEST CONSTRAINTS
#

testConstraint ttkEntry 1
testConstraint coreEntry [expr {![testConstraint ttkEntry]}]
testConstraint NA 0

#
# COMMON TEST SETUP
#

foreach i {1 2 3 4} {
    set validateCmd$i [list validateCommand$i %W %d %i %P %s %S %v %V]
}

#
# TESTS
#

test validate-0.0 "Setup" -constraints ttkEntry -body {
    rename entry {}
    interp alias {} entry {} ttk::entry
    return;
}

test validate-0.1 "More setup" -body {
    destroy .e
    catch {unset textVar}
    unset -nocomplain validationData; # not necessary
    entry .e -validate all \
	    -validatecommand $validateCmd1 \
	    -invalidcommand bell \
	    -textvariable textVar \
	    ;
    pack .e
}

# The validation tests build each one upon the previous, so cascading
# failures aren't good
#
test validate-1.1 {entry widget validation - insert} -body {
    .e insert 0 a
    set validationData
} -result {.e 1 0 a {} a all key}

test validate-1.2 {entry widget validation - insert} -body {
    .e insert 1 b
    set validationData
} -result {.e 1 1 ab a b all key}

test validate-1.3 {entry widget validation - insert} -body {
    .e insert end c
    set validationData
} -result {.e 1 2 abc ab c all key}

test validate-1.4 {entry widget validation - insert} -body {
    .e insert 1 123
    list $validationData $textVar
} -result {{.e 1 1 a123bc abc 123 all key} a123bc}

test validate-1.5 {entry widget validation - delete} -body {
    .e delete 2
    set validationData
} -result {.e 0 2 a13bc a123bc 2 all key}

test validate-1.6 {entry widget validation - delete} -body {
    .e configure -validate key
    .e delete 1 3
    set validationData
} -result {.e 0 1 abc a13bc 13 key key}

test validate-1.7 {entry widget validation - vmode focus} -body {
    set validationData {}
    .e configure -validate focus
    .e insert end d
    set validationData
} -result {}

test validate-1.8 {entry widget validation - vmode focus} -body {
    set validationData {}
    set timer [after 300 validationData lappend timeout]
    focus -force .e
    vwait validationData
    after cancel $timer
    set validationData
} -result {.e -1 -1 abcd abcd {} focus focusin}

test validate-1.9 {entry widget validation - vmode focus} -body {
    set validationData {}
    set timer [after 300 validationData lappend timeout]
    focus -force .
    vwait validationData
    after cancel $timer
    set validationData
} -result {.e -1 -1 abcd abcd {} focus focusout}

#
# COMMON TEST SETUP
#

.e configure -validate all

test validate-1.10 {entry widget validation - vmode all} -body {
    set validationData {}
    set timer [after 300 validationData lappend timeout]
    focus -force .e
    vwait validationData
    after cancel $timer
    set validationData
} -result {.e -1 -1 abcd abcd {} all focusin}

test validate-1.11 {entry widget validation} -body {
    set validationData {}
    set timer [after 300 validationData lappend timeout]
    focus -force .
    vwait validationData
    after cancel $timer
    set validationData
} -result {.e -1 -1 abcd abcd {} all focusout}

#
# COMMON TEST SETUP
#

.e configure -validate focusin

test validate-1.12 {entry widget validation} -body {
    set validationData {}
    set timer [after 300 validationData lappend timeout]
    focus -force .e
    vwait validationData
    after cancel $timer
    set validationData
} -result {.e -1 -1 abcd abcd {} focusin focusin}

test validate-1.13 {entry widget validation} -body {
    set validationData {}
    focus -force .
    update
    set validationData
} -result {}

#
# COMMON TEST SETUP
#

.e configure -validate focuso

test validate-1.14 {entry widget validation} -body {
    set validationData {}
    focus -force .e
    update
    set validationData
} -result {}

test validate-1.15 {entry widget validation} -body {
    focus -force .
    # update necessary to process FocusOut event
    update
    set validationData
} -result {.e -1 -1 abcd abcd {} focusout focusout}

# DIFFERENCE: core entry temporarily sets "-validate all", ttk::entry doesn't.
test validate-1.16 {entry widget validation} -body {
    .e configure -validate all
    list [.e validate] $validationData
} -result {1 {.e -1 -1 abcd abcd {} all forced}}

# DIFFERENCE: ttk::entry does not perform validation when setting the -variable
test validate-1.17 {entry widget validation} -constraints coreEntry -body {
    .e configure -validate all
    set textVar newdata
    list [.e cget -validate] $validationData
} -result {all {.e -1 -1 newdata abcd {} all forced}}

test validate-1.18 {entry widget validation} -constraints coreEntry -body {
    .e configure -validate all -validatecommand $validateCmd3
    set textVar nextdata
    list [.e cget -validate] $validationData
} -result {none {.e -1 -1 nextdata newdata {} all forced}}
# DIFFERENCE: ttk::entry doesn't validate when setting linked -variable
# DIFFERENCE: ttk::entry doesn't disable validation

## This sets validate to none because it shows that we prevent a possible
## loop condition in the validation, when the entry textvar is also set
test validate-1.19 {entry widget validation} -constraints coreEntry -body {
    .e configure -validate all -validatecommand $validateCmd2
    .e validate
    list [.e cget -validate] [.e get] $validationData
} -result {none mydata {.e -1 -1 nextdata nextdata {} all forced}}

## This leaves validate alone because we trigger validation through the
## textvar (a write trace), and the write during validation triggers
## nothing (by definition of avoiding loops on var traces).  This is
## one of those "dangerous" conditions where the user will have a
## different value in the entry widget shown as is in the textvar.

# DIFFERENCE: ttk entry doesn't get out of sync w/textvar
test validate-1.20 {entry widget validation} -constraints coreEntry -body {
    .e configure -validate all -validatecommand $validateCmd2
    set textVar testdata
    list [.e cget -validate] [.e get] $textVar $validationData
} -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}}

test validate-2.1 "Validation script changes value" -body {
    .e configure -validate none -validatecommand $validateCmd4
    set textVar testdata
    .e configure -validate all
    .e validate
    list [.e get] $textVar $validationData
} -result {dovaldata dovaldata {.e -1 -1 testdata testdata {} all forced}}
# DIFFERENCE: core entry disables validation, ttk entry does not.

#
# COMMON TEST CLEANUP
#

destroy .e
catch {unset textVar}

# See bug #1236979

test validate-2.2 "configure in -validatecommand" -body {
    proc validate-2.2 {win str} {
	$win configure -foreground black
	return 1
    }
    ttk::entry .e -textvariable var -validatecommand {validate-2.2 %W %P}
    .e validate
} -result 1 -cleanup { destroy .e }


### invalid state behavior
#

test validate-3.0 "Setup" -body {
    set ::E "123"
    ttk::entry .e \
	-validatecommand {string is integer -strict %P} \
	-validate all \
	-textvariable ::E \
	;
    return [list [.e get] [.e state]]
} -result [list 123 {}]

test validate-3.1 "insert - valid" -body {
    .e insert end "4"
    return [list [.e get] [.e state]]
} -result [list 1234 {}]

test validate-3.2 "insert - invalid" -body {
    .e insert end "X"
    return [list [.e get] [.e state]]
} -result [list 1234 {}]

test validate-3.3 "force invalid value" -body {
    append ::E "XY"
    return [list [.e get] [.e state]]
} -result [list 1234XY {}]

test validate-3.4 "revalidate" -body {
    return [list [.e validate] [.e get] [.e state]]
} -result [list 0 1234XY {invalid}]

# the next two tests (used to) exercise validation lockout protection --
# if the widget is currently invalid, all edits are allowed.
# This behavior is currently disabled.
#
test validate-3.5 "all edits allowed while invalid" -constraints NA -body {
    .e delete 4
    return [list [.e get] [.e state]]
} -result [list 1234Y {invalid}]

test validate-3.6 "...until the value becomes valid" -constraints NA -body {
    .e delete 4
    return [list [.e get] [.e state]]
} -result [list 1234 {}]

test validate-3.last "Cleanup" -body { destroy .e }

#
# TESTFILE CLEANUP
#

foreach i {1 2 3 4} {
    unset validateCmd$i
}
unset i
testutils forget entry
tcltest::cleanupTests