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