socket.test

tcl是工具命令语言

	    fileevent $s readable [list echo $s]
	    fconfigure $s -buffering line -translation crlf
	}
	proc echo {s} {
	    set l [gets $s]
	    if {[eof $s]} {
		close $s
	    } else {
		puts $s $l
	    }
	}
    }
    set f [socket $remoteServerIP 2836]
    fconfigure $f -translation crlf -buffering line
    for {set cnt 0} {$cnt < 50} {incr cnt} {
	puts $f "hello, $cnt"
	if {[string compare [gets $f] "hello, $cnt"] != 0} {
	    break
	}
    }
    close $f
    sendCommand {close $socket10_7_test_server}
    set cnt
} 50
# Macintosh sockets can have more than one server per port
if {$tcl_platform(platform) == "macintosh"} {
    set conflictResult {0 2836}
} else {
    set conflictResult {1 {couldn't open socket: address already in use}}
}
test socket-11.6 {socket conflict} {socket doTestsWithRemoteServer} {
    set s1 [socket -server accept 2836]
    if {[catch {set s2 [socket -server accept 2836]} msg]} {
	set result [list 1 $msg]
    } else {
	set result [list 0 [lindex [fconfigure $s2 -sockname] 2]]
	close $s2
    }
    close $s1
    set result
} $conflictResult
test socket-11.7 {server with several clients} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket10_9_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fconfigure $s -buffering line
	    fileevent $s readable [list echo $s]
	}
	proc echo {s} {
	    set l [gets $s]
	    if {[eof $s]} {
		close $s
	    } else {
		puts $s $l
	    }
	}
    }
    set s1 [socket $remoteServerIP 2836]
    fconfigure $s1 -buffering line
    set s2 [socket $remoteServerIP 2836]
    fconfigure $s2 -buffering line
    set s3 [socket $remoteServerIP 2836]
    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
    sendCommand {close $socket10_9_test_server}
    set i
} 100    
test socket-11.8 {client with several servers} {socket doTestsWithRemoteServer} {
    sendCommand {
	set s1 [socket -server "accept 4003" 4003]
	set s2 [socket -server "accept 4004" 4004]
	set s3 [socket -server "accept 4005" 4005]
	proc accept {mp s a p} {
	    puts $s $mp
	    close $s
	}
    }
    set s1 [socket $remoteServerIP 4003]
    set s2 [socket $remoteServerIP 4004]
    set s3 [socket $remoteServerIP 4005]
    set l ""
    lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \
	[gets $s3] [gets $s3] [eof $s3]
    close $s1
    close $s2
    close $s3
    sendCommand {
	close $s1
	close $s2
	close $s3
    }
    set l
} {4003 {} 1 4004 {} 1 4005 {} 1}
test socket-11.9 {accept callback error} {socket doTestsWithRemoteServer} {
    set s [socket -server accept 2836]
    proc accept {s a p} {expr 10 / 0}
    proc bgerror args {
	global x
	set x $args
    }
    if {[catch {sendCommand {
	    set peername [fconfigure $callerSocket -peername]
	    set s [socket [lindex $peername 0] 2836]
	    close $s
    	 }} msg]} {
	close $s
	error $msg
    }
    set timer [after 10000 "set x timed_out"]
    vwait x
    after cancel $timer
    close $s
    rename bgerror {}
    set x
} {{divide by zero}}
test socket-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket10_12_test_server [socket -server accept 2836]
	proc accept {s a p} {close $s}
    }
    set s [socket $remoteServerIP 2836]
    set p [fconfigure $s -peername]
    set n [fconfigure $s -sockname]
    set l ""
    lappend l [lindex $p 2] [llength $p] [llength $p]
    close $s
    sendCommand {close $socket10_12_test_server}
    set l
} {2836 3 3}
test socket-11.11 {testing spurious events} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket10_13_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    fconfigure $s -translation "auto lf"
	    after 100 writesome $s
	}
	proc writesome {s} {
	    for {set i 0} {$i < 100} {incr i} {
		puts $s "line $i from remote server"
	    }
	    close $s
	}
    }
    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]
	}
    }
    set c [socket $remoteServerIP 2836]
    fileevent $c readable "readlittle $c"
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    sendCommand {close $socket10_13_test_server}
    list $spurious $len
} {0 2690}

test socket-11.12 {testing EOF stickyness} {socket doTestsWithRemoteServer} {
    set counter 0
    set done 0
    proc count_up {s} {
	global counter done after_id
	set l [gets $s]
	if {[eof $s]} {
	    incr counter
	    if {$counter > 9} {
		set done {EOF is sticky}
		after cancel $after_id
		close $s
	    }
	}
    }
    proc timed_out {} {
	global c done
	set done {timed_out, EOF is not sticky}
	close $c
    }
    sendCommand {
	set socket10_14_test_server [socket -server accept 2836]
	proc accept {s a p} {
	    after 100 close $s
	}
    }
    set c [socket $remoteServerIP 2836]
    fileevent $c readable [list count_up $c]
    set after_id [after 1000 timed_out]
    vwait done
    sendCommand {close $socket10_14_test_server}
    set done
} {EOF is sticky}

test socket-11.13 {testing async write, async flush, async close} \
	{socket doTestsWithRemoteServer} {
    proc readit {s} {
	global count done
	set l [read $s]
	incr count [string length $l]
	if {[eof $s]} {
	    close $s
	    set done 1
	}
    }
    sendCommand {
	set firstblock ""
	for {set i 0} {$i < 5} {incr i} {
		set firstblock "a$firstblock$firstblock"
	}
	set secondblock ""
	for {set i 0} {$i < 16} {incr i} {
	    set secondblock "b$secondblock$secondblock"
	}
	set l [socket -server accept 2845]
	proc accept {s a p} {
	    fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
		-buffering line
	    fileevent $s readable "readable $s"
	}
	proc readable {s} {
	    set l [gets $s]
	    fileevent $s readable {}
	    after 1000 respond $s
	}
	proc respond {s} {
	    global firstblock
	    puts -nonewline $s $firstblock
	    after 1000 writedata $s
	}
	proc writedata {s} {
	    global secondblock
	    puts -nonewline $s $secondblock
	    close $s
	}
    }
    set s [socket $remoteServerIP 2845]
    fconfigure $s -blocking 0 -trans lf -buffering line
    set count 0
    puts $s hello
    fileevent $s readable "readit $s"
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    sendCommand {close $l}
    set count
} 65566

set path(script1) [makeFile {} script1]
set path(script2) [makeFile {} script2]

test socket-12.1 {testing inheritance of server sockets} {socket stdio exec} {
    removeFile script1
    removeFile script2

    # Script1 is just a 10 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open $path(script1) w]
    puts $f {
	after 10000 exit
	vwait forever
    }
    close $f

    # Script2 creates the server socket, launches script1,
    # waits a second, and exits.  The server socket will now
    # be closed unless script1 inherited it.

    set f [open $path(script2) w]
    puts $f [list set tcltest [interpreter]]
    puts $f [format {
	set f [socket -server accept 0]
	puts [lindex [fconfigure $f -sockname] 2]
	proc accept { file addr port } {
	    close $file
	}
	exec $tcltest "%s" &
	close $f
	after 1000 exit
	vwait forever
    } $path(script1)]
    close $f
	
    # Launch script2 and wait 5 seconds

    ### exec [interpreter] script2 &
    set p [open "|[list [interpreter] $path(script2)]" r]
    gets $p listen

    after 5000 { set ok_to_proceed 1 }
    vwait ok_to_proceed

    # If we can still connect to the server, the socket got inherited.

    if {[catch {socket 127.0.0.1 $listen} msg]} {
	set x {server socket was not inherited}
    } else {
	close $msg
	set x {server socket was inherited}
    }

    removeFile script1
    removeFile script2
    close $p
    set x
} {server socket was not inherited}
test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} {
    removeFile script1
    removeFile script2

    # Script1 is just a 20 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open $path(script1) w]
    puts $f {
	after 20000 exit
	vwait forever
    }
    close $f

    # Script2 opens the client socket and writes to it.  It then
    # launches script1 and exits.  If the child process inherited the
    # client socket, the socket will still be open.

    set f [open $path(script2) w]
    puts $f [list set tcltest [interpreter]]
    puts $f [format {
        gets stdin port
	set f [socket 127.0.0.1 $port]
	exec $tcltest "%s" &
	puts $f testing
	flush $f
	after 1000 exit
	vwait forever
    } $path(script1)]
    close $f

    # Create the server socket

    set server [socket -server accept 0]
    proc accept { file host port } {
	# When the client connects, establish the read handler
	global server
	close $server
	fileevent $file readable [list getdata $file]
	fconfigure $file -buffering line -blocking 0
	return
    }
    proc getdata { file } {
	# Read handler on the accepted socket.
	global x
	global failed
	set status [catch {read $file} data]
	if {$status != 0} {
	    set x {read failed, error was $data}
	    catch { close $file }
	} elseif {[string compare {} $data]} {
	} elseif {[fblocked $file]} {
	} elseif {[eof $file]} {
	    if {$failed} {
		set x {client socket was inherited}
	    } else {
		set x {client socket was not inherited}
	    }
	    catch { close $file }
	} else {
	    set x {impossible case}
	    catch { close $file }
	}
	return
    }

    # If the socket doesn't hit end-of-file in 10 seconds, the
    # script1 process must have inherited the client.

    set failed 0
    after 10000 [list set failed 1]

    # Launch the script2 process
    ### exec [interpreter] script2 &

    set p [open "|[list [interpreter] $path(script2)]" w]
    puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p

    vwait x
    if {!$failed} {
	vwait failed
    }
    removeFile script1
    removeFile script2
    close $p
    set x
} {client socket was not inherited}
test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} {
    removeFile script1
    removeFile script2

    set f [open $path(script1) w]
    puts $f {
	after 10000 exit
	vwait forever
    }
    close $f

    set f [open $path(script2) w]
    puts $f [list set tcltest [interpreter]]
    puts $f [format {
	set server [socket -server accept 0]
	puts stdout [lindex [fconfigure $server -sockname] 2]
	proc accept { file host port } {
	    global tcltest
	    puts $file {test data on socket}
	    exec $tcltest "%s" &
	    after 1000 exit
	}
	vwait forever
    } $path(script1)]
    close $f

    # Launch the script2 process and connect to it.  See how long
    # the socket stays open

    ## exec [interpreter] script2 &
    set p [open "|[list [interpreter] $path(script2)]" r]
    gets $p listen

    after 1000 set ok_to_proceed 1
    vwait ok_to_proceed

    set f [socket 127.0.0.1 $listen]
    fconfigure $f -buffering full -blocking 0
    fileevent $f readable [list getdata $f]

    # If the socket is still open after 5 seconds, the script1 process
    # must have inherited the accepted socket.

    set failed 0
    after 5000 set failed 1

    proc getdata { file } {
	# Read handler on the client socket.
	global x
	global failed
	set status [catch {read $file} data]
	if {$status != 0} {
	    set x {read failed, error was $data}
	    catch { close $file }
	} elseif {[string compare {} $data]} {
	} elseif {[fblocked $file]} {
	} elseif {[eof $file]} {
	    if {$failed} {
		set x {accepted socket was inherited}
	    } else {
		set x {accepted socket was not inherited}
	    }
	    catch { close $file }
	} else {
	    set x {impossible case}
	    catch { close $file }
	}
	return
    }
    
    vwait x

    removeFile script1
    removeFile script2
    close $p
    set x
} {accepted socket was not inherited}

test socket-13.1 {Testing use of shared socket between two threads} \
	{socket testthread} {

    removeFile script
    threadReap

    makeFile {
	set f [socket -server accept 0]
	set listen [lindex [fconfigure $f -sockname] 2]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
            fconfigure $s -buffering line
        }
	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
	vwait x
	close $f

	# thread cleans itself up.
	testthread exit
    } script
    
    # create a thread
    set serverthread [testthread create { source script } ]
    update
    set port [testthread send $serverthread {set listen}]
    update

    after 1000
    set s [socket 127.0.0.1 $port]
    fconfigure $s -buffering line

    catch {
	puts $s "hello"
	gets $s result
    }
    close $s
    update

    after 2000
    lappend result [threadReap]
    
    set result

} {hello 1}

# cleanup
if {[string match sock* $commandSocket] == 1} {
   puts $commandSocket exit
   flush $commandSocket
}
catch {close $commandSocket}
catch {close $remoteProcChan}
::tcltest::cleanupTests
flush stdout
return