summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorhobbs <hobbs>2000-03-02 21:52:24 (GMT)
committerhobbs <hobbs>2000-03-02 21:52:24 (GMT)
commit9521a71f90589b90b5506505a8c81b7cb198b96d (patch)
treed64e49d733925389d130957ffe45696b65aa128d /tests
parent99ad7ea580fa5e8a8b31feee30c6cbd6615b9ba7 (diff)
downloadtk-9521a71f90589b90b5506505a8c81b7cb198b96d.zip
tk-9521a71f90589b90b5506505a8c81b7cb198b96d.tar.gz
tk-9521a71f90589b90b5506505a8c81b7cb198b96d.tar.bz2
* tests/config.test: extra test to check object cleanup when
destroying the widget * tests/entry.test: added test suite for entry validation
Diffstat (limited to 'tests')
-rw-r--r--tests/button.test15
-rw-r--r--tests/canvas.test15
-rw-r--r--tests/config.test26
-rw-r--r--tests/entry.test164
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.