diff options
| author | dgp@users.sourceforge.net <dgp> | 2002-07-14 05:48:45 (GMT) |
|---|---|---|
| committer | dgp@users.sourceforge.net <dgp> | 2002-07-14 05:48:45 (GMT) |
| commit | a8d6d5a7d1a25bda8d02c4a62e8f58ff454a0924 (patch) | |
| tree | 506cf7b5383406d4969854b8209566f9c0b690c6 /tests | |
| parent | 8beb23bd1e2a1912c06850f0dbf839339ae38d98 (diff) | |
| download | tk-a8d6d5a7d1a25bda8d02c4a62e8f58ff454a0924.zip tk-a8d6d5a7d1a25bda8d02c4a62e8f58ff454a0924.tar.gz tk-a8d6d5a7d1a25bda8d02c4a62e8f58ff454a0924.tar.bz2 | |
* Completed conversion of Tk test suite to use tcltest.
Diffstat (limited to 'tests')
37 files changed, 779 insertions, 897 deletions
diff --git a/tests/all.tcl b/tests/all.tcl index f6dee92..dbfe6c6 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -9,59 +9,11 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: all.tcl,v 1.6 2002/04/12 09:18:52 hobbs Exp $ +# RCS: @(#) $Id: all.tcl,v 1.7 2002/07/14 05:48:45 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} -set ::tcltest::testSingleFile false - -puts stdout "Tk $tk_patchLevel tests running in interp: [info nameofexecutable]" -puts stdout "Tests running in working dir: $::tcltest::workingDir" -if {[llength $::tcltest::skip] > 0} { - puts stdout "Skipping tests that match: $::tcltest::skip" -} -if {[llength $::tcltest::match] > 0} { - puts stdout "Only running tests that match: $::tcltest::match" -} - -# Use command line specified glob pattern (specified by -file or -f) -# if one exists. Otherwise use *.test. If given, the file pattern -# should be specified relative to the dir containing this file. If no -# files are found to match the pattern, print an error message and exit. -set fileIndex [expr {[lsearch $argv "-file"] + 1}] -set fIndex [expr {[lsearch $argv "-f"] + 1}] -if {($fileIndex < 1) || ($fIndex > $fileIndex)} { - set fileIndex $fIndex -} -if {$fileIndex > 0} { - set globPattern [file join $::tcltest::testsDir [lindex $argv $fileIndex]] - puts stdout "Sourcing files that match: $globPattern" -} else { - set globPattern [file join $::tcltest::testsDir *.test] -} -set fileList [glob -nocomplain $globPattern] -if {[llength $fileList] < 1} { - puts "Error: no files found matching $globPattern" - exit -} -set timeCmd {clock format [clock seconds]} -puts stdout "Tests began at [eval $timeCmd]" - -# source each of the specified tests -foreach file [lsort $fileList] { - set tail [file tail $file] - if {[string match l.*.test $tail]} { - # This is an SCCS lockfile; ignore it - continue - } - puts stdout $tail - if {[catch {source $file} msg]} { - puts stdout $msg - } -} - -# cleanup -puts stdout "\nTests ended at [eval $timeCmd]" -::tcltest::cleanupTests 1 -return +package require Tcl 8.4 +package require tcltest 2.1 +tcltest::configure -testdir [file join [pwd] [file dirname [info script]]] +tcltest::configure -singleproc 1 +eval tcltest::configure $argv +tcltest::runAllTests diff --git a/tests/bell.test b/tests/bell.test index 96b7a74..3c0975b 100644 --- a/tests/bell.test +++ b/tests/bell.test @@ -5,11 +5,14 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: bell.test,v 1.5 2000/05/17 22:44:10 hobbs Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +# RCS: @(#) $Id: bell.test,v 1.6 2002/07/14 05:48:45 dgp Exp $ + +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands test bell-1.1 {bell command} { list [catch {bell a} msg] $msg diff --git a/tests/bgerror.test b/tests/bgerror.test index cf6489b..dab97fd 100644 --- a/tests/bgerror.test +++ b/tests/bgerror.test @@ -5,11 +5,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: bgerror.test,v 1.3 1999/04/16 01:51:33 stanton Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +# RCS: @(#) $Id: bgerror.test,v 1.4 2002/07/14 05:48:45 dgp Exp $ + +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands test bgerror-1.1 {bgerror / tkerror compat} { set errRes {} diff --git a/tests/bind.test b/tests/bind.test index ad84ed5..e5ff490 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -7,11 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: bind.test,v 1.9 2001/03/30 21:52:28 hobbs Exp $ +# RCS: @(#) $Id: bind.test,v 1.10 2002/07/14 05:48:45 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands catch {destroy .b} toplevel .b -width 100 -height 50 @@ -214,13 +217,7 @@ test bind-5.1 {Tk_CreateBindingTable procedure} { .b.c bind foo } {} - -if {[string compare testcbind [info commands testcbind]] != 0} { - puts "This application hasn't been compiled with the testcbind command," - puts "therefore I am skipping all of these tests." - ::tcltest::cleanupTests - return -} +testConstraint testcbind [llength [info commands testcbind]] test bind-6.1 {Tk_DeleteBindTable procedure} { catch {destroy .b.c} @@ -230,7 +227,7 @@ test bind-6.1 {Tk_DeleteBindTable procedure} { .b.c bind 1 <2> {string 2} destroy .b.c } {} -test bind-6.2 {Tk_DeleteBindTable procedure: pending bindings deleted later} { +test bind-6.2 {Tk_DeleteBindTable procedure: pending bindings deleted later} testcbind { catch {interp delete foo} interp create foo foo eval { @@ -258,7 +255,7 @@ test bind-7.1 {Tk_CreateBinding procedure: bad binding} { canvas .b.c list [catch {.b.c bind foo <} msg] $msg } {1 {no event type or button # or keysym}} -test bind-7.2 {Tk_CreateBinding procedure: replace existing C binding} { +test bind-7.2 {Tk_CreateBinding procedure: replace existing C binding} testcbind { catch {destroy .b.f} frame .b.f testcbind .b.f <1> "xyz" "lappend x bye.1" @@ -282,10 +279,10 @@ test bind-7.4 {Tk_CreateBinding procedure: append to non-existing} { .b.c bind foo <1> } {button 1} -test bind-8.1 {TkCreateBindingProcedure: error} { +test bind-8.1 {TkCreateBindingProcedure: error} testcbind { list [catch {testcbind . <xyz> "xyz"} msg] $msg } {1 {bad event type or keysym "xyz"}} -test bind-8.2 {TkCreateBindingProcedure: new binding} { +test bind-8.2 {TkCreateBindingProcedure: new binding} testcbind { catch {destroy .b.f} frame .b.f testcbind .b.f <1> "lappend x 1" "lappend x bye.1" @@ -294,7 +291,7 @@ test bind-8.2 {TkCreateBindingProcedure: new binding} { destroy .b.f set x } {bye.1} -test bind-8.3 {TkCreateBindingProcedure: replace existing} { +test bind-8.3 {TkCreateBindingProcedure: replace existing} testcbind { catch {destroy .b.f} frame .b.f pack .b.f @@ -303,7 +300,7 @@ test bind-8.3 {TkCreateBindingProcedure: replace existing} { testcbind .b.f <1> "lappend x new1" "lappend x bye.new1" set x } {bye.old1} -test bind-8.4 {TkCreateBindingProcedure: replace existing while pending} { +test bind-8.4 {TkCreateBindingProcedure: replace existing while pending} testcbind { catch {destroy .b.f} frame .b.f pack .b.f @@ -347,7 +344,7 @@ test bind-9.3 {Tk_DeleteBinding procedure} { } set result } {{<Button-1> <Double-Alt-Button-1> <Meta-Button-1>} {<Button-1> <Meta-Button-1>} <Meta-Button-1> {}} -test bind-9.4 {Tk_DeleteBinding procedure: pending bindings delete later} { +test bind-9.4 {Tk_DeleteBinding procedure: pending bindings delete later} testcbind { catch {destroy .b.f} frame .b.f pack .b.f @@ -375,7 +372,7 @@ test bind-10.2 {Tk_GetBinding procedure} { .b.c bind foo a Test .b.c bind foo a } {Test} -test bind-10.3 {Tk_GetBinding procedure: C binding} { +test bind-10.3 {Tk_GetBinding procedure: C binding} testcbind { catch {destroy .b.f} frame .b.f testcbind .b.f <1> "foo" @@ -421,7 +418,7 @@ test bind-12.2 {Tk_DeleteAllBindings procedure} { } destroy .b.f } {} -test bind-12.3 {Tk_DeleteAllBindings procedure: pending bindings deleted later} { +test bind-12.3 {Tk_DeleteAllBindings procedure: pending bindings deleted later} testcbind { catch {destroy .b.f} frame .b.f pack .b.f @@ -731,7 +728,7 @@ test bind-13.31 {Tk_BindEvent procedure: match} { event gen .b.f <Button-2> set x } {Button-2} -test bind-13.32 {Tk_BindEvent procedure: many C bindings cause realloc} { +test bind-13.32 {Tk_BindEvent procedure: many C bindings cause realloc} testcbind { setup bindtags .b.f {a b c d e f g h i j k l m n o p} foreach p [bindtags .b.f] { @@ -753,14 +750,14 @@ test bind-13.33 {Tk_BindEvent procedure: multiple tags} { bind Test <Button-2> {} set x } {.b.f Button} -test bind-13.34 {Tk_BindEvent procedure: execute C binding} { +test bind-13.34 {Tk_BindEvent procedure: execute C binding} testcbind { setup testcbind .b.f <1> {lappend x 1} set x {} event gen .b.f <1> set x } {1} -test bind-13.35 {Tk_BindEvent procedure: pending list marked deleted} { +test bind-13.35 {Tk_BindEvent procedure: pending list marked deleted} testcbind { setup testcbind Test <1> {lappend x Test} {lappend x Deleted} bind .b.f <1> {lappend x .b.f; destroy .b.f} @@ -770,7 +767,7 @@ test bind-13.35 {Tk_BindEvent procedure: pending list marked deleted} { bind Test <1> {} set y } {.b.f <Button-1>} -test bind-13.36 {Tk_BindEvent procedure: C binding marked deleted} { +test bind-13.36 {Tk_BindEvent procedure: C binding marked deleted} testcbind { setup testcbind Test <1> {lappend x Test} {lappend x Deleted} bind .b.f <1> {lappend x .b.f; bind Test <1> {}; lappend x after} @@ -778,7 +775,7 @@ test bind-13.36 {Tk_BindEvent procedure: C binding marked deleted} { event gen .b.f <1> set x } {.b.f after Deleted} -test bind-13.37 {Tk_BindEvent procedure: C binding gets to run} { +test bind-13.37 {Tk_BindEvent procedure: C binding gets to run} testcbind { setup testcbind Test <1> {lappend x Test} bind .b.f <1> {lappend x .b.f} @@ -787,14 +784,14 @@ test bind-13.37 {Tk_BindEvent procedure: C binding gets to run} { bind Test <1> {} set x } {.b.f Test} -test bind-13.38 {Tk_BindEvent procedure: C binding deleted, refcount == 0} { +test bind-13.38 {Tk_BindEvent procedure: C binding deleted, refcount == 0} testcbind { setup testcbind .b.f <1> {lappend x hi; bind .b.f <1> {}} {lappend x bye} set x {} event gen .b.f <1> set x } {hi bye} -test bind-13.39 {Tk_BindEvent procedure: C binding deleted, refcount != 0} { +test bind-13.39 {Tk_BindEvent procedure: C binding deleted, refcount != 0} testcbind { setup testcbind .b.f <1> { lappend x before$n @@ -820,7 +817,7 @@ test bind-13.40 {Tk_BindEvent procedure: continue in script} { bind Test <Button-2> {} set x } {b1 B1} -test bind-13.41 {Tk_BindEvent procedure: continue in script} { +test bind-13.41 {Tk_BindEvent procedure: continue in script} testcbind { setup testcbind .b.f <Button-2> {lappend x b1; continue; lappend x b2} testcbind Test <Button-2> {lappend x B1; continue; lappend x B2} @@ -838,7 +835,7 @@ test bind-13.42 {Tk_BindEvent procedure: break in script} { bind Test <Button-2> {} set x } {b1} -test bind-13.43 {Tk_BindEvent procedure: break in script} { +test bind-13.43 {Tk_BindEvent procedure: break in script} testcbind { setup testcbind .b.f <Button-2> {lappend x b1; break; lappend x b2} testcbind Test <Button-2> {lappend x B1; break; lappend x B2} @@ -862,7 +859,7 @@ test bind-13.44 {Tk_BindEvent procedure: error in script} { bind Test <Button-2> {} set x } {b1 {invalid command name "blap"}} -test bind-13.45 {Tk_BindEvent procedure: error in script} { +test bind-13.45 {Tk_BindEvent procedure: error in script} testcbind { setup testcbind .b.f <Button-2> {lappend x b1; blap} testcbind Test <Button-2> {lappend x B1} @@ -873,13 +870,13 @@ test bind-13.45 {Tk_BindEvent procedure: error in script} { set x } {b1 {invalid command name "blap"}} -test bind-14.1 {TkBindDeadWindow: no C bindings pending} { +test bind-14.1 {TkBindDeadWindow: no C bindings pending} testcbind { setup bind .b.f <1> x testcbind .b.f <2> y destroy .b.f } {} -test bind-14.2 {TkBindDeadWindow: is called after <Destroy>} { +test bind-14.2 {TkBindDeadWindow: is called after <Destroy>} testcbind { setup testcbind .b.f <Destroy> "lappend x .b.f" testcbind Test <Destroy> "lappend x Test" @@ -888,7 +885,7 @@ test bind-14.2 {TkBindDeadWindow: is called after <Destroy>} { bind Test <Destroy> {} set x } {.b.f Test} -test bind-14.3 {TkBindDeadWindow: pending C bindings} { +test bind-14.3 {TkBindDeadWindow: pending C bindings} testcbind { setup bindtags .b.f {a b c d} testcbind a <1> "lappend x a1" "lappend x bye.a1" diff --git a/tests/bitmap.test b/tests/bitmap.test index 2049840..bb5a50f 100644 --- a/tests/bitmap.test +++ b/tests/bitmap.test @@ -6,23 +6,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: bitmap.test,v 1.2 1999/04/16 01:51:34 stanton Exp $ +# RCS: @(#) $Id: bitmap.test,v 1.3 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands -if {[info commands testbitmap] != "testbitmap"} { - puts "testbitmap command not available; skipping tests" - ::tcltest::cleanupTests - return -} +testConstraint testbitmap [llength [info commands testbitmap]] -eval destroy [winfo children .] -wm geometry . {} -raise . - -test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} { +test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} testbitmap { set x gray25 lindex $x 0 destroy .b1 @@ -30,7 +25,7 @@ test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} { lindex $x 0 testbitmap gray25 } {{1 0}} -test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} { +test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} testbitmap { set x gray25 destroy .b1 .b2 button .b1 -bitmap $x @@ -40,7 +35,7 @@ test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} { button .b2 -bitmap $x lappend result [testbitmap gray25] } {{} {{1 1}}} -test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} { +test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} testbitmap { set x gray25 destroy .b1 .b2 button .b1 -bitmap $x @@ -60,7 +55,7 @@ test bitmap-2.2 {Tk_GetBitmap procedure} { list [catch {button .b1 -bitmap @xyzzy} msg] $msg } {1 {error reading bitmap file "xyzzy"}} -test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} { +test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} testbitmap { set x questhead destroy .b1 .b2 .b3 button .b1 -bitmap $x @@ -76,7 +71,7 @@ test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} { lappend result [testbitmap questhead] } {{{3 1}} {{2 1}} {{1 1}} {}} -test bitmap-4.1 {FreeBitmapObjProc} { +test bitmap-4.1 {FreeBitmapObjProc} testbitmap { destroy .b set x [format questhead] button .b -bitmap $x diff --git a/tests/border.test b/tests/border.test index e59b405..55df1e4 100644 --- a/tests/border.test +++ b/tests/border.test @@ -5,39 +5,23 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: border.test,v 1.2 1999/04/16 01:51:34 stanton Exp $ +# RCS: @(#) $Id: border.test,v 1.3 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -if {[info commands testborder] != "testborder"} { - puts "testborder command not available; skipping tests" - ::tcltest::cleanupTests - return -} - -eval destroy [winfo children .] -wm geometry . {} -raise . +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands -# Create a top-level with its own colormap (so we can test under -# controlled conditions), then check to make sure that the visual -# is color-mapped with 256 borders. If not, just skip this whole -# test file. +testConstraint testborder [llength [info commands testborder]] -if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] { - ::tcltest::cleanupTests - return -} -wm geom .t +0+0 -if {[winfo depth .t] != 8} { - destroy .t - ::tcltest::cleanupTests - return +if {[testConstraint pseudocolor8]} { + toplevel .t -visual {pseudocolor 8} -colormap new + wm geom .t +0+0 } -test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} { +test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} testborder { set x orange lindex $x 0 destroy .b1 @@ -45,7 +29,7 @@ test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} { lindex $x 0 testborder orange } {{1 0}} -test border-1.3 {Tk_AllocBorderFromObj - discard stale border} { +test border-1.3 {Tk_AllocBorderFromObj - discard stale border} testborder { set x orange destroy .b1 .b2 button .b1 -bg $x -text First @@ -55,7 +39,7 @@ test border-1.3 {Tk_AllocBorderFromObj - discard stale border} { button .b2 -bg $x -text Second lappend result [testborder orange] } {{} {{1 1}}} -test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} { +test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} testborder { set x orange destroy .b1 .b2 button .b1 -bg $x -text First @@ -65,7 +49,7 @@ test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} { pack .b1 .b2 -side top lappend result [testborder orange] } {{{1 1}} {{2 1}}} -test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} { +test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {pseudocolor8 testborder} { set x purple destroy .b1 .b2 .t.b button .b1 -bg $x -text First @@ -80,7 +64,7 @@ test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} { lappend result [testborder purple] } {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}} -test border-3.1 {Tk_Free3DBorder - reference counts} { +test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} { set x purple destroy .b1 .b2 .t.b button .b1 -bg $x -text First @@ -98,7 +82,7 @@ test border-3.1 {Tk_Free3DBorder - reference counts} { destroy .t.b lappend result [testborder purple] } {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}} -test border-3.4 {Tk_Free3DBorder - unlinking from list} { +test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder} { destroy .b .t.b .t2 .t3 toplevel .t2 -visual {pseudocolor 8} -colormap new toplevel .t3 -visual {pseudocolor 8} -colormap new @@ -125,7 +109,7 @@ test border-3.4 {Tk_Free3DBorder - unlinking from list} { lappend result [testborder purple] } {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}} -test border-4.1 {FreeBorderObjProc} { +test border-4.1 {FreeBorderObjProc} testborder { destroy .b set x [format purple] button .b -bg $x -text .b1 @@ -175,7 +159,9 @@ test get-2.4 {Tk_GetReliefFromObj - error} { list [catch {.b configure -relief upanddown} msg] $msg } {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}} -destroy .t +if {[testConstraint pseudocolor8]} { + destroy .t +} # cleanup ::tcltest::cleanupTests diff --git a/tests/button.test b/tests/button.test index ed0b7ee..d7f9028 100644 --- a/tests/button.test +++ b/tests/button.test @@ -7,25 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: button.test,v 1.11 2002/06/17 10:54:29 drh Exp $ +# RCS: @(#) $Id: button.test,v 1.12 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -if {[lsearch [image types] test] < 0} { - puts "This application hasn't been compiled with the \"test\"" - puts "image, so I can't run this test. Are you sure you're using" - puts "tktest instead of wish?" - ::tcltest::cleanupTests - return -} - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands proc bogusTrace args { error "trace aborted" @@ -41,7 +30,9 @@ option add *Button.highlightThickness 2 option add *Button.font {Helvetica -12 bold} eval image delete [image names] -image create test image1 +if {[testConstraint testImageType]} { + image create test image1 +} label .l -text Label button .b -text Button checkbutton .c -text Checkbutton @@ -109,19 +100,19 @@ foreach test { set classes [lindex $test 5] foreach w {.l .b .c .r} hasOption [lindex $test 5] { if $hasOption { - test button-1.$i {configuration options} { + test button-1.$i {configuration options} testImageType { $w configure $name [lindex $test 1] lindex [$w configure $name] 4 } [lindex $test 2] incr i if {[lindex $test 3] != ""} { - test button-1.$i {configuration options} { + test button-1.$i {configuration options} testImageType { list [catch {$w configure $name [lindex $test 3]} msg] $msg } [list 1 [lindex $test 4]] } $w configure $name [lindex [$w configure $name] 3] } else { - test button-1.$i {configuration options} { + test button-1.$i {configuration options} testImageType { list [catch {$w configure $name [lindex $test 1]} msg] $msg } "1 {unknown option \"$name\"}" } @@ -412,7 +403,7 @@ test button-4.50 {ButtonWidgetCmd procedure, "toggle" option} { while executing ".c toggle"}} -test button-5.1 {DestroyButton procedure} { +test button-5.1 {DestroyButton procedure} testImageType { image create test image1 button .b1 -image image1 button .b2 -fg #ff0000 -text "Button 2" @@ -422,7 +413,7 @@ test button-5.1 {DestroyButton procedure} { set x 1 pack .b1 .b2 .b3 .b4 .b5 update - eval destroy [winfo children .] + deleteWindows } {} test button-6.1 {ConfigureButton - textvariable trace} { @@ -452,7 +443,7 @@ test button-6.2 {ConfigureButton - variable traces} { .b1 toggle set y } {1} -test button-6.3 {ConfigureButton - image handling} { +test button-6.3 {ConfigureButton - image handling} testImageType { catch {destroy .b1} eval image delete [image names] image create test image1 @@ -545,7 +536,7 @@ test button-6.16 {ConfigureButton - -width option} { (processing -width option) invoked from within ".b1 configure -width abc"}} -test button-6.17 {ConfigureButton - -height option} { +test button-6.17 {ConfigureButton - -height option} testImageType { catch {destroy .b1} eval image delete [image names] image create test image1 @@ -582,7 +573,7 @@ test button-7.1 {ButtonEventProc procedure} { set x } {0 {}} test button-7.2 {ButtonEventProc procedure} { - eval destroy [winfo children .] + deleteWindows button .b1 -bg #543210 rename .b1 .b2 set x {} @@ -593,7 +584,7 @@ test button-7.2 {ButtonEventProc procedure} { } {.b1 #543210 {} {}} test button-8.1 {ButtonCmdDeletedProc procedure} { - eval destroy [winfo children .] + deleteWindows button .b1 rename .b1 {} list [info command .b*] [winfo children .] @@ -649,20 +640,20 @@ test button-9.5 {TkInvokeButton procedure} { while executing ".b1 invoke"} red} test button-9.6 {TkInvokeButton procedure} { - eval destroy [winfo children .] + deleteWindows set result untouched button .b1 -command {set result invoked} list [catch {.b1 invoke} msg] $msg $result } {0 invoked invoked} test button-9.7 {TkInvokeButton procedure} { - eval destroy [winfo children .] + deleteWindows set result untouched set x 0 checkbutton .b1 -variable x -command {set result "invoked $x"} list [catch {.b1 invoke} msg] $msg $result } {0 {invoked 1} {invoked 1}} test button-9.8 {TkInvokeButton procedure} { - eval destroy [winfo children .] + deleteWindows set result untouched set x 0 radiobutton .b1 -variable x -value red -command {set result "invoked $x"} @@ -670,7 +661,7 @@ test button-9.8 {TkInvokeButton procedure} { } {0 {invoked red} {invoked red}} test button-10.1 {ButtonVarProc procedure} { - eval destroy [winfo children .] + deleteWindows set x 1 checkbutton .b1 -variable x unset x @@ -682,7 +673,7 @@ test button-10.1 {ButtonVarProc procedure} { lappend result $x } {0 1 1} test button-10.2 {ButtonVarProc procedure} { - eval destroy [winfo children .] + deleteWindows set x 0 checkbutton .b1 -variable x set x 44 @@ -690,7 +681,7 @@ test button-10.2 {ButtonVarProc procedure} { set x } {1} test button-10.3 {ButtonVarProc procedure} { - eval destroy [winfo children .] + deleteWindows set x 1 checkbutton .b1 -variable x set x 44 @@ -698,7 +689,7 @@ test button-10.3 {ButtonVarProc procedure} { set x } {1} test button-10.4 {ButtonVarProc procedure} { - eval destroy [winfo children .] + deleteWindows set x 0 checkbutton .b1 -variable x set x 1 @@ -706,7 +697,7 @@ test button-10.4 {ButtonVarProc procedure} { set x } {0} test button-10.5 {ButtonVarProc procedure} { - eval destroy [winfo children .] + deleteWindows set x 1 checkbutton .b1 -variable x set x 1 @@ -714,7 +705,7 @@ test button-10.5 {ButtonVarProc procedure} { set x } {0} test button-10.6 {ButtonVarProc procedure} { - eval destroy [winfo children .] + deleteWindows set x 0 checkbutton .b1 -variable x set x 0 @@ -722,7 +713,7 @@ test button-10.6 {ButtonVarProc procedure} { set x } {1} test button-10.7 {ButtonVarProc procedure} { - eval destroy [winfo children .] + deleteWindows set x 1 checkbutton .b1 -variable x set x 0 @@ -731,7 +722,7 @@ test button-10.7 {ButtonVarProc procedure} { } {1} test button-10.8 {ButtonVarProc procedure, can't read variable} { # This test does nothing but produce a core dump if there's a prbblem. - eval destroy [winfo children .] + deleteWindows catch {unset a} checkbutton .b1 -variable a unset a @@ -740,7 +731,7 @@ test button-10.8 {ButtonVarProc procedure, can't read variable} { } {} test button-11.1 {ButtonTextVarProc procedure} { - eval destroy [winfo children .] + deleteWindows set x Label button .b1 -textvariable x unset x @@ -749,7 +740,7 @@ test button-11.1 {ButtonTextVarProc procedure} { lappend result [lindex [.b1 configure -text] 4] } {Label Label New} test button-11.2 {ButtonTextVarProc procedure} { - eval destroy [winfo children .] + deleteWindows # Windows buttons have a default min width, so we have to # set this to be longer to force the wider button. set x ExtraLongLabel @@ -760,8 +751,8 @@ test button-11.2 {ButtonTextVarProc procedure} { list [lindex [.b1 configure -text] 4] [expr $old == $new] } {New 0} -test button-12.1 {ButtonImageProc procedure} { - eval destroy [winfo children .] +test button-12.1 {ButtonImageProc procedure} testImageType { + deleteWindows eval image delete [image names] image create test image1 label .b1 -image image1 -padx 0 -pady 0 -bd 0 @@ -771,7 +762,7 @@ test button-12.1 {ButtonImageProc procedure} { lappend result [winfo reqwidth .b1] [winfo reqheight .b1] } {30 15 80 100} -eval destroy [winfo children .] +deleteWindows set l [interp hidden] test button-13.1 {button widget vs hidden commands} { @@ -782,7 +773,7 @@ test button-13.1 {button widget vs hidden commands} { list [winfo children .] [interp hidden] } [list {} $l] -eval destroy [winfo children .] +deleteWindows option clear diff --git a/tests/canvImg.test b/tests/canvImg.test index 44d6546..94292d2 100644 --- a/tests/canvImg.test +++ b/tests/canvImg.test @@ -7,33 +7,24 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: canvImg.test,v 1.4 1999/12/14 06:53:12 hobbs Exp $ +# RCS: @(#) $Id: canvImg.test,v 1.5 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -if {[lsearch [image types] test] < 0} { - puts "This application hasn't been compiled with the \"test\" image" - puts "type, so I can't run this test. Are you sure you're using" - puts "tktest instead of wish?" - ::tcltest::cleanupTests - return -} - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands eval image delete [image names] canvas .c pack .c update -image create test foo -variable x -image create test foo2 -variable y -foo2 changed 0 0 0 0 80 60 +if {[testConstraint testImageType]} { + image create test foo -variable x + image create test foo2 -variable y + foo2 changed 0 0 0 0 80 60 +} test canvImg-1.1 {options for image items} { .c delete all .c create image 50 50 -anchor nw -tags i1 @@ -43,7 +34,7 @@ test canvImg-1.2 {options for image items} { .c delete all list [catch {.c create image 50 50 -anchor gorp -tags i1} msg] $msg } {1 {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center}} -test canvImg-1.3 {options for image items} { +test canvImg-1.3 {options for image items} testImageType { .c delete all .c create image 50 50 -image foo -tags i1 .c itemconfigure i1 -image @@ -52,7 +43,7 @@ test canvImg-1.4 {options for image items} { .c delete all list [catch {.c create image 50 50 -image unknown -tags i1} msg] $msg } {1 {image "unknown" doesn't exist}} -test canvImg-1.5 {options for image items} { +test canvImg-1.5 {options for image items} testImageType { .c delete all .c create image 50 50 -image foo -tags {i1 foo} .c itemconfigure i1 -tags @@ -77,37 +68,37 @@ test canvImg-2.4 {CreateImage procedure} { test canvImg-2.5 {CreateImage procedure} { list [catch {.c create image 50 qrs} msg] $msg } {1 {bad screen distance "qrs"}} -test canvImg-2.6 {CreateImage procedure} { +test canvImg-2.6 {CreateImage procedure} testImageType { list [catch {.c create image 50 50 -gorp foo} msg] $msg } {1 {unknown option "-gorp"}} -test canvImg-3.1 {ImageCoords procedure} { +test canvImg-3.1 {ImageCoords procedure} testImageType { .c delete all .c create image 50 100 -image foo -tags i1 .c coords i1 } {50.0 100.0} -test canvImg-3.2 {ImageCoords procedure} { +test canvImg-3.2 {ImageCoords procedure} testImageType { .c delete all .c create image 50 100 -image foo -tags i1 list [catch {.c coords i1 dumb 100} msg] $msg } {1 {bad screen distance "dumb"}} -test canvImg-3.3 {ImageCoords procedure} { +test canvImg-3.3 {ImageCoords procedure} testImageType { .c delete all .c create image 50 100 -image foo -tags i1 list [catch {.c coords i1 250 dumb0} msg] $msg } {1 {bad screen distance "dumb0"}} -test canvImg-3.4 {ImageCoords procedure} { +test canvImg-3.4 {ImageCoords procedure} testImageType { .c delete all .c create image 50 100 -image foo -tags i1 list [catch {.c coords i1 250} msg] $msg } {1 {wrong # coordinates: expected 2, got 1}} -test canvImg-3.5 {ImageCoords procedure} { +test canvImg-3.5 {ImageCoords procedure} testImageType { .c delete all .c create image 50 100 -image foo -tags i1 list [catch {.c coords i1 250 300 400} msg] $msg } {1 {wrong # coordinates: expected 0 or 2, got 3}} -test canvImg-4.1 {ConfiugreImage procedure} { +test canvImg-4.1 {ConfiugreImage procedure} testImageType { .c delete all .c create image 50 100 -image foo -tags i1 update @@ -116,7 +107,7 @@ test canvImg-4.1 {ConfiugreImage procedure} { update list $x [.c bbox i1] } {{{foo free}} {}} -test canvImg-4.2 {ConfiugreImage procedure} { +test canvImg-4.2 {ConfiugreImage procedure} testImageType { .c delete all .c create image 50 100 -image foo -tags i1 -anchor nw update @@ -126,7 +117,7 @@ test canvImg-4.2 {ConfiugreImage procedure} { update list $x $y [.c bbox i1] } {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}} -test canvImg-4.3 {ConfiugreImage procedure} { +test canvImg-4.3 {ConfiugreImage procedure} testImageType { .c delete all .c create image 50 100 -image foo -tags i1 -anchor nw update @@ -135,7 +126,7 @@ test canvImg-4.3 {ConfiugreImage procedure} { list [catch {.c itemconfigure i1 -image lousy} msg] $msg } {1 {image "lousy" doesn't exist}} -test canvImg-5.1 {DeleteImage procedure} { +test canvImg-5.1 {DeleteImage procedure} testImageType { image create test xyzzy -variable z .c delete all .c create image 50 100 -image xyzzy -tags i1 @@ -155,12 +146,12 @@ test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} { update } {} -test canvImg-6.1 {ComputeImageBbox procedure} { +test canvImg-6.1 {ComputeImageBbox procedure} testImageType { .c delete all .c create image 15.51 17.51 -image foo -tags i1 -anchor nw .c bbox i1 } {16 18 46 33} -test canvImg-6.2 {ComputeImageBbox procedure} { +test canvImg-6.2 {ComputeImageBbox procedure} testImageType { .c delete all .c create image 15.49 17.49 -image foo -tags i1 -anchor nw .c bbox i1 @@ -170,47 +161,47 @@ test canvImg-6.3 {ComputeImageBbox procedure} { .c create image 20 30 -tags i1 -anchor nw .c bbox i1 } {} -test canvImg-6.4 {ComputeImageBbox procedure} { +test canvImg-6.4 {ComputeImageBbox procedure} testImageType { .c delete all .c create image 20 30 -image foo -tags i1 -anchor nw .c bbox i1 } {20 30 50 45} -test canvImg-6.5 {ComputeImageBbox procedure} { +test canvImg-6.5 {ComputeImageBbox procedure} testImageType { .c delete all .c create image 20 30 -image foo -tags i1 -anchor n .c bbox i1 } {5 30 35 45} -test canvImg-6.6 {ComputeImageBbox procedure} { +test canvImg-6.6 {ComputeImageBbox procedure} testImageType { .c delete all .c create image 20 30 -image foo -tags i1 -anchor ne .c bbox i1 } {-10 30 20 45} -test canvImg-6.7 {ComputeImageBbox procedure} { +test canvImg-6.7 {ComputeImageBbox procedure} testImageType { .c delete all .c create image 20 30 -image foo -tags i1 -anchor e .c bbox i1 } {-10 23 20 38} -test canvImg-6.8 {ComputeImageBbox procedure} { +test canvImg-6.8 {ComputeImageBbox procedure} testImageType { .c delete all .c create image 20 30 -image foo -tags i1 -anchor se .c bbox i1 } {-10 15 20 30} -test canvImg-6.9 {ComputeImageBbox procedure} { +test canvImg-6.9 {ComputeImageBbox procedure} testImageType { .c delete all .c create image 20 30 -image foo -tags i1 -anchor s .c bbox i1 } {5 15 35 30} -test canvImg-6.10 {ComputeImageBbox procedure} { +test canvImg-6.10 {ComputeImageBbox procedure} testImageType { .c delete all .c create image 20 30 -image foo -tags i1 -anchor sw .c bbox i1 } {20 15 50 30} -test canvImg-6.11 {ComputeImageBbox procedure} { +test canvImg-6.11 {ComputeImageBbox procedure} testImageType { .c delete all .c create image 20 30 -image foo -tags i1 -anchor w .c bbox i1 } {20 23 50 38} -test canvImg-6.12 {ComputeImageBbox procedure} { +test canvImg-6.12 {ComputeImageBbox procedure} testImageType { .c delete all .c create image 20 30 -image foo -tags i1 -anchor center .c bbox i1 @@ -219,7 +210,7 @@ test canvImg-6.12 {ComputeImageBbox procedure} { # The following test is non-portable because of differences in # coordinate rounding on some machines (does 0.5 round up?). -test canvImg-7.1 {DisplayImage procedure} {nonPortable} { +test canvImg-7.1 {DisplayImage procedure} {nonPortable testImageType} { .c delete all .c create image 50 100 -image foo -tags i1 -anchor nw update @@ -238,7 +229,9 @@ test canvImg-7.2 {DisplayImage procedure, no image} { set i 1 .c delete all -.c create image 50 100 -image foo -tags image -anchor nw +if {[testConstraint testImageType]} { + .c create image 50 100 -image foo -tags image -anchor nw +} .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} foreach check { {{50 70 80 81} {70 90} {rect}} @@ -260,7 +253,7 @@ foreach check { {{60 70 69 109} {70 110} {image}} {{60 70 71 111} {70 110} {rect}} } { - test canvImg-8.$i {ImageToPoint procedure} { + test canvImg-8.$i {ImageToPoint procedure} testImageType { eval .c coords rect [lindex $check 0] .c gettags [eval .c find closest [lindex $check 1]] } [lindex $check 2] @@ -268,94 +261,96 @@ foreach check { } .c delete all -.c create image 50 100 -image foo -tags image -anchor nw -test canvImg-8.19 {ImageToArea procedure} { +if {[testConstraint testImageType]} { + .c create image 50 100 -image foo -tags image -anchor nw +} +test canvImg-8.19 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 60 0 70 99] } {} -test canvImg-8.20 {ImageToArea procedure} { +test canvImg-8.20 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 60 0 70 99.999] } {} -test canvImg-8.21 {ImageToArea procedure} { +test canvImg-8.21 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 60 0 70 101] } {image} -test canvImg-8.22 {ImageToArea procedure} { +test canvImg-8.22 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 81 105 120 115] } {} -test canvImg-8.23 {ImageToArea procedure} { +test canvImg-8.23 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 80.001 105 120 115] } {} -test canvImg-8.24 {ImageToArea procedure} { +test canvImg-8.24 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 79 105 120 115] } {image} -test canvImg-8.25 {ImageToArea procedure} { +test canvImg-8.25 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 60 116 70 150] } {} -test canvImg-8.26 {ImageToArea procedure} { +test canvImg-8.26 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 60 115.001 70 150] } {} -test canvImg-8.27 {ImageToArea procedure} { +test canvImg-8.27 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 60 114 70 150] } {image} -test canvImg-8.28 {ImageToArea procedure} { +test canvImg-8.28 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 0 105 49 115] } {} -test canvImg-8.29 {ImageToArea procedure} { +test canvImg-8.29 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 0 105 50 114.999] } {} -test canvImg-8.30 {ImageToArea procedure} { +test canvImg-8.30 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 0 105 51 115] } {image} -test canvImg-8.31 {ImageToArea procedure} { +test canvImg-8.31 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 0 0 49.999 99.999] } {} -test canvImg-8.32 {ImageToArea procedure} { +test canvImg-8.32 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 0 0 51 101] } {image} -test canvImg-8.33 {ImageToArea procedure} { +test canvImg-8.33 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 80 0 150 100] } {} -test canvImg-8.34 {ImageToArea procedure} { +test canvImg-8.34 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 79 0 150 101] } {image} -test canvImg-8.35 {ImageToArea procedure} { +test canvImg-8.35 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 80.001 115.001 150 180] } {} -test canvImg-8.36 {ImageToArea procedure} { +test canvImg-8.36 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 79 114 150 180] } {image} -test canvImg-8.37 {ImageToArea procedure} { +test canvImg-8.37 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 0 115 50 180] } {} -test canvImg-8.38 {ImageToArea procedure} { +test canvImg-8.38 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 0 114 51 180] } {image} -test canvImg-8.39 {ImageToArea procedure} { +test canvImg-8.39 {ImageToArea procedure} testImageType { .c gettags [.c find enclosed 0 0 200 200] } {image} -test canvImg-8.40 {ImageToArea procedure} { +test canvImg-8.40 {ImageToArea procedure} testImageType { .c gettags [.c find enclosed 49.999 99.999 80.001 115.001] } {image} -test canvImg-8.41 {ImageToArea procedure} { +test canvImg-8.41 {ImageToArea procedure} testImageType { .c gettags [.c find enclosed 51 100 80 115] } {} -test canvImg-8.42 {ImageToArea procedure} { +test canvImg-8.42 {ImageToArea procedure} testImageType { .c gettags [.c find enclosed 50 101 80 115] } {} -test canvImg-8.43 {ImageToArea procedure} { +test canvImg-8.43 {ImageToArea procedure} testImageType { .c gettags [.c find enclosed 50 100 79 115] } {} -test canvImg-8.44 {ImageToArea procedure} { +test canvImg-8.44 {ImageToArea procedure} testImageType { .c gettags [.c find enclosed 50 100 80 114] } {} -test canvImg-9.1 {DisplayImage procedure} { +test canvImg-9.1 {DisplayImage procedure} testImageType { .c delete all .c create image 50 100 -image foo -tags image -anchor nw .c scale image 25 0 2.0 1.5 .c bbox image } {75 150 105 165} -test canvImg-10.1 {TranslateImage procedure} { +test canvImg-10.1 {TranslateImage procedure} testImageType { .c delete all .c create image 50 100 -image foo -tags image -anchor nw update @@ -365,7 +360,7 @@ test canvImg-10.1 {TranslateImage procedure} { set x } {{foo display 2 4 6 8 30 30}} -test canvImg-11.1 {TranslateImage procedure} { +test canvImg-11.1 {TranslateImage procedure} testImageType { .c delete all .c create image 50 100 -image foo -tags image -anchor nw update @@ -374,7 +369,7 @@ test canvImg-11.1 {TranslateImage procedure} { update set x } {{foo display 0 0 40 50 30 30}} -test canvImg-11.2 {ImageChangedProc procedure} { +test canvImg-11.2 {ImageChangedProc procedure} testImageType { .c delete all image create test foo -variable x .c create image 50 100 -image foo -tags image -anchor center @@ -383,7 +378,7 @@ test canvImg-11.2 {ImageChangedProc procedure} { foo changed 0 0 0 0 40 50 .c bbox image } {30 75 70 125} -test canvImg-11.3 {ImageChangedProc procedure} { +test canvImg-11.3 {ImageChangedProc procedure} testImageType { .c delete all image create test foo -variable x foo changed 0 0 0 0 40 50 diff --git a/tests/canvPs.test b/tests/canvPs.test index 08d72cf..8faad75 100644 --- a/tests/canvPs.test +++ b/tests/canvPs.test @@ -6,17 +6,17 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: canvPs.test,v 1.3 1999/04/16 01:51:34 stanton Exp $ +# RCS: @(#) $Id: canvPs.test,v 1.4 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . +namespace import -force tcltest::makeFile +namespace import -force tcltest::removeFile canvas .c -width 400 -height 300 -bd 2 -relief sunken .c create rectangle 20 20 80 80 -fill red @@ -97,9 +97,7 @@ test canvPs-2.4 {test writing to channel and file, same output} {pcOnly} { # cleanup removeFile foo.ps removeFile bar.ps -foreach i [winfo children .] { - destroy $i -} +deleteWindows ::tcltest::cleanupTests return diff --git a/tests/canvRect.test b/tests/canvRect.test index 64d7de3..a08679d 100644 --- a/tests/canvRect.test +++ b/tests/canvRect.test @@ -6,17 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: canvRect.test,v 1.4 1999/12/14 06:53:12 hobbs Exp $ +# RCS: @(#) $Id: canvRect.test,v 1.5 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands canvas .c -width 400 -height 300 -bd 2 -relief sunken pack .c diff --git a/tests/canvText.test b/tests/canvText.test index a6316c0..c23f949 100644 --- a/tests/canvText.test +++ b/tests/canvText.test @@ -6,17 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: canvText.test,v 1.10 2002/06/25 16:27:44 a_kovalenko Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . +# RCS: @(#) $Id: canvText.test,v 1.11 2002/07/14 05:48:46 dgp Exp $ + +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands canvas .c -width 400 -height 300 -bd 2 -relief sunken pack .c diff --git a/tests/canvWind.test b/tests/canvWind.test index 76db55c..e8077cb 100644 --- a/tests/canvWind.test +++ b/tests/canvWind.test @@ -6,17 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: canvWind.test,v 1.3 1999/04/16 01:51:35 stanton Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . +# RCS: @(#) $Id: canvWind.test,v 1.4 2002/07/14 05:48:46 dgp Exp $ + +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} { catch {destroy .t} diff --git a/tests/canvas.test b/tests/canvas.test index 15cd806..84e7c62 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -6,17 +6,14 @@ # Copyright (c) 1998-2000 Ajuba Solutions. # All rights reserved. # -# RCS: @(#) $Id: canvas.test,v 1.13 2001/07/04 00:40:11 hobbs Exp $ +# RCS: @(#) $Id: canvas.test,v 1.14 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands # XXX - This test file is woefully incomplete. At present, only a # few of the features are tested. @@ -135,7 +132,7 @@ test canvas-3.2 {CanvasWidgetCmd, yview option} { } {{0 0.5} {0.1 0.6}} test canvas-4.1 {ButtonEventProc procedure} { - eval destroy [winfo children .] + deleteWindows canvas .c1 -bg #543210 rename .c1 .c2 set x {} @@ -146,7 +143,7 @@ test canvas-4.1 {ButtonEventProc procedure} { } {.c1 #543210 {} {}} test canvas-5.1 {ButtonCmdDeletedProc procedure} { - eval destroy [winfo children .] + deleteWindows canvas .c1 rename .c1 {} list [info command .c*] [winfo children .] @@ -196,7 +193,7 @@ test canvas-6.5 {CanvasSetOrigin procedure} { } {55.0} set l [interp hidden] -eval destroy [winfo children .] +deleteWindows test canvas-7.1 {canvas widget vs hidden commands} { catch {destroy .c} diff --git a/tests/choosedir.test b/tests/choosedir.test index 6e03266..e8da6a3 100644 --- a/tests/choosedir.test +++ b/tests/choosedir.test @@ -5,13 +5,17 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: choosedir.test,v 1.9 2000/04/10 22:43:13 ericm Exp $ +# RCS: @(#) $Id: choosedir.test,v 1.10 2002/07/14 05:48:46 dgp Exp $ # -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands + +namespace import -force tcltest::makeDirectory #---------------------------------------------------------------------- # diff --git a/tests/clipboard.test b/tests/clipboard.test index 02c3fa2..ba937fc 100644 --- a/tests/clipboard.test +++ b/tests/clipboard.test @@ -6,18 +6,19 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: clipboard.test,v 1.5 2000/08/01 18:52:45 ericm Exp $ +# RCS: @(#) $Id: clipboard.test,v 1.6 2002/07/14 05:48:46 dgp Exp $ # # Note: Multiple display clipboard handling will only be tested if the # environment variable TK_ALT_DISPLAY is set to an alternate display. # -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -eval destroy [winfo child .] +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands # set up a very large buffer to test INCR retrievals set longValue "" diff --git a/tests/clrpick.test b/tests/clrpick.test index 2259fe7..77dce58 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -5,18 +5,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: clrpick.test,v 1.6 2001/08/01 16:21:12 dgp Exp $ +# RCS: @(#) $Id: clrpick.test,v 1.7 2002/07/14 05:48:46 dgp Exp $ # -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -# Some tests require user interaction on non-unix platform - -set ::tcltest::testConfig(nonUnixUserInteraction) \ - [expr {$::tcltest::testConfig(userInteraction) || \ - $::tcltest::testConfig(unixOnly)}] +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands test clrpick-1.1 {tk_chooseColor command} { list [catch {tk_chooseColor -foo} msg] $msg @@ -140,7 +137,7 @@ set verylongstring $verylongstring$verylongstring # machines with small color palettes still fail. # some tests will be skipped if there are no more colors set numcolors 32 -set ::tcltest::testConfig(colorsLeftover) 1 +testConstraint colorsLeftover 1 set i 0 canvas .c pack .c -expand 1 -fill both @@ -158,7 +155,7 @@ while {$i<$numcolors} { set g [expr $g/256] set b [expr $b/256] if {"$color" != "#[format %02x%02x%02x $r $g $b]"} { - set ::tcltest::testConfig(colorsLeftover) 0 + testConstraint colorsLeftover 0 } } .c delete $i diff --git a/tests/cmds.test b/tests/cmds.test index c6301d9..87871b3 100644 --- a/tests/cmds.test +++ b/tests/cmds.test @@ -5,14 +5,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: cmds.test,v 1.3 1999/04/16 01:51:35 stanton Exp $ +# RCS: @(#) $Id: cmds.test,v 1.4 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands -eval destroy [winfo child .] -wm geometry . {} update test cmds-1.1 {tkwait visibility, argument errors} { diff --git a/tests/color.test b/tests/color.test index b7fed15..fec3748 100644 --- a/tests/color.test +++ b/tests/color.test @@ -5,21 +5,16 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: color.test,v 1.5 2000/11/02 01:18:35 hobbs Exp $ +# RCS: @(#) $Id: color.test,v 1.6 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -if {[info commands testcolor] != "testcolor"} { - puts "testcolor command not available; skipping tests" - ::tcltest::cleanupTests - return -} +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands -eval destroy [winfo children .] -wm geometry . {} -raise . +testConstraint testcolor [llength [info commands testcolor]] # cname -- # Returns a proper name for a color, given its intensities. @@ -102,39 +97,24 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} { && ([lindex $vals 2]/256 == $blue) } -# Create a top-level with its own colormap (so we can test under -# controlled conditions), then check to make sure that the visual -# is color-mapped with 256 colors. If not, just skip this whole -# test file. +if {[testConstraint psuedocolor8]} { + toplevel .t -visual {pseudocolor 8} -colormap new + wm geom .t +0+0 + mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40 + pack .t.c + update -if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] { - ::tcltest::cleanupTests - return -} -wm geom .t +0+0 -if {[winfo depth .t] != 8} { - destroy .t - ::tcltest::cleanupTests - return -} -mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40 -pack .t.c -update -if ![colorsFree .t.c 101 233 17] { - destroy .t - ::tcltest::cleanupTests - return -} -mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 -pack .t.c2 -if [colorsFree .t.c] { - destroy .t - ::tcltest::cleanupTests - return + testConstraint colorsFree [colorsFree .t.c 101 233 17] + + if {[testConstraint colorsFree]} { + mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 + pack .t.c2 + testConstraint colorsFree [expr {![colorsFree .t.c]}] + } + destroy .t.c .t.c2 } -destroy .t.c .t.c2 -test color-1.1 {Tk_AllocColorFromObj - converting internal reps} { +test color-1.1 {Tk_AllocColorFromObj - converting internal reps} colorsFree { set x green lindex $x 0 destroy .b1 @@ -142,7 +122,7 @@ test color-1.1 {Tk_AllocColorFromObj - converting internal reps} { lindex $x 0 testcolor green } {{1 0}} -test color-1.2 {Tk_AllocColorFromObj - discard stale color} { +test color-1.2 {Tk_AllocColorFromObj - discard stale color} colorsFree { set x green destroy .b1 .b2 button .b1 -foreground $x -text First @@ -152,7 +132,7 @@ test color-1.2 {Tk_AllocColorFromObj - discard stale color} { button .b2 -foreground $x -text Second lappend result [testcolor green] } {{} {{1 1}}} -test color-1.3 {Tk_AllocColorFromObj - reuse existing color} { +test color-1.3 {Tk_AllocColorFromObj - reuse existing color} colorsFree { set x green destroy .b1 .b2 button .b1 -foreground $x -text First @@ -162,7 +142,7 @@ test color-1.3 {Tk_AllocColorFromObj - reuse existing color} { pack .b1 .b2 -side top lappend result [testcolor green] } {{{1 1}} {{2 1}}} -test color-1.4 {Tk_AllocColorFromObj - try other colors in list} { +test color-1.4 {Tk_AllocColorFromObj - try other colors in list} colorsFree { set x purple destroy .b1 .b2 .t.b button .b1 -foreground $x -text First @@ -177,30 +157,30 @@ test color-1.4 {Tk_AllocColorFromObj - try other colors in list} { lappend result [testcolor purple] } {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}} -test color-2.1 {Tk_GetColor procedure} { +test color-2.1 {Tk_GetColor procedure} colorsFree { c255 [winfo rgb .t #FF0000] } {255 0 0} -test color-2.2 {Tk_GetColor procedure} { +test color-2.2 {Tk_GetColor procedure} colorsFree { list [catch {winfo rgb .t noname} msg] $msg } {1 {unknown color name "noname"}} -test color-2.3 {Tk_GetColor procedure} { +test color-2.3 {Tk_GetColor procedure} colorsFree { c255 [winfo rgb .t #123456] } {18 52 86} -test color-2.4 {Tk_GetColor procedure} { +test color-2.4 {Tk_GetColor procedure} colorsFree { list [catch {winfo rgb .t #xyz} msg] $msg } {1 {invalid color name "#xyz"}} -test color-2.5 {Tk_GetColor procedure} { +test color-2.5 {Tk_GetColor procedure} colorsFree { winfo rgb .t #00FF00 } {0 65535 0} -test color-2.6 {Tk_GetColor procedure} {nonPortable} { +test color-2.6 {Tk_GetColor procedure} {colorsFree nonPortable} { # Red doesn't always map to *pure* red winfo rgb .t red } {65535 0 0} -test color-2.7 {Tk_GetColor procedure} { +test color-2.7 {Tk_GetColor procedure} colorsFree { winfo rgb .t #ff0000 } {65535 0 0} -test color-3.1 {Tk_FreeColor procedure, reference counting} { +test color-3.1 {Tk_FreeColor procedure, reference counting} colorsFree { eval destroy [winfo child .t] mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40 pack .t.c @@ -214,7 +194,7 @@ test color-3.1 {Tk_FreeColor procedure, reference counting} { .t.c2 delete $last lappend result [colorsFree .t] } {0 1} -test color-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} { +test color-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} colorsFree { eval destroy [winfo child .t] mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40 pack .t.c @@ -224,7 +204,7 @@ test color-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} { update closest .t 241 241 1 } {240 240 0} -test color-3.3 {Tk_FreeColorFromObj - reference counts} { +test color-3.3 {Tk_FreeColorFromObj - reference counts} colorsFree { set x purple destroy .b1 .b2 .t.b button .b1 -foreground $x -text First @@ -242,7 +222,7 @@ test color-3.3 {Tk_FreeColorFromObj - reference counts} { destroy .t.b lappend result [testcolor purple] } {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}} -test color-3.4 {Tk_FreeColorFromObj - unlinking from list} { +test color-3.4 {Tk_FreeColorFromObj - unlinking from list} colorsFree { destroy .b .t.b .t2 .t3 toplevel .t2 -visual {pseudocolor 8} -colormap new toplevel .t3 -visual {pseudocolor 8} -colormap new @@ -269,7 +249,7 @@ test color-3.4 {Tk_FreeColorFromObj - unlinking from list} { lappend result [testcolor purple] } {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}} -test color-4.1 {FreeColorObjProc} { +test color-4.1 {FreeColorObjProc} colorsFree { destroy .b set x [format purple] button .b -foreground $x -text .b1 diff --git a/tests/config.test b/tests/config.test index 34c81fd..df9c0c4 100644 --- a/tests/config.test +++ b/tests/config.test @@ -6,19 +6,16 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: config.test,v 1.5 2001/08/29 23:22:24 hobbs Exp $ +# RCS: @(#) $Id: config.test,v 1.6 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands -if {[info command testobjconfig] != "testobjconfig"} { - puts "This application hasn't been compiled with the \"testobjconfig\"" - puts "command, so I can't run this test. Are you sure you're using" - puts "tktest instead of wish?" - ::tcltest::cleanupTests - return -} +testConstraint testobjconfig [llength [info commands testobjconfig]] proc killTables {} { # Note: it's important to delete chain2 before chain1, because @@ -33,79 +30,76 @@ proc killTables {} { } } -foreach i [winfo children .] { - destroy $i +if {[testConstraint testobjconfig]} { + killTables } -killTables -wm geometry . {} -raise . -test config-1.1 {Tk_CreateOptionTable - reference counts} { - eval destroy [winfo children .] +test config-1.1 {Tk_CreateOptionTable - reference counts} testobjconfig { + deleteWindows killTables set x {} testobjconfig alltypes .a lappend x [testobjconfig info alltypes] testobjconfig alltypes .b lappend x [testobjconfig info alltypes] - eval destroy [winfo children .] + deleteWindows set x } {{1 16 -boolean} {2 16 -boolean}} -test config-1.2 {Tk_CreateOptionTable - synonym initialization} { - eval destroy [winfo children .] +test config-1.2 {Tk_CreateOptionTable - synonym initialization} testobjconfig { + deleteWindows testobjconfig alltypes .a -synonym green .a cget -color } {green} -test config-1.3 {Tk_CreateOptionTable - option database initialization} { - eval destroy [winfo children .] +test config-1.3 {Tk_CreateOptionTable - option database initialization} testobjconfig { + deleteWindows option clear testobjconfig alltypes .a option add *b.string different testobjconfig alltypes .b list [.a cget -string] [.b cget -string] } {foo different} -test config-1.4 {Tk_CreateOptionTable - option database initialization} { - eval destroy [winfo children .] +test config-1.4 {Tk_CreateOptionTable - option database initialization} testobjconfig { + deleteWindows option clear testobjconfig alltypes .a option add *b.String bar testobjconfig alltypes .b list [.a cget -string] [.b cget -string] } {foo bar} -test config-1.5 {Tk_CreateOptionTable - default initialization} { - eval destroy [winfo children .] +test config-1.5 {Tk_CreateOptionTable - default initialization} testobjconfig { + deleteWindows testobjconfig alltypes .a .a cget -relief } {raised} -test config-1.6 {Tk_CreateOptionTable - chained tables} { - eval destroy [winfo children .] +test config-1.6 {Tk_CreateOptionTable - chained tables} testobjconfig { + deleteWindows killTables testobjconfig chain1 .a testobjconfig chain2 .b testobjconfig info chain2 } {1 4 -three 2 2 -one} -test config-1.7 {Tk_CreateOptionTable - chained tables} { - eval destroy [winfo children .] +test config-1.7 {Tk_CreateOptionTable - chained tables} testobjconfig { + deleteWindows killTables testobjconfig chain2 .b testobjconfig chain1 .a testobjconfig info chain2 } {1 4 -three 2 2 -one} -test config-1.8 {Tk_CreateOptionTable - chained tables} { - eval destroy [winfo children .] +test config-1.8 {Tk_CreateOptionTable - chained tables} testobjconfig { + deleteWindows testobjconfig chain1 .a testobjconfig chain2 .b list [catch {.a cget -four} msg] $msg [.a cget -one] \ [.b cget -four] [.b cget -one] } {1 {unknown option "-four"} one four one} -test config-2.1 {Tk_DeleteOptionTable - reference counts} { - eval destroy [winfo children .] +test config-2.1 {Tk_DeleteOptionTable - reference counts} testobjconfig { + deleteWindows killTables testobjconfig chain1 .a testobjconfig chain2 .b testobjconfig chain2 .c - eval destroy [winfo children .] + deleteWindows set x {} testobjconfig delete chain2 lappend x [testobjconfig info chain2] [testobjconfig info chain1] @@ -115,38 +109,38 @@ test config-2.1 {Tk_DeleteOptionTable - reference counts} { # No tests for DestroyOptionHashTable; couldn't figure out how to test. -test config-3.1 {Tk_InitOptions - priority of chained tables} { - eval destroy [winfo children .] +test config-3.1 {Tk_InitOptions - priority of chained tables} testobjconfig { + deleteWindows testobjconfig chain1 .a testobjconfig chain2 .b list [.a cget -two] [.b cget -two] } {two {two and a half}} -test config-3.2 {Tk_InitOptions - initialize from database} { - eval destroy [winfo children .] +test config-3.2 {Tk_InitOptions - initialize from database} testobjconfig { + deleteWindows option clear option add *a.color blue testobjconfig alltypes .a list [.a cget -color] } {blue} -test config-3.3 {Tk_InitOptions - initialize from database} { - eval destroy [winfo children .] +test config-3.3 {Tk_InitOptions - initialize from database} testobjconfig { + deleteWindows option clear option add *a.justify bogus testobjconfig alltypes .a list [.a cget -justify] } {left} -test config-3.4 {Tk_InitOptions - initialize from widget class} { - eval destroy [winfo children .] +test config-3.4 {Tk_InitOptions - initialize from widget class} testobjconfig { + deleteWindows testobjconfig alltypes .a list [.a cget -color] } {red} -test config-3.5 {Tk_InitOptions - no initial value} { - eval destroy [winfo children .] +test config-3.5 {Tk_InitOptions - no initial value} testobjconfig { + deleteWindows testobjconfig alltypes .a .a cget -anchor } {} -test config-3.6 {Tk_InitOptions - bad initial value} { - eval destroy [winfo children .] +test config-3.6 {Tk_InitOptions - bad initial value} testobjconfig { + deleteWindows option clear option add *a.color non-existent list [catch {testobjconfig alltypes .a} msg] $msg $errorInfo @@ -155,8 +149,8 @@ test config-3.6 {Tk_InitOptions - bad initial value} { invoked from within "testobjconfig alltypes .a"}} option clear -test config-3.7 {Tk_InitOptions - bad initial value} { - eval destroy [winfo children .] +test config-3.7 {Tk_InitOptions - bad initial value} testobjconfig { + deleteWindows list [catch {testobjconfig configerror} msg] $msg $errorInfo } {1 {expected integer but got "bogus"} {expected integer but got "bogus" (default value for "-int") @@ -164,280 +158,280 @@ test config-3.7 {Tk_InitOptions - bad initial value} { "testobjconfig configerror"}} option clear -test config-4.1 {DoObjConfig - boolean} { +test config-4.1 {DoObjConfig - boolean} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -boolean 0} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}] } {0 .foo 0 0 0} -test config-4.2 {DoObjConfig - boolean} { +test config-4.2 {DoObjConfig - boolean} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -boolean 1} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}] } {0 .foo 0 1 0} -test config-4.3 {DoObjConfig - invalid boolean} { +test config-4.3 {DoObjConfig - invalid boolean} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -boolean {}} msg] $msg } {1 {expected boolean value but got ""}} -test config-4.4 {DoObjConfig - boolean internal value} { +test config-4.4 {DoObjConfig - boolean internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -boolean 0 .foo cget -boolean } {0} -test config-4.5 {DoObjConfig - integer} { +test config-4.5 {DoObjConfig - integer} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -integer 3} msg] $msg [catch {.foo cget -integer} result] $result [catch {rename .foo {}}] } {0 .foo 0 3 0} -test config-4.6 {DoObjConfig - invalid integer} { +test config-4.6 {DoObjConfig - invalid integer} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -integer bar} msg] $msg } {1 {expected integer but got "bar"}} -test config-4.7 {DoObjConfig - integer internal value} { +test config-4.7 {DoObjConfig - integer internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -integer 421 .foo cget -integer } {421} -test config-4.8 {DoObjConfig - double} { +test config-4.8 {DoObjConfig - double} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -double 3.14} msg] $msg [catch {.foo cget -double} result] $result [catch {rename .foo {}}] } {0 .foo 0 3.14 0} -test config-4.9 {DoObjConfig - invalid double} { +test config-4.9 {DoObjConfig - invalid double} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -double bar} msg] $msg } {1 {expected floating-point number but got "bar"}} -test config-4.10 {DoObjConfig - double internal value} { +test config-4.10 {DoObjConfig - double internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -double 62.75 .foo cget -double } {62.75} -test config-4.11 {DoObjConfig - string} { +test config-4.11 {DoObjConfig - string} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -string test} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo] } {0 .foo 0 test {}} -test config-4.12 {DoObjConfig - null string} { +test config-4.12 {DoObjConfig - null string} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -string {}} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo] } {0 .foo 0 {} {}} -test config-4.13 {DoObjConfig - string internal value} { +test config-4.13 {DoObjConfig - string internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -string "this is a test" .foo cget -string } {this is a test} -test config-4.14 {DoObjConfig - string table} { +test config-4.14 {DoObjConfig - string table} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -stringtable two} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo] } {0 .foo 0 two {}} -test config-4.15 {DoObjConfig - invalid string table} { +test config-4.15 {DoObjConfig - invalid string table} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -stringtable foo} msg] $msg } {1 {bad stringtable "foo": must be one, two, three, or four}} -test config-4.16 {DoObjConfig - new string table} { +test config-4.16 {DoObjConfig - new string table} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo -stringtable two list [catch {.foo configure -stringtable three} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo] } {0 16 0 three {}} -test config-4.17 {DoObjConfig - stringtable internal value} { +test config-4.17 {DoObjConfig - stringtable internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -stringtable "four" .foo cget -stringtable } {four} -test config-4.18 {DoObjConfig - color} { +test config-4.18 {DoObjConfig - color} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -color blue} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo] } {0 .foo 0 blue {}} -test config-4.19 {DoObjConfig - invalid color} { +test config-4.19 {DoObjConfig - invalid color} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -color xxx} msg] $msg } {1 {unknown color name "xxx"}} -test config-4.20 {DoObjConfig - color internal value} { +test config-4.20 {DoObjConfig - color internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -color purple .foo cget -color } {purple} -test config-4.21 {DoObjConfig - null color} { +test config-4.21 {DoObjConfig - null color} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -color {}} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo] } {0 .foo 0 {} {}} -test config-4.22 {DoObjConfig - getting rid of old color} { +test config-4.22 {DoObjConfig - getting rid of old color} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo -color #333333 list [catch {.foo configure -color #444444} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo] } {0 32 0 #444444 {}} -test config-4.23 {DoObjConfig - font} { +test config-4.23 {DoObjConfig - font} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo] } {0 .foo 0 {Helvetica 72} {}} -test config-4.24 {DoObjConfig - new font} { +test config-4.24 {DoObjConfig - new font} testobjconfig { catch {rename .foo {}} testobjconfig alltypes .foo -font {Courier 12} list [catch {.foo configure -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo] } {0 64 0 {Helvetica 72} {}} -test config-4.25 {DoObjConfig - invalid font} { +test config-4.25 {DoObjConfig - invalid font} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -font {Helvetica 12 foo}} msg] $msg } {1 {unknown font style "foo"}} -test config-4.26 {DoObjConfig - null font} { +test config-4.26 {DoObjConfig - null font} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -font {}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo] } {0 .foo 0 {} {}} -test config-4.27 {DoObjConfig - font internal value} { +test config-4.27 {DoObjConfig - font internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -font {Times 16} .foo cget -font } {Times 16} -test config-4.28 {DoObjConfig - bitmap} { +test config-4.28 {DoObjConfig - bitmap} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -bitmap gray75} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo] } {0 .foo 0 gray75 {}} -test config-4.29 {DoObjConfig - new bitmap} { +test config-4.29 {DoObjConfig - new bitmap} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo -bitmap gray75 list [catch {.foo configure -bitmap gray50} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo] } {0 128 0 gray50 {}} -test config-4.30 {DoObjConfig - invalid bitmap} { +test config-4.30 {DoObjConfig - invalid bitmap} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -bitmap foo} msg] $msg } {1 {bitmap "foo" not defined}} -test config-4.31 {DoObjConfig - null bitmap} { +test config-4.31 {DoObjConfig - null bitmap} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -bitmap {}} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo] } {0 .foo 0 {} {}} -test config-4.32 {DoObjConfig - bitmap internal value} { +test config-4.32 {DoObjConfig - bitmap internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -bitmap gray25 .foo cget -bitmap } {gray25} -test config-4.33 {DoObjConfig - border} { +test config-4.33 {DoObjConfig - border} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -border green} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo] } {0 .foo 0 green {}} -test config-4.34 {DoObjConfig - invalid border} { +test config-4.34 {DoObjConfig - invalid border} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -border xxx} msg] $msg } {1 {unknown color name "xxx"}} -test config-4.35 {DoObjConfig - null border} { +test config-4.35 {DoObjConfig - null border} testobjconfig { catch {rename .foo {}} list [catch {testobjconfig alltypes .foo -border {}} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo] } {0 .foo 0 {} {}} -test config-4.36 {DoObjConfig - border internal value} { +test config-4.36 {DoObjConfig - border internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -border #123456 .foo cget -border } {#123456} -test config-4.37 {DoObjConfig - getting rid of old border} { +test config-4.37 {DoObjConfig - getting rid of old border} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo -border #333333 list [catch {.foo configure -border #444444} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo] } {0 256 0 #444444 {}} -test config-4.38 {DoObjConfig - relief} { +test config-4.38 {DoObjConfig - relief} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo] } {0 .foo 0 flat {}} -test config-4.39 {DoObjConfig - invalid relief} { +test config-4.39 {DoObjConfig - invalid relief} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -relief foo} msg] $msg } {1 {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken}} -test config-4.40 {DoObjConfig - new relief} { +test config-4.40 {DoObjConfig - new relief} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo -relief raised list [catch {.foo configure -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo] } {0 512 0 flat {}} -test config-4.41 {DoObjConfig - relief internal value} { +test config-4.41 {DoObjConfig - relief internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -relief ridge .foo cget -relief } {ridge} -test config-4.42 {DoObjConfig - cursor} { +test config-4.42 {DoObjConfig - cursor} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo] } {0 .foo 0 arrow {}} -test config-4.43 {DoObjConfig - invalid cursor} { +test config-4.43 {DoObjConfig - invalid cursor} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -cursor foo} msg] $msg } {1 {bad cursor spec "foo"}} -test config-4.44 {DoObjConfig - null cursor} { +test config-4.44 {DoObjConfig - null cursor} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -cursor {}} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo] } {0 .foo 0 {} {}} -test config-4.45 {DoObjConfig - new cursor} { +test config-4.45 {DoObjConfig - new cursor} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo -cursor xterm list [catch {.foo configure -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo] } {0 1024 0 arrow {}} -test config-4.46 {DoObjConfig - cursor internal value} { +test config-4.46 {DoObjConfig - cursor internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -cursor watch .foo cget -cursor } {watch} -test config-4.47 {DoObjConfig - justify} { +test config-4.47 {DoObjConfig - justify} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -justify center} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo] } {0 .foo 0 center {}} -test config-4.48 {DoObjConfig - invalid justify} { +test config-4.48 {DoObjConfig - invalid justify} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -justify foo} msg] $msg } {1 {bad justification "foo": must be left, right, or center}} -test config-4.49 {DoObjConfig - new justify} { +test config-4.49 {DoObjConfig - new justify} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo -justify left list [catch {.foo configure -justify right} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo] } {0 2048 0 right {}} -test config-4.50 {DoObjConfig - justify internal value} { +test config-4.50 {DoObjConfig - justify internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -justify center .foo cget -justify } {center} -test config-4.51 {DoObjConfig - anchor} { +test config-4.51 {DoObjConfig - anchor} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -anchor center} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo] } {0 .foo 0 center {}} -test config-4.52 {DoObjConfig - invalid anchor} { +test config-4.52 {DoObjConfig - invalid anchor} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -anchor foo} msg] $msg } {1 {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center}} -test config-4.53 {DoObjConfig - new anchor} { +test config-4.53 {DoObjConfig - new anchor} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo -anchor e list [catch {.foo configure -anchor n} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo] } {0 4096 0 n {}} -test config-4.54 {DoObjConfig - anchor internal value} { +test config-4.54 {DoObjConfig - anchor internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -anchor sw .foo cget -anchor } {sw} -test config-4.55 {DoObjConfig - pixel} { +test config-4.55 {DoObjConfig - pixel} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -pixel 42} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo] } {0 .foo 0 42 {}} -test config-4.56 {DoObjConfig - invalid pixel} { +test config-4.56 {DoObjConfig - invalid pixel} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -pixel foo} msg] $msg } {1 {bad screen distance "foo"}} -test config-4.57 {DoObjConfig - new pixel} { +test config-4.57 {DoObjConfig - new pixel} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo -pixel 42m list [catch {.foo configure -pixel 3c} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo] } {0 8192 0 3c {}} -test config-4.58 {DoObjConfig - pixel internal value} { +test config-4.58 {DoObjConfig - pixel internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -pixel [winfo screenmmwidth .]m .foo cget -pixel } [winfo screenwidth .] -test config-4.59 {DoObjConfig - window} { +test config-4.59 {DoObjConfig - window} testobjconfig { catch {destroy .foo} catch {destroy .bar} toplevel .bar list [catch {testobjconfig twowindows .foo -window .bar} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] } {0 .foo 0 .bar {} {}} -test config-4.60 {DoObjConfig - invalid window} { +test config-4.60 {DoObjConfig - invalid window} testobjconfig { catch {destroy .foo} toplevel .bar list [catch {testobjconfig twowindows .foo -window foo} msg] $msg [destroy .bar] } {1 {bad window path name "foo"} {}} -test config-4.61 {DoObjConfig - null window} { +test config-4.61 {DoObjConfig - null window} testobjconfig { catch {destroy .foo} catch {destroy .bar} toplevel .bar list [catch {testobjconfig twowindows .foo -window {}} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] } {0 .foo 0 {} {}} -test config-4.62 {DoObjConfig - new window} { +test config-4.62 {DoObjConfig - new window} testobjconfig { catch {destroy .foo} catch {destroy .bar} catch {destroy .blamph} @@ -446,12 +440,12 @@ test config-4.62 {DoObjConfig - new window} { testobjconfig twowindows .foo -window .bar list [catch {.foo configure -window .blamph} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] [destroy .blamph] } {0 0 0 .blamph {} {} {}} -test config-4.63 {DoObjConfig - window internal value} { +test config-4.63 {DoObjConfig - window internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -window . .foo cget -window } {.} -test config-4.64 {DoObjConfig - releasing old values} { +test config-4.64 {DoObjConfig - releasing old values} testobjconfig { # This test doesn't generate a useful value to check; if an # error occurs, it will be detected only by memory checking software # such as Purify or Tcl's built-in checker. @@ -465,7 +459,7 @@ test config-4.64 {DoObjConfig - releasing old values} { -custom barbaz concat {} } {} -test config-4.65 {DoObjConfig - releasing old values} { +test config-4.65 {DoObjConfig - releasing old values} testobjconfig { # This test doesn't generate a useful value to check; if an # error occurs, it will be detected only by memory checking software # such as Purify or Tcl's built-in checker. @@ -479,188 +473,192 @@ test config-4.65 {DoObjConfig - releasing old values} { -custom barbaz concat {} } {} -test config-4.66 {DoObjConfig - custom} { +test config-4.66 {DoObjConfig - custom} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -custom test} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo] } {0 .foo 0 TEST {}} -test config-4.67 {DoObjConfig - null custom} { +test config-4.67 {DoObjConfig - null custom} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -custom {}} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo] } {0 .foo 0 {} {}} -test config-4.68 {DoObjConfig - custom internal value} { +test config-4.68 {DoObjConfig - custom internal value} testobjconfig { catch {rename .foo {}} testobjconfig internal .foo -custom "this is a test" .foo cget -custom } {THIS IS A TEST} -test config-5.1 {ObjectIsEmpty - object is already string} { +test config-5.1 {ObjectIsEmpty - object is already string} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo -color [format ""] .foo cget -color } {} -test config-5.2 {ObjectIsEmpty - object is already string} { +test config-5.2 {ObjectIsEmpty - object is already string} testobjconfig { catch {destroy .foo} list [catch {testobjconfig alltypes .foo -color [format " "]} msg] $msg } {1 {unknown color name " "}} -test config-5.3 {ObjectIsEmpty - must convert back to string} { +test config-5.3 {ObjectIsEmpty - must convert back to string} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo -color [list] .foo cget -color } {} -eval destroy [winfo children .] -testobjconfig chain2 .a -testobjconfig alltypes .b -test config-6.1 {GetOptionFromObj - cached answer} { +deleteWindows +if {[testConstraint testobjconfig]} { + testobjconfig chain2 .a + testobjconfig alltypes .b +} +test config-6.1 {GetOptionFromObj - cached answer} testobjconfig { list [.a cget -three] [.a cget -three] } {three three} -test config-6.2 {GetOptionFromObj - exact match} { +test config-6.2 {GetOptionFromObj - exact match} testobjconfig { .a cget -one } {one} -test config-6.3 {GetOptionFromObj - abbreviation} { +test config-6.3 {GetOptionFromObj - abbreviation} testobjconfig { .a cget -fo } {four} -test config-6.4 {GetOptionFromObj - ambiguous abbreviation} { +test config-6.4 {GetOptionFromObj - ambiguous abbreviation} testobjconfig { list [catch {.a cget -on} msg] $msg } {1 {unknown option "-on"}} -test config-6.5 {GetOptionFromObj - duplicate options in different tables} { +test config-6.5 {GetOptionFromObj - duplicate options in different tables} testobjconfig { .a cget -tw } {two and a half} -test config-6.6 {GetOptionFromObj - synonym} { +test config-6.6 {GetOptionFromObj - synonym} testobjconfig { .b cget -synonym } {red} -eval destroy [winfo children .] -testobjconfig alltypes .a -test config-7.1 {Tk_SetOptions - basics} { +deleteWindows +if {[testConstraint testobjconfig]} { + testobjconfig alltypes .a +} +test config-7.1 {Tk_SetOptions - basics} testobjconfig { .a configure -color green -rel sunken list [.a cget -color] [.a cget -relief] } {green sunken} -test config-7.2 {Tk_SetOptions - bogus option name} { +test config-7.2 {Tk_SetOptions - bogus option name} testobjconfig { list [catch {.a configure -bogus} msg] $msg } {1 {unknown option "-bogus"}} -test config-7.3 {Tk_SetOptions - synonym} { +test config-7.3 {Tk_SetOptions - synonym} testobjconfig { .a configure -synonym blue .a cget -color } {blue} -test config-7.4 {Tk_SetOptions - missing value} { +test config-7.4 {Tk_SetOptions - missing value} testobjconfig { list [catch {.a configure -color green -relief} msg] $msg [.a cget -color] } {1 {value for "-relief" missing} green} -test config-7.5 {Tk_SetOptions - saving old values} { +test config-7.5 {Tk_SetOptions - saving old values} testobjconfig { .a configure -color red -int 7 -relief raised -double 3.14159 list [catch {.a csave -color green -int 432 -relief sunken \ -double 2.0 -color bogus} msg] $msg [.a cget -color] \ [.a cget -int] [.a cget -relief] [.a cget -double] } {1 {unknown color name "bogus"} red 7 raised 3.14159} -test config-7.6 {Tk_SetOptions - error in DoObjConfig call} { +test config-7.6 {Tk_SetOptions - error in DoObjConfig call} testobjconfig { list [catch {.a configure -color bogus} msg] $msg $errorInfo } {1 {unknown color name "bogus"} {unknown color name "bogus" (processing "-color" option) invoked from within ".a configure -color bogus"}} -test config-7.7 {Tk_SetOptions - synonym name in error message} { +test config-7.7 {Tk_SetOptions - synonym name in error message} testobjconfig { list [catch {.a configure -synonym bogus} msg] $msg $errorInfo } {1 {unknown color name "bogus"} {unknown color name "bogus" (processing "-synonym" option) invoked from within ".a configure -synonym bogus"}} -test config-7.8 {Tk_SetOptions - returning mask} { +test config-7.8 {Tk_SetOptions - returning mask} testobjconfig { format %x [.a configure -color red -int 7 -relief raised -double 3.14159] } {226} -test config-7.9 {Tk_SetOptions - error in DoObjConfig with custom option} { +test config-7.9 {Tk_SetOptions - error in DoObjConfig with custom option} testobjconfig { list [catch {.a configure -custom bad} msg] $msg $errorInfo } {1 {expected good value, got "BAD"} {expected good value, got "BAD" (processing "-custom" option) invoked from within ".a configure -custom bad"}} -test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} { - eval destroy [winfo children .] +test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} testobjconfig { + deleteWindows testobjconfig alltypes .a list [catch {.a csave -color green -color black -color blue \ -color #ffff00 -color #ff00ff -color bogus} msg] $msg \ [.a cget -color] } {1 {unknown color name "bogus"} red} -test config-8.2 {Tk_RestoreSavedOptions - freeing object memory} { - eval destroy [winfo children .] +test config-8.2 {Tk_RestoreSavedOptions - freeing object memory} testobjconfig { + deleteWindows testobjconfig alltypes .a .a csave -color green -color black -color blue -color #ffff00 \ -color #ff00ff } {32} -test config-8.3 {Tk_RestoreSavedOptions - boolean internal form} { - eval destroy [winfo children .] +test config-8.3 {Tk_RestoreSavedOptions - boolean internal form} testobjconfig { + deleteWindows testobjconfig internal .a list [catch {.a csave -boolean 0 -color bogus}] [.a cget -boolean] } {1 1} -test config-8.4 {Tk_RestoreSavedOptions - integer internal form} { - eval destroy [winfo children .] +test config-8.4 {Tk_RestoreSavedOptions - integer internal form} testobjconfig { + deleteWindows testobjconfig internal .a list [catch {.a csave -integer 24 -color bogus}] [.a cget -integer] } {1 148962237} -test config-8.5 {Tk_RestoreSavedOptions - double internal form} { - eval destroy [winfo children .] +test config-8.5 {Tk_RestoreSavedOptions - double internal form} testobjconfig { + deleteWindows testobjconfig internal .a list [catch {.a csave -double 62.4 -color bogus}] [.a cget -double] } {1 3.14159} -test config-8.6 {Tk_RestoreSavedOptions - string internal form} { - eval destroy [winfo children .] +test config-8.6 {Tk_RestoreSavedOptions - string internal form} testobjconfig { + deleteWindows testobjconfig internal .a list [catch {.a csave -string "A long string" -color bogus}] \ [.a cget -string] } {1 foo} -test config-8.7 {Tk_RestoreSavedOptions - string table internal form} { - eval destroy [winfo children .] +test config-8.7 {Tk_RestoreSavedOptions - string table internal form} testobjconfig { + deleteWindows testobjconfig internal .a list [catch {.a csave -stringtable three -color bogus}] \ [.a cget -stringtable] } {1 one} -test config-8.8 {Tk_RestoreSavedOptions - color internal form} { - eval destroy [winfo children .] +test config-8.8 {Tk_RestoreSavedOptions - color internal form} testobjconfig { + deleteWindows testobjconfig internal .a list [catch {.a csave -color green -color bogus}] [.a cget -color] } {1 red} -test config-8.9 {Tk_RestoreSavedOptions - font internal form} {nonPortable} { - eval destroy [winfo children .] +test config-8.9 {Tk_RestoreSavedOptions - font internal form} {testobjconfig nonPortable} { + deleteWindows testobjconfig internal .a list [catch {.a csave -font {Times 12} -color bogus}] [.a cget -font] } {1 {Helvetica 12}} -test config-8.10 {Tk_RestoreSavedOptions - bitmap internal form} { - eval destroy [winfo children .] +test config-8.10 {Tk_RestoreSavedOptions - bitmap internal form} testobjconfig { + deleteWindows testobjconfig internal .a list [catch {.a csave -bitmap questhead -color bogus}] [.a cget -bitmap] } {1 gray50} -test config-8.11 {Tk_RestoreSavedOptions - border internal form} { - eval destroy [winfo children .] +test config-8.11 {Tk_RestoreSavedOptions - border internal form} testobjconfig { + deleteWindows testobjconfig internal .a list [catch {.a csave -border brown -color bogus}] [.a cget -border] } {1 blue} -test config-8.12 {Tk_RestoreSavedOptions - relief internal form} { - eval destroy [winfo children .] +test config-8.12 {Tk_RestoreSavedOptions - relief internal form} testobjconfig { + deleteWindows testobjconfig internal .a list [catch {.a csave -relief sunken -color bogus}] [.a cget -relief] } {1 raised} -test config-8.13 {Tk_RestoreSavedOptions - cursor internal form} { - eval destroy [winfo children .] +test config-8.13 {Tk_RestoreSavedOptions - cursor internal form} testobjconfig { + deleteWindows testobjconfig internal .a list [catch {.a csave -cursor watch -color bogus}] [.a cget -cursor] } {1 xterm} -test config-8.14 {Tk_RestoreSavedOptions - justify internal form} { - eval destroy [winfo children .] +test config-8.14 {Tk_RestoreSavedOptions - justify internal form} testobjconfig { + deleteWindows testobjconfig internal .a list [catch {.a csave -justify right -color bogus}] [.a cget -justify] } {1 left} -test config-8.15 {Tk_RestoreSavedOptions - anchor internal form} { - eval destroy [winfo children .] +test config-8.15 {Tk_RestoreSavedOptions - anchor internal form} testobjconfig { + deleteWindows testobjconfig internal .a list [catch {.a csave -anchor center -color bogus}] [.a cget -anchor] } {1 n} -test config-8.16 {Tk_RestoreSavedOptions - window internal form} { - eval destroy [winfo children .] +test config-8.16 {Tk_RestoreSavedOptions - window internal form} testobjconfig { + deleteWindows testobjconfig internal .a -window .a list [catch {.a csave -window .a -color bogus}] [.a cget -window] } {1 .a} -test config-8.17 {Tk_RestoreSavedOptions - custom internal form} { - eval destroy [winfo children .] +test config-8.17 {Tk_RestoreSavedOptions - custom internal form} testobjconfig { + deleteWindows testobjconfig internal .a -custom "foobar" list [catch {.a csave -custom "barbaz" -color bogus}] [.a cget -custom] } {1 FOOBAR} @@ -669,187 +667,191 @@ test config-8.17 {Tk_RestoreSavedOptions - custom internal form} { # problem. This may not be evident unless the tests are run in # conjunction with a memory usage analyzer such as Purify. -test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} { +test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} testobjconfig { catch {destroy .foo} testobjconfig internal .foo .foo configure -string "two words" destroy .foo } {} -test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} { +test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} testobjconfig { catch {destroy .foo} testobjconfig internal .foo .foo configure -color yellow destroy .foo } {} -test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} { +test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo .foo configure -color [format blue] destroy .foo } {} -test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} { +test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} testobjconfig { catch {destroy .foo} testobjconfig internal .foo .foo configure -font {Courier 20} destroy .foo } {} -test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} { +test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo .foo configure -font [format {Courier 24}] destroy .foo } {} -test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} { +test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} testobjconfig { catch {destroy .foo} testobjconfig internal .foo .foo configure -bitmap gray75 destroy .foo } {} -test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} { +test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo .foo configure -bitmap [format gray75] destroy .foo } {} -test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} { +test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} testobjconfig { catch {destroy .foo} testobjconfig internal .foo .foo configure -border orange destroy .foo } {} -test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} { +test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo .foo configure -border [format blue] destroy .foo } {} -test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} { +test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} testobjconfig { catch {destroy .foo} testobjconfig internal .foo .foo configure -cursor cross destroy .foo } {} -test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} { +test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo .foo configure -cursor [format watch] destroy .foo } {} -test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} { +test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo .foo configure -integer [format 27] destroy .foo } {} -test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} { +test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} testobjconfig { catch {destroy .fpp} testobjconfig internal .foo .foo configure -custom "foobar" destroy .foo } {} -test config-10.1 {Tk_GetOptionInfo - one item} { +test config-10.1 {Tk_GetOptionInfo - one item} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo .foo configure -relief groove .foo configure -relief } {-relief relief Relief raised groove} -test config-10.2 {Tk_GetOptionInfo - one item, synonym} { +test config-10.2 {Tk_GetOptionInfo - one item, synonym} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo .foo configure -color black .foo configure -synonym } {-color color Color red black} -test config-10.3 {Tk_GetOptionInfo - all items} { +test config-10.3 {Tk_GetOptionInfo - all items} testobjconfig { catch {destroy .foo} testobjconfig alltypes .foo -font {Helvetica 18} -integer 13563 .foo configure } {{-boolean boolean Boolean 1 1} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief raised raised} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor {} {}} {-pixel pixel Pixel 1 1} {-custom {} {} {} {}} {-synonym -color}} -test config-10.4 {Tk_GetOptionInfo - chaining through tables} { +test config-10.4 {Tk_GetOptionInfo - chaining through tables} testobjconfig { catch {destroy .foo} testobjconfig chain2 .foo -one asdf -three xyzzy .foo configure } {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}} -eval destroy [winfo children .] -testobjconfig alltypes .a -test config-11.1 {GetConfigList - synonym} { +deleteWindows +if {[testConstraint testobjconfig]} { + testobjconfig alltypes .a +} +test config-11.1 {GetConfigList - synonym} testobjconfig { lindex [.a configure] end } {-synonym -color} -test config-11.2 {GetConfigList - null database names} { +test config-11.2 {GetConfigList - null database names} testobjconfig { .a configure -justify } {-justify {} {} left left} -test config-11.3 {GetConfigList - null default and current value} { +test config-11.3 {GetConfigList - null default and current value} testobjconfig { .a configure -anchor } {-anchor anchor Anchor {} {}} -eval destroy [winfo children .] -testobjconfig internal .a -test config-12.1 {GetObjectForOption - boolean} { +deleteWindows +if {[testConstraint testobjconfig]} { + testobjconfig internal .a +} +test config-12.1 {GetObjectForOption - boolean} testobjconfig { .a configure -boolean 0 .a cget -boolean } {0} -test config-12.2 {GetObjectForOption - integer} { +test config-12.2 {GetObjectForOption - integer} testobjconfig { .a configure -integer 1247 .a cget -integer } {1247} -test config-12.3 {GetObjectForOption - double} { +test config-12.3 {GetObjectForOption - double} testobjconfig { .a configure -double -88.82 .a cget -double } {-88.82} -test config-12.4 {GetObjectForOption - string} { +test config-12.4 {GetObjectForOption - string} testobjconfig { .a configure -string "test value" .a cget -string } {test value} -test config-12.5 {GetObjectForOption - stringTable} { +test config-12.5 {GetObjectForOption - stringTable} testobjconfig { .a configure -stringtable "two" .a cget -stringtable } {two} -test config-12.6 {GetObjectForOption - color} { +test config-12.6 {GetObjectForOption - color} testobjconfig { .a configure -color "green" .a cget -color } {green} -test config-12.7 {GetObjectForOption - font} { +test config-12.7 {GetObjectForOption - font} testobjconfig { .a configure -font {Times 36} .a cget -font } {Times 36} -test config-12.8 {GetObjectForOption - bitmap} { +test config-12.8 {GetObjectForOption - bitmap} testobjconfig { .a configure -bitmap "questhead" .a cget -bitmap } {questhead} -test config-12.9 {GetObjectForOption - border} { +test config-12.9 {GetObjectForOption - border} testobjconfig { .a configure -border #33217c .a cget -border } {#33217c} -test config-12.10 {GetObjectForOption - relief} { +test config-12.10 {GetObjectForOption - relief} testobjconfig { .a configure -relief groove .a cget -relief } {groove} -test config-12.11 {GetObjectForOption - cursor} { +test config-12.11 {GetObjectForOption - cursor} testobjconfig { .a configure -cursor watch .a cget -cursor } {watch} -test config-12.12 {GetObjectForOption - justify} { +test config-12.12 {GetObjectForOption - justify} testobjconfig { .a configure -justify right .a cget -justify } {right} -test config-12.13 {GetObjectForOption - anchor} { +test config-12.13 {GetObjectForOption - anchor} testobjconfig { .a configure -anchor e .a cget -anchor } {e} -test config-12.14 {GetObjectForOption - pixels} { +test config-12.14 {GetObjectForOption - pixels} testobjconfig { .a configure -pixel 193.2 .a cget -pixel } {193} -test config-12.15 {GetObjectForOption - window} { +test config-12.15 {GetObjectForOption - window} testobjconfig { .a configure -window .a .a cget -window } {.a} -test config-12.16 {GetObjectForOption -custom} { +test config-12.16 {GetObjectForOption -custom} testobjconfig { .a configure -custom foobar .a cget -custom } {FOOBAR} -test config-12.17 {GetObjectForOption - null values} { +test config-12.17 {GetObjectForOption - null values} testobjconfig { .a configure -string {} -color {} -font {} -bitmap {} -border {} \ -cursor {} -window {} -custom {} list [.a cget -string] [.a cget -color] [.a cget -font] \ @@ -868,7 +870,7 @@ test config-13.1 {proper cleanup of options with widget destroy} { } } {} -eval destroy [winfo children .] +deleteWindows test config-14.1 {Tk_CreateOptionTable - use with namespace import} { namespace export -clear * @@ -887,7 +889,9 @@ test config-14.1 {Tk_CreateOptionTable - use with namespace import} { } {} # cleanup -eval destroy [winfo children .] -killTables +deleteWindows +if {[testConstraint testobjconfig]} { + killTables +} ::tcltest::cleanupTests return diff --git a/tests/constraints.tcl b/tests/constraints.tcl index 196c216..3c28b3a 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -1,15 +1,27 @@ +if {[namespace exists tk::test]} { + deleteWindows + wm geometry . {} + raise . + return +} + package require Tcl 8.4 package require Tk 8.4 tk appname tktest wm title . tktest +# If the main window isn't already mapped (e.g. because the tests are +# being run automatically) , specify a precise size for it so that the +# user won't have to position it manually. + +if {![winfo ismapped .]} { + wm geometry . +0+0 + update +} package require tcltest 2.1 namespace eval tk { - if {[namespace exists test]} { - namespace delete test - } namespace eval test { namespace eval bg { # Manage a background process. @@ -96,6 +108,19 @@ namespace eval tk { proc deleteWindows {} { eval destroy [winfo children .] } + + namespace export fixfocus + proc fixfocus {} { + catch {destroy .focus} + toplevel .focus + wm geometry .focus +0+0 + entry .focus.e + .focus.e insert 0 "fixfocus" + pack .focus.e + update + focus -force .focus.e + destroy .focus + } } } @@ -111,6 +136,7 @@ testConstraint noExceed [expr {![testConstraint unix] testConstraint testImageType [expr {[lsearch [image types] test] >= 0}] testConstraint testembed [llength [info commands testembed]] testConstraint testwrapper [llength [info commands testwrapper]] +testConstraint testfont [llength [info commands testfont]] testConstraint fonts 1 destroy .e entry .e -width 0 -font {Helvetica -12} -bd 1 @@ -129,6 +155,19 @@ destroy .t if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} { testConstraint fonts 0 } +testConstraint pseudocolor8 [expr {([catch { + toplevel .t -visual {pseudocolor 8} -colormap new + }] == 0) && ([winfo depth .t] == 8)}] +destroy .t +setupbg +set app [dobg {tk appname}] +testConstraint secureserver 1 +if {[catch {send $app set a 0} msg] == 1} { + if {[string match "X server insecure *" $msg]} { + testConstraint secureserver 0 + } +} +cleanupbg eval tcltest::configure $argv namespace import -force tcltest::test diff --git a/tests/cursor.test b/tests/cursor.test index 11e23aa..3753bab 100644 --- a/tests/cursor.test +++ b/tests/cursor.test @@ -6,17 +6,16 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: cursor.test,v 1.5 2002/06/13 15:31:39 dgp Exp $ +# RCS: @(#) $Id: cursor.test,v 1.6 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -set ::tcltest::testConfig(testcursor) [llength [info commands testcursor]] +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands -eval destroy [winfo children .] -wm geometry . {} -raise . +testConstraint testcursor [llength [info commands testcursor]] test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} {testcursor} { set x watch diff --git a/tests/dialog.test b/tests/dialog.test index 2fa194b..a10eb44 100644 --- a/tests/dialog.test +++ b/tests/dialog.test @@ -1,18 +1,15 @@ # This file is a Tcl script to test out Tk's "tk_dialog" command. # It is organized in the standard fashion for Tcl tests. # -# RCS: @(#) $Id: dialog.test,v 1.2 2001/08/22 17:29:23 hobbs Exp $ +# RCS: @(#) $Id: dialog.test,v 1.3 2002/07/14 05:48:46 dgp Exp $ # -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -# Some tests require user interaction on non-unix platform - -set ::tcltest::testConfig(nonUnixUserInteraction) \ - [expr {$::tcltest::testConfig(userInteraction) || \ - $::tcltest::testConfig(unixOnly)}] +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands test dialog-1.1 {tk_dialog command} { list [catch {tk_dialog} msg] $msg @@ -63,4 +60,5 @@ test dialog-2.2 {tk_dialog operation} { set res } {-1} - +tcltest::cleanupTests +return diff --git a/tests/embed.test b/tests/embed.test index f19583a..92a21b5 100644 --- a/tests/embed.test +++ b/tests/embed.test @@ -4,17 +4,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: embed.test,v 1.1 2002/05/27 17:33:26 mdejong Exp $ +# RCS: @(#) $Id: embed.test,v 1.2 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -proc deleteWindows {} { - foreach i [winfo children .] { - destroy $i - } -} +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands test embed-1.1 {TkpUseWindow procedure, bad window identifier} { deleteWindows @@ -49,3 +46,6 @@ test embed-1.5 {TkpUseWindow procedure, -container must be set} { # FIXME: test cases common to unixEmbed.test and macEmbed.test should # be moved here. + +tcltest::cleanupTests +return diff --git a/tests/entry.test b/tests/entry.test index fd4d7e3..5c6265f 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -6,17 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: entry.test,v 1.11 2001/04/03 04:40:50 hobbs Exp $ +# RCS: @(#) $Id: entry.test,v 1.12 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands proc scroll args { global scrollInfo @@ -1140,7 +1137,7 @@ test entry-11.1 {EntryEventProc procedure} { update } {} test entry-11.2 {EntryEventProc procedure} { - eval destroy [winfo children .] + deleteWindows entry .e1 -fg #112233 rename .e1 .e2 set x {} @@ -1151,7 +1148,7 @@ test entry-11.2 {EntryEventProc procedure} { } {.e1 #112233 {} {}} test entry-12.1 {EntryCmdDeletedProc procedure} { - eval destroy [winfo children .] + deleteWindows button .e1 -text "xyz_123" rename .e1 {} list [info command .e*] [winfo children .] @@ -1380,7 +1377,7 @@ test entry-17.4 {EntryUpdateScrollbar procedure} { (horizontal scrolling command executed by .e)}} set l [interp hidden] -eval destroy [winfo children .] +deleteWindows test entry-18.1 {Entry widget vs hiding} { destroy .e diff --git a/tests/event.test b/tests/event.test index 67c5afb..9637acd 100644 --- a/tests/event.test +++ b/tests/event.test @@ -6,24 +6,19 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: event.test,v 1.9 2002/02/15 05:48:08 mdejong Exp $ +# RCS: @(#) $Id: event.test,v 1.10 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands # XXX This test file is woefully incomplete. Right now it only tests # a few of the procedures in tkEvent.c. Please add more tests whenever # possible. - - # Setup table used to query key events. proc _init_keypress_lookup { } { diff --git a/tests/filebox.test b/tests/filebox.test index c4485bf..6cd1937 100644 --- a/tests/filebox.test +++ b/tests/filebox.test @@ -6,20 +6,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: filebox.test,v 1.12 2002/02/25 15:26:20 dkf Exp $ +# RCS: @(#) $Id: filebox.test,v 1.13 2002/07/14 05:48:46 dgp Exp $ # -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -set tk_strictMotif_old $tk_strictMotif +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands -# Some tests require user interaction on non-unix platform +namespace import -force tcltest::makeFile +namespace import -force tcltest::removeFile -set ::tcltest::testConfig(nonUnixUserInteraction) \ - [expr {$::tcltest::testConfig(userInteraction) || \ - $::tcltest::testConfig(unixOnly)}] +set tk_strictMotif_old $tk_strictMotif #---------------------------------------------------------------------- # diff --git a/tests/focus.test b/tests/focus.test index 2e95945..25cd932 100644 --- a/tests/focus.test +++ b/tests/focus.test @@ -6,15 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: focus.test,v 1.7 2001/03/28 17:27:10 dgp Exp $ +# RCS: @(#) $Id: focus.test,v 1.8 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -eval destroy [winfo children .] -wm geometry . {} -raise . +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands button .b -text .b -relief raised -bd 2 pack .b @@ -59,8 +58,7 @@ proc focusClear {} { } focusSetup -set ::tcltest::testConfig(altDisplay) [info exists env(TK_ALT_DISPLAY)] -if {$::tcltest::testConfig(altDisplay)} { +if {[testConstraint altDisplay]} { focusSetupAlt } update @@ -188,11 +186,6 @@ test focus-1.25 {Tk_FocusCmd procedure} {unixOnly} { list [catch {focus -unknown} msg] $msg } {1 {bad option "-unknown": must be -displayof, -force, or -lastfor}} -# Some tests require the testwrapper command - -set ::tcltest::testConfig(testwrapper) \ - [expr {[info commands testwrapper] != {}}] - test focus-2.1 {TkFocusFilterEvent procedure} {unixOnly nonPortable testwrapper} { focus -force .b destroy .t @@ -524,21 +517,9 @@ test focus-4.4 {TkFocusDeadWindow procedure} {unixOnly testwrapper} { # I don't know how to test most of the remaining procedures of this file # explicitly; they've already been exercised by the preceding tests. -# If send is disabled because of inadequate security, don't run any -# of these tests at all. - -setupbg -set app [dobg {tk appname}] -set ::tcltest::testConfig(secureServer) 1 -if {[catch {send $app set a 0} msg] == 1} { - if [string match "X server insecure *" $msg] { - set ::tcltest::testConfig(secureServer) 0 - } -} -cleanupbg setupbg test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} \ - {unixOnly testwrapper secureServer} { + {unixOnly testwrapper secureserver} { focusSetup focus -force .t update @@ -657,7 +638,7 @@ test focus-6.2 {miscellaneous - embedded application in different process} \ set result } {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} -eval destroy [winfo children .] +deleteWindows bind all <FocusIn> {} bind all <FocusOut> {} diff --git a/tests/focusTcl.test b/tests/focusTcl.test index 0d223cf..decc824 100644 --- a/tests/focusTcl.test +++ b/tests/focusTcl.test @@ -7,15 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: focusTcl.test,v 1.3 1999/04/16 01:51:37 stanton Exp $ +# RCS: @(#) $Id: focusTcl.test,v 1.4 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -eval destroy [winfo children .] -wm geometry . {} -raise . +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands proc setup1 w { if {$w == "."} { @@ -30,7 +29,9 @@ proc setup1 w { button $w.b.$i -text "Button $w.b.$i" pack $w.b.$i -side left } - tkwait visibility $w.b.z + if {[winfo ismapped $w.b.z]} { + tkwait visibility $w.b.z + } } option add *takeFocus 1 @@ -74,7 +75,7 @@ test focusTcl-1.11 {tk_focusNext procedure, basic tree traversal} { tk_focusNext .b.z } {.} test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} { - eval destroy [winfo child .] + deleteWindows setup1 . update . configure -takefocus 0 @@ -82,7 +83,7 @@ test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} { } {.a} . configure -takefocus 1 -eval destroy [winfo child .] +deleteWindows setup1 . toplevel .t wm geom .t +0+0 @@ -107,7 +108,7 @@ test focusTcl-2.5 {tk_focusNext procedure, toplevels} { tk_focusNext .t.b.z } {.t} -eval destroy [winfo child .] +deleteWindows test focusTcl-3.1 {tk_focusPrev procedure, no children} { tk_focusPrev . } {.} @@ -137,7 +138,7 @@ test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} { tk_focusPrev .a } {.} -eval destroy [winfo child .] +deleteWindows setup1 . toplevel .t wm geom .t +0+0 @@ -164,15 +165,15 @@ test focusTcl-4.5 {tk_focusPrev procedure, toplevels} { tk_focusPrev .t.a } {.t.b.z} -eval destroy [winfo child .] +deleteWindows test focusTcl-5.1 {tkFocusOK procedure, -takefocus 0} { - eval destroy [winfo child .] + deleteWindows setup1 . .b.x configure -takefocus 0 tk_focusNext .b } {.b.y} test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} { - eval destroy [winfo child .] + deleteWindows setup1 . pack forget .b update @@ -190,7 +191,7 @@ test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} { } return 0 } - eval destroy [winfo child .] + deleteWindows setup1 . pack forget .b.y update @@ -201,14 +202,14 @@ test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} { list [tk_focusNext .a] [tk_focusNext .b.x] } {.b.x .d} test focusTcl-5.4 {tkFocusOK procedure, -takefocus ""} { - eval destroy [winfo child .] + deleteWindows setup1 . .b.x configure -takefocus "" update tk_focusNext .b } {.b.x} test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} { - eval destroy [winfo child .] + deleteWindows setup1 . .b.x configure -takefocus "" pack unpack .b.x @@ -216,7 +217,7 @@ test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} { tk_focusNext .b } {.b.y} test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} { - eval destroy [winfo child .] + deleteWindows setup1 . foreach w {.b.x .b.y .b.z} { $w configure -takefocus "" @@ -226,7 +227,7 @@ test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} { tk_focusNext .b } {.c} test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} { - eval destroy [winfo child .] + deleteWindows setup1 . .b.y configure -takefocus 1 pack unpack .b.y @@ -235,7 +236,7 @@ test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} { } {.b.z} test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} { proc always args {return 1} - eval destroy [winfo child .] + deleteWindows setup1 . .b.y configure -takefocus always pack unpack .b.y @@ -243,7 +244,7 @@ test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} { tk_focusNext .b.x } {.b.y} test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} { - eval destroy [winfo child .] + deleteWindows setup1 . foreach w {.b.x .b.y .b.z} { $w configure -takefocus "" @@ -253,7 +254,7 @@ test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} { tk_focusNext .b } {.b.y} test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} { - eval destroy [winfo child .] + deleteWindows setup1 . foreach w {.a .b .c .d} { $w configure -takefocus "" @@ -263,7 +264,7 @@ test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} { list [tk_focusNext .] [tk_focusNext .a] } {.a .b.x} test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} { - eval destroy [winfo child .] + deleteWindows setup1 . foreach w {.a .b .c .d} { $w configure -takefocus "" diff --git a/tests/font.test b/tests/font.test index 07ab5cb..f16d895 100644 --- a/tests/font.test +++ b/tests/font.test @@ -6,17 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: font.test,v 1.7 2002/06/26 08:22:54 a_kovalenko Exp $ +# RCS: @(#) $Id: font.test,v 1.8 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -if {[info commands testfont] != "testfont"} { - puts "testfont command not available; skipping tests" - ::tcltest::cleanupTests - return -} +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands catch {destroy .b} toplevel .b @@ -458,7 +455,7 @@ test font-13.4 {CreateNamedFont: recreate "deleted" font} { test font-14.1 {Tk_GetFont procedure} { } {} -test font-15.1 {Tk_AllocFontFromObj - converting internal reps} { +test font-15.1 {Tk_AllocFontFromObj - converting internal reps} testfont { set x {Times 16} lindex $x 0 destroy .b1 .b2 @@ -466,7 +463,7 @@ test font-15.1 {Tk_AllocFontFromObj - converting internal reps} { lindex $x 0 testfont counts {Times 16} } {{1 0}} -test font-15.2 {Tk_AllocFontFromObj - discard stale font} { +test font-15.2 {Tk_AllocFontFromObj - discard stale font} testfont { set x {Times 16} destroy .b1 .b2 button .b1 -font $x @@ -476,7 +473,7 @@ test font-15.2 {Tk_AllocFontFromObj - discard stale font} { button .b2 -font $x lappend result [testfont counts {Times 16}] } {{} {{1 1}}} -test font-15.3 {Tk_AllocFontFromObj - reuse existing font} { +test font-15.3 {Tk_AllocFontFromObj - reuse existing font} testfont { set x {Times 16} destroy .b1 .b2 button .b1 -font $x @@ -551,7 +548,7 @@ test font-16.1 {Tk_NameOfFont procedure} { .b.f cget -font } {-family fixed} -test font-17.1 {Tk_FreeFontFromObj - reference counts} { +test font-17.1 {Tk_FreeFontFromObj - reference counts} testfont { set x {Courier 12} destroy .b1 .b2 .b3 button .b1 -font $x @@ -611,7 +608,7 @@ test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} { list [lindex [font actual xyz] 0] [lindex $x 0] } {-family -family} -test font-18.1 {FreeFontObjProc} { +test font-18.1 {FreeFontObjProc} testfont { destroy .b1 set x [format {Courier 12}] button .b1 -font $x diff --git a/tests/frame.test b/tests/frame.test index 7e7746c..4acd84b 100644 --- a/tests/frame.test +++ b/tests/frame.test @@ -7,17 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: frame.test,v 1.6 2001/09/26 21:36:19 pspjuth Exp $ +# RCS: @(#) $Id: frame.test,v 1.7 2002/07/14 05:48:46 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -foreach i [winfo children .] { - catch {destroy $i} -} -wm geometry . {} -raise . +package require tcltest 2.1 +namespace import -force tcltest::configure +namespace import -force tcltest::testsDirectory +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands # eatColors -- # Creates a toplevel window and allocates enough colors in it to @@ -532,7 +529,7 @@ test frame-7.1 {FrameEventProc procedure} { lappend result [info commands .frame2] } {.frame2 {}} test frame-7.2 {FrameEventProc procedure} { - eval destroy [winfo children .] + deleteWindows frame .f1 -bg #543210 rename .f1 .f2 set x {} @@ -543,13 +540,13 @@ test frame-7.2 {FrameEventProc procedure} { } {.f1 #543210 {} {}} test frame-8.1 {FrameCmdDeletedProc procedure} { - eval destroy [winfo children .] + deleteWindows frame .f1 rename .f1 {} list [info command .f*] [winfo children .] } {{} {}} test frame-8.2 {FrameCmdDeletedProc procedure} { - eval destroy [winfo children .] + deleteWindows toplevel .f1 -menu .m wm geometry .f1 +0+0 update @@ -604,7 +601,7 @@ test frame-9.3 {MapFrame procedure, window deleted while mapping} { } {0} set l [interp hidden] -eval destroy [winfo children .] +deleteWindows test frame-10.1 {frame widget vs hidden commands} { catch {destroy .t} diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test index f1101e6..63e697a 100644 --- a/tests/imgPhoto.test +++ b/tests/imgPhoto.test @@ -9,7 +9,7 @@ # # Author: Paul Mackerras (paulus@cs.anu.edu.au) # -# RCS: @(#) $Id: imgPhoto.test,v 1.12 2002/07/13 21:52:34 dgp Exp $ +# RCS: @(#) $Id: imgPhoto.test,v 1.13 2002/07/14 05:48:46 dgp Exp $ package require tcltest 2.1 namespace import -force tcltest::configure @@ -53,7 +53,7 @@ test imgPhoto-1.2 {options for photo images} { list [catch {image create photo p1 -file no.such.file} err] \ [string tolower $err] } {1 {couldn't open "no.such.file": no such file or directory}} -test imgPhoto-1.3 {options for photo images} hasTeapotPhoto hasTeapotPhoto { +test imgPhoto-1.3 {options for photo images} hasTeapotPhoto { list [catch {image create photo p1 -file $teapotPhotoFile \ -format no.such.format} err] $err } {1 {image file format "no.such.format" is not supported}} diff --git a/tests/listbox.test b/tests/listbox.test index 3c8069d..5e69d64 100644 --- a/tests/listbox.test +++ b/tests/listbox.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: listbox.test,v 1.19 2002/07/13 21:52:34 dgp Exp $ +# RCS: @(#) $Id: listbox.test,v 1.20 2002/07/14 05:48:46 dgp Exp $ package require tcltest 2.1 namespace import -force tcltest::configure @@ -1295,7 +1295,7 @@ test listbox-8.2 {ListboxEventProc procedure} {fonts} { list [.l xview] [.l yview] } {{0 0.222222} {0 0.333333}} test listbox-8.3 {ListboxEventProc procedure} { - eval destroy [winfo children .] + deleteWindows listbox .l1 -bg #543210 rename .l1 .l2 set x {} @@ -1306,7 +1306,7 @@ test listbox-8.3 {ListboxEventProc procedure} { } {.l1 #543210 {} {}} test listbox-9.1 {ListboxCmdDeletedProc procedure} { - eval destroy [winfo children .] + deleteWindows listbox .l1 rename .l1 {} list [info command .l*] [winfo children .] @@ -1749,7 +1749,7 @@ test listbox-19.2 {ListboxUpdateVScrollbar procedure} { (horizontal scrolling command executed by listbox)}} set l [interp hidden] -eval destroy [winfo children .] +deleteWindows test listbox-20.1 {listbox vs hidden commands} { catch {destroy .l} @@ -2133,7 +2133,7 @@ test listbox-28.3 {listbox -activestyle} { } dotbox resetGridInfo -eval destroy [winfo children .] +deleteWindows option clear # cleanup diff --git a/tests/macEmbed.test b/tests/macEmbed.test index e5a7bab..fe68f21 100644 --- a/tests/macEmbed.test +++ b/tests/macEmbed.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: macEmbed.test,v 1.7 2002/07/13 21:52:34 dgp Exp $ +# RCS: @(#) $Id: macEmbed.test,v 1.8 2002/07/14 05:48:46 dgp Exp $ package require tcltest 2.1 namespace import -force tcltest::configure @@ -33,7 +33,7 @@ test macEmbed-1.3 {TkpUseWindow procedure, creating Container records} {testembe toplevel .t -use $w list [testembed] [expr [lindex [lindex [testembed all] 1] 0] - $w] } {{{XXX .f2 {} {}} {XXX .f1 XXX .t}} 0} -test macEmbed-1.4 {TkpUseWindow procedure, creating Container records} {testembed macOnly} testembed { +test macEmbed-1.4 {TkpUseWindow procedure, creating Container records} {testembed macOnly} { deleteWindows frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 diff --git a/tests/macFont.test b/tests/macFont.test index f4e3083..0ba293e 100644 --- a/tests/macFont.test +++ b/tests/macFont.test @@ -10,7 +10,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: macFont.test,v 1.5 2002/07/13 20:28:35 dgp Exp $ +# RCS: @(#) $Id: macFont.test,v 1.6 2002/07/14 05:48:46 dgp Exp $ package require tcltest 2.1 namespace import -force tcltest::configure @@ -128,7 +128,7 @@ test macFont-5.1 {TkpGetFontFamilies} {macOnly} { expr {[lsearch [font families] Geneva] > 0} } {1} -test macFont-6.1 {TkpGetSubFonts} {gothic macOnly} { +test macFont-6.1 {TkpGetSubFonts} {testfont gothic macOnly} { .b.l config -text "abc\u4e4e" update set x [testfont subfonts $fixed] diff --git a/tests/menu.test b/tests/menu.test index 5c157f3..a9652bf 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -5,7 +5,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: menu.test,v 1.12 2002/07/13 20:28:35 dgp Exp $ +# RCS: @(#) $Id: menu.test,v 1.13 2002/07/14 05:48:46 dgp Exp $ package require tcltest 2.1 namespace import -force tcltest::configure @@ -2461,7 +2461,7 @@ test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} { } {.menubar.cascade .#menubar.#menubar#test.#menubar#cascade .menubar.cascade .#menubar.#menubar#test.#menubar#cascade} set l [interp hidden] -eval destroy [winfo children .] +deleteWindows test menu-33.1 {menu vs command hiding} { catch {destroy .m} diff --git a/tests/send.test b/tests/send.test index c69815f..a40eb98 100644 --- a/tests/send.test +++ b/tests/send.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: send.test,v 1.7 2002/07/13 20:28:35 dgp Exp $ +# RCS: @(#) $Id: send.test,v 1.8 2002/07/14 05:48:46 dgp Exp $ package require tcltest 2.1 namespace import -force tcltest::configure @@ -22,19 +22,6 @@ tcltest::loadTestedCommands testConstraint xhost [llength [auto_execok xhost]] testConstraint testsend [llength [info commands testsend]] -# If send is disabled because of inadequate security, don't run any -# of these tests at all. - -setupbg -set app [dobg {tk appname}] -testConstraint send 1 -if {[catch {send $app set a 0} msg] == 1} { - if {[string match "X server insecure *" $msg]} { - testConstraint send 0 - } -} -cleanupbg - # Compute a script that will load Tk into a child interpreter. foreach pkg [info loaded] { @@ -63,19 +50,19 @@ tk appname tktest catch {send t_s_1 destroy .} catch {send t_s_2 destroy .} -test send-1.1 {RegOpen procedure, bogus property} {send testsend} { +test send-1.1 {RegOpen procedure, bogus property} {secureserver testsend} { testsend bogus set result [winfo interps] tk appname tktest list $result [winfo interps] } {{} tktest} -test send-1.2 {RegOpen procedure, bogus property} {send testsend} { +test send-1.2 {RegOpen procedure, bogus property} {secureserver testsend} { testsend prop root InterpRegistry {} set result [winfo interps] tk appname tktest list $result [winfo interps] } {{} tktest} -test send-1.3 {RegOpen procedure, bogus property} {send testsend} { +test send-1.3 {RegOpen procedure, bogus property} {secureserver testsend} { testsend prop root InterpRegistry abcdefg tk appname tktest set x [testsend prop root InterpRegistry] @@ -84,52 +71,52 @@ test send-1.3 {RegOpen procedure, bogus property} {send testsend} { frame .f -width 1 -height 1 set id [string range [winfo id .f] 2 end] -test send-2.1 {RegFindName procedure} {send testsend} { +test send-2.1 {RegFindName procedure} {secureserver testsend} { testsend prop root InterpRegistry {} list [catch {send foo bar} msg] $msg } {1 {no application named "foo"}} -test send-2.2 {RegFindName procedure} {send testsend} { +test send-2.2 {RegFindName procedure} {secureserver testsend} { testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n" tk appname foo } {foo #2} -test send-2.3 {RegFindName procedure} {send testsend} { +test send-2.3 {RegFindName procedure} {secureserver testsend} { testsend prop root InterpRegistry "gyz foo\n" tk appname foo } {foo} -test send-2.4 {RegFindName procedure} {send testsend} { +test send-2.4 {RegFindName procedure} {secureserver testsend} { testsend prop root InterpRegistry "${id}z foo\n" tk appname foo } {foo} -test send-3.1 {RegDeleteName procedure} {send testsend} { +test send-3.1 {RegDeleteName procedure} {secureserver testsend} { tk appname tktest testsend prop root InterpRegistry "012345 gorp\n12345 foo\n12345 tktest" tk appname x set x [testsend prop root InterpRegistry] string range $x [string first " " $x] end } " x\n012345 gorp\n12345 foo\n" -test send-3.2 {RegDeleteName procedure} {send testsend} { +test send-3.2 {RegDeleteName procedure} {secureserver testsend} { tk appname tktest testsend prop root InterpRegistry "012345 gorp\n12345 tktest\n23456 tktest" tk appname x set x [testsend prop root InterpRegistry] string range $x [string first " " $x] end } " x\n012345 gorp\n23456 tktest\n" -test send-3.3 {RegDeleteName procedure} {send testsend} { +test send-3.3 {RegDeleteName procedure} {secureserver testsend} { tk appname tktest testsend prop root InterpRegistry "012345 tktest\n12345 bar\n23456 tktest" tk appname x set x [testsend prop root InterpRegistry] string range $x [string first " " $x] end } " x\n12345 bar\n23456 tktest\n" -test send-3.4 {RegDeleteName procedure} {send testsend} { +test send-3.4 {RegDeleteName procedure} {secureserver testsend} { tk appname tktest testsend prop root InterpRegistry "foo" tk appname x set x [testsend prop root InterpRegistry] string range $x [string first " " $x] end } " x\nfoo\n" -test send-3.5 {RegDeleteName procedure} {send testsend} { +test send-3.5 {RegDeleteName procedure} {secureserver testsend} { tk appname tktest testsend prop root InterpRegistry "" tk appname x @@ -137,12 +124,12 @@ test send-3.5 {RegDeleteName procedure} {send testsend} { string range $x [string first " " $x] end } " x\n" -test send-4.1 {RegAddName procedure} {send testsend} { +test send-4.1 {RegAddName procedure} {secureserver testsend} { testsend prop root InterpRegistry "" tk appname bar testsend prop root InterpRegistry } "$commId bar\n" -test send-4.2 {RegAddName procedure} {send testsend} { +test send-4.2 {RegAddName procedure} {secureserver testsend} { testsend prop root InterpRegistry "abc def" tk appname bar tk appname foo @@ -151,19 +138,19 @@ test send-4.2 {RegAddName procedure} {send testsend} { # Previous checks should already cover the Regclose procedure. -test send-5.1 {ValidateName procedure} {send testsend} { +test send-5.1 {ValidateName procedure} {secureserver testsend} { testsend prop root InterpRegistry "123 abc\n" winfo interps } {} -test send-5.2 {ValidateName procedure} {send testsend} { +test send-5.2 {ValidateName procedure} {secureserver testsend} { testsend prop root InterpRegistry "$id Hi there" winfo interps } {{Hi there}} -test send-5.3 {ValidateName procedure} {send testsend} { +test send-5.3 {ValidateName procedure} {secureserver testsend} { testsend prop root InterpRegistry "$id Bogus" list [catch {send Bogus set a 44} msg] $msg } {1 {target application died or uses a Tk version before 4.0}} -test send-5.4 {ValidateName procedure} {send testsend} { +test send-5.4 {ValidateName procedure} {secureserver testsend} { tk appname test testsend prop root InterpRegistry "$commId Bogus\n$commId test\n" winfo interps @@ -180,43 +167,43 @@ if {[testConstraint xhost]} { } } -test send-6.1 {ServerSecure procedure} {nonPortable send } { +test send-6.1 {ServerSecure procedure} {nonPortable secureserver} { set a 44 list [dobg [list send [tk appname] set a 55]] $a } {55 55} -test send-6.2 {ServerSecure procedure} {nonPortable send } { +test send-6.2 {ServerSecure procedure} {nonPortable secureserver} { set a 22 exec xhost [exec hostname] list [catch {dobg [list send [tk appname] set a 33]} msg] $a $msg } {0 22 {X server insecure (must use xauth-style authorization); command ignored}} -test send-6.3 {ServerSecure procedure} {nonPortable send } { +test send-6.3 {ServerSecure procedure} {nonPortable secureserver} { set a abc exec xhost - [exec hostname] list [dobg [list send [tk appname] set a new]] $a } {new new} cleanupbg -test send-7.1 {Tk_SetAppName procedure} {send testsend} { +test send-7.1 {Tk_SetAppName procedure} {secureserver testsend} { testsend prop root InterpRegistry "" tk appname newName list [tk appname oldName] [testsend prop root InterpRegistry] } "oldName {$commId oldName\n}" -test send-7.2 {Tk_SetAppName procedure, name not in use} {send testsend} { +test send-7.2 {Tk_SetAppName procedure, name not in use} {secureserver testsend} { testsend prop root InterpRegistry "" list [tk appname gorp] [testsend prop root InterpRegistry] } "gorp {$commId gorp\n}" -test send-7.3 {Tk_SetAppName procedure, name in use by us} {send testsend} { +test send-7.3 {Tk_SetAppName procedure, name in use by us} {secureserver testsend} { tk appname name1 testsend prop root InterpRegistry "$commId name2\n" list [tk appname name2] [testsend prop root InterpRegistry] } "name2 {$commId name2\n}" -test send-7.4 {Tk_SetAppName procedure, name in use} {send testsend} { +test send-7.4 {Tk_SetAppName procedure, name in use} {secureserver testsend} { tk appname name1 testsend prop root InterpRegistry "$id foo\n$id foo #2\n$id foo #3\n" list [tk appname foo] [testsend prop root InterpRegistry] } "{foo #4} {$commId foo #4\n$id foo\n$id foo #2\n$id foo #3\n}" -test send-8.1 {Tk_SendCmd procedure, options} {send } { +test send-8.1 {Tk_SendCmd procedure, options} {secureserver} { setupbg set app [dobg {tk appname}] set a 66 @@ -227,7 +214,7 @@ test send-8.1 {Tk_SendCmd procedure, options} {send } { cleanupbg lappend result $a } {66 77} -test send-8.2 {Tk_SendCmd procedure, options} {send altDisplay} { +test send-8.2 {Tk_SendCmd procedure, options} {secureserver altDisplay} { setupbg -display $env(TK_ALT_DISPLAY) tk appname xyzgorp set a homeDisplay @@ -241,29 +228,29 @@ test send-8.2 {Tk_SendCmd procedure, options} {send altDisplay} { cleanupbg set result } {altDisplay homeDisplay} -test send-8.3 {Tk_SendCmd procedure, options} {send } { +test send-8.3 {Tk_SendCmd procedure, options} {secureserver} { list [catch {send -- -async foo bar baz} msg] $msg } {1 {no application named "-async"}} -test send-8.4 {Tk_SendCmd procedure, options} {send } { +test send-8.4 {Tk_SendCmd procedure, options} {secureserver} { list [catch {send -gorp foo bar baz} msg] $msg } {1 {bad option "-gorp": must be -async, -displayof, or --}} -test send-8.5 {Tk_SendCmd procedure, options} {send } { +test send-8.5 {Tk_SendCmd procedure, options} {secureserver} { list [catch {send -async foo} msg] $msg } {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} -test send-8.6 {Tk_SendCmd procedure, options} {send } { +test send-8.6 {Tk_SendCmd procedure, options} {secureserver} { list [catch {send foo} msg] $msg } {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} -test send-8.7 {Tk_SendCmd procedure, local execution} {send } { +test send-8.7 {Tk_SendCmd procedure, local execution} {secureserver} { set a initial send [tk appname] {set a new} set a } {new} -test send-8.8 {Tk_SendCmd procedure, local execution} {send } { +test send-8.8 {Tk_SendCmd procedure, local execution} {secureserver} { set a initial send [tk appname] set a new set a } {new} -test send-8.9 {Tk_SendCmd procedure, local execution} {send } { +test send-8.9 {Tk_SendCmd procedure, local execution} {secureserver} { set a initial string tolower [list [catch {send [tk appname] open bad_file} msg] \ $msg $errorInfo $errorCode] @@ -272,7 +259,7 @@ test send-8.9 {Tk_SendCmd procedure, local execution} {send } { "open bad_file" invoked from within "send [tk appname] open bad_file"} {posix enoent {no such file or directory}}} -test send-8.10 {Tk_SendCmd procedure, no such interpreter} {send } { +test send-8.10 {Tk_SendCmd procedure, no such interpreter} {secureserver} { list [catch {send bogus_name bogus_command} msg] $msg } {1 {no application named "bogus_name"}} @@ -281,29 +268,29 @@ catch { t_s_1 eval wm withdraw . } -test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {send testsend} { +test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} { set a us send t_s_1 set a them list $a [send t_s_1 set a] } {us them} -test send-8.12 {Tk_SendCmd procedure, local execution, different interp} {send testsend} { +test send-8.12 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} { set a us send t_s_1 {set a them} list $a [send t_s_1 {set a}] } {us them} -test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {send testsend} { +test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} { set a us send t_s_1 {set a them} list $a [send t_s_1 {set a}] } {us them} -test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {send testsend} { +test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {secureserver testsend} { newApp "" t_s_2 Test list [catch {send t_s_2 {destroy .; concat result}} msg] $msg } {0 result} catch {interp delete t_s_2} -test send-8.15 {Tk_SendCmd procedure, local interp, error info} {send testsend} { +test send-8.15 {Tk_SendCmd procedure, local interp, error info} {secureserver testsend} { catch {error foo} list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode } {1 {couldn't open "bogus_file_name": no such file or directory} {couldn't open "bogus_file_name": no such file or directory @@ -313,7 +300,7 @@ test send-8.15 {Tk_SendCmd procedure, local interp, error info} {send testsend} "if 1 {open bogus_file_name}" invoked from within "send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}} -test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {send testsend} { +test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {secureserver testsend} { testsend prop root InterpRegistry "10234 bogus\n" set result [list [catch {send bogus bogus command} msg] $msg] winfo interps @@ -323,7 +310,7 @@ test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {send testsend} { catch {interp delete t_s_1} -test send-8.17 {Tk_SendCmd procedure, deferring events} {send nonPortable} { +test send-8.17 {Tk_SendCmd procedure, deferring events} {secureserver nonPortable} { # Non-portable because some window managers ignore "raise" # requests so can't guarantee that new app's window won't # obscure .f, thereby masking the Expose event. @@ -343,7 +330,7 @@ test send-8.17 {Tk_SendCmd procedure, deferring events} {send nonPortable} { cleanupbg lappend result $a } {{no event yet} {no event yet} exposed} -test send-8.18 {Tk_SendCmd procedure, error in remote app} {send } { +test send-8.18 {Tk_SendCmd procedure, error in remote app} {secureserver} { setupbg set app [dobg {tk appname}] set result [string tolower [list [catch {send $app open bad_name} msg] \ @@ -355,7 +342,7 @@ test send-8.18 {Tk_SendCmd procedure, error in remote app} {send } { "open bad_name" invoked from within "send $app open bad_name"} {posix enoent {no such file or directory}}} -test send-8.19 {Tk_SendCmd, using modal timeouts} {send } { +test send-8.19 {Tk_SendCmd, using modal timeouts} {secureserver} { setupbg set app [dobg {tk appname}] set x no @@ -373,30 +360,30 @@ catch {destroy .f} frame .f set id [string range [winfo id .f] 2 end] -test send-9.1 {Tk_GetInterpNames procedure} {send testsend} { +test send-9.1 {Tk_GetInterpNames procedure} {secureserver testsend} { testsend prop root InterpRegistry \ "$commId tktest\nfoo bar\n$commId tktest\n$id frame .f\n\n\n" list [winfo interps] [testsend prop root InterpRegistry] } "{tktest tktest {frame .f}} {$commId tktest\n$commId tktest\n$id frame .f }" -test send-9.2 {Tk_GetInterpNames procedure} {send testsend} { +test send-9.2 {Tk_GetInterpNames procedure} {secureserver testsend} { testsend prop root InterpRegistry \ "$commId tktest\nfoobar\n$commId gorp\n" list [winfo interps] [testsend prop root InterpRegistry] } "tktest {$commId tktest\n}" -test send-9.3 {Tk_GetInterpNames procedure} {send testsend} { +test send-9.3 {Tk_GetInterpNames procedure} {secureserver testsend} { testsend prop root InterpRegistry {} list [winfo interps] [testsend prop root InterpRegistry] } {{} {}} catch {testsend prop root InterpRegistry "$commId tktest\n$id dummy\n"} -test send-10.1 {SendEventProc procedure, bogus comm property} {send testsend} { +test send-10.1 {SendEventProc procedure, bogus comm property} {secureserver testsend} { testsend prop comm Comm {abc def} testsend prop comm Comm {} update } {} -test send-10.2 {SendEventProc procedure, simultaneous messages} {send testsend} { +test send-10.2 {SendEventProc procedure, simultaneous messages} {secureserver testsend} { testsend prop comm Comm \ "c\n-n tktest\n-s set a 44\nc\n-n tktest\n-s set b 45\n" set a null @@ -404,7 +391,7 @@ test send-10.2 {SendEventProc procedure, simultaneous messages} {send testsend} update list $a $b } {44 45} -test send-10.3 {SendEventProc procedure, simultaneous messages} {send testsend} { +test send-10.3 {SendEventProc procedure, simultaneous messages} {secureserver testsend} { testsend prop comm Comm \ "c\n-n tktest\n-s set a newA\nr\n-s [testsend serial]\n-r 12345\nc\n-n tktest\n-s set b newB\n" set a null @@ -412,21 +399,21 @@ test send-10.3 {SendEventProc procedure, simultaneous messages} {send testsend} set x [send dummy bogus] list $x $a $b } {12345 newA newB} -test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} {send testsend} { +test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} {secureserver testsend} { testsend prop comm Comm \ "\n\nx\n-bogus\n\nc\n-n tktest\n-s set a 44\n" set a null update set a } {44} -test send-10.5 {SendEventProc procedure, extraneous command options} {send testsend} { +test send-10.5 {SendEventProc procedure, extraneous command options} {secureserver testsend} { testsend prop comm Comm \ "c\n-n tktest\n-x miscellanous\n-y who knows?\n-s set a new\n" set a null update set a } {new} -test send-10.6 {SendEventProc procedure, unknown interpreter} {send testsend} { +test send-10.6 {SendEventProc procedure, unknown interpreter} {secureserver testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n unknown\n-r $id 44\n-s set a new\n" @@ -434,7 +421,7 @@ test send-10.6 {SendEventProc procedure, unknown interpreter} {send testsend} { update list [testsend prop [winfo id .f] Comm] $a } "{\nr\n-s 44\n-r receiver never heard of interpreter \"unknown\"\n-c 1\n} null" -test send-10.7 {SendEventProc procedure, error in script} {send testsend} { +test send-10.7 {SendEventProc procedure, error in script} {secureserver testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-r $id 62\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n" @@ -451,7 +438,7 @@ r -e test code -c 1 } -test send-10.8 {SendEventProc procedure, exceptional return} {send testsend} { +test send-10.8 {SendEventProc procedure, exceptional return} {secureserver testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-r $id 62\n-s break\n" @@ -463,7 +450,7 @@ r -r -c 3 } -test send-10.9 {SendEventProc procedure, empty return} {send testsend} { +test send-10.9 {SendEventProc procedure, empty return} {secureserver testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-r $id 62\n-s concat\n" @@ -474,64 +461,64 @@ r -s 62 -r } -test send-10.10 {SendEventProc procedure, asynchronous calls} {send testsend} { +test send-10.10 {SendEventProc procedure, asynchronous calls} {secureserver testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n" update testsend prop [winfo id .f] Comm } {} -test send-10.11 {SendEventProc procedure, exceptional return} {send testsend} { +test send-10.11 {SendEventProc procedure, exceptional return} {secureserver testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-s break\n" update testsend prop [winfo id .f] Comm } {} -test send-10.12 {SendEventProc procedure, empty return} {send testsend} { +test send-10.12 {SendEventProc procedure, empty return} {secureserver testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-s concat\n" update testsend prop [winfo id .f] Comm } {} -test send-10.13 {SendEventProc procedure, return processing} {send testsend} { +test send-10.13 {SendEventProc procedure, return processing} {secureserver testsend} { testsend prop comm Comm \ "r\n-c 1\n-e test1\n-i test2\n-r test3\n-s [testsend serial]\n" list [catch {send dummy foo} msg] $msg $errorInfo $errorCode } {1 test3 {test2 invoked from within "send dummy foo"} test1} -test send-10.14 {SendEventProc procedure, extraneous return options} {send testsend} { +test send-10.14 {SendEventProc procedure, extraneous return options} {secureserver testsend} { testsend prop comm Comm \ "r\n-x test1\n-y test2\n-r result\n-s [testsend serial]\n" list [catch {send dummy foo} msg] $msg } {0 result} -test send-10.15 {SendEventProc procedure, serial number} {send testsend} { +test send-10.15 {SendEventProc procedure, serial number} {secureserver testsend} { testsend prop comm Comm \ "r\n-r response\n" list [catch {send dummy foo} msg] $msg } {1 {target application died or uses a Tk version before 4.0}} -test send-10.16 {SendEventProc procedure, serial number} {send testsend} { +test send-10.16 {SendEventProc procedure, serial number} {secureserver testsend} { testsend prop comm Comm \ "r\n-r response\n\n-s 0" list [catch {send dummy foo} msg] $msg } {1 {target application died or uses a Tk version before 4.0}} -test send-10.17 {SendEventProc procedure, errorCode and errorInfo} {send testsend} { +test send-10.17 {SendEventProc procedure, errorCode and errorInfo} {secureserver testsend} { testsend prop comm Comm \ "r\n-i test1\n-e test2\n-c 4\n-s [testsend serial]\n" set errorCode oldErrorCode set errorInfo oldErrorInfo list [catch {send dummy foo} msg] $msg $errorInfo $errorCode } {4 {} oldErrorInfo oldErrorCode} -test send-10.18 {SendEventProc procedure, send kills application} {send testsend} { +test send-10.18 {SendEventProc procedure, send kills application} {secureserver testsend} { setupbg dobg {tk appname t_s_3} set x [list [catch {send t_s_3 destroy .} msg] $msg] cleanupbg set x } {0 {}} -test send-10.19 {SendEventProc procedure, send exits} {send testsend} { +test send-10.19 {SendEventProc procedure, send exits} {secureserver testsend} { setupbg dobg {tk appname t_s_3} set x [list [catch {send t_s_3 exit} msg] $msg] @@ -539,11 +526,11 @@ test send-10.19 {SendEventProc procedure, send exits} {send testsend} { set x } {1 {target application died}} -test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} {send testsend} { +test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} {secureserver testsend} { testsend prop root InterpRegistry "0x21447 dummy\n" list [catch {send dummy foo} msg] $msg } {1 {no application named "dummy"}} -test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} {send testsend} { +test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} {secureserver testsend} { testsend prop comm Comm "c\n-r0x123 44\n-n tktest\n-s concat a b c\n" update } {} @@ -554,14 +541,14 @@ catch {destroy .f} frame .f set id [string range [winfo id .f] 2 end] -test send-12.1 {TimeoutProc procedure} {send testsend} { +test send-12.1 {TimeoutProc procedure} {secureserver testsend} { testsend prop root InterpRegistry "$id dummy\n" list [catch {send dummy foo} msg] $msg } {1 {target application died or uses a Tk version before 4.0}} catch {testsend prop root InterpRegistry ""} -test send-12.2 {TimeoutProc procedure} {send } { +test send-12.2 {TimeoutProc procedure} {secureserver} { winfo interps tk appname tktest update @@ -578,14 +565,14 @@ test send-12.2 {TimeoutProc procedure} {send } { winfo interps tk appname tktest -test send-13.1 {DeleteProc procedure} {send } { +test send-13.1 {DeleteProc procedure} {secureserver} { setupbg set app [dobg {rename send {}; tk appname}] set result [list [catch {send $app foo} msg] $msg [winfo interps]] cleanupbg set result } {1 {no application named "tktest #2"} tktest} -test send-13.2 {DeleteProc procedure} {send } { +test send-13.2 {DeleteProc procedure} {secureserver} { winfo interps tk appname tktest rename send {} @@ -595,7 +582,7 @@ test send-13.2 {DeleteProc procedure} {send } { lappend result [winfo interps] [info commands send] } {{} {} foo send} -test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {send altDisplay} { +test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {secureserver altDisplay} { setupbg -display $env(TK_ALT_DISPLAY) set result [dobg " toplevel .t -screen [winfo screen .] @@ -618,7 +605,7 @@ catch { testsend prop root InterpRegister $registry tk appname tktest } -test send-15.1 {UpdateCommWindow procedure} {send testsend} { +test send-15.1 {UpdateCommWindow procedure} {secureserver testsend} { set x [list [testsend prop comm TK_APPLICATION]] newApp "" t_s_1 Test send t_s_1 wm withdraw . diff --git a/tests/visual.test b/tests/visual.test index 28b2d22..ee13af2 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -7,7 +7,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: visual.test,v 1.5 2002/07/13 20:28:36 dgp Exp $ +# RCS: @(#) $Id: visual.test,v 1.6 2002/07/14 05:48:46 dgp Exp $ package require tcltest 2.1 namespace import -force tcltest::configure @@ -270,9 +270,7 @@ if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} { } test visual-8.1 {Tk_FreeColormap procedure} { - foreach w [winfo child .] { - destroy $w - } + deleteWindows toplevel .t1 -width 300 -height 180 -colormap new wm geometry .t1 +0+0 foreach i {.t2 .t3 .t4} { @@ -286,9 +284,7 @@ test visual-8.1 {Tk_FreeColormap procedure} { } {} if {$other != {}} { test visual-8.2 {Tk_FreeColormap procedure} { - foreach w [winfo child .] { - destroy $w - } + deleteWindows toplevel .t1 -width 300 -height 180 -visual $other wm geometry .t1 +0+0 foreach i {.t2 .t3 .t4} { |