home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tk8.0 / tests / send.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  20.3 KB  |  657 lines  |  [TEXT/ALFA]
  1. # This file is a Tcl script to test out the "send" command and the
  2. # other procedures in the file tkSend.c.  It is organized in the
  3. # standard fashion for Tcl tests.
  4. #
  5. # Copyright (c) 1994 Sun Microsystems, Inc.
  6. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  7. #
  8. # See the file "license.terms" for information on usage and redistribution
  9. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10. #
  11. # SCCS: @(#) send.test 1.26 96/12/09 17:26:42
  12.  
  13. if {$tcl_platform(platform) == "macintosh"} {
  14.     puts "send is not available on the Mac - skipping tests"
  15.     return
  16. }
  17. if {$tcl_platform(platform) == "window"} {
  18.     puts "send is not available under Windows - skipping tests"
  19.     return
  20. }
  21. if {[auto_execok xhost] == ""} {
  22.     puts "xhost application isn't available - skipping tests"
  23.     return
  24. }
  25.  
  26. if {[info procs test] != "test"} {
  27.     source defs
  28. }
  29. if {[info commands testsend] == "testsend"} {
  30.     set gotTestCmds 1
  31. } else {
  32.     set gotTestCmds 0
  33. }
  34.  
  35. foreach i [winfo children .] {
  36.     destroy $i
  37. }
  38. wm geometry . {}
  39. raise .
  40.  
  41. # If send is disabled because of inadequate security, don't run any
  42. # of these tests at all.
  43.  
  44. setupbg
  45. set app [dobg {tk appname}]
  46. if {[catch {send $app set a 0} msg] == 1} {
  47.     if [string match "X server insecure *" $msg] {
  48.     puts -nonewline "Your X server is insecure, so \"send\" can't be used;"
  49.     puts " skipping \"send\" tests."
  50.     cleanupbg
  51.     return
  52.     }
  53. }
  54. cleanupbg
  55.  
  56. # Compute a script that will load Tk into a child interpreter.
  57.  
  58. foreach pkg [info loaded] {
  59.     if {[lindex $pkg 1] == "Tk"} {
  60.     set loadTk "load $pkg"
  61.     break
  62.     }
  63. }
  64.  
  65. # Procedure to create a new application with a given name and class.
  66.  
  67. proc newApp {screen name class} {
  68.     global loadTk
  69.     interp create $name
  70.     $name eval [list set argv [list -display $screen -name $name -class $class]]
  71.     eval $loadTk $name
  72. }
  73.  
  74. set name [tk appname]
  75. if $gotTestCmds {
  76.     set registry [testsend prop root InterpRegistry]
  77.     set commId [lindex [testsend prop root InterpRegistry] 0]
  78. }
  79. tk appname tktest
  80. catch {send t_s_1 destroy .}
  81. catch {send t_s_2 destroy .}
  82.  
  83. if $gotTestCmds {
  84.     test send-1.1 {RegOpen procedure, bogus property} {
  85.     testsend bogus
  86.     set result [winfo interps]
  87.     tk appname tktest
  88.     list $result [winfo interps]
  89.     } {{} tktest}
  90.     test send-1.2 {RegOpen procedure, bogus property} {
  91.     testsend prop root InterpRegistry {}
  92.     set result [winfo interps]
  93.     tk appname tktest
  94.     list $result [winfo interps]
  95.     } {{} tktest}
  96.     test send-1.3 {RegOpen procedure, bogus property} {
  97.     testsend prop root InterpRegistry abcdefg
  98.     tk appname tktest
  99.     set x [testsend prop root InterpRegistry]
  100.     string range $x [string first " " $x] end
  101.     } " tktest\nabcdefg\n"
  102.  
  103.     frame .f -width 1 -height 1
  104.     set id [string range [winfo id .f] 2 end]
  105.     test send-2.1 {RegFindName procedure} {
  106.     testsend prop root InterpRegistry {}
  107.     list [catch {send foo bar} msg] $msg
  108.     } {1 {no application named "foo"}}
  109.     test send-2.2 {RegFindName procedure} {
  110.     testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n"
  111.     tk appname foo
  112.     } {foo #2}
  113.     test send-2.3 {RegFindName procedure} {
  114.     testsend prop root InterpRegistry "gyz foo\n"
  115.     tk appname foo
  116.     } {foo}
  117.     test send-2.4 {RegFindName procedure} {
  118.     testsend prop root InterpRegistry "${id}z foo\n"
  119.     tk appname foo
  120.     } {foo}
  121.  
  122.     test send-3.1 {RegDeleteName procedure} {
  123.     tk appname tktest
  124.     testsend prop root InterpRegistry "012345 gorp\n12345 foo\n12345 tktest"
  125.     tk appname x
  126.     set x [testsend prop root InterpRegistry]
  127.     string range $x [string first " " $x] end
  128.     } " x\n012345 gorp\n12345 foo\n"
  129.     test send-3.2 {RegDeleteName procedure} {
  130.     tk appname tktest
  131.     testsend prop root InterpRegistry "012345 gorp\n12345 tktest\n23456 tktest"
  132.     tk appname x
  133.     set x [testsend prop root InterpRegistry]
  134.     string range $x [string first " " $x] end
  135.     } " x\n012345 gorp\n23456 tktest\n"
  136.     test send-3.3 {RegDeleteName procedure} {
  137.     tk appname tktest
  138.     testsend prop root InterpRegistry "012345 tktest\n12345 bar\n23456 tktest"
  139.     tk appname x
  140.     set x [testsend prop root InterpRegistry]
  141.     string range $x [string first " " $x] end
  142.     } " x\n12345 bar\n23456 tktest\n"
  143.     test send-3.4 {RegDeleteName procedure} {
  144.     tk appname tktest
  145.     testsend prop root InterpRegistry "foo"
  146.     tk appname x
  147.     set x [testsend prop root InterpRegistry]
  148.     string range $x [string first " " $x] end
  149.     } " x\nfoo\n"
  150.     test send-3.5 {RegDeleteName procedure} {
  151.     tk appname tktest
  152.     testsend prop root InterpRegistry ""
  153.     tk appname x
  154.     set x [testsend prop root InterpRegistry]
  155.     string range $x [string first " " $x] end
  156.     } " x\n"
  157.  
  158.     test send-4.1 {RegAddName procedure} {
  159.     testsend prop root InterpRegistry ""
  160.     tk appname bar
  161.     testsend prop root InterpRegistry
  162.     } "$commId bar\n"
  163.     test send-4.2 {RegAddName procedure} {
  164.     testsend prop root InterpRegistry "abc def"
  165.     tk appname bar
  166.     tk appname foo
  167.     testsend prop root InterpRegistry
  168.     } "$commId foo\nabc def\n"
  169.  
  170.     # Previous checks should already cover the Regclose procedure.
  171.  
  172.     test send-5.1 {ValidateName procedure} {
  173.     testsend prop root InterpRegistry "123 abc\n"
  174.     winfo interps
  175.     } {}
  176.     test send-5.2 {ValidateName procedure} {
  177.     testsend prop root InterpRegistry "$id Hi there"
  178.     winfo interps
  179.     } {{Hi there}}
  180.     test send-5.3 {ValidateName procedure} {
  181.     testsend prop root InterpRegistry "$id Bogus"
  182.     list [catch {send Bogus set a 44} msg] $msg
  183.     } {1 {target application died or uses a Tk version before 4.0}}
  184.     test send-5.4 {ValidateName procedure} {
  185.     tk appname test
  186.     testsend prop root InterpRegistry "$commId Bogus\n$commId test\n"
  187.     winfo interps
  188.     } {test}
  189. }
  190.  
  191. winfo interps
  192. tk appname tktest
  193. update
  194. setupbg
  195. set x [split [exec xhost] \n]
  196. foreach i [lrange $x 1 end]  {
  197.     exec xhost - $i
  198. }
  199. test send-6.1 {ServerSecure procedure} {nonPortable} {
  200.     set a 44
  201.     list [dobg [list send [tk appname] set a 55]] $a
  202. } {55 55}
  203. test send-6.2 {ServerSecure procedure} {nonPortable} {
  204.     set a 22
  205.     exec xhost [exec hostname]
  206.     list [catch {dobg [list send [tk appname] set a 33]} msg] $a $msg
  207. } {0 22 {X server insecure (must use xauth-style authorization); command ignored}}
  208. test send-6.3 {ServerSecure procedure} {nonPortable} {
  209.     set a abc
  210.     exec xhost - [exec hostname]
  211.     list [dobg [list send [tk appname] set a new]] $a
  212. } {new new}
  213. cleanupbg
  214.  
  215. if $gotTestCmds {
  216.     test send-7.1 {Tk_SetAppName procedure} {
  217.     testsend prop root InterpRegistry ""
  218.     tk appname newName
  219.     list [tk appname oldName] [testsend prop root InterpRegistry]
  220.     } "oldName {$commId oldName\n}"
  221.     test send-7.2 {Tk_SetAppName procedure, name not in use} {
  222.     testsend prop root InterpRegistry ""
  223.     list [tk appname gorp] [testsend prop root InterpRegistry]
  224.     } "gorp {$commId gorp\n}"
  225.     test send-7.3 {Tk_SetAppName procedure, name in use by us} {
  226.     tk appname name1
  227.     testsend prop root InterpRegistry "$commId name2\n"
  228.     list [tk appname name2] [testsend prop root InterpRegistry]
  229.     } "name2 {$commId name2\n}"
  230.     test send-7.4 {Tk_SetAppName procedure, name in use} {
  231.     tk appname name1
  232.     testsend prop root InterpRegistry "$id foo\n$id foo #2\n$id foo #3\n"
  233.     list [tk appname foo] [testsend prop root InterpRegistry]
  234.     } "{foo #4} {$commId foo #4\n$id foo\n$id foo #2\n$id foo #3\n}"
  235. }
  236.  
  237. test send-8.1 {Tk_SendCmd procedure, options} {
  238.     setupbg
  239.     set app [dobg {tk appname}]
  240.     set a 66
  241.     send -async $app [list send [tk appname] set a 77]
  242.     set result $a
  243.     after 200 set x 40
  244.     tkwait variable x
  245.     cleanupbg
  246.     lappend result $a
  247. } {66 77}
  248. if [info exists env(TK_ALT_DISPLAY)] {
  249.     test send-8.2 {Tk_SendCmd procedure, options} {
  250.     setupbg -display $env(TK_ALT_DISPLAY)
  251.     tk appname xyzgorp
  252.     set a homeDisplay
  253.     set result [dobg "
  254.         toplevel .t -screen [winfo screen .]
  255.         wm geometry .t +0+0
  256.         set a altDisplay
  257.         tk appname xyzgorp
  258.         list \[send xyzgorp set a\] \[send -displayof .t xyzgorp set a\]
  259.     "]
  260.     cleanupbg
  261.     set result
  262.     } {altDisplay homeDisplay}
  263. }
  264. test send-8.3 {Tk_SendCmd procedure, options} {
  265.     list [catch {send -- -async foo bar baz} msg] $msg
  266. } {1 {no application named "-async"}}
  267. test send-8.4 {Tk_SendCmd procedure, options} {
  268.     list [catch {send -gorp foo bar baz} msg] $msg
  269. } {1 {bad option "-gorp": must be -async, -displayof, or --}}
  270. test send-8.5 {Tk_SendCmd procedure, options} {
  271.     list [catch {send -async foo} msg] $msg
  272. } {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}}
  273. test send-8.6 {Tk_SendCmd procedure, options} {
  274.     list [catch {send foo} msg] $msg
  275. } {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}}
  276. test send-8.7 {Tk_SendCmd procedure, local execution} {
  277.     set a initial
  278.     send [tk appname] {set a new}
  279.     set a
  280. } {new}
  281. test send-8.8 {Tk_SendCmd procedure, local execution} {
  282.     set a initial
  283.     send [tk appname] set a new
  284.     set a
  285. } {new}
  286. test send-8.9 {Tk_SendCmd procedure, local execution} {
  287.     set a initial
  288.     string tolower [list [catch {send [tk appname] open bad_file} msg] \
  289.         $msg $errorInfo $errorCode]
  290. } {1 {couldn't open "bad_file": no such file or directory} {couldn't open "bad_file": no such file or directory
  291.     while executing
  292. "open bad_file"
  293.     invoked from within
  294. "send [tk appname] open bad_file"} {posix enoent {no such file or directory}}}
  295. test send-8.10 {Tk_SendCmd procedure, no such interpreter} {
  296.     list [catch {send bogus_name bogus_command} msg] $msg
  297. } {1 {no application named "bogus_name"}}
  298. if $gotTestCmds {
  299.     newApp "" t_s_1 Test
  300.     t_s_1 eval wm withdraw .
  301.     test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {
  302.     set a us
  303.     send t_s_1 set a them
  304.     list $a [send t_s_1 set a]
  305.     } {us them}
  306.     test send-8.12 {Tk_SendCmd procedure, local execution, different interp} {
  307.     set a us
  308.     send t_s_1 {set a them}
  309.     list $a [send t_s_1 {set a}]
  310.     } {us them}
  311.     test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {
  312.     set a us
  313.     send t_s_1 {set a them}
  314.     list $a [send t_s_1 {set a}]
  315.     } {us them}
  316.     test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {
  317.     newApp "" t_s_2 Test
  318.     list [catch {send t_s_2 {destroy .; concat result}} msg] $msg
  319.     } {0 result}
  320.     interp delete t_s_2
  321.     test send-8.15 {Tk_SendCmd procedure, local interp, error info} {
  322.     catch {error foo}
  323.     list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode
  324.     } {1 {couldn't open "bogus_file_name": no such file or directory} {couldn't open "bogus_file_name": no such file or directory
  325.     while executing
  326. "open bogus_file_name"
  327.     invoked from within
  328. "send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}}
  329.     test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {
  330.     testsend prop root InterpRegistry "10234 bogus\n"
  331.     set result [list [catch {send bogus bogus command} msg] $msg]
  332.     winfo interps
  333.     tk appname tktest
  334.     set result
  335.     } {1 {no application named "bogus"}}
  336.     interp delete t_s_1
  337. }
  338. test send-8.17 {Tk_SendCmd procedure, deferring events} {nonPortable} {
  339.     # Non-portable because some window managers ignore "raise"
  340.     # requests so can't guarantee that new app's window won't
  341.     # obscure .f, thereby masking the Expose event.
  342.  
  343.     setupbg
  344.     set app [dobg {tk appname}]
  345.     raise .        ; # Don't want new app obscuring .f
  346.     catch {destroy .f}
  347.     frame .f
  348.     place .f -x 0 -y 0
  349.     bind .f <Expose> {set a exposed}
  350.     set a {no event yet}
  351.     set result ""
  352.     lappend result [send $app send [list [tk appname]] set a]
  353.     lappend result $a
  354.     update
  355.     cleanupbg
  356.     lappend result $a
  357. } {{no event yet} {no event yet} exposed}
  358. test send-8.18 {Tk_SendCmd procedure, error in remote app} {
  359.     setupbg
  360.     set app [dobg {tk appname}]
  361.     set result [string tolower [list [catch {send $app open bad_name} msg] \
  362.         $msg $errorInfo $errorCode]]
  363.     cleanupbg
  364.     set result
  365. } {1 {couldn't open "bad_name": no such file or directory} {couldn't open "bad_name": no such file or directory
  366.     while executing
  367. "open bad_name"
  368.     invoked from within
  369. "send $app open bad_name"} {posix enoent {no such file or directory}}}
  370. test send-8.19 {Tk_SendCmd, using modal timeouts} {
  371.     setupbg
  372.     set app [dobg {tk appname}]
  373.     set x no
  374.     set result ""
  375.     after 0 {set x yes}
  376.     lappend result [send $app {concat x y z}]
  377.     lappend result $x
  378.     update
  379.     cleanupbg
  380.     lappend result $x
  381. } {{x y z} no yes}
  382.  
  383. tk appname tktest
  384. catch {destroy .f}
  385. frame .f
  386. set id [string range [winfo id .f] 2 end]
  387. if $gotTestCmds {
  388.     test send-9.1 {Tk_GetInterpNames procedure} {
  389.     testsend prop root InterpRegistry \
  390.         "$commId tktest\nfoo bar\n$commId tktest\n$id frame .f\n\n\n"
  391.     list [winfo interps] [testsend prop root InterpRegistry]
  392.     } "{tktest tktest {frame .f}} {$commId tktest\n$commId tktest\n$id frame .f
  393. }"
  394.     test send-9.2 {Tk_GetInterpNames procedure} {
  395.     testsend prop root InterpRegistry \
  396.         "$commId tktest\nfoobar\n$commId gorp\n"
  397.     list [winfo interps] [testsend prop root InterpRegistry]
  398.     } "tktest {$commId tktest\n}"
  399.     test send-9.3 {Tk_GetInterpNames procedure} {
  400.     testsend prop root InterpRegistry {}
  401.     list [winfo interps] [testsend prop root InterpRegistry]
  402.     } {{} {}}
  403.  
  404.     testsend prop root InterpRegistry "$commId tktest\n$id dummy\n"
  405.     test send-10.1 {SendEventProc procedure, bogus comm property} {
  406.     testsend prop comm Comm {abc def}
  407.     testsend prop comm Comm {}
  408.     update
  409.     } {}
  410.     test send-10.2 {SendEventProc procedure, simultaneous messages} {
  411.     testsend prop comm Comm \
  412.         "c\n-n tktest\n-s set a 44\nc\n-n tktest\n-s set b 45\n"
  413.     set a null
  414.     set b xyzzy
  415.     update
  416.     list $a $b
  417.     } {44 45}
  418.     test send-10.3 {SendEventProc procedure, simultaneous messages} {
  419.     testsend prop comm Comm \
  420.         "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"
  421.     set a null
  422.     set b xyzzy
  423.     set x [send dummy bogus]
  424.     list $x $a $b
  425.     } {12345 newA newB}
  426.     test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} {
  427.     testsend prop comm Comm \
  428.         "\n\nx\n-bogus\n\nc\n-n tktest\n-s set a 44\n"
  429.     set a null
  430.     update
  431.     set a
  432.     } {44}
  433.     test send-10.5 {SendEventProc procedure, extraneous command options} {
  434.     testsend prop comm Comm \
  435.         "c\n-n tktest\n-x miscellanous\n-y who knows?\n-s set a new\n"
  436.     set a null
  437.     update
  438.     set a
  439.     } {new}
  440.     test send-10.6 {SendEventProc procedure, unknown interpreter} {
  441.     testsend prop [winfo id .f] Comm {}
  442.     testsend prop comm Comm \
  443.         "c\n-n unknown\n-r $id 44\n-s set a new\n"
  444.     set a null
  445.     update
  446.     list [testsend prop [winfo id .f] Comm] $a
  447.     } "{\nr\n-s 44\n-r receiver never heard of interpreter \"unknown\"\n-c 1\n} null"
  448.     test send-10.7 {SendEventProc procedure, error in script} {
  449.     testsend prop [winfo id .f] Comm {}
  450.     testsend prop comm Comm \
  451.         "c\n-n tktest\n-r $id 62\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n"
  452.     update
  453.     testsend prop [winfo id .f] Comm
  454.     } {
  455. r
  456. -s 62
  457. -r test error
  458. -i Initial errorInfo
  459.     ("foreach" body line 1)
  460.     invoked from within
  461. "foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}"
  462. -e test code
  463. -c 1
  464. }
  465.     test send-10.8 {SendEventProc procedure, exceptional return} {
  466.     testsend prop [winfo id .f] Comm {}
  467.     testsend prop comm Comm \
  468.         "c\n-n tktest\n-r $id 62\n-s break\n"
  469.     update
  470.     testsend prop [winfo id .f] Comm
  471.     } {
  472. r
  473. -s 62
  474. -r 
  475. -c 3
  476. }
  477.     test send-10.9 {SendEventProc procedure, empty return} {
  478.     testsend prop [winfo id .f] Comm {}
  479.     testsend prop comm Comm \
  480.         "c\n-n tktest\n-r $id 62\n-s concat\n"
  481.     update
  482.     testsend prop [winfo id .f] Comm
  483.     } {
  484. r
  485. -s 62
  486. -r 
  487. }
  488.     test send-10.10 {SendEventProc procedure, asynchronous calls} {
  489.     testsend prop [winfo id .f] Comm {}
  490.     testsend prop comm Comm \
  491.         "c\n-n tktest\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n"
  492.     update
  493.     testsend prop [winfo id .f] Comm
  494.     } {}
  495.     test send-10.11 {SendEventProc procedure, exceptional return} {
  496.     testsend prop [winfo id .f] Comm {}
  497.     testsend prop comm Comm \
  498.         "c\n-n tktest\n-s break\n"
  499.     update
  500.     testsend prop [winfo id .f] Comm
  501.     } {}
  502.     test send-10.12 {SendEventProc procedure, empty return} {
  503.     testsend prop [winfo id .f] Comm {}
  504.     testsend prop comm Comm \
  505.         "c\n-n tktest\n-s concat\n"
  506.     update
  507.     testsend prop [winfo id .f] Comm
  508.     } {}
  509.     test send-10.13 {SendEventProc procedure, return processing} {
  510.     testsend prop comm Comm \
  511.         "r\n-c 1\n-e test1\n-i test2\n-r test3\n-s [testsend serial]\n"
  512.     list [catch {send dummy foo} msg] $msg $errorInfo $errorCode
  513.     } {1 test3 {test2
  514.     invoked from within
  515. "send dummy foo"} test1}
  516.     test send-10.14 {SendEventProc procedure, extraneous return options} {
  517.     testsend prop comm Comm \
  518.         "r\n-x test1\n-y test2\n-r result\n-s [testsend serial]\n"
  519.     list [catch {send dummy foo} msg] $msg
  520.     } {0 result}
  521.     test send-10.15 {SendEventProc procedure, serial number} {
  522.     testsend prop comm Comm \
  523.         "r\n-r response\n"
  524.     list [catch {send dummy foo} msg] $msg
  525.     } {1 {target application died or uses a Tk version before 4.0}}
  526.     test send-10.16 {SendEventProc procedure, serial number} {
  527.     testsend prop comm Comm \
  528.         "r\n-r response\n\n-s 0"
  529.     list [catch {send dummy foo} msg] $msg
  530.     } {1 {target application died or uses a Tk version before 4.0}}
  531.     test send-10.17 {SendEventProc procedure, errorCode and errorInfo} {
  532.     testsend prop comm Comm \
  533.         "r\n-i test1\n-e test2\n-c 4\n-s [testsend serial]\n"
  534.     set errorCode oldErrorCode
  535.     set errorInfo oldErrorInfo
  536.     list [catch {send dummy foo} msg] $msg $errorInfo $errorCode
  537.     } {4 {} oldErrorInfo oldErrorCode}
  538.     test send-10.18 {SendEventProc procedure, send kills application} {
  539.     setupbg
  540.     dobg {tk appname t_s_3}
  541.     set x [list [catch {send t_s_3 destroy .} msg] $msg]
  542.     cleanupbg
  543.     set x
  544.     } {0 {}}
  545.     test send-10.19 {SendEventProc procedure, send exits} {
  546.     setupbg
  547.     dobg {tk appname t_s_3}
  548.     set x [list [catch {send t_s_3 exit} msg] $msg]
  549.     close $fd
  550.     set x
  551.     } {1 {target application died}}
  552.  
  553.     test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} {
  554.     testsend prop root InterpRegistry "0x21447 dummy\n"
  555.     list [catch {send dummy foo} msg] $msg
  556.     } {1 {no application named "dummy"}}
  557.     test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} {
  558.     testsend prop comm Comm "c\n-r0x123 44\n-n tktest\n-s concat a b c\n"
  559.     update
  560.     } {}
  561. }
  562.  
  563. winfo interps
  564. tk appname tktest
  565. catch {destroy .f}
  566. frame .f
  567. set id [string range [winfo id .f] 2 end]
  568. if $gotTestCmds {
  569.     test send-12.1 {TimeoutProc procedure} {
  570.         testsend prop root InterpRegistry "$id dummy\n"
  571.         list [catch {send dummy foo} msg] $msg
  572.     } {1 {target application died or uses a Tk version before 4.0}}
  573.     testsend prop root InterpRegistry ""
  574. }
  575. test send-12.2 {TimeoutProc procedure} {
  576.     winfo interps
  577.     tk appname tktest
  578.     update
  579.     setupbg
  580.     puts $fd {after 10 {after 5000; exit}; puts [tk appname]; puts **DONE**; flush stdout}
  581.     set bgDone 0
  582.     set bgData {}
  583.     flush $fd
  584.     tkwait variable bgDone
  585.     set app $bgData
  586.     after 200
  587.     set result [list [catch {send $app foo} msg] $msg]
  588.     close $fd
  589.     set result
  590. } {1 {target application died}}
  591.  
  592. winfo interps
  593. tk appname tktest
  594. test send-13.1 {DeleteProc procedure} {
  595.     setupbg
  596.     set app [dobg {rename send {}; tk appname}]
  597.     set result [list [catch {send $app foo} msg] $msg [winfo interps]]
  598.     cleanupbg
  599.     set result
  600. } {1 {no application named "tktest #2"} tktest}
  601. test send-13.2 {DeleteProc procedure} {
  602.     winfo interps
  603.     tk appname tktest
  604.     rename send {}
  605.     set result {}
  606.     lappend result [winfo interps] [info commands send]
  607.     tk appname foo
  608.     lappend result [winfo interps] [info commands send]
  609. } {{} {} foo send}
  610.  
  611. if [info exists env(TK_ALT_DISPLAY)] {
  612.     test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {
  613.     setupbg -display $env(TK_ALT_DISPLAY)
  614.     set result [dobg "
  615.         toplevel .t -screen [winfo screen .]
  616.         wm geometry .t +0+0
  617.         tk appname xyzgorp1
  618.         set x child
  619.     "]
  620.     toplevel .t -screen $env(TK_ALT_DISPLAY)
  621.     wm geometry .t +0+0
  622.     tk appname xyzgorp2
  623.     update
  624.     set y parent
  625.     set result [send -displayof .t xyzgorp1 {list $x [send -displayof .t xyzgorp2 set y]}]
  626.     destroy .t
  627.     cleanupbg
  628.     set result
  629.     } {child parent}
  630. }
  631.  
  632. if $gotTestCmds {
  633.     testsend prop root InterpRegister $registry
  634.     tk appname tktest
  635.     test send-15.1 {UpdateCommWindow procedure} {
  636.     set x [list [testsend prop comm TK_APPLICATION]]
  637.     newApp "" t_s_1 Test
  638.     send t_s_1 wm withdraw .
  639.     newApp "" t_s_2 Test
  640.     send t_s_2 wm withdraw .
  641.     lappend x [testsend prop comm TK_APPLICATION]
  642.     interp delete t_s_1
  643.     lappend x [testsend prop comm TK_APPLICATION]
  644.     interp delete t_s_2
  645.     lappend x [testsend prop comm TK_APPLICATION]
  646.     } {tktest {t_s_2 t_s_1 tktest} {t_s_2 tktest} tktest}
  647. }
  648.  
  649. tk appname $name
  650. if $gotTestCmds {
  651.     testsend prop root InterpRegistry $registry
  652. }
  653. if $gotTestCmds {
  654.     testdeleteapps
  655. }
  656. rename newApp {}
  657.