send.test

linux系统下的音频通信

# 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} {