diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/menu.test | 23 | ||||
| -rw-r--r-- | tests/select.test | 222 | ||||
| -rw-r--r-- | tests/send.test | 74 |
3 files changed, 157 insertions, 162 deletions
diff --git a/tests/menu.test b/tests/menu.test index 33995b0..a298e79 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -5,7 +5,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: menu.test,v 1.7 2001/08/01 16:21:12 dgp Exp $ +# RCS: @(#) $Id: menu.test,v 1.8 2001/08/30 01:51:42 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -24,6 +24,8 @@ set ::tcltest::testConfig(nonUnixUserInteraction) \ [expr {$::tcltest::testConfig(userInteraction) || \ $::tcltest::testConfig(unixOnly)}] +set ::tcltest::testConfig(altDisplay) [info exists env(TK_ALT_DISPLAY)] + proc deleteWindows {} { foreach i [winfo children .] { catch [destroy $i] @@ -2441,17 +2443,14 @@ test menu-33.1 {menu vs command hiding} { # creating menus on two different screens then deleting the # menu from the first screen crashes Tk8.3.1 # -test menu-35.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} { - if {[info exists ::env(TK_ALT_DISPLAY)]} { - toplevel .one - menu .one.m - toplevel .two -screen $::env(TK_ALT_DISPLAY) - menu .two.m - destroy .one - destroy .two - } else { - puts "skipping: Multi-screen tests requiring TK_ALT_DISPLAY..." - } +test menu-35.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} \ + {altDisplay} { + toplevel .one + menu .one.m + toplevel .two -screen $::env(TK_ALT_DISPLAY) + menu .two.m + destroy .one + destroy .two } {} # cleanup diff --git a/tests/select.test b/tests/select.test index 3682f28..9d48083 100644 --- a/tests/select.test +++ b/tests/select.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: select.test,v 1.6 2001/07/03 01:03:16 hobbs Exp $ +# RCS: @(#) $Id: select.test,v 1.7 2001/08/30 01:51:42 hobbs Exp $ # # Note: Multiple display selection handling will only be tested if the @@ -17,6 +17,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] } +set ::tcltest::testConfig(altDisplay) [info exists env(TK_ALT_DISPLAY)] + eval destroy [winfo child .] global longValue selValue selInfo @@ -333,27 +335,24 @@ test select-3.9 {Tk_OwnSelection procedure} { } {} # multiple display tests -if {[info exists env(TK_ALT_DISPLAY)]} { - - test select-3.10 {Tk_OwnSelection procedure} { - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) - list [selection own -displayof .f1] [selection own -displayof .f2] - } {.f1 .f2} - test select-3.11 {Tk_OwnSelection procedure} { - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) - setupbg - update - set result "" - lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] - lappend result [selection own -displayof .f1] \ +test select-3.10 {Tk_OwnSelection procedure} {altDisplay} { + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + list [selection own -displayof .f1] [selection own -displayof .f2] +} {.f1 .f2} +test select-3.11 {Tk_OwnSelection procedure} {altDisplay} { + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + setupbg + update + set result "" + lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] + lappend result [selection own -displayof .f1] \ [selection own -displayof .f2] - cleanupbg - set result - } {{} .f1 {}} + cleanupbg + set result +} {{} .f1 {}} -} ############################################################################## test select-4.1 {Tk_ClearSelection procedure} { @@ -387,38 +386,36 @@ test select-4.4 {Tk_ClearSelection procedure} {unixOnly} { } {{} {}} # multiple display tests -if {[info exists env(TK_ALT_DISPLAY)]} { - test select-4.5 {Tk_ClearSelection procedure} { - global lostSel lostSel2 - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) - set lostSel {owned} - set lostSel2 {owned2} - selection own -command { set lostSel {lost1} } .f1 - selection own -command { set lostSel2 {lost2} } .f2 - update - selection clear -displayof .f2 - update - list $lostSel $lostSel2 - } {owned lost2} - test select-4.6 {Tk_ClearSelection procedure} {unixOnly} { - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) - setupbg - set lostSel {owned} - set lostSel2 {owned2} - selection own -command { set lostSel {lost1} } .f1 - selection own -command { set lostSel2 {lost2} } .f2 - update - set result "" - lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] - lappend result [selection own -displayof .f1] \ +test select-4.5 {Tk_ClearSelection procedure} {altDisplay} { + global lostSel lostSel2 + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + set lostSel {owned} + set lostSel2 {owned2} + selection own -command { set lostSel {lost1} } .f1 + selection own -command { set lostSel2 {lost2} } .f2 + update + selection clear -displayof .f2 + update + list $lostSel $lostSel2 +} {owned lost2} +test select-4.6 {Tk_ClearSelection procedure} {unixOnly altDisplay} { + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + setupbg + set lostSel {owned} + set lostSel2 {owned2} + selection own -command { set lostSel {lost1} } .f1 + selection own -command { set lostSel2 {lost2} } .f2 + update + set result "" + lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] + lappend result [selection own -displayof .f1] \ [selection own -displayof .f2] $lostSel $lostSel2 - cleanupbg - set result - } {{} .f1 {} owned lost2} + cleanupbg + set result +} {{} .f1 {} owned lost2} -} ############################################################################## test select-5.1 {Tk_GetSelection procedure} { @@ -511,71 +508,70 @@ test select-5.10 {Tk_GetSelection procedure} {unixOnly} { } {{selection owner didn't respond} {}} # multiple display tests -if {[info exists env(TK_ALT_DISPLAY)]} { - test select-5.11 {Tk_GetSelection procedure} { - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) - selection handle -selection PRIMARY .f1 {handler TEST} TEST - selection handle -selection PRIMARY .f2 {handler TEST2} TEST - set selValue "Test value" - set selInfo "" - set result [list [selection get TEST] $selInfo] - set selValue "Test value2" - set selInfo "" - lappend result [selection get -displayof .f2 TEST] $selInfo - } {{Test value} {TEST 0 4000} {Test value2} {TEST2 0 4000}} - test select-5.12 {Tk_GetSelection procedure} { - global lostSel lostSel2 - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) - selection handle -selection PRIMARY .f1 {handler TEST} TEST - selection handle -selection PRIMARY .f2 {} TEST - set selValue "Test value" - set selInfo "" - set result [list [catch {selection get TEST} msg] $msg $selInfo] - set selValue "Test value2" - set selInfo "" - lappend result [catch {selection get -displayof .f2 TEST} msg] $msg \ + +test select-5.11 {Tk_GetSelection procedure} {altDisplay} { + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + selection handle -selection PRIMARY .f1 {handler TEST} TEST + selection handle -selection PRIMARY .f2 {handler TEST2} TEST + set selValue "Test value" + set selInfo "" + set result [list [selection get TEST] $selInfo] + set selValue "Test value2" + set selInfo "" + lappend result [selection get -displayof .f2 TEST] $selInfo +} {{Test value} {TEST 0 4000} {Test value2} {TEST2 0 4000}} +test select-5.12 {Tk_GetSelection procedure} {altDisplay} { + global lostSel lostSel2 + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + selection handle -selection PRIMARY .f1 {handler TEST} TEST + selection handle -selection PRIMARY .f2 {} TEST + set selValue "Test value" + set selInfo "" + set result [list [catch {selection get TEST} msg] $msg $selInfo] + set selValue "Test value2" + set selInfo "" + lappend result [catch {selection get -displayof .f2 TEST} msg] $msg \ $selInfo - } {0 {Test value} {TEST 0 4000} 1 {PRIMARY selection doesn't exist or form "TEST" not defined} {}} - test select-5.13 {Tk_GetSelection procedure} {unixOnly} { - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) - setupbg - selection handle -selection PRIMARY .f1 {handler TEST} TEST - selection own .f1 - selection handle -selection PRIMARY .f2 {handler TEST2} TEST - selection own .f2 - set selValue "Test value" - set selInfo "" - update - set result "" - lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"] - set selValue "Test value2" - lappend result [dobg "selection get TEST"] - cleanupbg - lappend result $selInfo - } {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}} - test select-5.14 {Tk_GetSelection procedure} {unixOnly} { - setup .f1 - setup .f2 $env(TK_ALT_DISPLAY) - setupbg - selection handle -selection PRIMARY .f1 {handler TEST} TEST - selection own .f1 - selection handle -selection PRIMARY .f2 {} TEST - selection own .f2 - set selValue "Test value" - set selInfo "" - update - set result "" - lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"] - set selValue "Test value2" - lappend result [dobg "selection get TEST"] - cleanupbg - lappend result $selInfo - } {{PRIMARY selection doesn't exist or form "TEST" not defined} {Test value2} {TEST 0 4000}} +} {0 {Test value} {TEST 0 4000} 1 {PRIMARY selection doesn't exist or form "TEST" not defined} {}} +test select-5.13 {Tk_GetSelection procedure} {unixOnly altDisplay} { + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + setupbg + selection handle -selection PRIMARY .f1 {handler TEST} TEST + selection own .f1 + selection handle -selection PRIMARY .f2 {handler TEST2} TEST + selection own .f2 + set selValue "Test value" + set selInfo "" + update + set result "" + lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"] + set selValue "Test value2" + lappend result [dobg "selection get TEST"] + cleanupbg + lappend result $selInfo +} {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}} +test select-5.14 {Tk_GetSelection procedure} {unixOnly altDisplay} { + setup .f1 + setup .f2 $env(TK_ALT_DISPLAY) + setupbg + selection handle -selection PRIMARY .f1 {handler TEST} TEST + selection own .f1 + selection handle -selection PRIMARY .f2 {} TEST + selection own .f2 + set selValue "Test value" + set selInfo "" + update + set result "" + lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection get -displayof .t TEST"] + set selValue "Test value2" + lappend result [dobg "selection get TEST"] + cleanupbg + lappend result $selInfo +} {{PRIMARY selection doesn't exist or form "TEST" not defined} {Test value2} {TEST 0 4000}} -} ############################################################################## test select-6.1 {Tk_SelectionCmd procedure} { diff --git a/tests/send.test b/tests/send.test index 816151e..c2263c2 100644 --- a/tests/send.test +++ b/tests/send.test @@ -7,12 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: send.test,v 1.3 1999/04/16 01:51:40 stanton Exp $ +# RCS: @(#) $Id: send.test,v 1.4 2001/08/30 01:51:42 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] } +# 'send' is only available on Unix... + if {$tcl_platform(platform) == "macintosh"} { puts "send is not available on the Mac - skipping tests" ::tcltest::cleanupTests @@ -29,6 +31,8 @@ if {[auto_execok xhost] == ""} { return } +set ::tcltest::testConfig(altDisplay) [info exists env(TK_ALT_DISPLAY)] + if {[info commands testsend] == "testsend"} { set gotTestCmds 1 } else { @@ -249,22 +253,20 @@ test send-8.1 {Tk_SendCmd procedure, options} { cleanupbg lappend result $a } {66 77} -if [info exists env(TK_ALT_DISPLAY)] { - test send-8.2 {Tk_SendCmd procedure, options} { - setupbg -display $env(TK_ALT_DISPLAY) - tk appname xyzgorp - set a homeDisplay - set result [dobg " - toplevel .t -screen [winfo screen .] - wm geometry .t +0+0 - set a altDisplay - tk appname xyzgorp - list \[send xyzgorp set a\] \[send -displayof .t xyzgorp set a\] - "] - cleanupbg - set result - } {altDisplay homeDisplay} -} +test send-8.2 {Tk_SendCmd procedure, options} {altDisplay} { + setupbg -display $env(TK_ALT_DISPLAY) + tk appname xyzgorp + set a homeDisplay + set result [dobg " + toplevel .t -screen [winfo screen .] + wm geometry .t +0+0 + set a altDisplay + tk appname xyzgorp + list \[send xyzgorp set a\] \[send -displayof .t xyzgorp set a\] + "] + cleanupbg + set result +} {altDisplay homeDisplay} test send-8.3 {Tk_SendCmd procedure, options} { list [catch {send -- -async foo bar baz} msg] $msg } {1 {no application named "-async"}} @@ -614,26 +616,24 @@ test send-13.2 {DeleteProc procedure} { lappend result [winfo interps] [info commands send] } {{} {} foo send} -if [info exists env(TK_ALT_DISPLAY)] { - test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} { - setupbg -display $env(TK_ALT_DISPLAY) - set result [dobg " - toplevel .t -screen [winfo screen .] - wm geometry .t +0+0 - tk appname xyzgorp1 - set x child - "] - toplevel .t -screen $env(TK_ALT_DISPLAY) - wm geometry .t +0+0 - tk appname xyzgorp2 - update - set y parent - set result [send -displayof .t xyzgorp1 {list $x [send -displayof .t xyzgorp2 set y]}] - destroy .t - cleanupbg - set result - } {child parent} -} +test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {altDisplay} { + setupbg -display $env(TK_ALT_DISPLAY) + set result [dobg " + toplevel .t -screen [winfo screen .] + wm geometry .t +0+0 + tk appname xyzgorp1 + set x child + "] + toplevel .t -screen $env(TK_ALT_DISPLAY) + wm geometry .t +0+0 + tk appname xyzgorp2 + update + set y parent + set result [send -displayof .t xyzgorp1 {list $x [send -displayof .t xyzgorp2 set y]}] + destroy .t + cleanupbg + set result +} {child parent} if $gotTestCmds { testsend prop root InterpRegister $registry |