socket.test

linux系统下的音频通信

	proc echo {s} {
	     global i
             set l [gets $s]
             if {[eof $s]} {
                 global x
                 close $s
                 set x done
             } else { 
	         incr i
                 puts $s $l
             }
	}
	set i 0
	puts ready
	set timer [after 20000 "set x done"]
	vwait x
	after cancel $timer
	close $f
	puts "done $i"
    }
    close $f
    set f [open "|[list $tcltest script]" r]
    gets $f
    set s [socket localhost 2828]
    fconfigure $s -buffering line
    for {set x 0} {$x < 50} {incr x} {
        puts $s "hello abcdefghijklmnop"
        gets $s
    }
    close $s
    set x [gets $f]
    close $f
    set x
} {done 50}
test socket-2.9 {socket conflict} {stdio} {
    set s [socket -server accept 2828]
    removeFile script
    set f [open script w]
    puts $f {set f [socket -server accept 2828]}
    close $f
    set f [open "|[list $tcltest script]" r]
    gets $f
    after 100
    set x [list [catch {close $f} msg] $msg]
    close $s
    set x
} {1 {couldn't open socket: address already in use
    while executing
"socket -server accept 2828"
    (file "script" line 1)}}
test socket-2.10 {close on accept, accepted socket lives} {
    set done 0
    set timer [after 20000 "set done timed_out"]
    set ss [socket -server accept 2830]
    proc accept {s a p} {
	global ss
	close $ss
	fileevent $s readable "readit $s"
	fconfigure $s -trans lf
    }
    proc readit {s} {
	global done
	gets $s
	close $s
	set done 1
    }
    set cs [socket [info hostname] 2830]
    puts $cs hello
    close $cs
    vwait done
    after cancel $timer
    set done
} 1
test socket-2.11 {detecting new data} {
    proc accept {s a p} {
	global sock
	set sock $s
    }

    set s [socket -server accept 2400]
    set sock ""
    set s2 [socket localhost 2400]
    vwait sock
    puts $s2 one
    flush $s2
    after 500
    fconfigure $sock -blocking 0
    set result [gets $sock]
    lappend result [gets $sock]
    fconfigure $sock -blocking 1
    puts $s2 two
    flush $s2
    fconfigure $sock -blocking 0
    lappend result [gets $sock]
    fconfigure $sock -blocking 1
    close $s2
    close $s
    close $sock
    set result
} {one {} two}


test socket-3.1 {socket conflict} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set f [socket -server accept 2828]
	puts ready
	gets stdin
	close $f
    }
    close $f
    set f [open "|[list $tcltest script]" r+]
    gets $f
    set x [list [catch {socket -server accept 2828} msg] \
		$msg]
    puts $f bye
    close $f
    set x
} {1 {couldn't open socket: address already in use}}
test socket-3.2 {server with several clients} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set t1 [after 30000 "set x timed_out"]
	set t2 [after 31000 "set x timed_out"]
	set t3 [after 32000 "set x timed_out"]
	set counter 0
	set s [socket -server accept 2828]
	proc accept {s a p} {
	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line
	}
	proc echo {s} {
	     global x
             set l [gets $s]
             if {[eof $s]} {
                 close $s
                 set x done
             } else {
                 puts $s $l
             }
	}
	puts ready
	vwait x
	after cancel $t1
	vwait x
	after cancel $t2
	vwait x
	after cancel $t3
	close $s
	puts $x
    }
    close $f
    set f [open "|[list $tcltest script]" r+]
    set x [gets $f]
    set s1 [socket localhost 2828]
    fconfigure $s1 -buffering line
    set s2 [socket localhost 2828]
    fconfigure $s2 -buffering line
    set s3 [socket localhost 2828]
    fconfigure $s3 -buffering line
    for {set i 0} {$i < 100} {incr i} {
	puts $s1 hello,s1
	gets $s1
	puts $s2 hello,s2
	gets $s2
	puts $s3 hello,s3
	gets $s3
    }
    close $s1
    close $s2
    close $s3
    lappend x [gets $f]
    close $f
    set x
} {ready done}

test socket-4.1 {server with several clients} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	gets stdin
	set s [socket localhost 2828]
	fconfigure $s -buffering line
	for {set i 0} {$i < 100} {incr i} {
	    puts $s hello
	    gets $s
	}
	close $s
	puts bye
	gets stdin
    }
    close $f
    set p1 [open "|[list $tcltest script]" r+]
    fconfigure $p1 -buffering line
    set p2 [open "|[list $tcltest script]" r+]
    fconfigure $p2 -buffering line
    set p3 [open "|[list $tcltest script]" r+]
    fconfigure $p3 -buffering line
    proc accept {s a p} {
	fconfigure $s -buffering line
	fileevent $s readable [list echo $s]
    }
    proc echo {s} {
	global x
        set l [gets $s]
        if {[eof $s]} {
            close $s
            set x done
        } else {
            puts $s $l
        }
    }
    set t1 [after 30000 "set x timed_out"]
    set t2 [after 31000 "set x timed_out"]
    set t3 [after 32000 "set x timed_out"]
    set s [socket -server accept 2828]
    puts $p1 open
    puts $p2 open
    puts $p3 open
    vwait x
    vwait x
    vwait x
    after cancel $t1
    after cancel $t2
    after cancel $t3
    close $s
    set l ""
    lappend l [list p1 [gets $p1] $x]
    lappend l [list p2 [gets $p2] $x]
    lappend l [list p3 [gets $p3] $x]
    puts $p1 bye
    puts $p2 bye
    puts $p3 bye
    close $p1
    close $p2
    close $p3
    set l
} {{p1 bye done} {p2 bye done} {p3 bye done}}
test socket-4.2 {byte order problems, socket numbers, htons} {
    set x ok
    if {[catch {socket -server dodo 0x3000} msg]} {
	set x $msg
    } else {
	close $msg
    }
    set x
} ok

test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} {
    #
    # THIS TEST WILL FAIL if you are running as superuser.
    #
    set x {couldn't open socket: not owner}
    if {![catch {socket -server dodo 0x1} msg]} {
        set x {htons problem, should be disallowed, are you running as SU?}
	close $msg
    }
    set x
} {couldn't open socket: not owner}
test socket-5.2 {byte order problems, socket numbers, htons} {
    set x {couldn't open socket: port number too high}
    if {![catch {socket -server dodo 0x10000} msg]} {
	set x {port resolution problem, should be disallowed}
	close $msg
    }
    set x
} {couldn't open socket: port number too high}
test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} {
    #
    # THIS TEST WILL FAIL if you are running as superuser.
    #
    set x {couldn't open socket: not owner}
    if {![catch {socket -server dodo 21} msg]} {
	set x {htons problem, should be disallowed, are you running as SU?}
	close $msg
    }
    set x
} {couldn't open socket: not owner}

test socket-6.1 {accept callback error} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	gets stdin
	socket localhost 2848
    }
    close $f
    set f [open "|[list $tcltest script]" r+]
    proc bgerror args {
	global x
	set x $args
    }
    proc accept {s a p} {expr 10 / 0}
    set s [socket -server accept 2848]
    puts $f hello
    close $f
    set timer [after 10000 "set x timed_out"]
    vwait x
    after cancel $timer
    close $s
    rename bgerror {}
    set x
} {{divide by zero}}

test socket-7.1 {testing socket specific options} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	socket -server accept 2820
	proc accept args {
	    global x
	    set x done
	}
	puts ready
	set timer [after 10000 "set x timed_out"]
	vwait x
	after cancel $timer
    }
    close $f
    set f [open "|[list $tcltest script]" r]
    gets $f
    set s [socket localhost 2820]
    set p [fconfigure $s -peername]
    close $s
    close $f
    set l ""
    lappend l [string compare [lindex $p 0] 127.0.0.1]
    lappend l [string compare [lindex $p 2] 2820]
    lappend l [llength $p]
} {0 0 3}
test socket-7.2 {testing socket specific options} {stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	socket -server accept 2821
	proc accept args {
	    global x
	    set x done
	}
	puts ready
	set timer [after 10000 "set x timed_out"]
	vwait x
	after cancel $timer
    }
    close $f
    set f [open "|[list $tcltest script]" r]
    gets $f
    set s [socket localhost 2821]
    set p [fconfigure $s -sockname]
    close $s
    close $f
    set l ""
    lappend l [llength $p]
    lappend l [lindex $p 0]
    lappend l [expr [lindex $p 2] == 2821]
} {3 127.0.0.1 0}
test socket-7.3 {testing socket specific options} {
    set s [socket -server accept 2822]
    set l [fconfigure $s]
    close $s
    update
    llength $l
} 10
test socket-7.4 {testing socket specific options} {
    set s [socket -server accept 2823]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
    }
    set s1 [socket [info hostname] 2823]
    set timer [after 10000 "set x timed_out"]
    vwait x
    after cancel $timer
    close $s
    close $s1
    set l ""
    lappend l [lindex $x 2] [llength $x]
} {2823 3}
test socket-7.5 {testing socket specific options} {unixOrPc} {
    set s [socket -server accept 2829]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
    }
    set s1 [socket localhost 2829]
    set timer [after 10000 "set x timed_out"]
    vwait x
    after cancel $timer
    close $s
    close $s1
    set l ""
    lappend l [lindex $x 0] [lindex $x 2] [llength $x]
} {127.0.0.1 2829 3}

test socket-8.1 {testing -async flag on sockets} {
    # NOTE: This test may fail on some Solaris 2.4 systems. If it does,
    # check that you have these patches installed (using showrev -p):
    #
    # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
    # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
    # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
    # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
    # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01,
    # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03
    #
    # If after installing these patches you are still experiencing a
    # problem, please email [e-mail]. We have not observed this
    # failure on Solaris 2.5, so another option (instead of installing
    # these patches) is to upgrade to Solaris 2.5.
    set s [socket -server accept 2830]
    proc accept {s a p} {
	global x
	puts $s bye
	close $s
	set x done
    }
    set s1 [socket -async [info hostname] 2830]
    vwait x
    set z [gets $s1]
    close $s
    close $s1
    set z
} bye

test socket-9.1 {testing spurious events} {
    set len 0
    set spurious 0
    set done 0
    proc readlittle {s} {
	global spurious done len
	set l [read $s 1]
	if {[string length $l] == 0} {
	    if {![eof $s]} {
		incr spurious
	    } else {
		close $s
		set done 1
	    }
	} else {
	    incr len [string length $l]
	}
    }
    proc accept {s a p} {
	fconfigure $s -buffering none -blocking off
	fileevent $s readable [list readlittle $s]
    }
    set s [socket -server accept 2831]
    set c [socket [info hostname] 2831]
    puts -nonewline $c 01234567890123456789012345678901234567890123456789
    close $c
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    close $s
    list $spurious $len
} {0 50}
test socket-9.2 {testing async write, fileevents, flush on close} {} {