diff options
| -rw-r--r-- | ChangeLog | 2 | ||||
| -rw-r--r-- | tests/constraints.tcl | 27 | ||||
| -rw-r--r-- | tests/raise.test | 31 | ||||
| -rw-r--r-- | tests/safe.test | 8 | ||||
| -rw-r--r-- | tests/scale.test | 13 | ||||
| -rw-r--r-- | tests/scrollbar.test | 43 | ||||
| -rw-r--r-- | tests/select.test | 45 | ||||
| -rw-r--r-- | tests/send.test | 190 | ||||
| -rw-r--r-- | tests/spinbox.test | 13 |
9 files changed, 198 insertions, 174 deletions
@@ -2,7 +2,7 @@ * tests/canvPsImg.tcl: Converted several files in the * tests/constraints.tcl (new file): Tk test suite for testing by - * tests/[t-x]*.test: tcltest 2.1. + * tests/[r-x]*.test: tcltest 2.1. * unix/Makefile.in: 2002-07-11 Jeff Hobbs <jeffh@ActiveState.com> diff --git a/tests/constraints.tcl b/tests/constraints.tcl index a6c52da..065e52e 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -3,6 +3,7 @@ package require Tk 8.4 package require tcltest 2.1 namespace import -force tcltest::testConstraint testConstraint userInteraction 0 +testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)] testConstraint noExceed [expr {![testConstraint unix] || [catch {font actual "\{xyz"}]}] testConstraint testImageType [expr {[lsearch [image types] test] >= 0}] @@ -37,10 +38,9 @@ namespace eval ::tk { proc cleanup {} { variable fd - catch { - puts $fd exit - close $fd - } + # catch in case the background process has closed $fd + catch {puts $fd exit} + catch {close $fd} set fd "" } proc setup args { @@ -75,16 +75,29 @@ namespace eval ::tk { append Data $x } } - proc do {cmd} { + proc do {cmd {block 0}} { variable fd variable Data variable Done + if {$block} { + fileevent $fd readable {} + } 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] + if {$block} { + while {![eof $fd]} { + set line [gets $fd] + if {$line eq "**DONE**"} { + break + } + append Data $line + } + } else { + set Done 0 + vwait [namespace which -variable Done] + } return $Data } } diff --git a/tests/raise.test b/tests/raise.test index f5d88d7..12b56cf 100644 --- a/tests/raise.test +++ b/tests/raise.test @@ -8,19 +8,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: raise.test,v 1.5 1999/08/18 00:11:13 jenn Exp $ +# RCS: @(#) $Id: raise.test,v 1.6 2002/07/13 00:30:25 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 -if {[info commands testmakeexist] == {}} { - puts "This application hasn't been compiled with the \"testmakeexist\"" - puts "command, so I can't run this test. Are you sure you're using" - puts "tktest instead of wish?" - ::tcltest::cleanupTests - return -} +testConstraint testmakeexist [llength [info commands testmakeexist]] # Procedure to create a bunch of overlapping windows, which should # make it easy to detect differences in order. @@ -79,25 +74,25 @@ test raise-1.1 {preserve creation order} { update raise_getOrder } {d d d b c e e e} -test raise-1.2 {preserve creation order} { +test raise-1.2 {preserve creation order} testmakeexist { raise_setup testmakeexist .raise.a update raise_getOrder } {d d d b c e e e} -test raise-1.3 {preserve creation order} { +test raise-1.3 {preserve creation order} testmakeexist { raise_setup testmakeexist .raise.c update raise_getOrder } {d d d b c e e e} -test raise-1.4 {preserve creation order} { +test raise-1.4 {preserve creation order} testmakeexist { raise_setup testmakeexist .raise.e update raise_getOrder } {d d d b c e e e} -test raise-1.5 {preserve creation order} { +test raise-1.5 {preserve creation order} testmakeexist { raise_setup testmakeexist .raise.d .raise.c .raise.b update @@ -141,21 +136,21 @@ test raise-3.1 {raise internal windows after creation} { raise .raise.a .raise.d raise_getOrder } {a d d a c e e e} -test raise-3.2 {raise internal windows after creation} { +test raise-3.2 {raise internal windows after creation} testmakeexist { raise_setup testmakeexist .raise.a .raise.b raise .raise.a .raise.b update raise_getOrder } {d d d a c e e e} -test raise-3.3 {raise internal windows after creation} { +test raise-3.3 {raise internal windows after creation} testmakeexist { raise_setup testmakeexist .raise.a .raise.d raise .raise.a .raise.b update raise_getOrder } {d d d a c e e e} -test raise-3.4 {raise internal windows after creation} { +test raise-3.4 {raise internal windows after creation} testmakeexist { raise_setup testmakeexist .raise.a .raise.c .raise.d raise .raise.a .raise.b diff --git a/tests/safe.test b/tests/safe.test index bf1b945..b695023 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -6,11 +6,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: safe.test,v 1.7 2001/03/31 05:46:10 hobbs Exp $ +# RCS: @(#) $Id: safe.test,v 1.8 2002/07/13 00:30:25 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 ## NOTE: Any time tests fail here with an error like: diff --git a/tests/scale.test b/tests/scale.test index c68bf01..ee4981b 100644 --- a/tests/scale.test +++ b/tests/scale.test @@ -6,11 +6,16 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: scale.test,v 1.10 2000/04/14 08:34:28 hobbs Exp $ +# RCS: @(#) $Id: scale.test,v 1.11 2002/07/13 00:30:25 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::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 diff --git a/tests/scrollbar.test b/tests/scrollbar.test index 88f31df..775e045 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -7,20 +7,16 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: scrollbar.test,v 1.7 2001/09/21 20:37:40 hobbs Exp $ +# RCS: @(#) $Id: scrollbar.test,v 1.8 2002/07/13 00:30:25 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 ## testmetrics is a win/mac only test command ## -if {[string compare unix $tcl_platform(platform)] && \ - [string equal {} [info commands testmetrics]]} { - puts "\"testmetrics\" isn't defined, skipping scrollbar tests" - ::tcltest::cleanupTests - return -} +testConstraint testmetrics [llength [info commands testmetrics]] foreach i [winfo children .] { destroy $i @@ -35,8 +31,7 @@ proc scroll args { } proc getTroughSize {w} { - global tcl_platform - if {$tcl_platform(platform) == "windows"} { + if {[testConstraint testmetrics]} { if [string match v* [$w cget -orient]] { return [expr [winfo height $w] - 2*[testmetrics cyvscroll]] } else { @@ -269,13 +264,13 @@ test scrollbar-3.35 {ScrollbarWidgetCmd procedure, "fraction" option} { test scrollbar-3.36 {ScrollbarWidgetCmd procedure, "fraction" option} {unixOnly} { .s fraction 4 179 } {1} -test scrollbar-3.37 {ScrollbarWidgetCmd procedure, "fraction" option} {macOrPc} { +test scrollbar-3.37 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics} { .s fraction 4 [expr 200 - [testmetrics cyvscroll .s]] } {1} test scrollbar-3.38 {ScrollbarWidgetCmd procedure, "fraction" option} {unixOnly} { .s fraction 4 178 } {0.993711} -test scrollbar-3.39 {ScrollbarWidgetCmd procedure, "fraction" option} {pcOnly} { +test scrollbar-3.39 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics pcOnly} { expr [.s fraction 4 [expr 200 - [testmetrics cyvscroll .s] - 2]] \ == [format %g [expr (200.0 - [testmetrics cyvscroll .s]*2 - 2) \ / ($height - 1 - [testmetrics cyvscroll .s]*2)]] @@ -293,7 +288,7 @@ update test scrollbar-3.41 {ScrollbarWidgetCmd procedure, "fraction" option} { .t.s fraction 100 0 } {0.5} -if {$tcl_platform(platform) == "windows"} { +if {[testConstraint testmetrics]} { place configure .t.s -width [expr 2*[testmetrics cxhscroll]+1] } else { place configure .t.s -width [expr [winfo reqwidth .t.s] - 4] @@ -489,7 +484,7 @@ test scrollbar-6.13 {ScrollbarPosition procedure} {macOnly} { test scrollbar-6.14 {ScrollbarPosition procedure} {pcOnly} { .s identify [expr [winfo width .s] / 2] 0 } {arrow1} -test scrollbar-6.15 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.15 {ScrollbarPosition procedure} {testmetrics pcOnly} { .s identify [expr [winfo width .s] / 2] [expr [testmetrics cyvscroll] - 1] } {arrow1} @@ -501,10 +496,10 @@ test scrollbar-6.17 {ScrollbarPosition procedure} {macOrUnix nonPortable} { # some platforms. .s identify 8 51 } {trough1} -test scrollbar-6.18 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.18 {ScrollbarPosition procedure} {testmetrics pcOnly} { .s identify [expr [winfo width .s] / 2] [testmetrics cyvscroll] } {trough1} -test scrollbar-6.19 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.19 {ScrollbarPosition procedure} {testmetrics pcOnly} { .s identify [expr [winfo width .s] / 2] [expr int(.2 / [.s delta 0 1]) \ + [testmetrics cyvscroll] - 1] } {trough1} @@ -517,11 +512,11 @@ test scrollbar-6.21 {ScrollbarPosition procedure} {macOrUnix nonPortable} { # some platforms. .s identify 8 83 } {slider} -test scrollbar-6.22 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.22 {ScrollbarPosition procedure} {testmetrics pcOnly} { .s identify [expr [winfo width .s] / 2] [expr int(.2 / [.s delta 0 1]) \ + [testmetrics cyvscroll]] } {slider} -test scrollbar-6.23 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.23 {ScrollbarPosition procedure} {testmetrics pcOnly} { .s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \ + [testmetrics cyvscroll] - 1] } {slider} @@ -535,7 +530,7 @@ test scrollbar-6.25 {ScrollbarPosition procedure} {unixOnly} { test scrollbar-6.26 {ScrollbarPosition procedure} {macOnly} { .s identify 8 179 } {arrow2} -test scrollbar-6.27 {ScrollbarPosition procedure} {pcOnly knownBug} { +test scrollbar-6.27 {ScrollbarPosition procedure} {testmetrics pcOnly knownBug} { # This asks for 8,21, which is actually the slider, but there is a # bug in that GetSystemMetrics(SM_CYVTHUMB) actually returns a value # that is larger than the thumb displayed, skewing the ability to @@ -543,7 +538,7 @@ test scrollbar-6.27 {ScrollbarPosition procedure} {pcOnly knownBug} { .s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \ + [testmetrics cyvscroll]] } {trough2} -test scrollbar-6.28 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.28 {ScrollbarPosition procedure} {testmetrics pcOnly} { .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \ - [testmetrics cyvscroll] - 1] } {trough2} @@ -557,7 +552,7 @@ test scrollbar-6.30 {ScrollbarPosition procedure} {unixOnly} { test scrollbar-6.31 {ScrollbarPosition procedure} {macOnly} { .s identify 8 195 } {} -test scrollbar-6.32 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.32 {ScrollbarPosition procedure} {testmetrics pcOnly} { .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \ - [testmetrics cyvscroll]] } {arrow2} @@ -600,7 +595,7 @@ test scrollbar-6.41 {ScrollbarPosition procedure} {unixOnly} { test scrollbar-6.42 {ScrollbarPosition procedure} {macOnly} { .t.s identify 82 8 } {} -test scrollbar-6.43 {ScrollbarPosition procedure} {pcOnly} { +test scrollbar-6.43 {ScrollbarPosition procedure} {testmetrics pcOnly} { .t.s identify [expr int(.4 / [.t.s delta 1 0]) + [testmetrics cxhscroll] \ - 1] [expr [winfo height .t.s] / 2] } {slider} diff --git a/tests/select.test b/tests/select.test index 9d48083..657786b 100644 --- a/tests/select.test +++ b/tests/select.test @@ -6,18 +6,22 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: select.test,v 1.7 2001/08/30 01:51:42 hobbs Exp $ +# RCS: @(#) $Id: select.test,v 1.8 2002/07/13 00:30:25 dgp Exp $ # # Note: Multiple display selection handling will only be tested if the # environment variable TK_ALT_DISPLAY is set to an alternate display. # -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -set ::tcltest::testConfig(altDisplay) [info exists env(TK_ALT_DISPLAY)] +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 eval destroy [winfo child .] @@ -499,10 +503,7 @@ test select-5.10 {Tk_GetSelection procedure} {unixOnly} { set selInfo "" selection own .f1 set result "" - fileevent $::tcltest::fd readable {} - puts $::tcltest::fd {catch {selection get TEST} msg; update; puts $msg; flush stdout} - flush $::tcltest::fd - lappend result [gets $::tcltest::fd] + lappend result [dobg {selection get TEST} 1] cleanupbg lappend result $selInfo } {{selection owner didn't respond} {}} @@ -858,19 +859,29 @@ test select-9.4 {SelCvtToX and SelCvtFromX procedures} {unixOnly} { # most control paths have been exercised above test select-10.1 {ConvertSelection procedure, race with selection clear} {unixOnly} { setup - setupbg + proc Ready {fd} { + variable x + lappend x [gets $fd] + } + set fd [open "|[list [interpreter] -geometry +0+0 -name tktest]" r+] + puts $fd "puts foo; flush stdout" + flush $fd + gets $fd + fileevent $fd readable [list Ready $fd] set selValue "Just a simple test" set selInfo "" selection handle .f1 {handler STRING} update - puts $::tcltest::fd {puts "[catch {selection get} msg] $msg"; puts **DONE**; flush stdout} - flush $::tcltest::fd + puts $fd {puts "[catch {selection get} msg] $msg"; puts **DONE**; flush stdout} + flush $fd after 200 selection own . - set ::tcltest::bgData {} - tkwait variable ::tcltest::bgDone - cleanupbg - list $::tcltest::bgData $selInfo + set x {} + vwait [namespace which -variable x] + puts $fd {exit} + flush $fd + close $fd + lappend x $selInfo } {{1 PRIMARY selection doesn't exist or form "STRING" not defined} {}} test select-10.2 {ConvertSelection procedure} {unixOnly} { setup diff --git a/tests/send.test b/tests/send.test index 9efd4bd..b31f550 100644 --- a/tests/send.test +++ b/tests/send.test @@ -10,17 +10,21 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: send.test,v 1.5 2001/09/21 20:38:18 hobbs Exp $ +# RCS: @(#) $Id: send.test,v 1.6 2002/07/13 00:30:25 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::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 # 'send' is only available on Unix... -set ::tcltest::testConfig(xhost) [string compare {} [auto_execok xhost]] -set ::tcltest::testConfig(testsend) [llength [info commands testsend]] -set ::tcltest::testConfig(altDisplay) [info exists env(TK_ALT_DISPLAY)] +testConstraint xhost [llength [auto_execok xhost]] +testConstraint testsend [llength [info commands testsend]] foreach i [winfo children .] { destroy $i @@ -33,13 +37,10 @@ raise . setupbg set app [dobg {tk appname}] +testConstraint send 1 if {[catch {send $app set a 0} msg] == 1} { if {[string match "X server insecure *" $msg]} { - puts "Your X server is insecure - \"send\" can't be used;\ - skipping \"send\" tests." - cleanupbg - ::tcltest::cleanupTests - return + testConstraint send 0 } } cleanupbg @@ -63,6 +64,7 @@ proc newApp {screen name class} { } set name [tk appname] +set commId "" catch { set registry [testsend prop root InterpRegistry] set commId [lindex [testsend prop root InterpRegistry] 0] @@ -71,19 +73,19 @@ tk appname tktest catch {send t_s_1 destroy .} catch {send t_s_2 destroy .} -test send-1.1 {RegOpen procedure, bogus property} {unixOnly testsend} { +test send-1.1 {RegOpen procedure, bogus property} {send testsend} { testsend bogus set result [winfo interps] tk appname tktest list $result [winfo interps] } {{} tktest} -test send-1.2 {RegOpen procedure, bogus property} {unixOnly testsend} { +test send-1.2 {RegOpen procedure, bogus property} {send testsend} { testsend prop root InterpRegistry {} set result [winfo interps] tk appname tktest list $result [winfo interps] } {{} tktest} -test send-1.3 {RegOpen procedure, bogus property} {unixOnly testsend} { +test send-1.3 {RegOpen procedure, bogus property} {send testsend} { testsend prop root InterpRegistry abcdefg tk appname tktest set x [testsend prop root InterpRegistry] @@ -92,52 +94,52 @@ test send-1.3 {RegOpen procedure, bogus property} {unixOnly testsend} { frame .f -width 1 -height 1 set id [string range [winfo id .f] 2 end] -test send-2.1 {RegFindName procedure} {unixOnly testsend} { +test send-2.1 {RegFindName procedure} {send testsend} { testsend prop root InterpRegistry {} list [catch {send foo bar} msg] $msg } {1 {no application named "foo"}} -test send-2.2 {RegFindName procedure} {unixOnly testsend} { +test send-2.2 {RegFindName procedure} {send testsend} { testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n" tk appname foo } {foo #2} -test send-2.3 {RegFindName procedure} {unixOnly testsend} { +test send-2.3 {RegFindName procedure} {send testsend} { testsend prop root InterpRegistry "gyz foo\n" tk appname foo } {foo} -test send-2.4 {RegFindName procedure} {unixOnly testsend} { +test send-2.4 {RegFindName procedure} {send testsend} { testsend prop root InterpRegistry "${id}z foo\n" tk appname foo } {foo} -test send-3.1 {RegDeleteName procedure} {unixOnly testsend} { +test send-3.1 {RegDeleteName procedure} {send testsend} { tk appname tktest testsend prop root InterpRegistry "012345 gorp\n12345 foo\n12345 tktest" tk appname x set x [testsend prop root InterpRegistry] string range $x [string first " " $x] end } " x\n012345 gorp\n12345 foo\n" -test send-3.2 {RegDeleteName procedure} {unixOnly testsend} { +test send-3.2 {RegDeleteName procedure} {send testsend} { tk appname tktest testsend prop root InterpRegistry "012345 gorp\n12345 tktest\n23456 tktest" tk appname x set x [testsend prop root InterpRegistry] string range $x [string first " " $x] end } " x\n012345 gorp\n23456 tktest\n" -test send-3.3 {RegDeleteName procedure} {unixOnly testsend} { +test send-3.3 {RegDeleteName procedure} {send testsend} { tk appname tktest testsend prop root InterpRegistry "012345 tktest\n12345 bar\n23456 tktest" tk appname x set x [testsend prop root InterpRegistry] string range $x [string first " " $x] end } " x\n12345 bar\n23456 tktest\n" -test send-3.4 {RegDeleteName procedure} {unixOnly testsend} { +test send-3.4 {RegDeleteName procedure} {send testsend} { tk appname tktest testsend prop root InterpRegistry "foo" tk appname x set x [testsend prop root InterpRegistry] string range $x [string first " " $x] end } " x\nfoo\n" -test send-3.5 {RegDeleteName procedure} {unixOnly testsend} { +test send-3.5 {RegDeleteName procedure} {send testsend} { tk appname tktest testsend prop root InterpRegistry "" tk appname x @@ -145,12 +147,12 @@ test send-3.5 {RegDeleteName procedure} {unixOnly testsend} { string range $x [string first " " $x] end } " x\n" -test send-4.1 {RegAddName procedure} {unixOnly testsend} { +test send-4.1 {RegAddName procedure} {send testsend} { testsend prop root InterpRegistry "" tk appname bar testsend prop root InterpRegistry } "$commId bar\n" -test send-4.2 {RegAddName procedure} {unixOnly testsend} { +test send-4.2 {RegAddName procedure} {send testsend} { testsend prop root InterpRegistry "abc def" tk appname bar tk appname foo @@ -159,25 +161,25 @@ test send-4.2 {RegAddName procedure} {unixOnly testsend} { # Previous checks should already cover the Regclose procedure. -test send-5.1 {ValidateName procedure} {unixOnly testsend} { +test send-5.1 {ValidateName procedure} {send testsend} { testsend prop root InterpRegistry "123 abc\n" winfo interps } {} -test send-5.2 {ValidateName procedure} {unixOnly testsend} { +test send-5.2 {ValidateName procedure} {send testsend} { testsend prop root InterpRegistry "$id Hi there" winfo interps } {{Hi there}} -test send-5.3 {ValidateName procedure} {unixOnly testsend} { +test send-5.3 {ValidateName procedure} {send testsend} { testsend prop root InterpRegistry "$id Bogus" list [catch {send Bogus set a 44} msg] $msg } {1 {target application died or uses a Tk version before 4.0}} -test send-5.4 {ValidateName procedure} {unixOnly testsend} { +test send-5.4 {ValidateName procedure} {send testsend} { tk appname test testsend prop root InterpRegistry "$commId Bogus\n$commId test\n" winfo interps } {test} -if {$::tcltest::testConfig(xhost)} { +if {[testConstraint xhost]} { winfo interps tk appname tktest update @@ -188,43 +190,43 @@ if {$::tcltest::testConfig(xhost)} { } } -test send-6.1 {ServerSecure procedure} {nonPortable unixOnly} { +test send-6.1 {ServerSecure procedure} {nonPortable send } { set a 44 list [dobg [list send [tk appname] set a 55]] $a } {55 55} -test send-6.2 {ServerSecure procedure} {nonPortable unixOnly} { +test send-6.2 {ServerSecure procedure} {nonPortable send } { set a 22 exec xhost [exec hostname] list [catch {dobg [list send [tk appname] set a 33]} msg] $a $msg } {0 22 {X server insecure (must use xauth-style authorization); command ignored}} -test send-6.3 {ServerSecure procedure} {nonPortable unixOnly} { +test send-6.3 {ServerSecure procedure} {nonPortable send } { set a abc exec xhost - [exec hostname] list [dobg [list send [tk appname] set a new]] $a } {new new} cleanupbg -test send-7.1 {Tk_SetAppName procedure} {unixOnly testsend} { +test send-7.1 {Tk_SetAppName procedure} {send testsend} { testsend prop root InterpRegistry "" tk appname newName list [tk appname oldName] [testsend prop root InterpRegistry] } "oldName {$commId oldName\n}" -test send-7.2 {Tk_SetAppName procedure, name not in use} {unixOnly testsend} { +test send-7.2 {Tk_SetAppName procedure, name not in use} {send testsend} { testsend prop root InterpRegistry "" list [tk appname gorp] [testsend prop root InterpRegistry] } "gorp {$commId gorp\n}" -test send-7.3 {Tk_SetAppName procedure, name in use by us} {unixOnly testsend} { +test send-7.3 {Tk_SetAppName procedure, name in use by us} {send testsend} { tk appname name1 testsend prop root InterpRegistry "$commId name2\n" list [tk appname name2] [testsend prop root InterpRegistry] } "name2 {$commId name2\n}" -test send-7.4 {Tk_SetAppName procedure, name in use} {unixOnly testsend} { +test send-7.4 {Tk_SetAppName procedure, name in use} {send testsend} { tk appname name1 testsend prop root InterpRegistry "$id foo\n$id foo #2\n$id foo #3\n" list [tk appname foo] [testsend prop root InterpRegistry] } "{foo #4} {$commId foo #4\n$id foo\n$id foo #2\n$id foo #3\n}" -test send-8.1 {Tk_SendCmd procedure, options} {unixOnly} { +test send-8.1 {Tk_SendCmd procedure, options} {send } { setupbg set app [dobg {tk appname}] set a 66 @@ -235,7 +237,7 @@ test send-8.1 {Tk_SendCmd procedure, options} {unixOnly} { cleanupbg lappend result $a } {66 77} -test send-8.2 {Tk_SendCmd procedure, options} {unixOnly altDisplay} { +test send-8.2 {Tk_SendCmd procedure, options} {send altDisplay} { setupbg -display $env(TK_ALT_DISPLAY) tk appname xyzgorp set a homeDisplay @@ -249,29 +251,29 @@ test send-8.2 {Tk_SendCmd procedure, options} {unixOnly altDisplay} { cleanupbg set result } {altDisplay homeDisplay} -test send-8.3 {Tk_SendCmd procedure, options} {unixOnly} { +test send-8.3 {Tk_SendCmd procedure, options} {send } { list [catch {send -- -async foo bar baz} msg] $msg } {1 {no application named "-async"}} -test send-8.4 {Tk_SendCmd procedure, options} {unixOnly} { +test send-8.4 {Tk_SendCmd procedure, options} {send } { list [catch {send -gorp foo bar baz} msg] $msg } {1 {bad option "-gorp": must be -async, -displayof, or --}} -test send-8.5 {Tk_SendCmd procedure, options} {unixOnly} { +test send-8.5 {Tk_SendCmd procedure, options} {send } { list [catch {send -async foo} msg] $msg } {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} -test send-8.6 {Tk_SendCmd procedure, options} {unixOnly} { +test send-8.6 {Tk_SendCmd procedure, options} {send } { list [catch {send foo} msg] $msg } {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} -test send-8.7 {Tk_SendCmd procedure, local execution} {unixOnly} { +test send-8.7 {Tk_SendCmd procedure, local execution} {send } { set a initial send [tk appname] {set a new} set a } {new} -test send-8.8 {Tk_SendCmd procedure, local execution} {unixOnly} { +test send-8.8 {Tk_SendCmd procedure, local execution} {send } { set a initial send [tk appname] set a new set a } {new} -test send-8.9 {Tk_SendCmd procedure, local execution} {unixOnly} { +test send-8.9 {Tk_SendCmd procedure, local execution} {send } { set a initial string tolower [list [catch {send [tk appname] open bad_file} msg] \ $msg $errorInfo $errorCode] @@ -280,7 +282,7 @@ test send-8.9 {Tk_SendCmd procedure, local execution} {unixOnly} { "open bad_file" invoked from within "send [tk appname] open bad_file"} {posix enoent {no such file or directory}}} -test send-8.10 {Tk_SendCmd procedure, no such interpreter} {unixOnly} { +test send-8.10 {Tk_SendCmd procedure, no such interpreter} {send } { list [catch {send bogus_name bogus_command} msg] $msg } {1 {no application named "bogus_name"}} @@ -289,29 +291,29 @@ catch { t_s_1 eval wm withdraw . } -test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {unixOnly testsend} { +test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {send testsend} { set a us send t_s_1 set a them list $a [send t_s_1 set a] } {us them} -test send-8.12 {Tk_SendCmd procedure, local execution, different interp} {unixOnly testsend} { +test send-8.12 {Tk_SendCmd procedure, local execution, different interp} {send testsend} { set a us send t_s_1 {set a them} list $a [send t_s_1 {set a}] } {us them} -test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {unixOnly testsend} { +test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {send testsend} { set a us send t_s_1 {set a them} list $a [send t_s_1 {set a}] } {us them} -test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {unixOnly testsend} { +test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {send testsend} { newApp "" t_s_2 Test list [catch {send t_s_2 {destroy .; concat result}} msg] $msg } {0 result} catch {interp delete t_s_2} -test send-8.15 {Tk_SendCmd procedure, local interp, error info} {unixOnly testsend} { +test send-8.15 {Tk_SendCmd procedure, local interp, error info} {send testsend} { catch {error foo} list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode } {1 {couldn't open "bogus_file_name": no such file or directory} {couldn't open "bogus_file_name": no such file or directory @@ -321,7 +323,7 @@ test send-8.15 {Tk_SendCmd procedure, local interp, error info} {unixOnly testse "if 1 {open bogus_file_name}" invoked from within "send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}} -test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {unixOnly testsend} { +test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {send testsend} { testsend prop root InterpRegistry "10234 bogus\n" set result [list [catch {send bogus bogus command} msg] $msg] winfo interps @@ -331,7 +333,7 @@ test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {unixOnly testsend} { catch {interp delete t_s_1} -test send-8.17 {Tk_SendCmd procedure, deferring events} {unixOnly nonPortable} { +test send-8.17 {Tk_SendCmd procedure, deferring events} {send nonPortable} { # Non-portable because some window managers ignore "raise" # requests so can't guarantee that new app's window won't # obscure .f, thereby masking the Expose event. @@ -351,7 +353,7 @@ test send-8.17 {Tk_SendCmd procedure, deferring events} {unixOnly nonPortable} { cleanupbg lappend result $a } {{no event yet} {no event yet} exposed} -test send-8.18 {Tk_SendCmd procedure, error in remote app} {unixOnly} { +test send-8.18 {Tk_SendCmd procedure, error in remote app} {send } { setupbg set app [dobg {tk appname}] set result [string tolower [list [catch {send $app open bad_name} msg] \ @@ -363,7 +365,7 @@ test send-8.18 {Tk_SendCmd procedure, error in remote app} {unixOnly} { "open bad_name" invoked from within "send $app open bad_name"} {posix enoent {no such file or directory}}} -test send-8.19 {Tk_SendCmd, using modal timeouts} {unixOnly} { +test send-8.19 {Tk_SendCmd, using modal timeouts} {send } { setupbg set app [dobg {tk appname}] set x no @@ -381,30 +383,30 @@ catch {destroy .f} frame .f set id [string range [winfo id .f] 2 end] -test send-9.1 {Tk_GetInterpNames procedure} {unixOnly testsend} { +test send-9.1 {Tk_GetInterpNames procedure} {send testsend} { testsend prop root InterpRegistry \ "$commId tktest\nfoo bar\n$commId tktest\n$id frame .f\n\n\n" list [winfo interps] [testsend prop root InterpRegistry] } "{tktest tktest {frame .f}} {$commId tktest\n$commId tktest\n$id frame .f }" -test send-9.2 {Tk_GetInterpNames procedure} {unixOnly testsend} { +test send-9.2 {Tk_GetInterpNames procedure} {send testsend} { testsend prop root InterpRegistry \ "$commId tktest\nfoobar\n$commId gorp\n" list [winfo interps] [testsend prop root InterpRegistry] } "tktest {$commId tktest\n}" -test send-9.3 {Tk_GetInterpNames procedure} {unixOnly testsend} { +test send-9.3 {Tk_GetInterpNames procedure} {send testsend} { testsend prop root InterpRegistry {} list [winfo interps] [testsend prop root InterpRegistry] } {{} {}} catch {testsend prop root InterpRegistry "$commId tktest\n$id dummy\n"} -test send-10.1 {SendEventProc procedure, bogus comm property} {unixOnly testsend} { +test send-10.1 {SendEventProc procedure, bogus comm property} {send testsend} { testsend prop comm Comm {abc def} testsend prop comm Comm {} update } {} -test send-10.2 {SendEventProc procedure, simultaneous messages} {unixOnly testsend} { +test send-10.2 {SendEventProc procedure, simultaneous messages} {send testsend} { testsend prop comm Comm \ "c\n-n tktest\n-s set a 44\nc\n-n tktest\n-s set b 45\n" set a null @@ -412,7 +414,7 @@ test send-10.2 {SendEventProc procedure, simultaneous messages} {unixOnly testse update list $a $b } {44 45} -test send-10.3 {SendEventProc procedure, simultaneous messages} {unixOnly testsend} { +test send-10.3 {SendEventProc procedure, simultaneous messages} {send testsend} { testsend prop comm Comm \ "c\n-n tktest\n-s set a newA\nr\n-s [testsend serial]\n-r 12345\nc\n-n tktest\n-s set b newB\n" set a null @@ -420,21 +422,21 @@ test send-10.3 {SendEventProc procedure, simultaneous messages} {unixOnly testse set x [send dummy bogus] list $x $a $b } {12345 newA newB} -test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} {unixOnly testsend} { +test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} {send testsend} { testsend prop comm Comm \ "\n\nx\n-bogus\n\nc\n-n tktest\n-s set a 44\n" set a null update set a } {44} -test send-10.5 {SendEventProc procedure, extraneous command options} {unixOnly testsend} { +test send-10.5 {SendEventProc procedure, extraneous command options} {send testsend} { testsend prop comm Comm \ "c\n-n tktest\n-x miscellanous\n-y who knows?\n-s set a new\n" set a null update set a } {new} -test send-10.6 {SendEventProc procedure, unknown interpreter} {unixOnly testsend} { +test send-10.6 {SendEventProc procedure, unknown interpreter} {send testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n unknown\n-r $id 44\n-s set a new\n" @@ -442,7 +444,7 @@ test send-10.6 {SendEventProc procedure, unknown interpreter} {unixOnly testsend update list [testsend prop [winfo id .f] Comm] $a } "{\nr\n-s 44\n-r receiver never heard of interpreter \"unknown\"\n-c 1\n} null" -test send-10.7 {SendEventProc procedure, error in script} {unixOnly testsend} { +test send-10.7 {SendEventProc procedure, error in script} {send testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-r $id 62\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n" @@ -459,7 +461,7 @@ r -e test code -c 1 } -test send-10.8 {SendEventProc procedure, exceptional return} {unixOnly testsend} { +test send-10.8 {SendEventProc procedure, exceptional return} {send testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-r $id 62\n-s break\n" @@ -471,7 +473,7 @@ r -r -c 3 } -test send-10.9 {SendEventProc procedure, empty return} {unixOnly testsend} { +test send-10.9 {SendEventProc procedure, empty return} {send testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-r $id 62\n-s concat\n" @@ -482,76 +484,76 @@ r -s 62 -r } -test send-10.10 {SendEventProc procedure, asynchronous calls} {unixOnly testsend} { +test send-10.10 {SendEventProc procedure, asynchronous calls} {send testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n" update testsend prop [winfo id .f] Comm } {} -test send-10.11 {SendEventProc procedure, exceptional return} {unixOnly testsend} { +test send-10.11 {SendEventProc procedure, exceptional return} {send testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-s break\n" update testsend prop [winfo id .f] Comm } {} -test send-10.12 {SendEventProc procedure, empty return} {unixOnly testsend} { +test send-10.12 {SendEventProc procedure, empty return} {send testsend} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-s concat\n" update testsend prop [winfo id .f] Comm } {} -test send-10.13 {SendEventProc procedure, return processing} {unixOnly testsend} { +test send-10.13 {SendEventProc procedure, return processing} {send testsend} { testsend prop comm Comm \ "r\n-c 1\n-e test1\n-i test2\n-r test3\n-s [testsend serial]\n" list [catch {send dummy foo} msg] $msg $errorInfo $errorCode } {1 test3 {test2 invoked from within "send dummy foo"} test1} -test send-10.14 {SendEventProc procedure, extraneous return options} {unixOnly testsend} { +test send-10.14 {SendEventProc procedure, extraneous return options} {send testsend} { testsend prop comm Comm \ "r\n-x test1\n-y test2\n-r result\n-s [testsend serial]\n" list [catch {send dummy foo} msg] $msg } {0 result} -test send-10.15 {SendEventProc procedure, serial number} {unixOnly testsend} { +test send-10.15 {SendEventProc procedure, serial number} {send testsend} { testsend prop comm Comm \ "r\n-r response\n" list [catch {send dummy foo} msg] $msg } {1 {target application died or uses a Tk version before 4.0}} -test send-10.16 {SendEventProc procedure, serial number} {unixOnly testsend} { +test send-10.16 {SendEventProc procedure, serial number} {send testsend} { testsend prop comm Comm \ "r\n-r response\n\n-s 0" list [catch {send dummy foo} msg] $msg } {1 {target application died or uses a Tk version before 4.0}} -test send-10.17 {SendEventProc procedure, errorCode and errorInfo} {unixOnly testsend} { +test send-10.17 {SendEventProc procedure, errorCode and errorInfo} {send testsend} { testsend prop comm Comm \ "r\n-i test1\n-e test2\n-c 4\n-s [testsend serial]\n" set errorCode oldErrorCode set errorInfo oldErrorInfo list [catch {send dummy foo} msg] $msg $errorInfo $errorCode } {4 {} oldErrorInfo oldErrorCode} -test send-10.18 {SendEventProc procedure, send kills application} {unixOnly testsend} { +test send-10.18 {SendEventProc procedure, send kills application} {send testsend} { setupbg dobg {tk appname t_s_3} set x [list [catch {send t_s_3 destroy .} msg] $msg] cleanupbg set x } {0 {}} -test send-10.19 {SendEventProc procedure, send exits} {unixOnly testsend} { +test send-10.19 {SendEventProc procedure, send exits} {send testsend} { setupbg dobg {tk appname t_s_3} set x [list [catch {send t_s_3 exit} msg] $msg] - close $::tcltest::fd + cleanupbg set x } {1 {target application died}} -test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} {unixOnly testsend} { +test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} {send testsend} { testsend prop root InterpRegistry "0x21447 dummy\n" list [catch {send dummy foo} msg] $msg } {1 {no application named "dummy"}} -test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} {unixOnly testsend} { +test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} {send testsend} { testsend prop comm Comm "c\n-r0x123 44\n-n tktest\n-s concat a b c\n" update } {} @@ -562,40 +564,38 @@ catch {destroy .f} frame .f set id [string range [winfo id .f] 2 end] -test send-12.1 {TimeoutProc procedure} {unixOnly testsend} { +test send-12.1 {TimeoutProc procedure} {send testsend} { testsend prop root InterpRegistry "$id dummy\n" list [catch {send dummy foo} msg] $msg } {1 {target application died or uses a Tk version before 4.0}} catch {testsend prop root InterpRegistry ""} -test send-12.2 {TimeoutProc procedure} {unixOnly} { +test send-12.2 {TimeoutProc procedure} {send } { winfo interps tk appname tktest update setupbg - puts $::tcltest::fd {after 10 {after 5000; exit}; puts [tk appname]; puts **DONE**; flush stdout} - set ::tcltest::bgDone 0 - set ::tcltest::bgData {} - flush $::tcltest::fd - tkwait variable ::tcltest::bgDone - set app $::tcltest::bgData + set app [dobg { + after 10 {after 10 {after 5000; exit}} + tk appname + }] after 200 set result [list [catch {send $app foo} msg] $msg] - close $::tcltest::fd + cleanupbg set result } {1 {target application died}} winfo interps tk appname tktest -test send-13.1 {DeleteProc procedure} {unixOnly} { +test send-13.1 {DeleteProc procedure} {send } { setupbg set app [dobg {rename send {}; tk appname}] set result [list [catch {send $app foo} msg] $msg [winfo interps]] cleanupbg set result } {1 {no application named "tktest #2"} tktest} -test send-13.2 {DeleteProc procedure} {unixOnly} { +test send-13.2 {DeleteProc procedure} {send } { winfo interps tk appname tktest rename send {} @@ -605,7 +605,7 @@ test send-13.2 {DeleteProc procedure} {unixOnly} { lappend result [winfo interps] [info commands send] } {{} {} foo send} -test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {unixOnly altDisplay} { +test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {send altDisplay} { setupbg -display $env(TK_ALT_DISPLAY) set result [dobg " toplevel .t -screen [winfo screen .] @@ -628,7 +628,7 @@ catch { testsend prop root InterpRegister $registry tk appname tktest } -test send-15.1 {UpdateCommWindow procedure} {unixOnly testsend} { +test send-15.1 {UpdateCommWindow procedure} {send testsend} { set x [list [testsend prop comm TK_APPLICATION]] newApp "" t_s_1 Test send t_s_1 wm withdraw . diff --git a/tests/spinbox.test b/tests/spinbox.test index 1a42d06..41ca9f8 100644 --- a/tests/spinbox.test +++ b/tests/spinbox.test @@ -4,11 +4,16 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: spinbox.test,v 1.1 2000/05/29 01:43:15 hobbs Exp $ +# RCS: @(#) $Id: spinbox.test,v 1.2 2002/07/13 00:30:25 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::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 |