diff options
| -rw-r--r-- | tests/button.test | 15 | ||||
| -rw-r--r-- | tests/canvas.test | 15 | ||||
| -rw-r--r-- | tests/config.test | 26 | ||||
| -rw-r--r-- | tests/entry.test | 164 |
4 files changed, 174 insertions, 46 deletions
diff --git a/tests/button.test b/tests/button.test index 309c795..24fc2dc 100644 --- a/tests/button.test +++ b/tests/button.test @@ -7,7 +7,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: button.test,v 1.3 1999/04/16 01:51:34 stanton Exp $ +# RCS: @(#) $Id: button.test,v 1.4 2000/03/02 21:52:24 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -783,16 +783,3 @@ option clear # cleanup ::tcltest::cleanupTests return - - - - - - - - - - - - - diff --git a/tests/canvas.test b/tests/canvas.test index 569dd6b..f02d404 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: canvas.test,v 1.6 1999/12/14 06:53:12 hobbs Exp $ +# RCS: @(#) $Id: canvas.test,v 1.7 2000/03/02 21:52:25 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -355,16 +355,3 @@ test canvas-10.12 {multple events bound to same tag expr} { # cleanup ::tcltest::cleanupTests return - - - - - - - - - - - - - diff --git a/tests/config.test b/tests/config.test index 8fdbbd7..a12ecb5 100644 --- a/tests/config.test +++ b/tests/config.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: config.test,v 1.2 1999/04/16 01:51:36 stanton Exp $ +# RCS: @(#) $Id: config.test,v 1.3 2000/03/02 21:52:25 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -819,21 +819,19 @@ test config-12.16 {GetObjectForOption - null values} { [.a cget -cursor] [.a cget -window] } {{} {} {} {} {} {} {} {}} +test config-13.1 {proper cleanup of options with widget destroy} { + foreach type { + button canvas entry frame listbox menu menubutton message + scale scrollbar text radiobutton checkbutton + } { + destroy .w + $type .w -cursor crosshair + destroy .w + } +} {} + # cleanup eval destroy [winfo children .] killTables ::tcltest::cleanupTests return - - - - - - - - - - - - - diff --git a/tests/entry.test b/tests/entry.test index bb0c19c..f90e5b4 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: entry.test,v 1.5 1999/12/21 23:55:54 hobbs Exp $ +# RCS: @(#) $Id: entry.test,v 1.6 2000/03/02 21:52:26 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -1329,7 +1329,7 @@ test entry-17.3 {EntryUpdateScrollbar procedure} { set scrollInfo } {0.315789 0.842105} test entry-17.4 {EntryUpdateScrollbar procedure} { - catch {destroy .e} + destroy .e proc bgerror msg { global x set x $msg @@ -1348,13 +1348,169 @@ set l [interp hidden] eval destroy [winfo children .] test entry-18.1 {Entry widget vs hiding} { - catch {destroy .e} + destroy .e entry .e interp hide {} .e destroy .e list [winfo children .] [interp hidden] } [list {} $l] - + +## +## Entry widget VALIDATION tests +## + +destroy .e +catch {unset ::e} +catch {unset ::vVals} +entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white +pack .e +proc doval {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + return 1 +} + +# The validation tests build each one upon the previous, so cascading +# failures aren't good +# +test entry-19.1 {entry widget validation} { + .e insert 0 a + set ::vVals +} {.e 1 0 a {} a all key} +test entry-19.2 {entry widget validation} { + .e insert 1 b + set ::vVals +} {.e 1 1 ab a b all key} +test entry-19.3 {entry widget validation} { + .e insert end c + set ::vVals +} {.e 1 2 abc ab c all key} +test entry-19.4 {entry widget validation} { + .e insert 1 123 + list $::vVals $::e +} {{.e 1 1 a123bc abc 123 all key} a123bc} +test entry-19.5 {entry widget validation} { + .e delete 2 + set ::vVals +} {.e 0 2 a13bc a123bc 2 all key} +test entry-19.6 {entry widget validation} { + .e configure -validate key + .e delete 1 3 + set ::vVals +} {.e 0 1 abc a13bc 13 key key} +test entry-19.7 {entry widget validation} { + set ::vVals {} + .e configure -validate focus + .e insert end d + set ::vVals +} {} +test entry-19.8 {entry widget validation} { + focus -force .e + # update necessary to process FocusIn event + update + set ::vVals +} {.e -1 -1 abcd abcd {} focus focusin} +test entry-19.9 {entry widget validation} { + focus -force . + # update necessary to process FocusOut event + update + set ::vVals +} {.e -1 -1 abcd abcd {} focus focusout} +.e configure -validate all +test entry-19.10 {entry widget validation} { + focus -force .e + # update necessary to process FocusIn event + update + set ::vVals +} {.e -1 -1 abcd abcd {} all focusin} +test entry-19.11 {entry widget validation} { + focus -force . + # update necessary to process FocusOut event + update + set ::vVals +} {.e -1 -1 abcd abcd {} all focusout} +.e configure -validate focusin +test entry-19.12 {entry widget validation} { + focus -force .e + # update necessary to process FocusIn event + update + set ::vVals +} {.e -1 -1 abcd abcd {} focusin focusin} +test entry-19.13 {entry widget validation} { + set ::vVals {} + focus -force . + # update necessary to process FocusOut event + update + set ::vVals +} {} +.e configure -validate focuso +test entry-19.14 {entry widget validation} { + focus -force .e + # update necessary to process FocusIn event + update + set ::vVals +} {} +test entry-19.15 {entry widget validation} { + focus -force . + # update necessary to process FocusOut event + update + set ::vVals +} {.e -1 -1 abcd abcd {} focusout focusout} +test entry-19.16 {entry widget validation} { + list [.e validate] $::vVals +} {1 {.e -1 -1 abcd abcd {} all forced}} +test entry-19.17 {entry widget validation} { + set ::e newdata + list [.e cget -validate] $::vVals +} {focusout {.e -1 -1 newdata abcd {} focusout forced}} + +proc doval {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + return 0 +} +.e configure -validate all + +test entry-19.18 {entry widget validation} { + set ::e nextdata + list [.e cget -validate] $::vVals +} {none {.e -1 -1 nextdata newdata {} all forced}} + +proc doval {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + set ::e mydata + return 1 +} +.e configure -validate all + +## 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 entry-19.19 {entry widget validation} { + .e validate + list [.e cget -validate] [.e get] $::vVals +} {none mydata {.e -1 -1 nextdata nextdata {} all forced}} + +.e configure -validate all + +## 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. +test entry-19.20 {entry widget validation} { + set ::e testdata + list [.e cget -validate] [.e get] $::e $::vVals +} {all testdata mydata {.e -1 -1 testdata mydata {} all forced}} + +destroy .e +catch {unset ::e ::vVals} + +## +## End validation tests +## + # XXX Still need to write tests for EntryBlinkProc, EntryFocusProc, # and EntryTextVarProc. |