diff options
| author | dgp@users.sourceforge.net <dgp> | 2002-07-13 20:28:35 (GMT) |
|---|---|---|
| committer | dgp@users.sourceforge.net <dgp> | 2002-07-13 20:28:35 (GMT) |
| commit | e03a6d8c8daca0485139c9a7edc9008565c2e000 (patch) | |
| tree | 83ce372d1ae9d46d27acc5638739bddcbc8e6ba6 | |
| parent | 60df07e990cbc0441a2fcf7783ccbfae69a82aa8 (diff) | |
| download | tk-e03a6d8c8daca0485139c9a7edc9008565c2e000.zip tk-e03a6d8c8daca0485139c9a7edc9008565c2e000.tar.gz tk-e03a6d8c8daca0485139c9a7edc9008565c2e000.tar.bz2 | |
* Converted more files to tcltest and factored out common code.
55 files changed, 506 insertions, 790 deletions
@@ -1,3 +1,8 @@ +2002-07-12 Don Porter <dgp@users.sf.net> + + * tests/constraints.tcl: Converted more files to tcltest and + * tests/[m-x]*.test: factored out common code. + 2002-07-11 Don Porter <dgp@users.sf.net> * tests/canvPsImg.tcl: Converted several files in the diff --git a/tests/constraints.tcl b/tests/constraints.tcl index 065e52e..f58cf67 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -1,31 +1,12 @@ package require Tcl 8.4 + package require Tk 8.4 +tk appname tktest +wm title . tktest + package require tcltest 2.1 -namespace import -force tcltest::testConstraint -testConstraint userInteraction 0 -testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)] -testConstraint noExceed [expr {![testConstraint unix] - || [catch {font actual "\{xyz"}]}] -testConstraint testImageType [expr {[lsearch [image types] test] >= 0}] -testConstraint fonts 1 -destroy .e -entry .e -width 0 -font {Helvetica -12} -bd 1 -.e insert end a.bcd -if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} { - testConstraint fonts 0 -} -destroy .e -text .t -width 80 -height 20 -font {Times -14} -bd 1 -pack .t -.t insert end "This is\na dot." -update -set x [list [.t bbox 1.3] [.t bbox 2.5]] -destroy .t -if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} { - testConstraint fonts 0 -} -namespace eval ::tk { +namespace eval tk { if {[namespace exists test]} { namespace delete test } @@ -110,8 +91,47 @@ namespace eval ::tk { Export bg::setup as setupbg Export bg::cleanup as cleanupbg Export bg::do as dobg + + namespace export deleteWindows + proc deleteWindows {} { + eval destroy [winfo children .] + } } } -namespace import -force ::tk::test::* +namespace import -force tk::test::* + +namespace import -force tcltest::testConstraint +testConstraint userInteraction 0 +testConstraint nonUnixUserInteraction [expr {[testConstraint userInteraction] + || [testConstraint unix]}] +testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)] +testConstraint noExceed [expr {![testConstraint unix] + || [catch {font actual "\{xyz"}]}] +testConstraint testImageType [expr {[lsearch [image types] test] >= 0}] +testConstraint fonts 1 +destroy .e +entry .e -width 0 -font {Helvetica -12} -bd 1 +.e insert end a.bcd +if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} { + testConstraint fonts 0 +} +destroy .e +destroy .t +text .t -width 80 -height 20 -font {Times -14} -bd 1 +pack .t +.t insert end "This is\na dot." +update +set x [list [.t bbox 1.3] [.t bbox 2.5]] +destroy .t +if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} { + testConstraint fonts 0 +} + +eval tcltest::configure $argv +namespace import -force tcltest::test + +deleteWindows +wm geometry . {} +raise . diff --git a/tests/macEmbed.test b/tests/macEmbed.test index b6c2f68..bd9cdbc 100644 --- a/tests/macEmbed.test +++ b/tests/macEmbed.test @@ -6,16 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: macEmbed.test,v 1.5 2001/03/28 17:27:10 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 . +# RCS: @(#) $Id: macEmbed.test,v 1.6 2002/07/13 20:28:35 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 macEmbed-1.1 {TkpUseWindow procedure, bad window identifier} {macOnly} { catch {destroy .t} @@ -34,7 +32,7 @@ if {[string compare testembed [info commands testembed]] != 0} { } test macEmbed-1.3 {TkpUseWindow procedure, creating Container records} {macOnly} { - eval destroy [winfo child .] + deleteWindows frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 @@ -43,7 +41,7 @@ test macEmbed-1.3 {TkpUseWindow procedure, creating Container records} {macOnly} 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} {macOnly} { - eval destroy [winfo child .] + deleteWindows frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 @@ -58,9 +56,7 @@ test macEmbed-1.4 {TkpUseWindow procedure, creating Container records} {macOnly} # TkpMakeContainer, or EmbedErrorProc. test macEmbed-2.1 {EmbeddedEventProc procedure} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 set w1 [winfo id .f1] @@ -71,9 +67,7 @@ test macEmbed-2.1 {EmbeddedEventProc procedure} {macOnly} { testembed } {} test macEmbed-2.2 {EmbeddedEventProc procedure} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] @@ -82,9 +76,7 @@ test macEmbed-2.2 {EmbeddedEventProc procedure} {macOnly} { testembed } {} test macEmbed-2.3 {EmbeddedEventProc procedure} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] @@ -95,9 +87,7 @@ test macEmbed-2.3 {EmbeddedEventProc procedure} {macOnly} { } {{} {}} test macEmbed-3.1 {EmbeddedEventProc procedure, detect creation} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 set w1 [winfo id .f1] @@ -108,9 +98,7 @@ test macEmbed-3.1 {EmbeddedEventProc procedure, detect creation} {macOnly} { } {{{XXX .f1 {} {}}} {{XXX .f1 XXX .t1}}} test macEmbed-3.2 {EmbeddedEventProc procedure, disallow position changes} \ {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 set w1 [winfo id .f1] @@ -122,9 +110,7 @@ test macEmbed-3.2 {EmbeddedEventProc procedure, disallow position changes} \ } {200x200+0+0} test macEmbed-3.3 {EmbeddedEventProc procedure, disallow position changes} \ {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 set w1 [winfo id .f1] @@ -135,9 +121,7 @@ test macEmbed-3.3 {EmbeddedEventProc procedure, disallow position changes} \ wm geometry .t1 } {300x100+0+0} test macEmbed-3.4 {EmbeddedEventProc procedure, geometry requests} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows toplevel .t1 -container 1 -width 200 -height 50 set w1 [winfo id .t1] toplevel .t2 -use $w1 @@ -147,9 +131,7 @@ test macEmbed-3.4 {EmbeddedEventProc procedure, geometry requests} {macOnly} { list [winfo width .t1] [winfo height .t1] [wm geometry .t2] } {300 80 300x80+0+0} test macEmbed-3.5 {EmbeddedEventProc procedure, map requests} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 set w1 [winfo id .f1] @@ -162,9 +144,7 @@ test macEmbed-3.5 {EmbeddedEventProc procedure, map requests} {macOnly} { set x } {mapped} test macEmbed-3.6 {EmbeddedEventProc procedure, destroy events} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 set w1 [winfo id .f1] @@ -178,9 +158,7 @@ test macEmbed-3.6 {EmbeddedEventProc procedure, destroy events} {macOnly} { } {dead 0} test macEmbed-4.1 {EmbedStructureProc procedure, configure events} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 set w1 [winfo id .f1] @@ -191,9 +169,7 @@ test macEmbed-4.1 {EmbedStructureProc procedure, configure events} {macOnly} { winfo geometry .t1 } {180x100+0+0} test macEmbed-4.2 {EmbedStructureProc procedure, destroy events} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 set w1 [winfo id .f1] @@ -208,9 +184,7 @@ test macEmbed-4.2 {EmbedStructureProc procedure, destroy events} {macOnly} { test unixEmbed-5.1 {TkpClaimFocus procedure} {macOnly tempNotMac} { catch {interp delete child} - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 frame .f2 -width 200 -height 50 pack .f1 .f2 @@ -232,9 +206,7 @@ test unixEmbed-5.1 {TkpClaimFocus procedure} {macOnly tempNotMac} { catch {interp delete child} test macEmbed-6.1 {EmbedWindowDeleted procedure, check parentPtr} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 frame .f3 -container 1 -width 200 -height 50 @@ -249,9 +221,7 @@ test macEmbed-6.1 {EmbedWindowDeleted procedure, check parentPtr} {macOnly} { set x } {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}} test macEmbed-6.2 {EmbedWindowDeleted procedure, check embeddedPtr} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 set w1 [winfo id .f1] @@ -264,9 +234,7 @@ test macEmbed-6.2 {EmbedWindowDeleted procedure, check embeddedPtr} {macOnly} { } {{{XXX .f1 XXX .t1}} {}} test macEmbed-7.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] -width 150 -height 80 @@ -276,9 +244,7 @@ test macEmbed-7.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {macOn wm geometry .t1 } {150x80+0+0} test macEmbed-7.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {macOnly} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] -width 150 -height 80 @@ -290,9 +256,7 @@ test macEmbed-7.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} {macOn -foreach w [winfo child .] { - catch {destroy $w} -} +deleteWindows # cleanup ::tcltest::cleanupTests diff --git a/tests/macFont.test b/tests/macFont.test index 972f81d..f4e3083 100644 --- a/tests/macFont.test +++ b/tests/macFont.test @@ -10,11 +10,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: macFont.test,v 1.4 2001/09/21 20:38:18 hobbs Exp $ +# RCS: @(#) $Id: macFont.test,v 1.5 2002/07/13 20:28:35 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 @@ -39,11 +42,11 @@ proc getsize {} { return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" } -set ::tcltest::testConfig(gothic) 0 +testConstraint gothic 0 set gothic {gothic 12} set mx [font measure $gothic \u4e4e] if {[font actual $gothic -family] != [font actual system -family]} { - set ::tcltest::testConfig(gothic) 1 + testConstraint gothic 1 } test macFont-1.1 {TkpFontPkgInit} {macOnly} { diff --git a/tests/macMenu.test b/tests/macMenu.test index f1ee519..2a36c60 100644 --- a/tests/macMenu.test +++ b/tests/macMenu.test @@ -7,24 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: macMenu.test,v 1.6 2001/09/21 20:38:18 hobbs Exp $ +# RCS: @(#) $Id: macMenu.test,v 1.7 2002/07/13 20:28:35 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -set ::tcltest::testConfig(testimage) \ - [expr {[lsearch [image types] test] >= 0}] - -proc deleteWindows {} { - foreach i [winfo children .] { - catch [destroy $i] - } -} - -deleteWindows -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 test macMenu-1.0 {TkMacUseMenuID} {macOnly} { # Can't really test TkMacUseMenuID; it's only called on startup. @@ -184,7 +174,7 @@ test macMenu-8.1 {GetEntryText} {macOnly} { catch {destroy .m1} list [catch {menu .m1} msg] $msg [destroy .m1] } {0 .m1 {}} -test macMenu-8.2 {GetEntryText} {macOnly testimage} { +test macMenu-8.2 {GetEntryText} {macOnly testImageType} { catch {destroy .m1} catch {image delete image1} menu .m1 @@ -1377,7 +1367,7 @@ test macMenu-41.12 {TkpComputeStandardMenuGeometry - indicator} {macOnly} { .m1 invoke 1 list [update idletasks] [destroy .m1] } {{} {}} -test macMenu-41.13 {TkpComputeStandardMenuGeometry - second indicator less or equal } {macOnly testimage} { +test macMenu-41.13 {TkpComputeStandardMenuGeometry - second indicator less or equal } {macOnly testImageType} { catch {destroy .m1} catch {image delete image1} image create test image1 @@ -1449,7 +1439,7 @@ test macMenu-42.1 {DrawMenuEntryLabel - setting indicatorSpace} {macOnly} { set tearoff [tk::TearOffMenu .m1] list [update idletasks] [destroy .m1] } {{} {}} -test macMenu-42.2 {DrawMenuEntryLabel - drawing image} {macOnly testimage} { +test macMenu-42.2 {DrawMenuEntryLabel - drawing image} {macOnly testImageType} { catch {destroy .m1} catch {image delete image1} image create test image1 @@ -1458,7 +1448,7 @@ test macMenu-42.2 {DrawMenuEntryLabel - drawing image} {macOnly testimage} { set tearoff [tk::TearOffMenu .m1] list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} -test macMenu-42.3 {DrawMenuEntryLabel - drawing select image} {macOnly testimage} { +test macMenu-42.3 {DrawMenuEntryLabel - drawing select image} {macOnly testImageType} { catch {destroy .m1} catch {eval image delete [image names]} image create test image1 @@ -1497,7 +1487,7 @@ test macMenu-42.7 {DrawMenuEntryLabel - drawing disabled label} {macOnly} { set tearoff [tk::TearOffMenu .m1] list [update idletasks] [destroy .m1] } {{} {}} -test macMenu-42.8 {DrawMenuEntryLabel - disabled images} {macOnly testimage} { +test macMenu-42.8 {DrawMenuEntryLabel - disabled images} {macOnly testImageType} { catch {destroy .m1} catch {image delete image1} image create test image1 @@ -1507,7 +1497,7 @@ test macMenu-42.8 {DrawMenuEntryLabel - disabled images} {macOnly testimage} { list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} -test macMenu-43.1 {GetMenuLabelGeometry - image} {macOnly testimage} { +test macMenu-43.1 {GetMenuLabelGeometry - image} {macOnly testImageType} { catch {destroy .m1} catch {image delete image1} menu .m1 diff --git a/tests/macWinMenu.test b/tests/macWinMenu.test index 2aad508..315f2aa 100644 --- a/tests/macWinMenu.test +++ b/tests/macWinMenu.test @@ -6,34 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: macWinMenu.test,v 1.3 1999/04/16 01:51:39 stanton 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 -} - -# Some tests require user interaction on non-unix platform -set ::tcltest::testConfig(nonUnixUserInteraction) \ - [expr {$::tcltest::testConfig(userInteraction) || \ - $::tcltest::testConfig(unixOnly)}] - -proc deleteWindows {} { - foreach i [winfo children .] { - catch [destroy $i] - } -} - -deleteWindows -wm geometry . {} -raise . +# RCS: @(#) $Id: macWinMenu.test,v 1.4 2002/07/13 20:28:35 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 macWinMenu-1.1 {PreprocessMenu} {macOrPc nonUnixUserInteraction} { catch {destroy .m1} diff --git a/tests/macscrollbar.test b/tests/macscrollbar.test index 479f8c6..b62c65e 100644 --- a/tests/macscrollbar.test +++ b/tests/macscrollbar.test @@ -7,17 +7,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: macscrollbar.test,v 1.4 2001/09/21 20:38:18 hobbs Exp $ +# RCS: @(#) $Id: macscrollbar.test,v 1.5 2002/07/13 20:28:35 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 . update # Tests for display and layout @@ -91,10 +89,7 @@ test macscroll-1.7 {TkpDisplayScrollbar procedure} {macOnly} { place .s2 -x 0 -y 284 -width 300 } {} -foreach i [winfo children .] { - destroy $i -} - +deleteWindows # cleanup ::tcltest::cleanupTests return diff --git a/tests/main.test b/tests/main.test index 0422223..0f25637 100644 --- a/tests/main.test +++ b/tests/main.test @@ -8,30 +8,33 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: main.test,v 1.5 1999/04/16 01:51:39 stanton Exp $ +# RCS: @(#) $Id: main.test,v 1.6 2002/07/13 20:28:35 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 -test main-1.1 {StdinProc} {unixOnly} { - catch {removeFile script} - set fd [open script w] - puts $fd { +namespace import -force tcltest::interpreter +namespace import -force tcltest::makeFile +namespace import -force tcltest::removeFile + +test main-1.1 {StdinProc} {unix} { + set script [makeFile { close stdin; exit - } - close $fd - if {[catch {exec $::tcltest::tktest <script} msg]} { + } script] + if {[catch {exec [interpreter] <$script} msg]} { set error 1 } else { set error 0 } - file delete -force script + removeFile script list $error $msg } {0 {}} # cleanup -catch {removeFile script} ::tcltest::cleanupTests return diff --git a/tests/menu.test b/tests/menu.test index 701a3af..5c157f3 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -5,36 +5,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: menu.test,v 1.11 2002/01/31 21:05:27 uid38226 Exp $ +# RCS: @(#) $Id: menu.test,v 1.12 2002/07/13 20:28:35 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 -} - -# Some tests require user interaction on non-unix platform -set ::tcltest::testConfig(nonUnixUserInteraction) \ - [expr {$::tcltest::testConfig(userInteraction) || \ - $::tcltest::testConfig(unixOnly)}] - -set ::tcltest::testConfig(altDisplay) [info exists env(TK_ALT_DISPLAY)] - -proc deleteWindows {} { - foreach i [winfo children .] { - catch [destroy $i] - } -} - -deleteWindows -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 test menu-1.1 {Tk_MenuCmd procedure} { list [catch menu msg] $msg @@ -1377,7 +1355,7 @@ test menu-8.2 {DestroyMenuEntry} { .m1 add command -image image1a list [catch {.m1 delete 1} msg] $msg [destroy .m1] [image delete image1a] } {0 {} {} {}} -test menu-8.3 {DestroyMenuEntry} { +test menu-8.3 {DestroyMenuEntry} testImageType { catch {eval image delete [image names]} catch {destroy .m1} image create test image1 @@ -1613,7 +1591,7 @@ test menu-11.17 {ConfigureMenuEntry} { .m1 add checkbutton list [catch {.m1 entryconfigure 1 -onvalue "test"} msg] $msg [.m1 entrycget 1 -onvalue] [destroy .m1] } {0 {} test {}} -test menu-11.18 {ConfigureMenuEntry} { +test menu-11.18 {ConfigureMenuEntry} testImageType { catch {destroy .m1} catch {image delete image1} menu .m1 @@ -1621,7 +1599,7 @@ test menu-11.18 {ConfigureMenuEntry} { image create test image1 list [catch {.m1 entryconfigure 1 -image image1} msg] $msg [destroy .m1] [image delete image1] } {0 {} {} {}} -test menu-11.19 {ConfigureMenuEntry} { +test menu-11.19 {ConfigureMenuEntry} testImageType { catch {destroy .m1} catch {image delete image1} catch {image delete image2} @@ -1631,7 +1609,7 @@ test menu-11.19 {ConfigureMenuEntry} { .m1 add command -image image1 list [catch {.m1 entryconfigure 1 -image image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] } {0 {} {} {} {}} -test menu-11.20 {ConfigureMenuEntry} { +test menu-11.20 {ConfigureMenuEntry} testImageType { catch {destroy .m1} catch {image delete image1} catch {image delete image2} @@ -1641,7 +1619,7 @@ test menu-11.20 {ConfigureMenuEntry} { .m1 add checkbutton -image image1 list [catch {.m1 entryconfigure 1 -selectimage image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] } {0 {} {} {} {}} -test menu-11.21 {ConfigureMenuEntry} { +test menu-11.21 {ConfigureMenuEntry} testImageType { catch {destroy .m1} catch {image delete image1} catch {image delete image2} diff --git a/tests/menuDraw.test b/tests/menuDraw.test index ea3503b..d412a23 100644 --- a/tests/menuDraw.test +++ b/tests/menuDraw.test @@ -5,29 +5,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: menuDraw.test,v 1.4 2001/08/01 16:21:12 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 -} - -proc deleteWindows {} { - foreach i [winfo children .] { - catch [destroy $i] - } -} +# RCS: @(#) $Id: menuDraw.test,v 1.5 2002/07/13 20:28:35 dgp Exp $ -deleteWindows -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 test menuDraw-1.1 {TkMenuInitializeDrawingFields} { catch {destroy .m1} @@ -236,7 +221,7 @@ test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} { list [update idletasks] [destroy .m1] } {{} {}} -test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} { +test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} testImageType { catch {destroy .m1} catch {eval image delete [image names]} image create test image1 @@ -248,7 +233,7 @@ test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} update idletasks list [image delete image2] [destroy .m1] [eval image delete [image names]] } {{} {} {}} -test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} { +test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} testImageType { catch {destroy .m1} catch {eval image delete [image names]} image create test image1 @@ -259,7 +244,7 @@ test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} { set tearoff [tk::TearOffMenu .m1 40 40] list [image delete image2] [destroy .m1] [eval image delete [image names]] } {{} {} {}} -test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} { +test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} testImageType { catch {destroy .m1} catch {eval image delete [image names]} image create test image1 @@ -388,7 +373,7 @@ test menuDraw-13.5 {TkMenuEventProc - nothing pending} { list [destroy .m1] } {{}} -test menuDraw-14.1 {TkMenuImageProc} { +test menuDraw-14.1 {TkMenuImageProc} testImageType { catch {destroy .m1} catch {image delete image1} menu .m1 @@ -397,7 +382,7 @@ test menuDraw-14.1 {TkMenuImageProc} { update idletasks list [image delete image1] [destroy .m1] } {{} {}} -test menuDraw-14.2 {TkMenuImageProc} { +test menuDraw-14.2 {TkMenuImageProc} testImageType { catch {destroy .m1} catch {image delete image1} menu .m1 diff --git a/tests/menubut.test b/tests/menubut.test index e1042b1..86db6ae 100644 --- a/tests/menubut.test +++ b/tests/menubut.test @@ -6,29 +6,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: menubut.test,v 1.6 2001/05/21 14:07:33 tmh Exp $ +# RCS: @(#) $Id: menubut.test,v 1.7 2002/07/13 20:28:35 dgp Exp $ # XXX This test file is woefully incomplete right now. If any part # XXX of a procedure has tests then the whole procedure has tests, # XXX but many procedures have no tests. -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 # Create entries in the option database to be sure that geometry options # like border width have predictable values. @@ -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 +} menubutton .mb -text "Test" pack .mb update @@ -84,7 +75,7 @@ foreach test { {-wraplength 100 100 6x {bad screen distance "6x"}} } { set name [lindex $test 0] - test menubutton-1.$i {configuration options} { + test menubutton-1.$i {configuration options} testImageType { .mb configure $name [lindex $test 1] lindex [.mb configure $name] 4 } [lindex $test 2] @@ -181,7 +172,7 @@ test menubutton-4.3 {ConfigureMenuButton procedure} { (processing -width option) invoked from within ".mb1 configure -width abc"}} -test menubutton-4.4 {ConfigureMenuButton procedure} { +test menubutton-4.4 {ConfigureMenuButton procedure} testImageType { catch {destroy .mb1} eval image delete [image names] image create test image1 @@ -209,7 +200,7 @@ test menubutton-4.6 {ConfigureMenuButton procedure - bad direction} { # XXX Need to add tests for several procedures here. XXX test menubutton-5.1 {MenuButtonEventProc procedure} { - eval destroy [winfo children .] + deleteWindows menubutton .mb1 -bg #543210 rename .mb1 .mb2 set x {} @@ -220,38 +211,38 @@ test menubutton-5.1 {MenuButtonEventProc procedure} { } {.mb1 #543210 {} {}} test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} { - eval destroy [winfo children .] + deleteWindows menubutton .mb1 rename .mb1 {} list [info command .mb*] [winfo children .] } {{} {}} -test menubutton-7.1 {ComputeMenuButtonGeometry procedure} { +test menubutton-7.1 {ComputeMenuButtonGeometry procedure} testImageType { catch {destroy .mb} menubutton .mb -image image1 -bd 4 -highlightthickness 0 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } {38 23} -test menubutton-7.2 {ComputeMenuButtonGeometry procedure} { +test menubutton-7.2 {ComputeMenuButtonGeometry procedure} testImageType { catch {destroy .mb} menubutton .mb -image image1 -bd 1 -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } {36 21} -test menubutton-7.3 {ComputeMenuButtonGeometry procedure} { +test menubutton-7.3 {ComputeMenuButtonGeometry procedure} testImageType { catch {destroy .mb} menubutton .mb -image image1 -bd 0 -highlightthickness 2 -padx 5 -pady 5 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } {34 19} -test menubutton-7.4 {ComputeMenuButtonGeometry procedure} { +test menubutton-7.4 {ComputeMenuButtonGeometry procedure} testImageType { catch {destroy .mb} menubutton .mb -image image1 -bd 2 -relief raised -width 40 \ -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } {48 23} -test menubutton-7.5 {ComputeMenuButtonGeometry procedure} { +test menubutton-7.5 {ComputeMenuButtonGeometry procedure} testImageType { catch {destroy .mb} menubutton .mb -image image1 -bd 2 -relief raised -height 30 \ -highlightthickness 2 @@ -314,7 +305,7 @@ test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {nonPortable fonts} { pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } {78 28} -test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {unixOnly nonPortable} { +test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {testImageType unixOnly nonPortable} { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. @@ -324,7 +315,7 @@ test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {unixOnly nonPortable pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } {64 23} -test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {pcOnly nonPortable} { +test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {testImageType pcOnly nonPortable} { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. @@ -336,7 +327,7 @@ test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {pcOnly nonPortable} } {65 23} set l [interp hidden] -eval destroy [winfo children .] +deleteWindows test menubutton-8.1 {menubutton vs hidden commands} { catch {destroy .mb} @@ -347,7 +338,7 @@ test menubutton-8.1 {menubutton vs hidden commands} { } [list {} $l] eval image delete [image names] -eval destroy [winfo children .] +deleteWindows option clear # cleanup diff --git a/tests/message.test b/tests/message.test index f2c7d5d..a5f52e5 100644 --- a/tests/message.test +++ b/tests/message.test @@ -6,11 +6,14 @@ # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. # -# RCS: @(#) $Id: message.test,v 1.1 2000/08/02 01:33:34 ericm Exp $ +# RCS: @(#) $Id: message.test,v 1.2 2002/07/13 20:28:35 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 option add *Message.borderWidth 2 option add *Message.highlightThickness 2 diff --git a/tests/msgbox.test b/tests/msgbox.test index b37305c..a20d787 100644 --- a/tests/msgbox.test +++ b/tests/msgbox.test @@ -5,17 +5,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: msgbox.test,v 1.5 2001/08/01 16:21:12 dgp Exp $ +# RCS: @(#) $Id: msgbox.test,v 1.6 2002/07/13 20:28:35 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 msgbox-1.1 {tk_messageBox command} { list [catch {tk_messageBox -foo} msg] $msg diff --git a/tests/obj.test b/tests/obj.test index f24ff68..bc4618e 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -5,17 +5,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: obj.test,v 1.2 1999/04/16 01:51:39 stanton Exp $ +# RCS: @(#) $Id: obj.test,v 1.3 2002/07/13 20:28:35 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 test obj-1.1 {TkGetPixelsFromObj} { } {} @@ -31,7 +28,7 @@ test obj-4.1 {SetPixelFromAny} { -eval destroy [winfo children .] +deleteWindows # cleanup ::tcltest::cleanupTests diff --git a/tests/oldpack.test b/tests/oldpack.test index e809da5..52e2d4e 100644 --- a/tests/oldpack.test +++ b/tests/oldpack.test @@ -7,11 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: oldpack.test,v 1.4 2001/08/21 20:21:36 pspjuth Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +# RCS: @(#) $Id: oldpack.test,v 1.5 2002/07/13 20:28:35 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 # First, test a single window packed in various ways in a parent diff --git a/tests/option.test b/tests/option.test index 339d723..173ec37 100644 --- a/tests/option.test +++ b/tests/option.test @@ -6,11 +6,17 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: option.test,v 1.3 1999/04/16 01:51:40 stanton Exp $ +# RCS: @(#) $Id: option.test,v 1.4 2002/07/13 20:28:35 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 + +namespace import -force tcltest::makeFile +namespace import -force tcltest::removeFile catch {destroy .op1} catch {destroy .op2} @@ -185,9 +191,8 @@ test option-14.12 {error conditions} { list [catch {option get .gorp.gorp a A} msg] $msg } {1 {bad window path name ".gorp.gorp"}} -set option1 [file join $::tcltest::testsDir option.file1] -set option2 [file join $::tcltest::testsDir option.file2] -set option3 [file join $::tcltest::testsDir option.file3] +set option1 [file join [testsDirectory] option.file1] +set option2 [file join [testsDirectory] option.file2] test option-15.1 {database files} { list [catch {option read non-existent} msg] $msg @@ -211,7 +216,8 @@ test option-15.9 {database files} { } {1 {missing colon on line 2}} test option-16.1 {ReadOptionFile} { - set file [open "$option3" w] + set option3 [makeFile {} option.file3] + set file [open $option3 w] fconfigure $file -translation crlf puts $file "*x7: true\n*x8: false" close $file diff --git a/tests/pack.test b/tests/pack.test index 395b3f2..488281a 100644 --- a/tests/pack.test +++ b/tests/pack.test @@ -6,11 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: pack.test,v 1.9 2001/09/26 21:36:19 pspjuth Exp $ +# RCS: @(#) $Id: pack.test,v 1.10 2002/07/13 20:28:35 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 # Utility procedures: diff --git a/tests/panedwindow.test b/tests/panedwindow.test index 3a88c18..1a25487 100644 --- a/tests/panedwindow.test +++ b/tests/panedwindow.test @@ -6,23 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: panedwindow.test,v 1.2 2002/06/19 23:17:17 hobbs Exp $ - -if {[info tclversion] < 8.4} { - puts "panedwindow requires Tk 8.4" - exit -} - -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: panedwindow.test,v 1.3 2002/07/13 20:28:35 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 set i 1 panedwindow .p diff --git a/tests/place.test b/tests/place.test index 2d25e3c..02d87ac 100644 --- a/tests/place.test +++ b/tests/place.test @@ -5,17 +5,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: place.test,v 1.6 2001/09/26 21:36:19 pspjuth Exp $ +# RCS: @(#) $Id: place.test,v 1.7 2002/07/13 20:28:35 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. diff --git a/tests/raise.test b/tests/raise.test index 12b56cf..53bf9b3 100644 --- a/tests/raise.test +++ b/tests/raise.test @@ -8,12 +8,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: raise.test,v 1.6 2002/07/13 00:30:25 dgp Exp $ +# RCS: @(#) $Id: raise.test,v 1.7 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -eval tcltest::configure $argv +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 testConstraint testmakeexist [llength [info commands testmakeexist]] @@ -53,9 +55,7 @@ proc raise_getOrder {} { # Procedure to set up a collection of top-level windows proc raise_makeToplevels {} { - foreach i [winfo child .] { - destroy $i - } + deleteWindows foreach i {.raise1 .raise2 .raise3} { toplevel $i wm geom $i 150x100+0+0 @@ -63,15 +63,12 @@ proc raise_makeToplevels {} { } } -foreach i [winfo child .] { - destroy $i -} toplevel .raise wm geom .raise 250x200+0+0 test raise-1.1 {preserve creation order} { raise_setup - update + tkwait visibility .raise.e raise_getOrder } {d d d b c e e e} test raise-1.2 {preserve creation order} testmakeexist { @@ -290,9 +287,7 @@ test raise-7.8 {errors in raise/lower commands} { list [catch {lower . badName4} msg] $msg } {1 {bad window path name "badName4"}} -foreach i [winfo child .] { - destroy $i -} +deleteWindows # cleanup ::tcltest::cleanupTests diff --git a/tests/safe.test b/tests/safe.test index b695023..ba483dc 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -6,11 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: safe.test,v 1.8 2002/07/13 00:30:25 dgp Exp $ +# RCS: @(#) $Id: safe.test,v 1.9 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -eval tcltest::configure $argv +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 ## NOTE: Any time tests fail here with an error like: @@ -32,10 +35,6 @@ eval tcltest::configure $argv ## Ensure that any changes that occured to tk.tcl will work or ## are properly prevented in a safe interpreter. -- hobbs -foreach i [winfo children .] { - destroy $i -} - # The set of hidden commands is platform dependent: if {"$tcl_platform(platform)" == "macintosh"} { diff --git a/tests/scale.test b/tests/scale.test index ee4981b..fb9ba5d 100644 --- a/tests/scale.test +++ b/tests/scale.test @@ -6,22 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: scale.test,v 1.11 2002/07/13 00:30:25 dgp Exp $ +# RCS: @(#) $Id: scale.test,v 1.12 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testsDirectory 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 configure $argv - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . # Create entries in the option database to be sure that geometry options # like border width have predictable values. @@ -623,7 +615,7 @@ test scale-11.1 {ScaleEventProc procedure} { set x } {initial 1 0 {}} test scale-11.2 {ScaleEventProc procedure} { - eval destroy [winfo children .] + deleteWindows scale .s1 -bg #543210 rename .s1 .s2 set x {} @@ -634,7 +626,7 @@ test scale-11.2 {ScaleEventProc procedure} { } {.s1 #543210 {} {}} test scale-12.1 {ScaleCmdDeletedProc procedure} { - eval destroy [winfo children .] + deleteWindows scale .s1 rename .s1 {} list [info command .s*] [winfo children .] @@ -791,7 +783,7 @@ test scale-15.6 {ScaleVarProc procedure, don't call -command} { } {untouched 60} set l [interp hidden] -eval destroy [winfo children .] +deleteWindows test scale-16.1 {scale widget vs hidden commands} { catch {destroy .s} diff --git a/tests/scrollbar.test b/tests/scrollbar.test index 775e045..025df53 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -7,22 +7,19 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: scrollbar.test,v 1.8 2002/07/13 00:30:25 dgp Exp $ +# RCS: @(#) $Id: scrollbar.test,v 1.9 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -eval tcltest::configure $argv +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 ## testmetrics is a win/mac only test command ## testConstraint testmetrics [llength [info commands testmetrics]] -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . update proc scroll args { @@ -659,7 +656,7 @@ test scrollbar-8.2 {TkScrollbarEventProc: recursive deletion} { } {1 0 1} set l [interp hidden] -eval destroy [winfo children .] +deleteWindows test scrollbar-9.1 {scrollbar widget vs hidden commands} { catch {destroy .s} diff --git a/tests/select.test b/tests/select.test index 657786b..0e24c7c 100644 --- a/tests/select.test +++ b/tests/select.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: select.test,v 1.8 2002/07/13 00:30:25 dgp Exp $ +# RCS: @(#) $Id: select.test,v 1.9 2002/07/13 20:28:35 dgp Exp $ # # Note: Multiple display selection handling will only be tested if the @@ -14,16 +14,13 @@ # package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testsDirectory namespace import -force tcltest::configure -namespace import -force tcltest::interpreter +namespace import -force tcltest::testsDirectory configure -testdir [file join [pwd] [file dirname [info script]]] configure -loadfile [file join [testsDirectory] constraints.tcl] tcltest::loadTestedCommands -eval configure $argv -eval destroy [winfo child .] +namespace import -force tcltest::interpreter global longValue selValue selInfo diff --git a/tests/send.test b/tests/send.test index b31f550..c69815f 100644 --- a/tests/send.test +++ b/tests/send.test @@ -10,28 +10,18 @@ # 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.6 2002/07/13 00:30:25 dgp Exp $ +# RCS: @(#) $Id: send.test,v 1.7 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testsDirectory 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 configure $argv - -# 'send' is only available on Unix... testConstraint xhost [llength [auto_execok xhost]] testConstraint testsend [llength [info commands testsend]] -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . - # If send is disabled because of inadequate security, don't run any # of these tests at all. diff --git a/tests/spinbox.test b/tests/spinbox.test index 41ca9f8..0a576d3 100644 --- a/tests/spinbox.test +++ b/tests/spinbox.test @@ -4,22 +4,14 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: spinbox.test,v 1.2 2002/07/13 00:30:25 dgp Exp $ +# RCS: @(#) $Id: spinbox.test,v 1.3 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testsDirectory 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 configure $argv - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . proc scroll args { global scrollInfo @@ -1083,7 +1075,7 @@ test spinbox-11.1 {SpinboxEventProc procedure} { update } {} test spinbox-11.2 {SpinboxEventProc procedure} { - eval destroy [winfo children .] + deleteWindows spinbox .e1 -fg #112233 rename .e1 .e2 set x {} @@ -1094,7 +1086,7 @@ test spinbox-11.2 {SpinboxEventProc procedure} { } {.e1 #112233 {} {}} test spinbox-12.1 {SpinboxCmdDeletedProc procedure} { - eval destroy [winfo children .] + deleteWindows button .e1 -text "xyz_123" rename .e1 {} list [info command .e*] [winfo children .] @@ -1295,7 +1287,7 @@ test spinbox-17.4 {SpinboxUpdateScrollbar procedure} { (horizontal scrolling command executed by .e)}} set l [interp hidden] -eval destroy [winfo children .] +deleteWindows test spinbox-18.1 {Spinbox widget vs hiding} { destroy .e diff --git a/tests/text.test b/tests/text.test index 7ae80a0..0ea9165 100644 --- a/tests/text.test +++ b/tests/text.test @@ -6,18 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: text.test,v 1.17 2002/07/12 21:08:49 dgp Exp $ +# RCS: @(#) $Id: text.test,v 1.18 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testsDirectory 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 configure $argv - -eval destroy [winfo child .] # Create entries in the option database to be sure that geometry options # like border width have predictable values. @@ -1196,13 +1192,13 @@ test text-20.65 {TextSearchCmd, unicode with non-text segments} { } {1.3 3} test text-20.66 {TextSearchCmd, hidden text does not affect match index} { - eval destroy [winfo child .] + deleteWindows pack [text .t2] .t2 insert end "12345H7890" .t2 search 7 1.0 } 1.6 test text-20.67 {TextSearchCmd, hidden text does not affect match index} { - eval destroy [winfo child .] + deleteWindows pack [text .t2] .t2 insert end "12345H7890" .t2 tag configure hidden -elide true @@ -1210,13 +1206,13 @@ test text-20.67 {TextSearchCmd, hidden text does not affect match index} { .t2 search 7 1.0 } 1.6 test text-20.68 {TextSearchCmd, hidden text does not affect match index} { - eval destroy [winfo child .] + deleteWindows pack [text .t2] .t2 insert end "foobar\nbarbaz\nbazboo" .t2 search boo 1.0 } 3.3 test text-20.69 {TextSearchCmd, hidden text does not affect match index} { - eval destroy [winfo child .] + deleteWindows pack [text .t2] .t2 insert end "foobar\nbarbaz\nbazboo" .t2 tag configure hidden -elide true @@ -1249,7 +1245,7 @@ test text-20.72 {TextSearchCmd, -regexp -nocase searches} { set res } 1.0 -eval destroy [winfo child .] +deleteWindows text .t2 -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100 pack .t2 .t2 insert end "1\t2\t3\t4\t55.5" @@ -1287,7 +1283,7 @@ test text-21.7 {TkTextGetTabs procedure} { list [catch {.t2 configure -tabs {100 !44 200 lork}} msg] $msg } {1 {bad screen distance "!44"}} -eval destroy [winfo child .] +deleteWindows text .t pack .t .t insert 1.0 "One Line" @@ -1428,7 +1424,7 @@ test text-22.26 {TextDumpCmd procedure, unicode characters} { } "text abc\xb1\xb1\xb1 1.0 mark insert 1.6 mark current 1.6 text {\n} 1.6" set l [interp hidden] -eval destroy [winfo children .] +deleteWindows test text-23.1 {text widget vs hidden commands} { catch {destroy .t} @@ -1577,7 +1573,7 @@ test text-25.13 {-maxundo configuration option} { .t get 1.0 end } "line 1\n\n" -eval destroy [winfo child .] +deleteWindows option clear # cleanup diff --git a/tests/textBTree.test b/tests/textBTree.test index 9088f28..7578536 100644 --- a/tests/textBTree.test +++ b/tests/textBTree.test @@ -8,11 +8,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: textBTree.test,v 1.4 2002/07/12 21:08:49 dgp Exp $ +# RCS: @(#) $Id: textBTree.test,v 1.5 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -eval tcltest::configure $argv +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 .t} text .t diff --git a/tests/textDisp.test b/tests/textDisp.test index 64be19e..4e7674f 100644 --- a/tests/textDisp.test +++ b/tests/textDisp.test @@ -6,19 +6,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: textDisp.test,v 1.6 2002/07/12 21:08:49 dgp Exp $ +# RCS: @(#) $Id: textDisp.test,v 1.7 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testsDirectory namespace import -force tcltest::configure -namespace import -force tcltest::interpreter -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile +namespace import -force tcltest::testsDirectory configure -testdir [file join [pwd] [file dirname [info script]]] configure -loadfile [file join [testsDirectory] constraints.tcl] tcltest::loadTestedCommands -eval configure $argv + +namespace import -force tcltest::interpreter +namespace import -force tcltest::makeFile +namespace import -force tcltest::removeFile # The procedure below is used as the scrolling command for the text; # it just saves the scrolling information in a variable "scrollInfo". @@ -45,9 +44,6 @@ option add *Text.highlightThickness 2 # because some window managers don't allow the overall width of a window # to get very narrow. -foreach i [winfo child .] { - destroy $i -} frame .f -width 100 -height 20 pack append . .f left @@ -2862,9 +2858,7 @@ test textDisp-29.3 {miscellaneous: lines wrap but are still too long} {fonts} { list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } {{0.536667 1} 300x50+-156+18 {}} -foreach i [winfo children .] { - catch {destroy $i} -} +deleteWindows option clear # cleanup diff --git a/tests/textImage.test b/tests/textImage.test index 1698763..f75ce8a 100644 --- a/tests/textImage.test +++ b/tests/textImage.test @@ -7,20 +7,17 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: textImage.test,v 1.4 2002/07/12 21:08:49 dgp Exp $ +# RCS: @(#) $Id: textImage.test,v 1.5 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testsDirectory 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 configure $argv # One time setup. Create a font to insure the tests are font metric invariant. -wm geometry . {} catch {destroy .t} font create test_font -family courier -size 14 text .t -font test_font diff --git a/tests/textIndex.test b/tests/textIndex.test index 2973c8b..98f81bb 100644 --- a/tests/textIndex.test +++ b/tests/textIndex.test @@ -6,17 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: textIndex.test,v 1.6 2002/07/12 21:08:49 dgp Exp $ +# RCS: @(#) $Id: textIndex.test,v 1.7 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -namespace import -force tcltest::testsDirectory 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 configure $argv # Some tests require the testtext command testConstraint testtext [llength [info commands testtext]] diff --git a/tests/textMark.test b/tests/textMark.test index 6eae772..af1dc4d 100644 --- a/tests/textMark.test +++ b/tests/textMark.test @@ -6,12 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: textMark.test,v 1.4 2002/07/12 21:08:49 dgp Exp $ +# RCS: @(#) $Id: textMark.test,v 1.5 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -eval tcltest::configure $argv +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 .t} testConstraint courier12 [expr {[catch { diff --git a/tests/textTag.test b/tests/textTag.test index d0797f5..da86a7a 100644 --- a/tests/textTag.test +++ b/tests/textTag.test @@ -6,12 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: textTag.test,v 1.5 2002/07/12 21:08:49 dgp Exp $ +# RCS: @(#) $Id: textTag.test,v 1.6 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -eval tcltest::configure $argv +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 .t} testConstraint courier12 [expr {[catch { diff --git a/tests/textWind.test b/tests/textWind.test index 43aefff..c7093ca 100644 --- a/tests/textWind.test +++ b/tests/textWind.test @@ -6,21 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: textWind.test,v 1.4 2002/07/12 21:08:49 dgp Exp $ +# RCS: @(#) $Id: textWind.test,v 1.5 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testsDirectory 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 configure $argv - -foreach i [winfo child .] { - catch {destroy $i} -} - # Create entries in the option database to be sure that geometry options # like border width have predictable values. diff --git a/tests/tk.test b/tests/tk.test index 9423f15..38414ee 100644 --- a/tests/tk.test +++ b/tests/tk.test @@ -5,11 +5,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2002 ActiveState Corporation. # -# RCS: @(#) $Id: tk.test,v 1.7 2002/07/12 21:08:49 dgp Exp $ +# RCS: @(#) $Id: tk.test,v 1.8 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -eval tcltest::configure $argv +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 tk-1.1 {tk command: general} { list [catch {tk} msg] $msg diff --git a/tests/unixButton.test b/tests/unixButton.test index 6b1bcbb..85f9259 100644 --- a/tests/unixButton.test +++ b/tests/unixButton.test @@ -8,23 +8,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixButton.test,v 1.4 2002/07/12 13:40:59 dgp Exp $ +# RCS: @(#) $Id: unixButton.test,v 1.5 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -namespace import -force tcltest::testsDirectory 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 configure $argv - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . # Create entries in the option database to be sure that geometry options # like border width have predictable values. @@ -58,7 +49,7 @@ pack .l .b .c .r update test unixbutton-1.1 {TkpComputeButtonGeometry procedure} {unix testImageType} { - eval destroy [winfo children .] + deleteWindows image create test image1 image1 changed 0 0 0 0 60 40 label .b1 -image image1 -bd 4 -padx 0 -pady 2 @@ -73,7 +64,7 @@ test unixbutton-1.1 {TkpComputeButtonGeometry procedure} {unix testImageType} { [winfo reqwidth .b4] [winfo reqheight .b4] } {68 48 74 54 112 52 112 52} test unixbutton-1.2 {TkpComputeButtonGeometry procedure} unix { - eval destroy [winfo children .] + deleteWindows label .b1 -bitmap question -bd 3 -padx 0 -pady 2 button .b2 -bitmap question -bd 3 -padx 0 -pady 2 checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1 @@ -86,7 +77,7 @@ test unixbutton-1.2 {TkpComputeButtonGeometry procedure} unix { [winfo reqwidth .b4] [winfo reqheight .b4] } {23 33 29 39 54 37 54 37} test unixbutton-1.3 {TkpComputeButtonGeometry procedure} unix { - eval destroy [winfo children .] + deleteWindows label .b1 -bitmap question -bd 3 -highlightthickness 4 button .b2 -bitmap question -bd 3 -highlightthickness 0 checkbutton .b3 -bitmap question -bd 3 -highlightthickness 1 \ @@ -101,7 +92,7 @@ test unixbutton-1.3 {TkpComputeButtonGeometry procedure} unix { [winfo reqwidth .b4] [winfo reqheight .b4] } {31 41 25 35 25 35 25 35} test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { - eval destroy [winfo children .] + deleteWindows label .b1 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold} button .b2 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold} checkbutton .b3 -text Xagqpim -padx 1 -pady 1 -font {Helvetica -18 bold} @@ -114,21 +105,21 @@ test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts [winfo reqwidth .b4] [winfo reqheight .b4] } {82 29 88 35 114 31 121 29} test unixbutton-1.5 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { - eval destroy [winfo children .] + deleteWindows label .l1 -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." -wraplength 1.5i -padx 0 -pady 0 pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] } {136 88} test unixbutton-1.6 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { - eval destroy [winfo children .] + deleteWindows label .l1 -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." -padx 0 -pady 0 pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] } {231 46} test unixbutton-1.7 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { - eval destroy [winfo children .] + deleteWindows label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5 checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -width 20 -height 2 @@ -141,7 +132,7 @@ test unixbutton-1.7 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts [winfo reqwidth .b4] [winfo reqheight .b4] } {74 22 60 84 168 38 61 22} test unixbutton-1.8 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { - eval destroy [winfo children .] + deleteWindows label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \ -highlightthickness 4 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 \ @@ -157,22 +148,22 @@ test unixbutton-1.8 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts [winfo reqwidth .b4] [winfo reqheight .b4] } {62 30 56 24 58 22 62 22} test unixbutton-1.9 {TkpComputeButtonGeometry procedure} unix { - eval destroy [winfo children .] + deleteWindows button .b2 -bitmap question -default active list [winfo reqwidth .b2] [winfo reqheight .b2] } {37 47} test unixbutton-1.10 {TkpComputeButtonGeometry procedure} unix { - eval destroy [winfo children .] + deleteWindows button .b2 -bitmap question -default normal list [winfo reqwidth .b2] [winfo reqheight .b2] } {37 47} test unixbutton-1.11 {TkpComputeButtonGeometry procedure} unix { - eval destroy [winfo children .] + deleteWindows button .b2 -bitmap question -default disabled list [winfo reqwidth .b2] [winfo reqheight .b2] } {27 37} -eval destroy [winfo children .] +deleteWindows # cleanup ::tcltest::cleanupTests diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index 851cba6..8b3cede 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -6,21 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixEmbed.test,v 1.9 2002/07/12 13:40:59 dgp Exp $ +# RCS: @(#) $Id: unixEmbed.test,v 1.10 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -namespace import -force tcltest::testsDirectory 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 configure $argv - -eval destroy [winfo children .] -wm geometry . {} -raise . setupbg dobg {wm withdraw .} @@ -101,7 +94,7 @@ test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {unix nonPortab testConstraint testembed [llength [info commands testembed]] test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {unix testembed} { - eval destroy [winfo child .] + deleteWindows frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 @@ -113,7 +106,7 @@ test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {unix te } } {{{XXX {} {} .t}} 0} test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} {unix testembed} { - eval destroy [winfo child .] + deleteWindows frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 @@ -127,7 +120,7 @@ test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} {unix te } } {{XXX {} {} .t2} {XXX {} {} .t1}} test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} {unix testembed} { - eval destroy [winfo child .] + deleteWindows frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 @@ -140,9 +133,7 @@ test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} # TkpMakeContainer, or EmbedErrorProc. test unixEmbed-2.1 {EmbeddedEventProc procedure} {unix testembed} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -158,9 +149,7 @@ test unixEmbed-2.1 {EmbeddedEventProc procedure} {unix testembed} { } } {} test unixEmbed-2.2 {EmbeddedEventProc procedure} {unix testembed} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -173,9 +162,7 @@ test unixEmbed-2.2 {EmbeddedEventProc procedure} {unix testembed} { } } {} test unixEmbed-2.3 {EmbeddedEventProc procedure} {unix testembed} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] @@ -184,9 +171,7 @@ test unixEmbed-2.3 {EmbeddedEventProc procedure} {unix testembed} { testembed } {} test unixEmbed-2.4 {EmbeddedEventProc procedure} {unix testembed} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] @@ -199,9 +184,7 @@ test unixEmbed-2.4 {EmbeddedEventProc procedure} {unix testembed} { test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} \ {unix testembed nonPortable} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -214,9 +197,7 @@ test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} \ list $x [testembed] } {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}} test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows toplevel .t1 -container 1 wm geometry .t1 +0+0 toplevel .t2 -use [winfo id .t1] -bg red @@ -224,9 +205,7 @@ test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} unix { wm geometry .t2 } {200x200+0+0} test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -242,9 +221,7 @@ test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} uni } } {200x200+0+0} test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -260,9 +237,7 @@ test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} uni } } {300x100+0+0} test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -278,9 +253,7 @@ test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} unix { list [winfo width .f1] [winfo height .f1] [dobg {wm geometry .t1}] } {300 80 300x80+0+0} test unixEmbed-3.5 {ContainerEventProc procedure, map requests} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -298,9 +271,7 @@ test unixEmbed-3.5 {ContainerEventProc procedure, map requests} unix { } } {mapped} test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -319,9 +290,7 @@ test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} unix { } {dead 0} test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -339,9 +308,7 @@ test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} unix { } } {180x100+0+0} test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} {unix testembed} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -356,9 +323,7 @@ test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} {unix testembe } {{{XXX .f1 XXX {}}} {}} test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -374,9 +339,7 @@ test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} unix { dobg {set x} } {{focus in .t1}} test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -393,9 +356,7 @@ test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} unix { update } {} test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -415,9 +376,7 @@ test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} unix { } {{{focus in .t1}} {{focus in .t1} {focus out .t1}}} test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -435,9 +394,7 @@ test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} unix { } } {{{configure .t1 300 120}} 300x120+0+0} test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 place .f1 -width 200 -height 200 dobg "set w1 [winfo id .f1]" @@ -459,9 +416,7 @@ test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} unix { # Can't think up any tests for TkpGetOtherWindow procedure. test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -484,9 +439,7 @@ test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} unix { list $x $y } {{{key a 1}} {}} test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -512,9 +465,7 @@ test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width } {{} {{key b}}} test unixEmbed-8.1 {TkpClaimFocus procedure} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 frame .f2 -width 200 -height 50 pack .f1 .f2 @@ -536,9 +487,7 @@ test unixEmbed-8.1 {TkpClaimFocus procedure} unix { } {{{} .t1} .f1} test unixEmbed-8.2 {TkpClaimFocus procedure} unix { catch {interp delete child} - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 frame .f2 -width 200 -height 50 pack .f1 .f2 @@ -560,9 +509,7 @@ test unixEmbed-8.2 {TkpClaimFocus procedure} unix { catch {interp delete child} test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {unix testembed} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 frame .f3 -container 1 -width 200 -height 50 @@ -577,9 +524,7 @@ test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {unix testemb set x } {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}} test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} {unix testembed} { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -594,9 +539,7 @@ test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} {unix teste } {{{XXX {} {} .t1}} {}} test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] -width 150 -height 80 @@ -606,9 +549,7 @@ test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix wm geometry .t1 } {150x80+0+0} test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix { - foreach w [winfo child .] { - catch {destroy $w} - } + deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] -width 150 -height 80 @@ -619,9 +560,7 @@ test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix } {70x300+0+0} # cleanup -foreach w [winfo child .] { - catch {destroy $w} -} +deleteWindows cleanupbg ::tcltest::cleanupTests return diff --git a/tests/unixFont.test b/tests/unixFont.test index 16d2bf8..420bf13 100644 --- a/tests/unixFont.test +++ b/tests/unixFont.test @@ -12,17 +12,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixFont.test,v 1.6 2002/07/12 13:40:59 dgp Exp $ +# RCS: @(#) $Id: unixFont.test,v 1.7 2002/07/13 20:28:35 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -namespace import -force tcltest::testsDirectory 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 configure $argv testConstraint hasArial 1 testConstraint hasCourierNew 1 diff --git a/tests/unixMenu.test b/tests/unixMenu.test index ed4a048..7592921 100644 --- a/tests/unixMenu.test +++ b/tests/unixMenu.test @@ -7,27 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixMenu.test,v 1.6 2002/07/12 13:41:00 dgp Exp $ +# RCS: @(#) $Id: unixMenu.test,v 1.7 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -namespace import -force tcltest::testsDirectory 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 configure $argv - -proc deleteWindows {} { - foreach i [winfo children .] { - catch [destroy $i] - } -} - -deleteWindows -wm geometry . {} -raise . test unixMenu-1.1 {TkpNewMenu - normal menu} unix { catch {destroy .m1} diff --git a/tests/unixSelect.test b/tests/unixSelect.test index 84c4cc4..cc93902 100644 --- a/tests/unixSelect.test +++ b/tests/unixSelect.test @@ -9,18 +9,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixSelect.test,v 1.3 2002/07/12 13:41:00 dgp Exp $ +# RCS: @(#) $Id: unixSelect.test,v 1.4 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testsDirectory 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 configure $argv - -eval destroy [winfo child .] global longValue selValue selInfo diff --git a/tests/unixWm.test b/tests/unixWm.test index 1896e75..7bdd746 100644 --- a/tests/unixWm.test +++ b/tests/unixWm.test @@ -7,19 +7,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixWm.test,v 1.21 2002/07/12 21:08:49 dgp Exp $ +# RCS: @(#) $Id: unixWm.test,v 1.22 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testsDirectory namespace import -force tcltest::configure -namespace import -force tcltest::interpreter -namespace import -force tcltest::makeFile -namespace import -force tcltest::removeFile +namespace import -force tcltest::testsDirectory configure -testdir [file join [pwd] [file dirname [info script]]] configure -loadfile [file join [testsDirectory] constraints.tcl] tcltest::loadTestedCommands -eval configure $argv + +namespace import -force tcltest::interpreter +namespace import -force tcltest::makeFile +namespace import -force tcltest::removeFile proc sleep ms { global x @@ -30,9 +29,7 @@ proc sleep ms { # Procedure to set up a collection of top-level windows proc makeToplevels {} { - foreach i [winfo child .] { - destroy $i - } + deleteWindows foreach i {.raise1 .raise2 .raise3} { toplevel $i wm geom $i 150x100+0+0 @@ -1719,12 +1716,10 @@ test unixWm-49.2 {Tk_GetRootCoords procedure, menubars} {unix testmenubar} { [expr [winfo rootx .t.f] - $x] [expr [winfo rooty .t.f] - $y] } {52 7 12 62} -foreach w [winfo children .] { - catch {destroy $w} -} +deleteWindows wm iconify . test unixWm-50.1 {Tk_CoordsToWindow procedure, finding a toplevel, x-coords} { - eval destroy [winfo children .] + deleteWindows toplevel .t -width 300 -height 400 -bg green wm geom .t +40+0 tkwait visibility .t @@ -1744,7 +1739,7 @@ test unixWm-50.1 {Tk_CoordsToWindow procedure, finding a toplevel, x-coords} { [winfo containing [expr $x + 220] [expr $y + 250]] } {{} {} .t {} .t2 .t2 {} .t} test unixWm-50.2 {Tk_CoordsToWindow procedure, finding a toplevel, y-coords and overrideredirect} { - eval destroy [winfo children .] + deleteWindows toplevel .t -width 300 -height 400 -bg yellow wm geom .t +0+50 tkwait visibility .t @@ -1766,7 +1761,7 @@ test unixWm-50.2 {Tk_CoordsToWindow procedure, finding a toplevel, y-coords and [winfo containing [expr $x +150] [expr $y + 450]] } {{} {} .t .t .t2 .t2 .t {}} test unixWm-50.3 {Tk_CoordsToWindow procedure, finding a toplevel with embedding} { - eval destroy [winfo children .] + deleteWindows toplevel .t -width 300 -height 400 -bg blue wm geom .t +0+50 frame .t.f -container 1 @@ -1804,7 +1799,7 @@ test unixWm-50.4 {Tk_CoordsToWindow procedure, window in other application} { set result } {{} .} test unixWm-50.5 {Tk_CoordsToWindow procedure, handling menubars} {unix testmenubar} { - eval destroy [winfo children .] + deleteWindows toplevel .t -width 300 -height 400 -bd 2 -relief raised frame .t.f -width 150 -height 120 -bg green place .t.f -x 10 -y 150 @@ -1826,7 +1821,7 @@ test unixWm-50.5 {Tk_CoordsToWindow procedure, handling menubars} {unix testmenu [winfo containing [expr $x + 12] [expr $y + 152]] } {{} .t.menu .t.menu .t.menu.f .t .t .t.f} test unixWm-50.6 {Tk_CoordsToWindow procedure, embedding within one app.} { - eval destroy [winfo children .] + deleteWindows toplevel .t -width 300 -height 400 -bg orange wm geom .t +0+50 frame .t.f -container 1 @@ -1902,7 +1897,7 @@ test unixWm-50.10 {Tk_CoordsToWindow procedure, unmapped windows} { update lappend result [winfo containing 100 100] } {.t.f .t} -eval destroy [winfo children .] +deleteWindows wm deiconify . # No tests for UpdateVRootGeometry, Tk_GetVRootGeometry, @@ -1959,9 +1954,7 @@ test unixWm-51.5 {TkWmRestackToplevel procedure, basic tests} {nonPortable} { list $result [winfo containing [winfo rootx .raise2] \ [winfo rooty .raise2]] } {.raise1 .raise3} -foreach w [winfo children .] { - catch {destroy $w} -} +deleteWindows test unixWm-51.6 {TkWmRestackToplevel procedure, window to be stacked isn't mapped} { catch {destroy .t} toplevel .t -width 200 -height 200 -bg green diff --git a/tests/util.test b/tests/util.test index bf89528..f9ee697 100644 --- a/tests/util.test +++ b/tests/util.test @@ -6,17 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: util.test,v 1.4 2002/07/12 13:41:00 dgp Exp $ +# RCS: @(#) $Id: util.test,v 1.5 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -eval tcltest::configure $argv - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . +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 listbox .l -width 20 -height 5 -relief sunken -bd 2 pack .l diff --git a/tests/visual.test b/tests/visual.test index 6863abf..28b2d22 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -7,17 +7,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: visual.test,v 1.4 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: visual.test,v 1.5 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -eval tcltest::configure $argv +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 . update # eatColors -- @@ -304,9 +302,7 @@ if {$other != {}} { } {} } -foreach w [winfo child .] { - destroy $w -} +deleteWindows rename eatColors {} rename colorsFree {} diff --git a/tests/visual_bb.test b/tests/visual_bb.test index 480026c..5d99d3b 100644 --- a/tests/visual_bb.test +++ b/tests/visual_bb.test @@ -6,18 +6,16 @@ # at the window to make sure it appears as expected. Individual tests # are kept in separate ".tcl" files in this directory. # -# RCS: @(#) $Id: visual_bb.test,v 1.5 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: visual_bb.test,v 1.6 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -namespace import -force tcltest::testsDirectory -namespace import -force tcltest::cleanupTests 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 configure $argv + +namespace import -force tcltest::cleanupTests set auto_path ". $auto_path" wm title . "Visual Tests for Tk" diff --git a/tests/winButton.test b/tests/winButton.test index 0d890ca..5e6214c 100644 --- a/tests/winButton.test +++ b/tests/winButton.test @@ -8,25 +8,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winButton.test,v 1.7 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: winButton.test,v 1.8 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -eval tcltest::configure $argv - -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 . +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" @@ -35,7 +24,9 @@ catch {unset value} catch {unset value2} 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 @@ -43,8 +34,8 @@ radiobutton .r -text Radiobutton pack .l .b .c .r update -test winbutton-1.1 {TkpComputeButtonGeometry procedure} {pcOnly} { - eval destroy [winfo children .] +test winbutton-1.1 {TkpComputeButtonGeometry procedure} {testImageType pcOnly} { + deleteWindows image create test image1 image1 changed 0 0 0 0 60 40 label .b1 -image image1 -bd 4 -padx 0 -pady 2 @@ -61,7 +52,7 @@ test winbutton-1.1 {TkpComputeButtonGeometry procedure} {pcOnly} { [winfo reqwidth .b4] [winfo reqheight .b4] } {68 48 70 50 90 52 90 52} test winbutton-1.2 {TkpComputeButtonGeometry procedure} {pcOnly} { - eval destroy [winfo children .] + deleteWindows label .b1 -bitmap question -bd 3 -padx 0 -pady 2 button .b2 -bitmap question -bd 3 -padx 0 -pady 2 checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1 @@ -76,7 +67,7 @@ test winbutton-1.2 {TkpComputeButtonGeometry procedure} {pcOnly} { [winfo reqwidth .b4] [winfo reqheight .b4] } {23 33 25 35 45 37 45 37} test winbutton-1.3 {TkpComputeButtonGeometry procedure} {pcOnly} { - eval destroy [winfo children .] + deleteWindows label .b1 -bitmap question -bd 3 -highlightthickness 4 button .b2 -bitmap question -bd 3 -highlightthickness 0 checkbutton .b3 -bitmap question -bd 3 -highlightthickness 1 \ @@ -92,7 +83,7 @@ test winbutton-1.3 {TkpComputeButtonGeometry procedure} {pcOnly} { [winfo reqwidth .b4] [winfo reqheight .b4] } {31 41 23 33 27 37 27 37} test winbutton-1.4 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { - eval destroy [winfo children .] + deleteWindows label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8} button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8} checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -font {{MS Sans Serif} 8} @@ -105,21 +96,21 @@ test winbutton-1.4 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { [winfo reqwidth .b4] [winfo reqheight .b4] } {58 24 67 33 88 30 90 28} test winbutton-1.5 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { - eval destroy [winfo children .] + deleteWindows label .l1 -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." -wraplength 1.5i -padx 0 -pady 0 pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] } {178 84} test winbutton-1.6 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { - eval destroy [winfo children .] + deleteWindows label .l1 -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." -padx 0 -pady 0 pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] } {222 52} test winbutton-1.7 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { - eval destroy [winfo children .] + deleteWindows label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5 checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -width 20 -height 2 @@ -132,7 +123,7 @@ test winbutton-1.7 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { [winfo reqwidth .b4] [winfo reqheight .b4] } {74 24 67 97 174 46 64 28} test winbutton-1.8 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { - eval destroy [winfo children .] + deleteWindows label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \ -highlightthickness 4 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 \ @@ -148,12 +139,12 @@ test winbutton-1.8 {TkpComputeButtonGeometry procedure} {pcOnly nonPortable} { [winfo reqwidth .b4] [winfo reqheight .b4] } {66 32 65 31 69 31 71 29} test winbutton-1.9 {TkpComputeButtonGeometry procedure} {pcOnly} { - eval destroy [winfo children .] + deleteWindows button .b2 -bitmap question -default normal list [winfo reqwidth .b2] [winfo reqheight .b2] } {23 33} # cleanup -eval destroy [winfo children .] +deleteWindows ::tcltest::cleanupTests return diff --git a/tests/winClipboard.test b/tests/winClipboard.test index 078a2be..593c7da 100644 --- a/tests/winClipboard.test +++ b/tests/winClipboard.test @@ -10,13 +10,16 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winClipboard.test,v 1.10 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: winClipboard.test,v 1.11 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint +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::bytestring -eval tcltest::configure $argv # Note that these tests may fail if another application is grabbing the # clipboard (e.g. an X server) diff --git a/tests/winDialog.test b/tests/winDialog.test index bebfe08..9f49f28 100644 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -6,20 +6,19 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 1998-1999 ActiveState Corporation. # -# RCS: @(#) $Id: winDialog.test,v 1.8 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: winDialog.test,v 1.9 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -eval tcltest::configure $argv +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 + testConstraint testwinevent [llength [info commands testwinevent]] catch {testwinevent debug 1} -eval destroy [winfo children .] -wm geometry . {} -raise . - proc start {arg} { set ::tk_dialog 0 set ::iter_after 0 diff --git a/tests/winFont.test b/tests/winFont.test index 0341d86..de0f546 100644 --- a/tests/winFont.test +++ b/tests/winFont.test @@ -10,11 +10,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winFont.test,v 1.7 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: winFont.test,v 1.8 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -eval tcltest::configure $argv +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} catch {font delete xyz} diff --git a/tests/winMenu.test b/tests/winMenu.test index afa5ca0..9e79c33 100644 --- a/tests/winMenu.test +++ b/tests/winMenu.test @@ -7,28 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winMenu.test,v 1.5 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: winMenu.test,v 1.6 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -eval tcltest::configure $argv -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 -} - -proc deleteWindows {} { - foreach i [winfo children .] { - catch [destroy $i] - } -} - -deleteWindows -wm geometry . {} -raise . +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 winMenu-1.1 {GetNewID} {pcOnly} { catch {destroy .m1} @@ -80,7 +66,7 @@ test winMenu-6.1 {GetEntryText} {pcOnly} { catch {destroy .m1} list [catch {menu .m1} msg] $msg [destroy .m1] } {0 .m1 {}} -test winMenu-6.2 {GetEntryText} {pcOnly} { +test winMenu-6.2 {GetEntryText} {testImageType pcOnly} { catch {destroy .m1} catch {image delete image1} menu .m1 @@ -832,7 +818,7 @@ test winMenu-29.22 {TkpDrawMenuEntry - indicator} {pcOnly} { list [update] [destroy .m1] } {{} {}} -test winMenu-30.1 {GetMenuLabelGeometry - image} {pcOnly} { +test winMenu-30.1 {GetMenuLabelGeometry - image} {testImageType pcOnly} { catch {destroy .m1} catch {image delete image1} menu .m1 @@ -966,7 +952,7 @@ test winMenu-32.13 {TkpComputeStandardMenuGeometry - indicator} {pcOnly} { } {{} {}} test winMenu-32.14 \ {TkpComputeStandardMenuGeometry - second indicator less or equal} \ - {pcOnly} { + {testImageType pcOnly} { catch {destroy .m1} catch {image delete image1} image create test image1 @@ -978,7 +964,7 @@ test winMenu-32.14 \ list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger} \ - {unixOnly} { + {testImageType unixOnly} { catch {destroy .m1} catch {image delete image1} image create test image1 diff --git a/tests/winSend.test b/tests/winSend.test index 04491df..5a9640b 100644 --- a/tests/winSend.test +++ b/tests/winSend.test @@ -7,21 +7,16 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winSend.test,v 1.3 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: winSend.test,v 1.4 2002/07/13 20:28:36 dgp Exp $ -package require Tk 8.4 package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -namespace import -force tcltest::interpreter -eval tcltest::configure $argv - +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::interpreter # Compute a script that will load Tk into a child interpreter. diff --git a/tests/winWm.test b/tests/winWm.test index 5e81325..7f211bf 100644 --- a/tests/winWm.test +++ b/tests/winWm.test @@ -9,14 +9,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winWm.test,v 1.7 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: winWm.test,v 1.8 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -eval tcltest::configure $argv -foreach i [winfo children .] { - catch {destroy $i} -} +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 # Measure the height of a single menu line diff --git a/tests/window.test b/tests/window.test index 3b5ede6..1325fab 100644 --- a/tests/window.test +++ b/tests/window.test @@ -5,18 +5,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: window.test,v 1.5 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: window.test,v 1.6 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -eval tcltest::configure $argv - -foreach i [winfo children .] { - destroy $i -} -wm geometry . {} -raise . +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 + update # XXX This file is woefully incomplete. Right now it only tests diff --git a/tests/winfo.test b/tests/winfo.test index 1916cfa..89e6928 100644 --- a/tests/winfo.test +++ b/tests/winfo.test @@ -6,18 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winfo.test,v 1.7 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: winfo.test,v 1.8 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test -namespace import -force tcltest::testConstraint -eval tcltest::configure $argv - -foreach i [winfo children .] { - catch {destroy $i} -} -wm geometry . {} -raise . +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 the testwrapper command testConstraint testwrapper [llength [info commands testwrapper]] @@ -247,7 +243,7 @@ test winfo-9.5 {"winfo viewable" command} { list [winfo viewable .f1] [winfo viewable .f1.f2] } {1 1} test winfo-9.6 {"winfo viewable" command} { - eval destroy [winfo child .] + deleteWindows frame .f1 -width 100 -height 100 -relief raised -bd 2 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 place .f1.f2 -x 0 -y 0 @@ -255,7 +251,7 @@ test winfo-9.6 {"winfo viewable" command} { list [winfo viewable .f1] [winfo viewable .f1.f2] } {0 0} test winfo-9.7 {"winfo viewable" command} { - eval destroy [winfo child .] + deleteWindows frame .f1 -width 100 -height 100 -relief raised -bd 2 place .f1 -x 0 -y 0 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 @@ -265,7 +261,7 @@ test winfo-9.7 {"winfo viewable" command} { list [winfo viewable .f1] [winfo viewable .f1.f2] } {0 0} wm deiconify . -eval destroy [winfo child .] +deleteWindows test winfo-10.1 {"winfo visualid" command} { list [catch {winfo visualid} msg] $msg @@ -329,9 +325,7 @@ test winfo-13.2 {destroying embedded toplevel} { expr [winfo exists .emb.b] || [winfo exists .con] } 0 -foreach i [winfo children .] { - destroy $i -} +deleteWindows test winfo-13.3 {destroying container window} { MakeEmbed @@ -343,9 +337,7 @@ test winfo-13.3 {destroying container window} { set z } 0 -foreach i [winfo children .] { - destroy $i -} +deleteWindows test winfo-13.4 {[winfo containing] with embedded windows} { MakeEmbed @@ -381,11 +373,7 @@ test winfo-14.4 {mapped at idle time} { winfo ismapped .t } 1 - -foreach i [winfo children .] { - catch {destroy $i} -} - +deleteWindows # cleanup ::tcltest::cleanupTests return diff --git a/tests/wm.test b/tests/wm.test index 6c91e9d..6d576ea 100644 --- a/tests/wm.test +++ b/tests/wm.test @@ -7,23 +7,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: wm.test,v 1.14 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: wm.test,v 1.15 2002/07/13 20:28:36 dgp Exp $ # This file tests window manager interactions that work across # platforms. Window manager tests that only work on a specific # platform should be placed in unixWm.test or winWm.test. package require tcltest 2.1 -namespace import -force tcltest::test - -proc deleteWindows {} { - foreach i [winfo children .] { - destroy $i - } -} - - -deleteWindows +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 wm deiconify . if {![winfo ismapped .]} { diff --git a/tests/xmfbox.test b/tests/xmfbox.test index 8d7e221..7e5a1c1 100644 --- a/tests/xmfbox.test +++ b/tests/xmfbox.test @@ -10,13 +10,16 @@ # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. # -# RCS: @(#) $Id: xmfbox.test,v 1.6 2002/07/12 13:41:01 dgp Exp $ +# RCS: @(#) $Id: xmfbox.test,v 1.7 2002/07/13 20:28:36 dgp Exp $ package require tcltest 2.1 -namespace import -force tcltest::test +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 testPWD [pwd] -eval destroy [winfo children .] catch {unset foo} catch {unset data foo} |