diff options
Diffstat (limited to 'tests/send.test')
| -rw-r--r-- | tests/send.test | 656 |
1 files changed, 656 insertions, 0 deletions
diff --git a/tests/send.test b/tests/send.test new file mode 100644 index 0000000..7addb73 --- /dev/null +++ b/tests/send.test @@ -0,0 +1,656 @@ +# This file is a Tcl script to test out the "send" command and the +# other procedures in the file tkSend.c. It is organized in the +# standard fashion for Tcl tests. +# +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) send.test 1.26 96/12/09 17:26:42 + +if {$tcl_platform(platform) == "macintosh"} { + puts "send is not available on the Mac - skipping tests" + return +} +if {$tcl_platform(platform) == "window"} { + puts "send is not available under Windows - skipping tests" + return +} +if {[auto_execok xhost] == ""} { + puts "xhost application isn't available - skipping tests" + return +} + +if {[info procs test] != "test"} { + source defs +} +if {[info commands testsend] == "testsend"} { + set gotTestCmds 1 +} else { + set gotTestCmds 0 +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +# If send is disabled because of inadequate security, don't run any +# of these tests at all. + +setupbg +set app [dobg {tk appname}] +if {[catch {send $app set a 0} msg] == 1} { + if [string match "X server insecure *" $msg] { + puts -nonewline "Your X server is insecure, so \"send\" can't be used;" + puts " skipping \"send\" tests." + cleanupbg + return + } +} +cleanupbg + +# Compute a script that will load Tk into a child interpreter. + +foreach pkg [info loaded] { + if {[lindex $pkg 1] == "Tk"} { + set loadTk "load $pkg" + break + } +} + +# Procedure to create a new application with a given name and class. + +proc newApp {screen name class} { + global loadTk + interp create $name + $name eval [list set argv [list -display $screen -name $name -class $class]] + eval $loadTk $name +} + +set name [tk appname] +if $gotTestCmds { + set registry [testsend prop root InterpRegistry] + set commId [lindex [testsend prop root InterpRegistry] 0] +} +tk appname tktest +catch {send t_s_1 destroy .} +catch {send t_s_2 destroy .} + +if $gotTestCmds { + test send-1.1 {RegOpen procedure, bogus property} { + testsend bogus + set result [winfo interps] + tk appname tktest + list $result [winfo interps] + } {{} tktest} + test send-1.2 {RegOpen procedure, bogus property} { + testsend prop root InterpRegistry {} + set result [winfo interps] + tk appname tktest + list $result [winfo interps] + } {{} tktest} + test send-1.3 {RegOpen procedure, bogus property} { + testsend prop root InterpRegistry abcdefg + tk appname tktest + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " tktest\nabcdefg\n" + + frame .f -width 1 -height 1 + set id [string range [winfo id .f] 2 end] + test send-2.1 {RegFindName procedure} { + testsend prop root InterpRegistry {} + list [catch {send foo bar} msg] $msg + } {1 {no application named "foo"}} + test send-2.2 {RegFindName procedure} { + testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n" + tk appname foo + } {foo #2} + test send-2.3 {RegFindName procedure} { + testsend prop root InterpRegistry "gyz foo\n" + tk appname foo + } {foo} + test send-2.4 {RegFindName procedure} { + testsend prop root InterpRegistry "${id}z foo\n" + tk appname foo + } {foo} + + test send-3.1 {RegDeleteName procedure} { + 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} { + 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} { + 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} { + 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} { + tk appname tktest + testsend prop root InterpRegistry "" + tk appname x + set x [testsend prop root InterpRegistry] + string range $x [string first " " $x] end + } " x\n" + + test send-4.1 {RegAddName procedure} { + testsend prop root InterpRegistry "" + tk appname bar + testsend prop root InterpRegistry + } "$commId bar\n" + test send-4.2 {RegAddName procedure} { + testsend prop root InterpRegistry "abc def" + tk appname bar + tk appname foo + testsend prop root InterpRegistry + } "$commId foo\nabc def\n" + + # Previous checks should already cover the Regclose procedure. + + test send-5.1 {ValidateName procedure} { + testsend prop root InterpRegistry "123 abc\n" + winfo interps + } {} + test send-5.2 {ValidateName procedure} { + testsend prop root InterpRegistry "$id Hi there" + winfo interps + } {{Hi there}} + test send-5.3 {ValidateName procedure} { + 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} { + tk appname test + testsend prop root InterpRegistry "$commId Bogus\n$commId test\n" + winfo interps + } {test} +} + +winfo interps +tk appname tktest +update +setupbg +set x [split [exec xhost] \n] +foreach i [lrange $x 1 end] { + exec xhost - $i +} +test send-6.1 {ServerSecure procedure} {nonPortable} { + set a 44 + list [dobg [list send [tk appname] set a 55]] $a +} {55 55} +test send-6.2 {ServerSecure procedure} {nonPortable} { + 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} { + set a abc + exec xhost - [exec hostname] + list [dobg [list send [tk appname] set a new]] $a +} {new new} +cleanupbg + +if $gotTestCmds { + test send-7.1 {Tk_SetAppName procedure} { + 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} { + 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} { + 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} { + 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} { + setupbg + set app [dobg {tk appname}] + set a 66 + send -async $app [list send [tk appname] set a 77] + set result $a + after 200 set x 40 + tkwait variable x + 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.3 {Tk_SendCmd procedure, options} { + list [catch {send -- -async foo bar baz} msg] $msg +} {1 {no application named "-async"}} +test send-8.4 {Tk_SendCmd procedure, options} { + 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} { + 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} { + 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} { + set a initial + send [tk appname] {set a new} + set a +} {new} +test send-8.8 {Tk_SendCmd procedure, local execution} { + set a initial + send [tk appname] set a new + set a +} {new} +test send-8.9 {Tk_SendCmd procedure, local execution} { + set a initial + string tolower [list [catch {send [tk appname] open bad_file} msg] \ + $msg $errorInfo $errorCode] +} {1 {couldn't open "bad_file": no such file or directory} {couldn't open "bad_file": no such file or directory + while executing +"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} { + list [catch {send bogus_name bogus_command} msg] $msg +} {1 {no application named "bogus_name"}} +if $gotTestCmds { + newApp "" t_s_1 Test + t_s_1 eval wm withdraw . + test send-8.11 {Tk_SendCmd procedure, local execution, different interp} { + 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} { + 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} { + 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} { + newApp "" t_s_2 Test + list [catch {send t_s_2 {destroy .; concat result}} msg] $msg + } {0 result} + interp delete t_s_2 + test send-8.15 {Tk_SendCmd procedure, local interp, error info} { + 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 + while executing +"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} { + testsend prop root InterpRegistry "10234 bogus\n" + set result [list [catch {send bogus bogus command} msg] $msg] + winfo interps + tk appname tktest + set result + } {1 {no application named "bogus"}} + interp delete t_s_1 +} +test send-8.17 {Tk_SendCmd procedure, deferring events} {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. + + setupbg + set app [dobg {tk appname}] + raise . ; # Don't want new app obscuring .f + catch {destroy .f} + frame .f + place .f -x 0 -y 0 + bind .f <Expose> {set a exposed} + set a {no event yet} + set result "" + lappend result [send $app send [list [tk appname]] set a] + lappend result $a + update + cleanupbg + lappend result $a +} {{no event yet} {no event yet} exposed} +test send-8.18 {Tk_SendCmd procedure, error in remote app} { + setupbg + set app [dobg {tk appname}] + set result [string tolower [list [catch {send $app open bad_name} msg] \ + $msg $errorInfo $errorCode]] + cleanupbg + set result +} {1 {couldn't open "bad_name": no such file or directory} {couldn't open "bad_name": no such file or directory + while executing +"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} { + setupbg + set app [dobg {tk appname}] + set x no + set result "" + after 0 {set x yes} + lappend result [send $app {concat x y z}] + lappend result $x + update + cleanupbg + lappend result $x +} {{x y z} no yes} + +tk appname tktest +catch {destroy .f} +frame .f +set id [string range [winfo id .f] 2 end] +if $gotTestCmds { + test send-9.1 {Tk_GetInterpNames procedure} { + 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} { + 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} { + testsend prop root InterpRegistry {} + list [winfo interps] [testsend prop root InterpRegistry] + } {{} {}} + + testsend prop root InterpRegistry "$commId tktest\n$id dummy\n" + test send-10.1 {SendEventProc procedure, bogus comm property} { + testsend prop comm Comm {abc def} + testsend prop comm Comm {} + update + } {} + test send-10.2 {SendEventProc procedure, simultaneous messages} { + 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 + set b xyzzy + update + list $a $b + } {44 45} + test send-10.3 {SendEventProc procedure, simultaneous messages} { + 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 + set b xyzzy + set x [send dummy bogus] + list $x $a $b + } {12345 newA newB} + test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} { + 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} { + 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} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n unknown\n-r $id 44\n-s set a new\n" + set a null + 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} { + 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" + update + testsend prop [winfo id .f] Comm + } { +r +-s 62 +-r test error +-i Initial errorInfo + ("foreach" body line 1) + invoked from within +"foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}" +-e test code +-c 1 +} + test send-10.8 {SendEventProc procedure, exceptional return} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-r $id 62\n-s break\n" + update + testsend prop [winfo id .f] Comm + } { +r +-s 62 +-r +-c 3 +} + test send-10.9 {SendEventProc procedure, empty return} { + testsend prop [winfo id .f] Comm {} + testsend prop comm Comm \ + "c\n-n tktest\n-r $id 62\n-s concat\n" + update + testsend prop [winfo id .f] Comm + } { +r +-s 62 +-r +} + test send-10.10 {SendEventProc procedure, asynchronous calls} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + setupbg + dobg {tk appname t_s_3} + set x [list [catch {send t_s_3 exit} msg] $msg] + close $fd + set x + } {1 {target application died}} + + test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} { + 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} { + testsend prop comm Comm "c\n-r0x123 44\n-n tktest\n-s concat a b c\n" + update + } {} +} + +winfo interps +tk appname tktest +catch {destroy .f} +frame .f +set id [string range [winfo id .f] 2 end] +if $gotTestCmds { + test send-12.1 {TimeoutProc procedure} { + 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}} + testsend prop root InterpRegistry "" +} +test send-12.2 {TimeoutProc procedure} { + winfo interps + tk appname tktest + update + setupbg + puts $fd {after 10 {after 5000; exit}; puts [tk appname]; puts **DONE**; flush stdout} + set bgDone 0 + set bgData {} + flush $fd + tkwait variable bgDone + set app $bgData + after 200 + set result [list [catch {send $app foo} msg] $msg] + close $fd + set result +} {1 {target application died}} + +winfo interps +tk appname tktest +test send-13.1 {DeleteProc procedure} { + 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} { + winfo interps + tk appname tktest + rename send {} + set result {} + lappend result [winfo interps] [info commands send] + tk appname foo + 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} +} + +if $gotTestCmds { + testsend prop root InterpRegister $registry + tk appname tktest + test send-15.1 {UpdateCommWindow procedure} { + set x [list [testsend prop comm TK_APPLICATION]] + newApp "" t_s_1 Test + send t_s_1 wm withdraw . + newApp "" t_s_2 Test + send t_s_2 wm withdraw . + lappend x [testsend prop comm TK_APPLICATION] + interp delete t_s_1 + lappend x [testsend prop comm TK_APPLICATION] + interp delete t_s_2 + lappend x [testsend prop comm TK_APPLICATION] + } {tktest {t_s_2 t_s_1 tktest} {t_s_2 tktest} tktest} +} + +tk appname $name +if $gotTestCmds { + testsend prop root InterpRegistry $registry +} +if $gotTestCmds { + testdeleteapps +} +rename newApp {} |