From 92b5df1f4c8a5885e387c9f91b89b4ac70d00abd Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 12 Jul 2002 13:40:58 +0000 Subject: * Converted several files in the Tk test suite for testing by tcltest 2.1. --- ChangeLog | 7 ++ tests/canvPsImg.tcl | 4 +- tests/constraints.tcl | 104 +++++++++++++++++++ tests/unixButton.test | 53 +++++----- tests/unixEmbed.test | 96 +++++++++--------- tests/unixFont.test | 141 +++++++++++++------------- tests/unixMenu.test | 258 +++++++++++++++++++++++------------------------- tests/unixSelect.test | 21 ++-- tests/unixWm.test | 22 +++-- tests/util.test | 8 +- tests/visual.test | 8 +- tests/visual_bb.test | 27 +++-- tests/winButton.test | 8 +- tests/winClipboard.test | 13 +-- tests/winDialog.test | 13 ++- tests/winFont.test | 9 +- tests/winMenu.test | 9 +- tests/winSend.test | 167 +++++++++++++++---------------- tests/winWm.test | 9 +- tests/window.test | 12 +-- tests/winfo.test | 16 +-- tests/wm.test | 14 +-- tests/xmfbox.test | 10 +- unix/Makefile.in | 6 +- 24 files changed, 562 insertions(+), 473 deletions(-) create mode 100644 tests/constraints.tcl diff --git a/ChangeLog b/ChangeLog index 61cb31a..50f421b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2002-07-11 Don Porter + + * tests/canvPsImg.tcl: Converted several files in the + * tests/constraints.tcl (new file): Tk test suite for testing by + * tests/[u-x]*.test: tcltest 2.1. + * unix/Makefile.in: + 2002-07-11 Jeff Hobbs * win/tkWinDialog.c (Tk_ChooseDirectoryObjCmd): initialize diff --git a/tests/canvPsImg.tcl b/tests/canvPsImg.tcl index d460d03..054be90 100644 --- a/tests/canvPsImg.tcl +++ b/tests/canvPsImg.tcl @@ -2,7 +2,7 @@ # for images in canvases. It is part of the Tk visual test suite, # which is invoked via the "visual" script. # -# RCS: @(#) $Id: canvPsImg.tcl,v 1.1 1999/12/14 06:53:12 hobbs Exp $ +# RCS: @(#) $Id: canvPsImg.tcl,v 1.2 2002/07/12 13:40:59 dgp Exp $ # Build a test image in a canvas proc BuildTestImage {} { @@ -69,7 +69,7 @@ foreach l { monochrome gray color } { pack .t.$l -in .t.top.r -anchor w } -set BitmapImage [image create bitmap -file $tk_library/demos/images/face \ +set BitmapImage [image create bitmap -file $tk_library/demos/images/face.bmp \ -background white -foreground black] set PhotoImage [image create photo -file $tk_library/demos/images/teapot.ppm] diff --git a/tests/constraints.tcl b/tests/constraints.tcl new file mode 100644 index 0000000..a6c52da --- /dev/null +++ b/tests/constraints.tcl @@ -0,0 +1,104 @@ +package require Tcl 8.4 +package require Tk 8.4 +package require tcltest 2.1 +namespace import -force tcltest::testConstraint +testConstraint userInteraction 0 +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 { + if {[namespace exists test]} { + namespace delete test + } + namespace eval test { + namespace eval bg { + # Manage a background process. + # Replace with slave interp or thread? + namespace import ::tcltest::interpreter + namespace export setup cleanup do + + proc cleanup {} { + variable fd + catch { + puts $fd exit + close $fd + } + set fd "" + } + proc setup args { + variable fd + if {[info exists fd] && [string length $fd]} { + cleanup + } + set fd [open "|[list [interpreter] \ + -geometry +0+0 -name tktest] $args" r+] + puts $fd "puts foo; flush stdout" + flush $fd + if {[gets $fd data] < 0} { + error "unexpected EOF from \"[interpreter]\"" + } + if {$data ne "foo"} { + error "unexpected output from\ + background process: \"$data\"" + } + fileevent $fd readable [namespace code Ready] + } + proc Ready {} { + variable fd + variable Data + variable Done + set x [gets $fd] + if {[eof $fd]} { + fileevent $fd readable {} + set Done 1 + } elseif {$x eq "**DONE**"} { + set Done 1 + } else { + append Data $x + } + } + proc do {cmd} { + variable fd + variable Data + variable Done + puts $fd "[list catch $cmd msg]; update; puts \$msg;\ + puts **DONE**; flush stdout" + flush $fd + set Done 0 + set Data {} + vwait [namespace which -variable Done] + return $Data + } + } + + proc Export {internal as external} { + uplevel 1 [list namespace import $internal] + uplevel 1 [list rename [namespace tail $internal] $external] + uplevel 1 [list namespace export $external] + } + Export bg::setup as setupbg + Export bg::cleanup as cleanupbg + Export bg::do as dobg + } +} + +namespace import -force ::tk::test::* + diff --git a/tests/unixButton.test b/tests/unixButton.test index 6604e36..6b1bcbb 100644 --- a/tests/unixButton.test +++ b/tests/unixButton.test @@ -8,25 +8,17 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixButton.test,v 1.3 1999/04/16 01:51:41 stanton Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -if {$tcl_platform(platform)!="unix"} { - puts "skipping: Unix only tests..." - ::tcltest::cleanupTests - return -} - -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 -} +# RCS: @(#) $Id: unixButton.test,v 1.4 2002/07/12 13:40:59 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 +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 @@ -58,7 +50,6 @@ catch {unset value} catch {unset value2} eval image delete [image names] -image create test image1 label .l -text Label button .b -text Button checkbutton .c -text Checkbutton @@ -66,7 +57,7 @@ radiobutton .r -text Radiobutton pack .l .b .c .r update -test unixbutton-1.1 {TkpComputeButtonGeometry procedure} { +test unixbutton-1.1 {TkpComputeButtonGeometry procedure} {unix testImageType} { eval destroy [winfo children .] image create test image1 image1 changed 0 0 0 0 60 40 @@ -81,7 +72,7 @@ test unixbutton-1.1 {TkpComputeButtonGeometry procedure} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {68 48 74 54 112 52 112 52} -test unixbutton-1.2 {TkpComputeButtonGeometry procedure} { +test unixbutton-1.2 {TkpComputeButtonGeometry procedure} unix { eval destroy [winfo children .] label .b1 -bitmap question -bd 3 -padx 0 -pady 2 button .b2 -bitmap question -bd 3 -padx 0 -pady 2 @@ -94,7 +85,7 @@ test unixbutton-1.2 {TkpComputeButtonGeometry procedure} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {23 33 29 39 54 37 54 37} -test unixbutton-1.3 {TkpComputeButtonGeometry procedure} { +test unixbutton-1.3 {TkpComputeButtonGeometry procedure} unix { eval destroy [winfo children .] label .b1 -bitmap question -bd 3 -highlightthickness 4 button .b2 -bitmap question -bd 3 -highlightthickness 0 @@ -109,7 +100,7 @@ test unixbutton-1.3 {TkpComputeButtonGeometry procedure} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {31 41 25 35 25 35 25 35} -test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {nonPortable fonts} { +test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { eval destroy [winfo children .] label .b1 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold} button .b2 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold} @@ -122,21 +113,21 @@ test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {nonPortable fonts} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {82 29 88 35 114 31 121 29} -test unixbutton-1.5 {TkpComputeButtonGeometry procedure} {nonPortable fonts} { +test unixbutton-1.5 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { eval destroy [winfo children .] 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} {nonPortable fonts} { +test unixbutton-1.6 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { eval destroy [winfo children .] 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} {nonPortable fonts} { +test unixbutton-1.7 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { eval destroy [winfo children .] label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5 @@ -149,7 +140,7 @@ test unixbutton-1.7 {TkpComputeButtonGeometry procedure} {nonPortable fonts} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {74 22 60 84 168 38 61 22} -test unixbutton-1.8 {TkpComputeButtonGeometry procedure} {nonPortable fonts} { +test unixbutton-1.8 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { eval destroy [winfo children .] label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \ -highlightthickness 4 @@ -165,17 +156,17 @@ test unixbutton-1.8 {TkpComputeButtonGeometry procedure} {nonPortable fonts} { [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } {62 30 56 24 58 22 62 22} -test unixbutton-1.9 {TkpComputeButtonGeometry procedure} { +test unixbutton-1.9 {TkpComputeButtonGeometry procedure} unix { eval destroy [winfo children .] button .b2 -bitmap question -default active list [winfo reqwidth .b2] [winfo reqheight .b2] } {37 47} -test unixbutton-1.10 {TkpComputeButtonGeometry procedure} { +test unixbutton-1.10 {TkpComputeButtonGeometry procedure} unix { eval destroy [winfo children .] button .b2 -bitmap question -default normal list [winfo reqwidth .b2] [winfo reqheight .b2] } {37 47} -test unixbutton-1.11 {TkpComputeButtonGeometry procedure} { +test unixbutton-1.11 {TkpComputeButtonGeometry procedure} unix { eval destroy [winfo children .] button .b2 -bitmap question -default disabled list [winfo reqwidth .b2] [winfo reqheight .b2] diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index cbc7d96..851cba6 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -6,17 +6,17 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixEmbed.test,v 1.8 2001/03/28 17:27:10 dgp Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -if {$tcl_platform(platform) != "unix"} { - puts "skipping: Unix only tests..." - ::tcltest::cleanupTests - return -} +# RCS: @(#) $Id: unixEmbed.test,v 1.9 2002/07/12 13:40:59 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 +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 . {} @@ -65,15 +65,15 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} { && ([lindex $vals 2]/256 == $blue) } -test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} { +test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} unix { catch {destroy .t} list [catch {toplevel .t -use xyz} msg] $msg } {1 {expected integer but got "xyz"}} -test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} { +test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} unix { catch {destroy .t} list [catch {toplevel .t -use 47} msg] $msg } {1 {couldn't create child of window "47"}} -test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {nonPortable} { +test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {unix nonPortable} { catch {destroy .t} catch {destroy .x} toplevel .t -colormap new @@ -85,7 +85,7 @@ test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {nonPortable} { destroy .t set result } {0} -test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {nonPortable} { +test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {unix nonPortable} { catch {destroy .t} catch {destroy .t2} catch {destroy .x} @@ -98,15 +98,9 @@ test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {nonPortable} { set result } {1} -if {[string compare testembed [info commands testembed]] != 0} { - puts "This application hasn't been compiled with the testembed command," - puts "therefore I am skipping all of these tests." - cleanupbg - ::tcltest::cleanupTests - return -} +testConstraint testembed [llength [info commands testembed]] -test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} { +test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {unix testembed} { eval destroy [winfo child .] frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 @@ -118,7 +112,7 @@ test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} { list [testembed] [expr [lindex [lindex [testembed all] 0] 0] - $w] } } {{{XXX {} {} .t}} 0} -test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} { +test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} {unix testembed} { eval destroy [winfo child .] frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 @@ -132,7 +126,7 @@ test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} { testembed } } {{XXX {} {} .t2} {XXX {} {} .t1}} -test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} { +test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} {unix testembed} { eval destroy [winfo child .] frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 @@ -145,7 +139,7 @@ test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} # Can't think of any way to test the procedures TkpMakeWindow, # TkpMakeContainer, or EmbedErrorProc. -test unixEmbed-2.1 {EmbeddedEventProc procedure} { +test unixEmbed-2.1 {EmbeddedEventProc procedure} {unix testembed} { foreach w [winfo child .] { catch {destroy $w} } @@ -163,7 +157,7 @@ test unixEmbed-2.1 {EmbeddedEventProc procedure} { testembed } } {} -test unixEmbed-2.2 {EmbeddedEventProc procedure} { +test unixEmbed-2.2 {EmbeddedEventProc procedure} {unix testembed} { foreach w [winfo child .] { catch {destroy $w} } @@ -178,7 +172,7 @@ test unixEmbed-2.2 {EmbeddedEventProc procedure} { testembed } } {} -test unixEmbed-2.3 {EmbeddedEventProc procedure} { +test unixEmbed-2.3 {EmbeddedEventProc procedure} {unix testembed} { foreach w [winfo child .] { catch {destroy $w} } @@ -189,7 +183,7 @@ test unixEmbed-2.3 {EmbeddedEventProc procedure} { destroy .f1 testembed } {} -test unixEmbed-2.4 {EmbeddedEventProc procedure} { +test unixEmbed-2.4 {EmbeddedEventProc procedure} {unix testembed} { foreach w [winfo child .] { catch {destroy $w} } @@ -204,7 +198,7 @@ test unixEmbed-2.4 {EmbeddedEventProc procedure} { } {{{XXX .f1 {} {}}} {}} test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} \ - {nonPortable} { + {unix testembed nonPortable} { foreach w [winfo child .] { catch {destroy $w} } @@ -219,7 +213,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} { +test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -229,7 +223,7 @@ test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} { update wm geometry .t2 } {200x200+0+0} -test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} { +test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -247,7 +241,7 @@ test unixEmbed-3.2 {ContainerEventProc procedure, disallow position changes} { wm geometry .t1 } } {200x200+0+0} -test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} { +test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -265,7 +259,7 @@ test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} { wm geometry .t1 } } {300x100+0+0} -test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} { +test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -283,7 +277,7 @@ test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} { update list [winfo width .f1] [winfo height .f1] [dobg {wm geometry .t1}] } {300 80 300x80+0+0} -test unixEmbed-3.5 {ContainerEventProc procedure, map requests} { +test unixEmbed-3.5 {ContainerEventProc procedure, map requests} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -303,7 +297,7 @@ test unixEmbed-3.5 {ContainerEventProc procedure, map requests} { set x } } {mapped} -test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} { +test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -324,7 +318,7 @@ test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} { list $x [winfo exists .f1] } {dead 0} -test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} { +test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -344,7 +338,7 @@ test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} { winfo geometry .t1 } } {180x100+0+0} -test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} { +test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} {unix testembed} { foreach w [winfo child .] { catch {destroy $w} } @@ -361,7 +355,7 @@ test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} { list $x [testembed] } {{{XXX .f1 XXX {}}} {}} -test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} { +test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -379,7 +373,7 @@ test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} { update dobg {set x} } {{focus in .t1}} -test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} { +test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -398,7 +392,7 @@ test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} { focus -force .f1 update } {} -test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} { +test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -420,7 +414,7 @@ test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} { list $x [dobg {update; set x}] } {{{focus in .t1}} {{focus in .t1} {focus out .t1}}} -test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} { +test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -440,7 +434,7 @@ test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} { list $x [winfo geom .t1] } } {{{configure .t1 300 120}} 300x120+0+0} -test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} { +test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -464,7 +458,7 @@ test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} { # Can't think up any tests for TkpGetOtherWindow procedure. -test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} { +test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -489,7 +483,7 @@ test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} { bind . {} list $x $y } {{{key a 1}} {}} -test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} { +test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -517,7 +511,7 @@ test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width list $x $y } {{} {{key b}}} -test unixEmbed-8.1 {TkpClaimFocus procedure} { +test unixEmbed-8.1 {TkpClaimFocus procedure} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -540,7 +534,7 @@ test unixEmbed-8.1 {TkpClaimFocus procedure} { lappend x [focus] }] [focus] } {{{} .t1} .f1} -test unixEmbed-8.2 {TkpClaimFocus procedure} { +test unixEmbed-8.2 {TkpClaimFocus procedure} unix { catch {interp delete child} foreach w [winfo child .] { catch {destroy $w} @@ -565,7 +559,7 @@ test unixEmbed-8.2 {TkpClaimFocus procedure} { } {{{} .} .f1} catch {interp delete child} -test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} { +test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {unix testembed} { foreach w [winfo child .] { catch {destroy $w} } @@ -582,7 +576,7 @@ test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} { } 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} { +test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} {unix testembed} { foreach w [winfo child .] { catch {destroy $w} } @@ -599,7 +593,7 @@ test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} { } } {{{XXX {} {} .t1}} {}} -test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} { +test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix { foreach w [winfo child .] { catch {destroy $w} } @@ -611,7 +605,7 @@ test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} { update wm geometry .t1 } {150x80+0+0} -test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} { +test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix { foreach w [winfo child .] { catch {destroy $w} } diff --git a/tests/unixFont.test b/tests/unixFont.test index 34f0040..16d2bf8 100644 --- a/tests/unixFont.test +++ b/tests/unixFont.test @@ -12,33 +12,34 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixFont.test,v 1.5 2001/08/22 01:25:53 hobbs Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -if {$tcl_platform(platform) != "unix"} { - puts "skipping: Unix only tests..." - ::tcltest::cleanupTests - return -} - -set ::tcltest::testConfig(hasArial) 1 -set ::tcltest::testConfig(hasCourierNew) 1 -set ::tcltest::testConfig(hasTimesNew) 1 +# RCS: @(#) $Id: unixFont.test,v 1.6 2002/07/12 13:40:59 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 +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 +testConstraint hasTimesNew 1 set xlsf [auto_execok xlsfonts] -if {$xlsf != ""} { +if {[llength $xlsf]} { foreach {constraint font} { hasArial arial hasCourierNew "courier new" hasTimesNew "times new roman" } { - if {![catch {exec $xlsf *-$font-*} res] \ - && ![string match "*unmatched*" $res]} { - # Newer Unix systems have more default fonts installed, so we can't - # rely on fallbacks for fonts to need to fall back on anything. - set ::tcltest::testConfig($constraint) 0 + if {![catch {eval exec $xlsf [list *-$font-*]} res] + && ![string match *unmatched* $res]} { + # Newer Unix systems have more default fonts installed, + # so we can't rely on fallbacks for fonts to need to + # fall back on anything. + testConstraint $constraint 0 } } } @@ -69,58 +70,58 @@ proc getsize {} { return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" } -test unixfont-1.1 {TkpGetNativeFont procedure: not native} {noExceed} { +test unixfont-1.1 {TkpGetNativeFont procedure: not native} {unix noExceed} { list [catch {font measure {} xyz} msg] $msg } {1 {font "" doesn't exist}} -test unixfont-1.2 {TkpGetNativeFont procedure: native} { +test unixfont-1.2 {TkpGetNativeFont procedure: native} unix { font measure fixed 0 } {6} -test unixfont-2.1 {TkpGetFontFromAttributes procedure: no family} { +test unixfont-2.1 {TkpGetFontFromAttributes procedure: no family} unix { font actual {-size 10} set x {} } {} test unixfont-2.2 {TkpGetFontFromAttributes procedure: Times relatives} \ - {noExceed hasTimesNew} { + {unix noExceed hasTimesNew} { set x {} lappend x [lindex [font actual {-family "Times New Roman"}] 1] lappend x [lindex [font actual {-family "New York"}] 1] lappend x [lindex [font actual {-family "Times"}] 1] } {times times times} test unixfont-2.3 {TkpGetFontFromAttributes procedure: Courier relatives} \ - {noExceed hasCourierNew} { + {unix noExceed hasCourierNew} { set x {} lappend x [lindex [font actual {-family "Courier New"}] 1] lappend x [lindex [font actual {-family "Monaco"}] 1] lappend x [lindex [font actual {-family "Courier"}] 1] } {courier courier courier} test unixfont-2.4 {TkpGetFontFromAttributes procedure: Helvetica relatives} \ - {noExceed hasArial} { + {unix noExceed hasArial} { set x {} lappend x [lindex [font actual {-family "Arial"}] 1] lappend x [lindex [font actual {-family "Geneva"}] 1] lappend x [lindex [font actual {-family "Helvetica"}] 1] } {helvetica helvetica helvetica} -test unixfont-2.5 {TkpGetFontFromAttributes procedure: fallback} { +test unixfont-2.5 {TkpGetFontFromAttributes procedure: fallback} unix { font actual {-xyz-xyz-*-*-*-*-*-*-*-*-*-*-*-*} set x {} } {} -test unixfont-2.6 {TkpGetFontFromAttributes: fallback to fixed family} { +test unixfont-2.6 {TkpGetFontFromAttributes: fallback to fixed family} unix { lindex [font actual {-family fixed -size 10}] 1 } {fixed} -test unixfont-2.7 {TkpGetFontFromAttributes: fixed family not available!} { +test unixfont-2.7 {TkpGetFontFromAttributes: fixed family not available!} unix { # no test available } {} -test unixfont-2.8 {TkpGetFontFromAttributes: loop over returned font names} { +test unixfont-2.8 {TkpGetFontFromAttributes: loop over returned font names} unix { lindex [font actual {-family fixed -size 31}] 1 } {fixed} -test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} {noExceed} { +test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} {unix noExceed} { lindex [font actual {-family courier}] 1 } {courier} -test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} { +test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} unix { lindex [font actual {-family courier -size 37}] 3 } {37} -test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} { +test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} unix { # On Linux, XListFonts() was returning names for fonts that do not # actually exist, causing the subsequent XLoadQueryFont() to fail # unexpectedly. Now falls back to another font if that happens. @@ -129,114 +130,114 @@ test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} { set x {} } {} -test unixfont-3.1 {TkpDeleteFont procedure} { +test unixfont-3.1 {TkpDeleteFont procedure} unix { font actual {-family xyz} set x {} } {} -test unixfont-4.1 {TkpGetFontFamilies procedure} { +test unixfont-4.1 {TkpGetFontFamilies procedure} unix { font families set x {} } {} -test unixfont-5.1 {Tk_MeasureChars procedure: no chars to be measured} { +test unixfont-5.1 {Tk_MeasureChars procedure: no chars to be measured} unix { .b.l config -text "000000" -wrap [expr $ax*3] .b.l config -wrap 0 } {} -test unixfont-5.2 {Tk_MeasureChars procedure: no right margin} { +test unixfont-5.2 {Tk_MeasureChars procedure: no right margin} unix { .b.l config -text "000000" } {} -test unixfont-5.3 {Tk_MeasureChars procedure: loop over chars} { +test unixfont-5.3 {Tk_MeasureChars procedure: loop over chars} unix { .b.l config -text "0" .b.l config -text "\377" .b.l config -text "0\3770\377" .b.l config -text "000000000000000" } {} .b.l config -wrap [expr $ax*10] -test unixfont-5.4 {Tk_MeasureChars procedure: reached right edge} { +test unixfont-5.4 {Tk_MeasureChars procedure: reached right edge} unix { .b.l config -text "0000000000000" getsize } "[expr $ax*10] [expr $ay*2]" -test unixfont-5.5 {Tk_MeasureChars procedure: ran out of chars} { +test unixfont-5.5 {Tk_MeasureChars procedure: ran out of chars} unix { .b.l config -text "000000" getsize } "[expr $ax*6] $ay" -test unixfont-5.6 {Tk_MeasureChars procedure: find last word} { +test unixfont-5.6 {Tk_MeasureChars procedure: find last word} unix { .b.l config -text "000000 00000" getsize } "[expr $ax*6] [expr $ay*2]" -test unixfont-5.7 {Tk_MeasureChars procedure: already saw space in line} { +test unixfont-5.7 {Tk_MeasureChars procedure: already saw space in line} unix { .b.l config -text "000000 00000" getsize } "[expr $ax*6] [expr $ay*2]" -test unixfont-5.8 {Tk_MeasureChars procedure: internal spaces significant} { +test unixfont-5.8 {Tk_MeasureChars procedure: internal spaces significant} unix { .b.l config -text "00 000 00000" getsize } "[expr $ax*7] [expr $ay*2]" -test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} { +test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} unix { .b.c dchars $t 0 end .b.c insert $t 0 "0000" .b.c index $t @[expr int($ax*2.5)],1 } {2} -test unixfont-5.10 {Tk_MeasureChars procedure: TK_AT_LEAST_ONE} { +test unixfont-5.10 {Tk_MeasureChars procedure: TK_AT_LEAST_ONE} unix { .b.l config -text "000000000000" getsize } "[expr $ax*10] [expr $ay*2]" -test unixfont-5.11 {Tk_MeasureChars: TK_AT_LEAST_ONE + not even one char fit!} { +test unixfont-5.11 {Tk_MeasureChars: TK_AT_LEAST_ONE + not even one char fit!} unix { set a [.b.l cget -wrap] .b.l config -text "000000" -wrap 1 set x [getsize] .b.l config -wrap $a set x } "$ax [expr $ay*6]" -test unixfont-5.12 {Tk_MeasureChars procedure: include eol spaces} { +test unixfont-5.12 {Tk_MeasureChars procedure: include eol spaces} unix { .b.l config -text "000 \n000" getsize } "[expr $ax*6] [expr $ay*2]" -test unixfont-6.1 {Tk_DrawChars procedure: loop test} { +test unixfont-6.1 {Tk_DrawChars procedure: loop test} unix { .b.l config -text "a" update } {} -test unixfont-6.2 {Tk_DrawChars procedure: loop test} { +test unixfont-6.2 {Tk_DrawChars procedure: loop test} unix { .b.l config -text "abcd" update } {} -test unixfont-6.3 {Tk_DrawChars procedure: special char} { +test unixfont-6.3 {Tk_DrawChars procedure: special char} unix { .b.l config -text "\001" update } {} -test unixfont-6.4 {Tk_DrawChars procedure: normal then special} { +test unixfont-6.4 {Tk_DrawChars procedure: normal then special} unix { .b.l config -text "ab\001" update } {} -test unixfont-6.5 {Tk_DrawChars procedure: ends with special} { +test unixfont-6.5 {Tk_DrawChars procedure: ends with special} unix { .b.l config -text "ab\001" update } {} -test unixfont-6.6 {Tk_DrawChars procedure: more normal chars at end} { +test unixfont-6.6 {Tk_DrawChars procedure: more normal chars at end} unix { .b.l config -text "ab\001def" update } {} -test unixfont-7.1 {DrawChars procedure: no effects} { +test unixfont-7.1 {DrawChars procedure: no effects} unix { .b.l config -text "abc" update } {} -test unixfont-7.2 {DrawChars procedure: underlining} { +test unixfont-7.2 {DrawChars procedure: underlining} unix { set f [.b.l cget -font] .b.l config -text "abc" -font "courier 10 underline" update .b.l config -font $f } {} -test unixfont-7.3 {DrawChars procedure: overstrike} { +test unixfont-7.3 {DrawChars procedure: overstrike} unix { set f [.b.l cget -font] .b.l config -text "abc" -font "courier 10 overstrike" update .b.l config -font $f } {} -test unixfont-8.1 {AllocFont procedure: use old font} { +test unixfont-8.1 {AllocFont procedure: use old font} unix { font create xyz button .c -font xyz font configure xyz -family times @@ -244,10 +245,10 @@ test unixfont-8.1 {AllocFont procedure: use old font} { destroy .c font delete xyz } {} -test unixfont-8.2 {AllocFont procedure: parse information from XLFD} { +test unixfont-8.2 {AllocFont procedure: parse information from XLFD} unix { expr {[lindex [font actual {-family times -size 0}] 3] == 0} } {0} -test unixfont-8.3 {AllocFont procedure: can't parse info from name} { +test unixfont-8.3 {AllocFont procedure: can't parse info from name} unix { catch {unset fontArray} # check that font actual returns the correct attributes. # the values of those attributes are system dependent. @@ -256,7 +257,7 @@ test unixfont-8.3 {AllocFont procedure: can't parse info from name} { catch {unset fontArray} set result } {-family -overstrike -size -slant -underline -weight} -test unixfont-8.4 {AllocFont procedure: classify characters} { +test unixfont-8.4 {AllocFont procedure: classify characters} unix { set x 0 incr x [font measure $courier "\u4000"] ;# 6 incr x [font measure $courier "\002"] ;# 4 @@ -264,38 +265,38 @@ test unixfont-8.4 {AllocFont procedure: classify characters} { incr x [font measure $courier "\101"] ;# 1 set x } [expr $cx*13] -test unixfont-8.5 {AllocFont procedure: setup widths of normal chars} { +test unixfont-8.5 {AllocFont procedure: setup widths of normal chars} unix { font metrics $courier -fixed } {1} -test unixfont-8.6 {AllocFont procedure: setup widths of special chars} { +test unixfont-8.6 {AllocFont procedure: setup widths of special chars} unix { set x 0 incr x [font measure $courier "\001"] ;# 4 incr x [font measure $courier "\002"] ;# 4 incr x [font measure $courier "\012"] ;# 2 set x } [expr $cx*10] -test unixfont-8.7 {AllocFont procedure: XA_UNDERLINE_POSITION} { +test unixfont-8.7 {AllocFont procedure: XA_UNDERLINE_POSITION} unix { catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1} set x {} } {} -test unixfont-8.8 {AllocFont procedure: no XA_UNDERLINE_POSITION} { +test unixfont-8.8 {AllocFont procedure: no XA_UNDERLINE_POSITION} unix { catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific} set x {} } {} -test unixfont-8.9 {AllocFont procedure: XA_UNDERLINE_THICKNESS} { +test unixfont-8.9 {AllocFont procedure: XA_UNDERLINE_THICKNESS} unix { catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1} set x {} } {} -test unixfont-8.10 {AllocFont procedure: no XA_UNDERLINE_THICKNESS} { +test unixfont-8.10 {AllocFont procedure: no XA_UNDERLINE_THICKNESS} unix { catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific} set x {} } {} -test unixfont-8.11 {AllocFont procedure: XA_UNDERLINE_POSITION was 0} { +test unixfont-8.11 {AllocFont procedure: XA_UNDERLINE_POSITION was 0} unix { catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1} set x {} } {} -test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} { +test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} unix { .b.c dchars $t 0 end .b.c insert $t 0 "0\a0" set x {} @@ -304,7 +305,7 @@ test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} { lappend x [.b.c index $t @[expr $ax*2],0] lappend x [.b.c index $t @[expr $ax*3],0] } {0 1 1 2} -test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} { +test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} unix { .b.c dchars $t 0 end .b.c insert $t 0 "0\0010" set x {} diff --git a/tests/unixMenu.test b/tests/unixMenu.test index fe67be6..ed4a048 100644 --- a/tests/unixMenu.test +++ b/tests/unixMenu.test @@ -7,25 +7,17 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixMenu.test,v 1.5 2001/08/01 16:21:12 dgp Exp $ +# RCS: @(#) $Id: unixMenu.test,v 1.6 2002/07/12 13:41:00 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -if {$tcl_platform(platform) != "unix"} { - puts "skipping: Unix only tests..." - ::tcltest::cleanupTests - return -} - -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 -} +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 +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 .] { @@ -37,11 +29,11 @@ deleteWindows wm geometry . {} raise . -test unixMenu-1.1 {TkpNewMenu - normal menu} { +test unixMenu-1.1 {TkpNewMenu - normal menu} unix { catch {destroy .m1} list [catch {menu .m1} msg] $msg [destroy .m1] } {0 .m1 {}} -test unixMenu-1.2 {TkpNewMenu - help menu} { +test unixMenu-1.2 {TkpNewMenu - help menu} unix { catch {destroy .m1} menu .m1 -tearoff 0 . configure -menu .m1 @@ -52,13 +44,13 @@ test unixMenu-1.2 {TkpNewMenu - help menu} { test unixMenu-2.1 {TkpDestroyMenu - nothing to do} {} {} test unixMenu-3.1 {TkpDestroymenuEntry - nothing to do} {} {} -test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} { +test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label test list [catch {.m1 entryconfigure test -label foo} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} { +test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -menu .m2 -label test @@ -68,14 +60,14 @@ test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} { test unixMenu-5.1 {TkpMenuNewEntry - nothing to do} {} {} -test unixMenu-6.1 {TkpSetWindowMenuBar - null menu} { +test unixMenu-6.1 {TkpSetWindowMenuBar - null menu} unix { catch {destroy .m1} menu .m1 .m1 add cascade -label foo . configure -menu .m1 list [catch {. configure -menu ""} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-6.2 {TkpSetWindowMenuBar - menu} { +test unixMenu-6.2 {TkpSetWindowMenuBar - menu} unix { catch {destroy .m1} menu .m1 .m1 add cascade -label foo @@ -84,19 +76,19 @@ test unixMenu-6.2 {TkpSetWindowMenuBar - menu} { test unixMenu-7.1 {TkpSetMainMenubar - nothing to do} {} {} -test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} { +test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} unix { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo -indicatoron 0 list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-8.2 {GetMenuIndicatorGeometry - not checkbutton or radio} { +test unixMenu-8.2 {GetMenuIndicatorGeometry - not checkbutton or radio} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} { +test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} {unix testImageType} { catch {destroy .m1} catch {image delete image1} menu .m1 @@ -105,21 +97,21 @@ test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} { .m1 invoke foo list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] [image delete image1] } {0 {} {}} -test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} { +test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} unix { catch {destroy .m1} menu .m1 .m1 add checkbutton -bitmap questhead -label foo .m1 invoke foo list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-8.5 {GetMenuIndicatorGeometry - checkbutton} { +test unixMenu-8.5 {GetMenuIndicatorGeometry - checkbutton} unix { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo .m1 invoke foo list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} { +test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} {unix testImageType} { catch {destroy .m1} catch {image delete image1} menu .m1 @@ -128,21 +120,21 @@ test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} { .m1 invoke foo list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] [image delete image1] } {0 {} {}} -test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} { +test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} unix { catch {destroy .m1} menu .m1 .m1 add radiobutton -bitmap questhead -label foo .m1 invoke foo list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} { +test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} unix { catch {destroy .m1} menu .m1 .m1 add radiobutton -label foo .m1 invoke foo list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} { +test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} unix { catch {destroy .m1} menu .m1 .m1 add radiobutton -label foo -hidemargin 1 @@ -150,26 +142,26 @@ test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} { list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} { +test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} unix { catch {destroy .m1} menu .m1 .m1 add cascade -label foo list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-9.2 {GetMenuAccelGeometry - non-null label} { +test unixMenu-9.2 {GetMenuAccelGeometry - non-null label} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo -accel "Ctrl+S" list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-9.3 {GetMenuAccelGeometry - null label} { +test unixMenu-9.3 {GetMenuAccelGeometry - null label} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} { +test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} unix { catch {destroy .m1} menu .m1 .m1 add cascade -label foo @@ -177,7 +169,7 @@ test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} { .m1 activate 1 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-10.2 {DrawMenuEntryBackground - active} { +test unixMenu-10.2 {DrawMenuEntryBackground - active} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -185,7 +177,7 @@ test unixMenu-10.2 {DrawMenuEntryBackground - active} { $tearoff activate 0 list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-10.3 {DrawMenuEntryBackground - non-active} { +test unixMenu-10.3 {DrawMenuEntryBackground - non-active} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -193,7 +185,7 @@ test unixMenu-10.3 {DrawMenuEntryBackground - non-active} { list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} { +test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo -accel "Ctrl+U" @@ -201,21 +193,21 @@ test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} { list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} # drawArrow parameter is never false under Unix -test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} { +test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} unix { catch {destroy .m1} menu .m1 .m1 add cascade -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} { +test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo -accel "Ctrl+U" set tearoff [tk::TearOffMenu .m1 40 40] list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} { +test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -223,28 +215,28 @@ test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} { list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} { +test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} { +test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} unix { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo -indicatoron 0 set tearoff [tk::TearOffMenu .m1 40 40] list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} { +test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} unix { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} { +test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} unix { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo @@ -252,21 +244,21 @@ test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} { set tearoff [tk::TearOffMenu .m1 40 40] list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} { +test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} unix { catch {destroy .m1} menu .m1 .m1 add radiobutton -label foo -indicatoron 0 set tearoff [tk::TearOffMenu .m1 40 40] list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} { +test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} unix { catch {destroy .m1} menu .m1 .m1 add radiobutton -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} { +test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} unix { catch {destroy .m1} menu .m1 .m1 add radiobutton -label foo @@ -275,14 +267,14 @@ test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} { list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-13.1 {DrawMenuSeparator - menubar case} { +test unixMenu-13.1 {DrawMenuSeparator - menubar case} unix { catch {destroy .m1} menu .m1 .m1 add separator . configure -menu .m1 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-13.2 {DrawMenuSepartor - normal menu} { +test unixMenu-13.2 {DrawMenuSepartor - normal menu} unix { catch {destroy .m1} menu .m1 .m1 add separator @@ -290,7 +282,7 @@ test unixMenu-13.2 {DrawMenuSepartor - normal menu} { list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-14.1 {DrawMenuEntryLabel} { +test unixMenu-14.1 {DrawMenuEntryLabel} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -298,14 +290,14 @@ test unixMenu-14.1 {DrawMenuEntryLabel} { list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-15.1 {DrawMenuUnderline - menubar} { +test unixMenu-15.1 {DrawMenuUnderline - menubar} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo -underline 0 . configure -menu .m1 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-15.2 {DrawMenuUnderline - no menubar} { +test unixMenu-15.2 {DrawMenuUnderline - no menubar} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo -underline 0 @@ -313,21 +305,21 @@ test unixMenu-15.2 {DrawMenuUnderline - no menubar} { list [catch {update} msg] $msg [destroy .m1] } {0 {} {}} -test unixMenu-16.1 {TkpPostMenu} { +test unixMenu-16.1 {TkpPostMenu} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-17.1 {GetMenuSeparatorGeometry} { +test unixMenu-17.1 {GetMenuSeparatorGeometry} unix { catch {destroy .m1} menu .m1 .m1 add separator list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] } {0 {}} -test unixMenu-18.1 {GetTearoffEntryGeometry} { +test unixMenu-18.1 {GetTearoffEntryGeometry} unix { catch {destroy .m1} menubutton .mb -text "test" -menu .mb.m menu .mb.m @@ -338,42 +330,42 @@ test unixMenu-18.1 {GetTearoffEntryGeometry} { } {0 {} {} {}} # Don't know how to reproduce the case where the tkwin has been deleted. -test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} { +test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} unix { catch {destroy .m1} menu .m1 . configure -menu .m1 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} # Don't know how to generate one width windows -test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} { +test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} unix { catch {destroy .m1} menu .m1 .m1 add cascade -label File . configure -menu .m1 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} { +test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} unix { catch {destroy .m1} menu .m1 -font "Courier 24" .m1 add cascade -label File -font "Helvetica 18" . configure -menu .m1 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} { +test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} unix { catch {destroy .m1} menu .m1 .m1 add separator . configure -menu .m1 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} { +test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label File . configure -menu .m1 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} { +test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label File -font "Times 72" @@ -381,7 +373,7 @@ test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} { wm geometry . 10x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} { +test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label File @@ -390,7 +382,7 @@ test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} { wm geometry . 200x200 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} { +test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label File @@ -399,7 +391,7 @@ test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} { wm geometry . 100x100 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} { +test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label File -font "Times 72" @@ -408,7 +400,7 @@ test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} { wm geometry . 100x100 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} { +test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} unix { catch {destroy .m1} menu .m1 -tearoff 0 -font "Times 72" .m1 add cascade -label File @@ -419,7 +411,7 @@ test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} { } {0 {} {} {}} # ABC notation; capital A means first window fits, small a means it # does not. capital B menu means second window fist, etc. -test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} { +test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} unix { catch {destroy .m1} menu .m1 -tearoff 0 -font "Times 72" .m1 add cascade -label "aaaaa" @@ -429,7 +421,7 @@ test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} { wm geometry . 10x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} { +test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label "aaaaa" -font "Times 72" @@ -439,7 +431,7 @@ test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} { wm geometry . 10x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} { +test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label "aaaaa" -font "Times 72" @@ -449,7 +441,7 @@ test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} { wm geometry . 10x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} { +test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label "aaaaa" -font "Times 72" @@ -459,7 +451,7 @@ test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} { wm geometry . 60x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} { +test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label "A" @@ -469,7 +461,7 @@ test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} { wm geometry . 60x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} { +test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label "A" @@ -479,7 +471,7 @@ test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} { wm geometry . 60x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} { +test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label "A" @@ -489,7 +481,7 @@ test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} { wm geometry . 60x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} { +test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label "A" @@ -499,7 +491,7 @@ test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} { wm geometry . 100x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} { +test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label Help -menu .m1.help @@ -512,7 +504,7 @@ test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} { wm geometry . 100x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} { +test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label Edit -menu .m1.edit @@ -525,7 +517,7 @@ test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} { wm geometry . 100x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} { +test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label File -menu .m1.file @@ -538,7 +530,7 @@ test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} { wm geometry . 100x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} { +test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label File -menu .m1.file @@ -549,7 +541,7 @@ test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} { wm geometry . 100x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} { +test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label File -menu .m1.file @@ -560,7 +552,7 @@ test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} { wm geometry . 100x10 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} { +test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label Help -menu .m1.help @@ -570,14 +562,14 @@ test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} { list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-20.1 {DrawTearoffEntry - menubar} { +test unixMenu-20.1 {DrawTearoffEntry - menubar} unix { catch {destroy .m1} menu .m1 .m1 add cascade -label File . configure -menu .m1 list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test unixMenu-20.2 {DrawTearoffEntry - non-menubar} { +test unixMenu-20.2 {DrawTearoffEntry - non-menubar} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -587,28 +579,28 @@ test unixMenu-20.2 {DrawTearoffEntry - non-menubar} { test unixMenu-21.1 {TkpInitializeMenuBindings - nothing to do} {} {} -test unixMenu-22.1 {SetHelpMenu - no menubars} { +test unixMenu-22.1 {SetHelpMenu - no menubars} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add cascade -label test -menu .m1.test list [catch {menu .m1.test} msg] $msg [destroy .m1] } {0 .m1.test {}} # Don't know how to automate missing tkwins -test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} { +test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} unix { catch {destroy .m1} menu .m1 -tearoff 0 . configure -menu .m1 .m1 add cascade -label .m1.file list [catch {menu .m1.file} msg] $msg [. configure -menu ""] [destroy .m1] } {0 .m1.file {} {}} -test unixMenu-22.3 {SetHelpMenu - menubar with help menu} { +test unixMenu-22.3 {SetHelpMenu - menubar with help menu} unix { catch {destroy .m1} menu .m1 -tearoff 0 . configure -menu .m1 .m1 add cascade -label .m1.help list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1] } {0 .m1.help {} {}} -test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} { +test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} unix { catch {destroy .m1} catch {destroy .t2} toplevel .t2 @@ -620,7 +612,7 @@ test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} { list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1] [destroy .t2] } {0 .m1.help {} {} {}} -test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} { +test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -628,7 +620,7 @@ test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} { +test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo -activeforeground red @@ -636,7 +628,7 @@ test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} { +test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} unix { catch {destroy .m1} menu .m1 set tk_strictMotif 1 @@ -645,42 +637,42 @@ test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] } {{} {} 0} -test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} { +test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} unix { catch {destroy .m1} menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled -background red set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} { +test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} unix { catch {destroy .m1} menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} { +test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} unix { catch {destroy .m1} menu .m1 -disabledforeground "" .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.7 {TkpDrawMenuEntry - gc for normal - custom entry} { +test unixMenu-23.7 {TkpDrawMenuEntry - gc for normal - custom entry} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo -foreground red set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.8 {TkpDrawMenuEntry - gc for normal} { +test unixMenu-23.8 {TkpDrawMenuEntry - gc for normal} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} { +test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} unix { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo -selectcolor orange @@ -688,7 +680,7 @@ test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} { set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} { +test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} unix { catch {destroy .m1} menu .m1 .m1 add checkbutton -label foo @@ -696,7 +688,7 @@ test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} { set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} { +test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo -activebackground green @@ -704,7 +696,7 @@ test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test unixMenu-23.12 {TkpDrawMenuEntry - border} { +test unixMenu-23.12 {TkpDrawMenuEntry - border} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -712,7 +704,7 @@ test unixMenu-23.12 {TkpDrawMenuEntry - border} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} { +test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} unix { catch {destroy .m1} set tk_strictMotif 1 menu .m1 @@ -721,7 +713,7 @@ test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] } {{} {} 0} -test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} { +test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo -activeforeground yellow @@ -729,7 +721,7 @@ test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test unixMenu-23.15 {TkpDrawMenuEntry - active border} { +test unixMenu-23.15 {TkpDrawMenuEntry - active border} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo @@ -737,35 +729,35 @@ test unixMenu-23.15 {TkpDrawMenuEntry - active border} { .m1 entryconfigure 1 -state active list [update] [destroy .m1] } {{} {}} -test unixMenu-23.16 {TkpDrawMenuEntry - font - custom entry} { +test unixMenu-23.16 {TkpDrawMenuEntry - font - custom entry} unix { catch {destroy .m1} menu .m1 .m1 add command -label foo -font "Helvectica 72" set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.17 {TkpDrawMenuEntry - font} { +test unixMenu-23.17 {TkpDrawMenuEntry - font} unix { catch {destroy .m1} menu .m1 -font "Courier 72" .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.18 {TkpDrawMenuEntry - separator} { +test unixMenu-23.18 {TkpDrawMenuEntry - separator} unix { catch {destroy .m1} menu .m1 .m1 add separator set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.19 {TkpDrawMenuEntry - standard} { +test unixMenu-23.19 {TkpDrawMenuEntry - standard} unix { catch {destroy .mb} menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} { +test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} unix { catch {destroy .m1} menu .m1 .m1 add cascade -label File -menu .m1.file @@ -775,7 +767,7 @@ test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} { set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.21 {TkpDrawMenuEntry - indicator} { +test unixMenu-23.21 {TkpDrawMenuEntry - indicator} unix { catch {destroy .m1} menu .m1 .m1 add checkbutton -label Foo @@ -783,7 +775,7 @@ test unixMenu-23.21 {TkpDrawMenuEntry - indicator} { set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } {{} {}} -test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} { +test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} unix { catch {destroy .m1} menu .m1 .m1 add checkbutton -label Foo -hidemargin 1 @@ -792,7 +784,7 @@ test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} { list [update] [destroy .m1] } {{} {}} -test unixMenu-24.1 {GetMenuLabelGeometry - image} { +test unixMenu-24.1 {GetMenuLabelGeometry - image} {testImageType unix} { catch {destroy .m1} catch {image delete image1} menu .m1 @@ -800,44 +792,44 @@ test unixMenu-24.1 {GetMenuLabelGeometry - image} { .m1 add command -image image1 list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} -test unixMenu-24.2 {GetMenuLabelGeometry - bitmap} { +test unixMenu-24.2 {GetMenuLabelGeometry - bitmap} unix { catch {destroy .m1} menu .m1 .m1 add command -bitmap questhead list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-24.3 {GetMenuLabelGeometry - no text} { +test unixMenu-24.3 {GetMenuLabelGeometry - no text} unix { catch {destroy .m1} menu .m1 .m1 add command list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-24.4 {GetMenuLabelGeometry - text} { +test unixMenu-24.4 {GetMenuLabelGeometry - text} unix { catch {destroy .m1} menu .m1 .m1 add command -label "This is a test." list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} { +test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} unix { catch {destroy .m1} menu .m1 list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} { +test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} unix { catch {destroy .m1} menu .m1 .m1 add command -label "one" list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} { +test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} unix { catch {destroy .m1} menu .m1 .m1 add command -label "one" .m1 add command -label "two" list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} { +test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} unix { catch {destroy .m1} menu .m1 .m1 add separator @@ -852,60 +844,60 @@ test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unixOnly} { catch {tk::MbPost .mb} list [update] [tk::MenuUnpost .mb.m] [destroy .mb] } {{} {} {}} -test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} { +test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} unix { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} { +test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} unix { catch {destroy .m1} menu .m1 -font "Helvetica 12" .m1 add command -label "test" -font "Courier 12" list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} { +test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} unix { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 add command -label "test test" list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} { +test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} unix { catch {destroy .m1} menu .m1 .m1 add command -label "test test" .m1 add command -label "test" list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} { +test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} unix { catch {destroy .m1} menu .m1 .m1 add command -label "test" -accel "Ctrl+S" list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} { +test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} unix { catch {destroy .m1} menu .m1 .m1 add command -label "test" -accel "1" .m1 add command -label "test" -accel "1 1" list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} { +test unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} unix { catch {destroy .m1} menu .m1 .m1 add command -label "test" -accel "1 1" .m1 add command -label "test" -accel "1" list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.13 {TkpComputeStandardMenuGeometry - indicator} { +test unixMenu-25.13 {TkpComputeStandardMenuGeometry - indicator} unix { catch {destroy .m1} menu .m1 .m1 add checkbutton -label test .m1 invoke 1 list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } { +test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } {unix testImageType} { catch {destroy .m1} catch {image delete image1} image create test image1 @@ -916,7 +908,7 @@ test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or e .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} -test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } {unixOnly} { +test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } {unixOnly testImageType} { catch {destroy .m1} catch {image delete image1} image create test image1 @@ -927,12 +919,12 @@ test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] } {{} {} {}} -test unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} { +test unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} unix { catch {destroy .m1} menu .m1 -tearoff 0 list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} { +test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} unix { catch {destroy .m1} menu .m1 .m1 add command -label one @@ -940,7 +932,7 @@ test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} { .m1 add command -label three -columnbreak 1 list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} { +test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label one @@ -948,7 +940,7 @@ test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} { .m1 add command -label three list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} { +test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label one @@ -959,7 +951,7 @@ test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} { .m1 add command -label six list [update idletasks] [destroy .m1] } {{} {}} -test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} { +test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} unix { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add checkbutton -label one -hidemargin 1 diff --git a/tests/unixSelect.test b/tests/unixSelect.test index c5ea280..84c4cc4 100644 --- a/tests/unixSelect.test +++ b/tests/unixSelect.test @@ -9,17 +9,16 @@ # 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.2 1999/07/09 02:10:07 stanton Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -if {$tcl_platform(platform) != "unix"} { - puts "skipping: Unix only tests..." - ::tcltest::cleanupTests - return -} +# RCS: @(#) $Id: unixSelect.test,v 1.3 2002/07/12 13:41:00 dgp Exp $ + +package require tcltest 2.1 +namespace import -force tcltest::test +namespace import -force tcltest::testsDirectory +namespace import -force tcltest::configure +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 .] diff --git a/tests/unixWm.test b/tests/unixWm.test index 64094fd..ddd641b 100644 --- a/tests/unixWm.test +++ b/tests/unixWm.test @@ -7,11 +7,17 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: unixWm.test,v 1.19 2002/06/22 10:13:26 hobbs Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +# RCS: @(#) $Id: unixWm.test,v 1.20 2002/07/12 13:41:00 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 +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands +eval configure $argv if {$tcl_platform(platform) != "unix"} { puts "skipping: Unix only tests..." @@ -2351,7 +2357,7 @@ test unixWm-59.1 {exit processing} { exit } close $fd - if {[catch {exec $::tcltest::tktest script -geometry 10x10+0+0} msg]} { + if {[catch {exec [interpreter] script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 @@ -2370,7 +2376,7 @@ test unixWm-59.2 {exit processing} { exit } close $fd - if {[catch {exec $::tcltest::tktest script -geometry 10x10+0+0} msg]} { + if {[catch {exec [interpreter] script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 @@ -2395,7 +2401,7 @@ test unixWm-59.3 {exit processing} { exit } close $fd - if {[catch {exec $::tcltest::tktest script -geometry 10x10+0+0} msg]} { + if {[catch {exec [interpreter] script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 diff --git a/tests/util.test b/tests/util.test index d3d5c91..bf89528 100644 --- a/tests/util.test +++ b/tests/util.test @@ -6,11 +6,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: util.test,v 1.3 1999/04/16 01:51:42 stanton Exp $ +# RCS: @(#) $Id: util.test,v 1.4 2002/07/12 13:41:00 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::test +eval tcltest::configure $argv foreach i [winfo children .] { destroy $i diff --git a/tests/visual.test b/tests/visual.test index 8614c2d..6863abf 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -7,11 +7,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: visual.test,v 1.3 1999/04/16 01:51:43 stanton Exp $ +# RCS: @(#) $Id: visual.test,v 1.4 2002/07/12 13:41:01 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::test +eval tcltest::configure $argv foreach i [winfo children .] { destroy $i diff --git a/tests/visual_bb.test b/tests/visual_bb.test index a113e3e..480026c 100644 --- a/tests/visual_bb.test +++ b/tests/visual_bb.test @@ -6,11 +6,18 @@ # 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.4 2002/07/11 13:01:31 dkf Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +# RCS: @(#) $Id: visual_bb.test,v 1.5 2002/07/12 13:41:01 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 +configure -testdir [file join [pwd] [file dirname [info script]]] +configure -loadfile [file join [testsDirectory] constraints.tcl] +tcltest::loadTestedCommands +eval configure $argv set auto_path ". $auto_path" wm title . "Visual Tests for Tk" @@ -23,7 +30,7 @@ proc runTest {file} { global testNum test "2.$testNum" "testing $file" {userInteraction} { - uplevel \#0 source [file join $::tcltest::testsDir $file] + uplevel \#0 source [file join [testsDirectory] $file] concat "" } {} incr testNum @@ -56,7 +63,7 @@ test 1.1 "running visual tests" {userInteraction} { menubutton .menu.file -text "File" -menu .menu.file.m menu .menu.file.m - .menu.file.m add command -label "Quit" -command ::tcltest::cleanupTests + .menu.file.m add command -label "Quit" -command cleanupTests menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m menu .menu.group1.m @@ -79,7 +86,7 @@ test 1.1 "running visual tests" {userInteraction} { .menu.ps.m add command -label "Bitmaps" \ -command {runTest canvPsBmap.tcl} .menu.ps.m add command -label "Images" \ - -command {source canvPsImg.tcl} + -command {runTest canvPsImg.tcl} .menu.ps.m add command -label "Arcs" \ -command {runTest canvPsArc.tcl} @@ -102,6 +109,6 @@ test 1.1 "running visual tests" {userInteraction} { concat "" } {} -if {!$::tcltest::testConfig(userInteraction)} { - ::tcltest::cleanupTests +if {![testConstraint userInteraction]} { + cleanupTests } diff --git a/tests/winButton.test b/tests/winButton.test index 0a0c5d0..0d890ca 100644 --- a/tests/winButton.test +++ b/tests/winButton.test @@ -8,11 +8,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winButton.test,v 1.6 2001/12/29 00:30:30 hobbs Exp $ +# RCS: @(#) $Id: winButton.test,v 1.7 2002/07/12 13:41:01 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::test +eval tcltest::configure $argv if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\"" diff --git a/tests/winClipboard.test b/tests/winClipboard.test index 73aaaef..078a2be 100644 --- a/tests/winClipboard.test +++ b/tests/winClipboard.test @@ -10,17 +10,18 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winClipboard.test,v 1.9 2001/09/21 20:38:18 hobbs Exp $ +# RCS: @(#) $Id: winClipboard.test,v 1.10 2002/07/12 13:41:01 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::test +namespace import -force tcltest::testConstraint +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) -set ::tcltest::testConfig(testclipboard) \ - [llength [info commands testclipboard]] +testConstraint testclipboard [llength [info commands testclipboard]] test winClipboard-1.1 {TkSelGetSelection} {pcOnly} { clipboard clear diff --git a/tests/winDialog.test b/tests/winDialog.test index 62c1c8a..bebfe08 100644 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -6,14 +6,13 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 1998-1999 ActiveState Corporation. # -# RCS: @(#) $Id: winDialog.test,v 1.7 2001/09/21 20:38:18 hobbs Exp $ +# RCS: @(#) $Id: winDialog.test,v 1.8 2002/07/12 13:41:01 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -set ::tcltest::testConfig(testwinevent) \ - [llength [info commands testwinevent]] +package require tcltest 2.1 +namespace import -force tcltest::test +namespace import -force tcltest::testConstraint +eval tcltest::configure $argv +testConstraint testwinevent [llength [info commands testwinevent]] catch {testwinevent debug 1} diff --git a/tests/winFont.test b/tests/winFont.test index ca19cd0..0341d86 100644 --- a/tests/winFont.test +++ b/tests/winFont.test @@ -10,12 +10,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winFont.test,v 1.6 2001/09/21 20:38:18 hobbs Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +# RCS: @(#) $Id: winFont.test,v 1.7 2002/07/12 13:41:01 dgp Exp $ +package require tcltest 2.1 +namespace import -force tcltest::test +eval tcltest::configure $argv catch {destroy .b} catch {font delete xyz} diff --git a/tests/winMenu.test b/tests/winMenu.test index fe4d90a..afa5ca0 100644 --- a/tests/winMenu.test +++ b/tests/winMenu.test @@ -7,12 +7,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winMenu.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] -} +# RCS: @(#) $Id: winMenu.test,v 1.5 2002/07/12 13:41:01 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" diff --git a/tests/winSend.test b/tests/winSend.test index 34819b5..04491df 100644 --- a/tests/winSend.test +++ b/tests/winSend.test @@ -7,23 +7,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winSend.test,v 1.2 1999/04/16 01:51:44 stanton Exp $ +# RCS: @(#) $Id: winSend.test,v 1.3 2002/07/12 13:41:01 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +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 -if {$tcl_platform(platform) != "windows"} { - puts "skipping: Windows only tests..." - ::tcltest::cleanupTests - return -} - -if {[info commands send] != "send"} { - puts "skipping: Unimplemented send command" - ::tcltest::cleanupTests - return -} foreach i [winfo children .] { destroy $i @@ -31,14 +23,6 @@ foreach i [winfo children .] { wm geometry . {} raise . -set currentInterps [winfo interps] - -if {[catch {exec tktest &}] == 1} { - puts "Could not run winSend.test because another instance of tktest could not be loaded." - ::tcltest::cleanupTests - return; -} - # Compute a script that will load Tk into a child interpreter. foreach pkg [info loaded] { @@ -61,86 +45,91 @@ proc newApp {name {safe {}}} { catch {eval $loadTk $name} } -# Wait until the child application has launched. +set currentInterps [winfo interps] +if {[testConstraint win] && [llength [info commands send]]} { -while {[llength [winfo interps]] == [llength $currentInterps]} { -} + if {[catch {exec [interpreter] &}] == 0} { -# Now find an interp to send to -set newInterps [winfo interps] -foreach interp $newInterps { - if {[lsearch -exact $currentInterps $interp] < 0} { - break - } -} + # Wait until the child application has launched. + while {[llength [winfo interps]] == [llength $currentInterps]} {} + + # Now find an interp to send to + set newInterps [winfo interps] + foreach interp $newInterps { + if {[lsearch -exact $currentInterps $interp] < 0} { + break + } + } -# Now we have found our interpreter we are going to send to. Make sure that -# it works first. -if {[catch {send $interp {console hide; update}}] == 1} { - puts "Could not send to child interpreter $interp" - ::tcltest::cleanupTests - return + # Now we have found our interpreter we are going to send to. + # Make sure that it works first. + testConstraint winSend [expr {[catch { + send $interp {console hide; update} + }] == 0}] + } } # setting up dde server is done when the first interp is created and # cannot be tested very easily. -test winSend-1.1 {Tk_SetAppName - changing name of interp} { +test winSend-1.1 {Tk_SetAppName - changing name of interp} winSend { newApp testApp list [testApp eval tk appname testApp2] [interp delete testApp] } {testApp2 {}} test winSend-1.2 {Tk_SetAppName - changing name - not front of linked list} { + winSend +} { newApp testApp newApp testApp2 list [testApp eval tk appname testApp3] [interp delete testApp] [interp delete testApp2] } {testApp3 {} {}} -test winSend-1.3 {Tk_SetAppName - unique name - no conflicts} { +test winSend-1.3 {Tk_SetAppName - unique name - no conflicts} winSend { newApp testApp list [testApp eval tk appname testApp] [interp delete testApp] } {testApp {}} -test winSend-1.4 {Tk_SetAppName - unique name - one conflict} { +test winSend-1.4 {Tk_SetAppName - unique name - one conflict} winSend { newApp testApp newApp foobar list [foobar eval tk appname testApp] [interp delete foobar] [interp delete testApp] } {{testApp #2} {} {}} -test winSend-1.5 {Tk_SetAppName - unique name - one conflict} { +test winSend-1.5 {Tk_SetAppName - unique name - one conflict} winSend { newApp testApp newApp foobar newApp blaz foobar eval tk appname testApp list [blaz eval tk appname testApp] [interp delete foobar] [interp delete testApp] [interp delete blaz] } {{testApp #3} {} {} {}} -test winSend-1.6 {Tk_SetAppName - safe interps} { +test winSend-1.6 {Tk_SetAppName - safe interps} winSend { newApp testApp -safe list [catch {testApp eval send testApp {set foo a}} msg] $msg [interp delete testApp] } {1 {invalid command name "send"} {}} -test winSend-2.1 {Tk_SendObjCmd - # of args} { +test winSend-2.1 {Tk_SendObjCmd - # of args} winSend { list [catch {send tktest} msg] $msg } {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} -test winSend-2.1 {Tk_SendObjCmd: arguments} { +test winSend-2.1 {Tk_SendObjCmd: arguments} winSend { list [catch {send -bogus tktest} msg] $msg } {1 {bad option "-bogus": must be -async, -displayof, or --}} -test winSend-2.1 {Tk_SendObjCmd: arguments} { +test winSend-2.1 {Tk_SendObjCmd: arguments} winSend { list [catch {send -async bogus foo} msg] $msg } {1 {no registered server named "bogus"}} -test winSend-2.1 {Tk_SendObjCmd: arguments} { +test winSend-2.1 {Tk_SendObjCmd: arguments} winSend { list [catch {send -displayof . bogus foo} msg] $msg } {1 {no registered server named "bogus"}} -test winSend-2.1 {Tk_SendObjCmd: arguments} { +test winSend-2.1 {Tk_SendObjCmd: arguments} winSend { list [catch {send -- -bogus foo} msg] $msg } {1 {no registered server named "-bogus"}} -test winSend-2.2 {Tk_SendObjCmd - sending to ourselves} { +test winSend-2.2 {Tk_SendObjCmd - sending to ourselves} winSend { list [send [tk appname] {set foo a}] } {a} -test winSend-2.3 {Tk_SendObjCmd - sending to ourselves in a different interpreter} { +test winSend-2.3 {Tk_SendObjCmd - sending to ourselves in a different interpreter} winSend { newApp testApp list [catch {send testApp {set foo b}} msg] $msg [interp delete testApp] } {0 b {}} -test winSend-2.4 {Tk_SendObjCmd - sending to ourselves in a different interp with errors} { +test winSend-2.4 {Tk_SendObjCmd - sending to ourselves in a different interp with errors} winSend { newApp testApp list [catch {send testApp {expr 2 / 0}} msg] $msg $errorCode $errorInfo [interp delete testApp] } "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr 2 / 0\"\n invoked from within\n\"send testApp {expr 2 / 0}\"} {}" -test winSend-2.5 {Tk_SendObjCmd - sending to another app async} { +test winSend-2.5 {Tk_SendObjCmd - sending to another app async} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -149,7 +138,7 @@ test winSend-2.5 {Tk_SendObjCmd - sending to another app async} { } list [catch {send -async $interp {set foo a}} msg] $msg } {0 {}} -test winSend-2.6 {Tk_SendObjCmd - sending to another app sync - no error} { +test winSend-2.6 {Tk_SendObjCmd - sending to another app sync - no error} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -158,7 +147,7 @@ test winSend-2.6 {Tk_SendObjCmd - sending to another app sync - no error} { } list [catch {send $interp {set foo a}} msg] $msg } {0 a} -test winSend-2.7 {Tk_SendObjCmd - sending to another app - error} { +test winSend-2.7 {Tk_SendObjCmd - sending to another app - error} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -168,22 +157,22 @@ test winSend-2.7 {Tk_SendObjCmd - sending to another app - error} { list [catch {send $interp {expr 2 / 0}} msg] $msg $errorCode $errorInfo } "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr 2 / 0\"\n invoked from within\n\"send \$interp {expr 2 / 0}\"}" -test winSend-3.1 {TkGetInterpNames} { +test winSend-3.1 {TkGetInterpNames} winSend { set origLength [llength $currentInterps] set newLength [llength [winfo interps]] expr {($newLength - 2) == $origLength} } {1} -test winSend-4.1 {DeleteProc - changing name of app} { +test winSend-4.1 {DeleteProc - changing name of app} winSend { newApp a list [a eval tk appname foo] [interp delete a] } {foo {}} -test winSend-4.2 {DeleteProc - normal} { +test winSend-4.2 {DeleteProc - normal} winSend { newApp a list [interp delete a] } {{}} -test winSend-5.1 {ExecuteRemoteObject - no error} { +test winSend-5.1 {ExecuteRemoteObject - no error} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -192,7 +181,7 @@ test winSend-5.1 {ExecuteRemoteObject - no error} { } list [send $interp {send [tk appname] {expr 2 / 1}}] } {2} -test winSend-5.2 {ExecuteRemoteObject - error} { +test winSend-5.2 {ExecuteRemoteObject - error} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -202,7 +191,7 @@ test winSend-5.2 {ExecuteRemoteObject - error} { list [catch {send $interp {send [tk appname] {expr 2 / 0}}} msg] $msg } {1 {divide by zero}} -test winSend-6.1 {SendDDEServer - XTYP_CONNECT} { +test winSend-6.1 {SendDDEServer - XTYP_CONNECT} winSend { set foo "Hello, World" set newInterps [winfo interps] foreach interp $newInterps { @@ -213,7 +202,7 @@ test winSend-6.1 {SendDDEServer - XTYP_CONNECT} { set command "dde request Tk [tk appname] foo" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 {Hello, World}} -test winSend-6.2 {SendDDEServer - XTYP_CONNECT_CONFIRM} { +test winSend-6.2 {SendDDEServer - XTYP_CONNECT_CONFIRM} winSend { set foo "Hello, World" set newInterps [winfo interps] foreach interp $newInterps { @@ -224,7 +213,7 @@ test winSend-6.2 {SendDDEServer - XTYP_CONNECT_CONFIRM} { set command "dde request Tk [tk appname] foo" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 {Hello, World}} -test winSend-6.3 {SendDDEServer - XTYP_DISCONNECT} { +test winSend-6.3 {SendDDEServer - XTYP_DISCONNECT} winSend { set foo "Hello, World" set newInterps [winfo interps] foreach interp $newInterps { @@ -235,7 +224,7 @@ test winSend-6.3 {SendDDEServer - XTYP_DISCONNECT} { set command "dde request Tk [tk appname] foo" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 {Hello, World}} -test winSend-6.4 {SendDDEServer - XTYP_REQUEST variable} { +test winSend-6.4 {SendDDEServer - XTYP_REQUEST variable} winSend { set foo "Hello, World" set newInterps [winfo interps] foreach interp $newInterps { @@ -246,7 +235,7 @@ test winSend-6.4 {SendDDEServer - XTYP_REQUEST variable} { set command "dde request Tk [tk appname] foo" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 {Hello, World}} -test winSend-6.5 {SendDDEServer - XTYP_REQUEST array} { +test winSend-6.5 {SendDDEServer - XTYP_REQUEST array} winSend { catch {unset foo} set foo(test) "Hello, World" set newInterps [winfo interps] @@ -258,7 +247,7 @@ test winSend-6.5 {SendDDEServer - XTYP_REQUEST array} { set command "dde request Tk [tk appname] foo(test)" list [catch "send \{$interp\} \{$command\}" msg] $msg [catch {unset foo}] } {0 {Hello, World} 0} -test winSend-6.6 {SendDDEServer - XTYP_REQUEST return results} { +test winSend-6.6 {SendDDEServer - XTYP_REQUEST return results} winSend { set foo 3 set newInterps [winfo interps] foreach interp $newInterps { @@ -269,7 +258,7 @@ test winSend-6.6 {SendDDEServer - XTYP_REQUEST return results} { set command "send [tk appname] {expr $foo + 1}" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 4} -test winSend-6.7 {SendDDEServer - XTYP_EXECUTE} { +test winSend-6.7 {SendDDEServer - XTYP_EXECUTE} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -279,7 +268,7 @@ test winSend-6.7 {SendDDEServer - XTYP_EXECUTE} { set command "send [tk appname] {expr 4 / 2}" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 2} -test winSend-6.8 {SendDDEServer - XTYP_WILDCONNECT} { +test winSend-6.8 {SendDDEServer - XTYP_WILDCONNECT} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -290,12 +279,12 @@ test winSend-6.8 {SendDDEServer - XTYP_WILDCONNECT} { list [catch "send \{$interp\} \{$command\}"] } {0} -test winSend-7.1 {DDEExitProc} { +test winSend-7.1 {DDEExitProc} winSend { newApp testApp list [interp delete testApp] } {{}} -test winSend-8.1 {SendDdeConnect} { +test winSend-8.1 {SendDdeConnect} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -305,38 +294,38 @@ test winSend-8.1 {SendDdeConnect} { list [send $interp {set tk foo}] } {foo} -test winSend-9.1 {SetDDEError} { +test winSend-9.1 {SetDDEError} winSend { list [catch {dde execute Tk foo {set foo hello}} msg] $msg } {1 {dde command failed}} -test winSend-10.1 {Tk_DDEObjCmd - wrong num args} { +test winSend-10.1 {Tk_DDEObjCmd - wrong num args} winSend { list [catch {dde} msg] $msg } {1 {wrong # args: should be "dde ?-async? serviceName topicName value"}} -test winSend-10.2 {Tk_DDEObjCmd - unknown subcommand} { +test winSend-10.2 {Tk_DDEObjCmd - unknown subcommand} winSend { list [catch {dde foo} msg] $msg } {1 {bad command "foo": must be execute, request, or services}} -test winSend-10.3 {Tk_DDEObjCmd - execute - wrong num args} { +test winSend-10.3 {Tk_DDEObjCmd - execute - wrong num args} winSend { list [catch {dde execute} msg] $msg } {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}} -test winSend-10.4 {Tk_DDEObjCmd - execute - wrong num args} { +test winSend-10.4 {Tk_DDEObjCmd - execute - wrong num args} winSend { list [catch {dde execute 3 4 5 6 7} msg] $msg } {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}} -test winSend-10.5 {Tk_DDEObjCmd - execute async - wrong num args} { +test winSend-10.5 {Tk_DDEObjCmd - execute async - wrong num args} winSend { list [catch {dde execute -async} msg] $msg } {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}} -test winSend-10.6 {Tk_DDEObjCmd - request - wrong num args} { +test winSend-10.6 {Tk_DDEObjCmd - request - wrong num args} winSend { list [catch {dde request} msg] $msg } {1 {wrong # args: should be "dde request serviceName topicName value"}} -test winSend-10.7 {Tk_DDEObjCmd - services wrong num args} { +test winSend-10.7 {Tk_DDEObjCmd - services wrong num args} winSend { list [catch {dde services} msg] $msg } {1 {wrong # args: should be "dde services serviceName topicName"}} -test winSend-10.8 {Tk_DDEObjCmd - null service name} { +test winSend-10.8 {Tk_DDEObjCmd - null service name} winSend { list [catch {dde services {} {tktest #2}}] } {0} -test winSend-10.9 {Tk_DDEObjCmd - null topic name} { +test winSend-10.9 {Tk_DDEObjCmd - null topic name} winSend { list [catch {dde services {Tk} {}}] } {0} -test winSend-10.10 {Tk_DDEObjCmd - execute - nothing to execute} { +test winSend-10.10 {Tk_DDEObjCmd - execute - nothing to execute} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -345,10 +334,10 @@ test winSend-10.10 {Tk_DDEObjCmd - execute - nothing to execute} { } list [catch {dde execute Tk $interp {}} msg] $msg } {1 {cannot execute null data}} -test winSend-10.11 {Tk_DDEObjCmd - execute - no such conversation} { +test winSend-10.11 {Tk_DDEObjCmd - execute - no such conversation} winSend { list [catch {dde execute Tk foo {set foo hello}} msg] $msg } {1 {dde command failed}} -test winSend-10.12 {Tk_DDEObjCmd - execute - async} { +test winSend-10.12 {Tk_DDEObjCmd - execute - async} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -357,7 +346,7 @@ test winSend-10.12 {Tk_DDEObjCmd - execute - async} { } list [catch {dde execute -async Tk $interp {set foo hello}} msg] $msg } {0 {}} -test winSend-10.13 {Tk_DDEObjCmd - execute} { +test winSend-10.13 {Tk_DDEObjCmd - execute} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -366,7 +355,7 @@ test winSend-10.13 {Tk_DDEObjCmd - execute} { } list [catch {dde execute Tk $interp {set foo goodbye}} msg] $msg } {0 {}} -test winSend-10.14 {Tk_DDEObjCmd - request - nothing to request} { +test winSend-10.14 {Tk_DDEObjCmd - request - nothing to request} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -375,7 +364,7 @@ test winSend-10.14 {Tk_DDEObjCmd - request - nothing to request} { } list [catch {dde request Tk $interp {}} msg] $msg } {1 {cannot request value of null data}} -test winSend-10.15 {Tk_DDEObjCmd - request - invalid interp} { +test winSend-10.15 {Tk_DDEObjCmd - request - invalid interp} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -384,7 +373,7 @@ test winSend-10.15 {Tk_DDEObjCmd - request - invalid interp} { } list [catch {dde request Tk foo foo} msg] $msg } {1 {dde command failed}} -test winSend-10.16 {Tk_DDEObjCmd - invalid variable} { +test winSend-10.16 {Tk_DDEObjCmd - invalid variable} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -394,7 +383,7 @@ test winSend-10.16 {Tk_DDEObjCmd - invalid variable} { send $interp {unset foo} list [catch {dde request Tk $interp foo} msg] $msg } {1 {remote server cannot handle this command}} -test winSend-10.17 {Tk_DDEObjCmd - valid variable} { +test winSend-10.17 {Tk_DDEObjCmd - valid variable} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { @@ -404,7 +393,7 @@ test winSend-10.17 {Tk_DDEObjCmd - valid variable} { send $interp {set foo winSend-10.17} list [catch {dde request Tk $interp foo} msg] $msg } {0 winSend-10.17} -test winSend-10.18 {Tk_DDEObjCmd - services} { +test winSend-10.18 {Tk_DDEObjCmd - services} winSend { set currentService [list Tk [tk appname]] list [catch {dde services Tk {}} msg] [expr [lsearch $msg $currentService] >= 0] } {0 1} diff --git a/tests/winWm.test b/tests/winWm.test index bc4a220..5e81325 100644 --- a/tests/winWm.test +++ b/tests/winWm.test @@ -9,12 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winWm.test,v 1.6 2002/06/24 20:34:40 mdejong Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} +# RCS: @(#) $Id: winWm.test,v 1.7 2002/07/12 13:41:01 dgp Exp $ +package require tcltest 2.1 +namespace import -force tcltest::test +eval tcltest::configure $argv foreach i [winfo children .] { catch {destroy $i} } diff --git a/tests/window.test b/tests/window.test index 2de63a0..3b5ede6 100644 --- a/tests/window.test +++ b/tests/window.test @@ -5,11 +5,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: window.test,v 1.4 1999/04/16 01:51:44 stanton Exp $ +# RCS: @(#) $Id: window.test,v 1.5 2002/07/12 13:41:01 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::test +namespace import -force tcltest::testConstraint +eval tcltest::configure $argv foreach i [winfo children .] { destroy $i @@ -80,8 +81,7 @@ test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} { } {} # Some tests require the testmenubar command -set ::tcltest::testConfig(testmenubar) \ - [expr {[info commands testmenubar] != {}}] +testConstraint testmenubar [llength [info commands testmenubar]] test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ {unixOnly testmenubar} { diff --git a/tests/winfo.test b/tests/winfo.test index a1344c9..1916cfa 100644 --- a/tests/winfo.test +++ b/tests/winfo.test @@ -6,11 +6,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: winfo.test,v 1.6 2002/06/14 07:17:53 mdejong Exp $ +# RCS: @(#) $Id: winfo.test,v 1.7 2002/07/12 13:41:01 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::test +namespace import -force tcltest::testConstraint +eval tcltest::configure $argv foreach i [winfo children .] { catch {destroy $i} @@ -19,8 +20,7 @@ wm geometry . {} raise . # Some tests require the testwrapper command -set ::tcltest::testConfig(testwrapper) \ - [expr {[info commands testwrapper] != {}}] +testConstraint testwrapper [llength [info commands testwrapper]] # eatColors -- # Creates a toplevel window and allocates enough colors in it to @@ -92,8 +92,8 @@ test winfo-2.7 {"winfo atom" command} { } SECONDARY # Some tests require the "pseudocolor" visual class. -set ::tcltest::testConfig(pseudocolor) \ - [expr {([winfo depth .] == 8) && ([winfo visual .] == "pseudocolor")}] +testConstraint pseudocolor [expr { ([winfo depth .] == 8) + && ([winfo visual .] == "pseudocolor")}] test winfo-3.1 {"winfo colormapfull" command} {pseudocolor} { list [catch {winfo colormapfull} msg] $msg diff --git a/tests/wm.test b/tests/wm.test index bc1bd1a..6c91e9d 100644 --- a/tests/wm.test +++ b/tests/wm.test @@ -7,15 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: wm.test,v 1.13 2002/06/24 20:34:40 mdejong Exp $ +# RCS: @(#) $Id: wm.test,v 1.14 2002/07/12 13:41:01 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. -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::test proc deleteWindows {} { foreach i [winfo children .] { @@ -26,7 +25,10 @@ proc deleteWindows {} { deleteWindows -wm deicon . +wm deiconify . +if {![winfo ismapped .]} { + tkwait visibility . +} test wm-stackorder-1.1 {usage} { list [catch {wm stackorder} err] $err @@ -808,7 +810,7 @@ test wm-deiconify-2.4 {invoking destroy after a deiconify deleteWindows - +tcltest::cleanupTests return diff --git a/tests/xmfbox.test b/tests/xmfbox.test index 8035e44..8d7e221 100644 --- a/tests/xmfbox.test +++ b/tests/xmfbox.test @@ -7,13 +7,13 @@ # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. +# Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. # -# RCS: @(#) $Id: xmfbox.test,v 1.5 2001/08/01 16:21:12 dgp Exp $ +# RCS: @(#) $Id: xmfbox.test,v 1.6 2002/07/12 13:41:01 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::test set testPWD [pwd] eval destroy [winfo children .] @@ -124,7 +124,7 @@ test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} {unixOnly} { $::tk::dialog::file::foo(sEnt) get } $testPWD/~nosuchuser1 -test xmfbox-2.5 {tk::MotifFDialog_ActivateFList, ~ in file names} {unixOnly} { +test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} {unixOnly} { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] diff --git a/unix/Makefile.in b/unix/Makefile.in index e67ef09..d3fddeb 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -5,7 +5,7 @@ # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.74 2002/07/08 22:08:49 davygrvy Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.75 2002/07/12 13:41:01 dgp Exp $ # Current Tk version; used in various names. @@ -442,7 +442,7 @@ xttest: test.o tkTest.o tkSquare.o $(TK_LIB_FILE) test: tktest TCL_LIBRARY=@TCL_SRC_DIR@/library; export TCL_LIBRARY; \ TK_LIBRARY=@TK_SRC_DIR@/library; export TK_LIBRARY; \ - ./tktest $(TOP_DIR)/tests/all.tcl -geometry +0+0 \ + ./tktest $(TOP_DIR)/tests/all.tcl -geometry +0+0 -match \* \ $(TESTFLAGS) $(TCLTESTARGS) # Tests with different languages @@ -452,7 +452,7 @@ testlang: tktest for lang in $(LOCALES) ; \ do \ LANG=$(lang); export LANG; \ - ./tktest $(TOP_DIR)/tests/all.tcl -geometry +0+0 \ + ./tktest $(TOP_DIR)/tests/all.tcl -geometry +0+0 -match \* \ $(TESTFLAGS) $(TCLTESTARGS); \ done -- cgit v0.12