os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/socket.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/socket.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1697 @@
1.4 +# Commands tested in this file: socket.
1.5 +#
1.6 +# This file contains a collection of tests for one or more of the Tcl
1.7 +# built-in commands. Sourcing this file into Tcl runs the tests and
1.8 +# generates output for errors. No output means no errors were found.
1.9 +#
1.10 +# Copyright (c) 1994-1996 Sun Microsystems, Inc.
1.11 +# Copyright (c) 1998-2000 Ajuba Solutions.
1.12 +#
1.13 +# See the file "license.terms" for information on usage and redistribution
1.14 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.15 +#
1.16 +# RCS: @(#) $Id: socket.test,v 1.26.2.6 2006/03/16 00:35:59 andreas_kupries Exp $
1.17 +
1.18 +# Running socket tests with a remote server:
1.19 +# ------------------------------------------
1.20 +#
1.21 +# Some tests in socket.test depend on the existence of a remote server to
1.22 +# which they connect. The remote server must be an instance of tcltest and it
1.23 +# must run the script found in the file "remote.tcl" in this directory. You
1.24 +# can start the remote server on any machine reachable from the machine on
1.25 +# which you want to run the socket tests, by issuing:
1.26 +#
1.27 +# tcltest remote.tcl -port 2048 # Or choose another port number.
1.28 +#
1.29 +# If the machine you are running the remote server on has several IP
1.30 +# interfaces, you can choose which interface the server listens on for
1.31 +# connections by specifying the -address command line flag, so:
1.32 +#
1.33 +# tcltest remote.tcl -address your.machine.com
1.34 +#
1.35 +# These options can also be set by environment variables. On Unix, you can
1.36 +# type these commands to the shell from which the remote server is started:
1.37 +#
1.38 +# shell% setenv serverPort 2048
1.39 +# shell% setenv serverAddress your.machine.com
1.40 +#
1.41 +# and subsequently you can start the remote server with:
1.42 +#
1.43 +# tcltest remote.tcl
1.44 +#
1.45 +# to have it listen on port 2048 on the interface your.machine.com.
1.46 +#
1.47 +# When the server starts, it prints out a detailed message containing its
1.48 +# configuration information, and it will block until killed with a Ctrl-C.
1.49 +# Once the remote server exists, you can run the tests in socket.test with
1.50 +# the server by setting two Tcl variables:
1.51 +#
1.52 +# % set remoteServerIP <name or address of machine on which server runs>
1.53 +# % set remoteServerPort 2048
1.54 +#
1.55 +# These variables are also settable from the environment. On Unix, you can:
1.56 +#
1.57 +# shell% setenv remoteServerIP machine.where.server.runs
1.58 +# shell% senetv remoteServerPort 2048
1.59 +#
1.60 +# The preamble of the socket.test file checks to see if the variables are set
1.61 +# either in Tcl or in the environment; if they are, it attempts to connect to
1.62 +# the server. If the connection is successful, the tests using the remote
1.63 +# server will be performed; otherwise, it will attempt to start the remote
1.64 +# server (via exec) on platforms that support this, on the local host,
1.65 +# listening at port 2048. If all fails, a message is printed and the tests
1.66 +# using the remote server are not performed.
1.67 +
1.68 +package require tcltest 2
1.69 +namespace import -force ::tcltest::*
1.70 +
1.71 +# Some tests require the testthread and exec commands
1.72 +testConstraint testthread [llength [info commands testthread]]
1.73 +testConstraint exec [llength [info commands exec]]
1.74 +
1.75 +# If remoteServerIP or remoteServerPort are not set, check in the
1.76 +# environment variables for externally set values.
1.77 +#
1.78 +
1.79 +if {![info exists remoteServerIP]} {
1.80 + if {[info exists env(remoteServerIP)]} {
1.81 + set remoteServerIP $env(remoteServerIP)
1.82 + }
1.83 +}
1.84 +if {![info exists remoteServerPort]} {
1.85 + if {[info exists env(remoteServerIP)]} {
1.86 + set remoteServerPort $env(remoteServerPort)
1.87 + } else {
1.88 + if {[info exists remoteServerIP]} {
1.89 + set remoteServerPort 2048
1.90 + }
1.91 + }
1.92 +}
1.93 +
1.94 +#
1.95 +# Check if we're supposed to do tests against the remote server
1.96 +#
1.97 +
1.98 +set doTestsWithRemoteServer 1
1.99 +if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} {
1.100 + set remoteServerIP 127.0.0.1
1.101 +}
1.102 +if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
1.103 + set remoteServerPort 2048
1.104 +}
1.105 +
1.106 +# Attempt to connect to a remote server if one is already running. If it
1.107 +# is not running or for some other reason the connect fails, attempt to
1.108 +# start the remote server on the local host listening on port 2048. This
1.109 +# is only done on platforms that support exec (i.e. not on the Mac). On
1.110 +# platforms that do not support exec, the remote server must be started
1.111 +# by the user before running the tests.
1.112 +
1.113 +set remoteProcChan ""
1.114 +set commandSocket ""
1.115 +if {$doTestsWithRemoteServer} {
1.116 + catch {close $commandSocket}
1.117 + if {[catch {set commandSocket [socket $remoteServerIP \
1.118 + $remoteServerPort]}] != 0} {
1.119 + if {[info commands exec] == ""} {
1.120 + set noRemoteTestReason "can't exec"
1.121 + set doTestsWithRemoteServer 0
1.122 + } else {
1.123 + set remoteServerIP 127.0.0.1
1.124 + # Be *extra* careful in case this file is sourced from
1.125 + # a directory other than the current one...
1.126 + set remoteFile [file join [pwd] [file dirname [info script]] \
1.127 + remote.tcl]
1.128 + if {[catch {set remoteProcChan \
1.129 + [open "|[list [interpreter] $remoteFile \
1.130 + -serverIsSilent \
1.131 + -port $remoteServerPort \
1.132 + -address $remoteServerIP]" \
1.133 + w+]} \
1.134 + msg] == 0} {
1.135 + after 1000
1.136 + if {[catch {set commandSocket [socket $remoteServerIP \
1.137 + $remoteServerPort]} msg] == 0} {
1.138 + fconfigure $commandSocket -translation crlf -buffering line
1.139 + } else {
1.140 + set noRemoteTestReason $msg
1.141 + set doTestsWithRemoteServer 0
1.142 + }
1.143 + } else {
1.144 + set noRemoteTestReason "$msg [interpreter]"
1.145 + set doTestsWithRemoteServer 0
1.146 + }
1.147 + }
1.148 + } else {
1.149 + fconfigure $commandSocket -translation crlf -buffering line
1.150 + }
1.151 +}
1.152 +
1.153 +# Some tests are run only if we are doing testing against a remote server.
1.154 +set ::tcltest::testConstraints(doTestsWithRemoteServer) $doTestsWithRemoteServer
1.155 +if {$doTestsWithRemoteServer == 0} {
1.156 + if {[string first s $::tcltest::verbose] != -1} {
1.157 + puts "Skipping tests with remote server. See tests/socket.test for"
1.158 + puts "information on how to run remote server."
1.159 + puts "Reason for not doing remote tests: $noRemoteTestReason"
1.160 + }
1.161 +}
1.162 +
1.163 +#
1.164 +# If we do the tests, define a command to send a command to the
1.165 +# remote server.
1.166 +#
1.167 +
1.168 +if {$doTestsWithRemoteServer == 1} {
1.169 + proc sendCommand {c} {
1.170 + global commandSocket
1.171 +
1.172 + if {[eof $commandSocket]} {
1.173 + error "remote server disappeared"
1.174 + }
1.175 +
1.176 + if {[catch {puts $commandSocket $c} msg]} {
1.177 + error "remote server disappaered: $msg"
1.178 + }
1.179 + if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} {
1.180 + error "remote server disappeared: $msg"
1.181 + }
1.182 +
1.183 + set resp ""
1.184 + while {1} {
1.185 + set line [gets $commandSocket]
1.186 + if {[eof $commandSocket]} {
1.187 + error "remote server disappaered"
1.188 + }
1.189 + if {[string compare $line "--Marker--Marker--Marker--"] == 0} {
1.190 + if {[string compare [lindex $resp 0] error] == 0} {
1.191 + error [lindex $resp 1]
1.192 + } else {
1.193 + return [lindex $resp 1]
1.194 + }
1.195 + } else {
1.196 + append resp $line "\n"
1.197 + }
1.198 + }
1.199 + }
1.200 +}
1.201 +
1.202 +test socket-1.1 {arg parsing for socket command} {socket} {
1.203 + list [catch {socket -server} msg] $msg
1.204 +} {1 {no argument given for -server option}}
1.205 +test socket-1.2 {arg parsing for socket command} {socket} {
1.206 + list [catch {socket -server foo} msg] $msg
1.207 +} {1 {wrong # args: should be either:
1.208 +socket ?-myaddr addr? ?-myport myport? ?-async? host port
1.209 +socket -server command ?-myaddr addr? port}}
1.210 +test socket-1.3 {arg parsing for socket command} {socket} {
1.211 + list [catch {socket -myaddr} msg] $msg
1.212 +} {1 {no argument given for -myaddr option}}
1.213 +test socket-1.4 {arg parsing for socket command} {socket} {
1.214 + list [catch {socket -myaddr 127.0.0.1} msg] $msg
1.215 +} {1 {wrong # args: should be either:
1.216 +socket ?-myaddr addr? ?-myport myport? ?-async? host port
1.217 +socket -server command ?-myaddr addr? port}}
1.218 +test socket-1.5 {arg parsing for socket command} {socket} {
1.219 + list [catch {socket -myport} msg] $msg
1.220 +} {1 {no argument given for -myport option}}
1.221 +test socket-1.6 {arg parsing for socket command} {socket} {
1.222 + list [catch {socket -myport xxxx} msg] $msg
1.223 +} {1 {expected integer but got "xxxx"}}
1.224 +test socket-1.7 {arg parsing for socket command} {socket} {
1.225 + list [catch {socket -myport 2522} msg] $msg
1.226 +} {1 {wrong # args: should be either:
1.227 +socket ?-myaddr addr? ?-myport myport? ?-async? host port
1.228 +socket -server command ?-myaddr addr? port}}
1.229 +test socket-1.8 {arg parsing for socket command} {socket} {
1.230 + list [catch {socket -froboz} msg] $msg
1.231 +} {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}}
1.232 +test socket-1.9 {arg parsing for socket command} {socket} {
1.233 + list [catch {socket -server foo -myport 2521 3333} msg] $msg
1.234 +} {1 {Option -myport is not valid for servers}}
1.235 +test socket-1.10 {arg parsing for socket command} {socket} {
1.236 + list [catch {socket host 2528 -junk} msg] $msg
1.237 +} {1 {wrong # args: should be either:
1.238 +socket ?-myaddr addr? ?-myport myport? ?-async? host port
1.239 +socket -server command ?-myaddr addr? port}}
1.240 +test socket-1.11 {arg parsing for socket command} {socket} {
1.241 + list [catch {socket -server callback 2520 --} msg] $msg
1.242 +} {1 {wrong # args: should be either:
1.243 +socket ?-myaddr addr? ?-myport myport? ?-async? host port
1.244 +socket -server command ?-myaddr addr? port}}
1.245 +test socket-1.12 {arg parsing for socket command} {socket} {
1.246 + list [catch {socket foo badport} msg] $msg
1.247 +} {1 {expected integer but got "badport"}}
1.248 +test socket-1.13 {arg parsing for socket command} {socket} {
1.249 +list [catch {socket -async -server} msg] $msg
1.250 +} {1 {cannot set -async option for server sockets}}
1.251 +test socket-1.14 {arg parsing for socket command} {socket} {
1.252 +list [catch {socket -server foo -async} msg] $msg
1.253 +} {1 {cannot set -async option for server sockets}}
1.254 +
1.255 +set path(script) [makeFile {} script]
1.256 +
1.257 +test socket-2.1 {tcp connection} {socket stdio} {
1.258 + file delete $path(script)
1.259 + set f [open $path(script) w]
1.260 + puts $f {
1.261 + set timer [after 10000 "set x timed_out"]
1.262 + set f [socket -server accept 0]
1.263 + proc accept {file addr port} {
1.264 + global x
1.265 + set x done
1.266 + close $file
1.267 + }
1.268 + puts ready
1.269 + puts [lindex [fconfigure $f -sockname] 2]
1.270 + vwait x
1.271 + after cancel $timer
1.272 + close $f
1.273 + puts $x
1.274 + }
1.275 + close $f
1.276 + set f [open "|[list [interpreter] $path(script)]" r]
1.277 + gets $f x
1.278 + gets $f listen
1.279 + if {[catch {socket 127.0.0.1 $listen} msg]} {
1.280 + set x $msg
1.281 + } else {
1.282 + lappend x [gets $f]
1.283 + close $msg
1.284 + }
1.285 + lappend x [gets $f]
1.286 + close $f
1.287 + set x
1.288 +} {ready done {}}
1.289 +
1.290 +if [info exists port] {
1.291 + incr port
1.292 +} else {
1.293 + set port [expr 2048 + [pid]%1024]
1.294 +}
1.295 +test socket-2.2 {tcp connection with client port specified} {socket stdio} {
1.296 + file delete $path(script)
1.297 + set f [open $path(script) w]
1.298 + puts $f {
1.299 + set timer [after 10000 "set x timeout"]
1.300 + set f [socket -server accept 0]
1.301 + proc accept {file addr port} {
1.302 + global x
1.303 + puts "[gets $file] $port"
1.304 + close $file
1.305 + set x done
1.306 + }
1.307 + puts ready
1.308 + puts [lindex [fconfigure $f -sockname] 2]
1.309 + vwait x
1.310 + after cancel $timer
1.311 + close $f
1.312 + }
1.313 + close $f
1.314 + set f [open "|[list [interpreter] $path(script)]" r]
1.315 + gets $f x
1.316 + gets $f listen
1.317 + global port
1.318 + if {[catch {socket -myport $port 127.0.0.1 $listen} sock]} {
1.319 + set x $sock
1.320 + close [socket 127.0.0.1 $listen]
1.321 + puts stderr $sock
1.322 + } else {
1.323 + puts $sock hello
1.324 + flush $sock
1.325 + lappend x [gets $f]
1.326 + close $sock
1.327 + }
1.328 + close $f
1.329 + set x
1.330 +} [list ready "hello $port"]
1.331 +test socket-2.3 {tcp connection with client interface specified} {socket stdio} {
1.332 + file delete $path(script)
1.333 + set f [open $path(script) w]
1.334 + puts $f {
1.335 + set timer [after 2000 "set x done"]
1.336 + set f [socket -server accept 2830]
1.337 + proc accept {file addr port} {
1.338 + global x
1.339 + puts "[gets $file] $addr"
1.340 + close $file
1.341 + set x done
1.342 + }
1.343 + puts ready
1.344 + vwait x
1.345 + after cancel $timer
1.346 + close $f
1.347 + }
1.348 + close $f
1.349 + set f [open "|[list [interpreter] $path(script)]" r]
1.350 + gets $f x
1.351 + if {[catch {socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} {
1.352 + set x $sock
1.353 + } else {
1.354 + puts $sock hello
1.355 + flush $sock
1.356 + lappend x [gets $f]
1.357 + close $sock
1.358 + }
1.359 + close $f
1.360 + set x
1.361 +} {ready {hello 127.0.0.1}}
1.362 +test socket-2.4 {tcp connection with server interface specified} {socket stdio} {
1.363 + file delete $path(script)
1.364 + set f [open $path(script) w]
1.365 + puts $f {
1.366 + set timer [after 2000 "set x done"]
1.367 + set f [socket -server accept -myaddr 127.0.0.1 0]
1.368 + proc accept {file addr port} {
1.369 + global x
1.370 + puts "[gets $file]"
1.371 + close $file
1.372 + set x done
1.373 + }
1.374 + puts ready
1.375 + puts [lindex [fconfigure $f -sockname] 2]
1.376 + vwait x
1.377 + after cancel $timer
1.378 + close $f
1.379 + }
1.380 + close $f
1.381 + set f [open "|[list [interpreter] $path(script)]" r]
1.382 + gets $f x
1.383 + gets $f listen
1.384 + if {[catch {socket 127.0.0.1 $listen} sock]} {
1.385 + set x $sock
1.386 + } else {
1.387 + puts $sock hello
1.388 + flush $sock
1.389 + lappend x [gets $f]
1.390 + close $sock
1.391 + }
1.392 + close $f
1.393 + set x
1.394 +} {ready hello}
1.395 +test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
1.396 + file delete $path(script)
1.397 + set f [open $path(script) w]
1.398 + puts $f {
1.399 + set timer [after 10000 "set x timeout"]
1.400 + set f [socket -server accept 0]
1.401 + proc accept {file addr port} {
1.402 + global x
1.403 + puts "[gets $file]"
1.404 + close $file
1.405 + set x done
1.406 + }
1.407 + puts ready
1.408 + puts [lindex [fconfigure $f -sockname] 2]
1.409 + vwait x
1.410 + after cancel $timer
1.411 + close $f
1.412 + }
1.413 + close $f
1.414 + set f [open "|[list [interpreter] $path(script)]" r]
1.415 + gets $f x
1.416 + gets $f listen
1.417 + if {[catch {socket 127.0.0.1 $listen} sock]} {
1.418 + set x $sock
1.419 + } else {
1.420 + puts $sock hello
1.421 + flush $sock
1.422 + lappend x [gets $f]
1.423 + close $sock
1.424 + }
1.425 + close $f
1.426 + set x
1.427 +} {ready hello}
1.428 +test socket-2.6 {tcp connection} {socket} {
1.429 + set status ok
1.430 + if {![catch {set sock [socket 127.0.0.1 2833]}]} {
1.431 + if {![catch {gets $sock}]} {
1.432 + set status broken
1.433 + }
1.434 + close $sock
1.435 + }
1.436 + set status
1.437 +} ok
1.438 +test socket-2.7 {echo server, one line} {socket stdio} {
1.439 + file delete $path(script)
1.440 + set f [open $path(script) w]
1.441 + puts $f {
1.442 + set timer [after 10000 "set x timeout"]
1.443 + set f [socket -server accept 0]
1.444 + proc accept {s a p} {
1.445 + fileevent $s readable [list echo $s]
1.446 + fconfigure $s -translation lf -buffering line
1.447 + }
1.448 + proc echo {s} {
1.449 + set l [gets $s]
1.450 + if {[eof $s]} {
1.451 + global x
1.452 + close $s
1.453 + set x done
1.454 + } else {
1.455 + puts $s $l
1.456 + }
1.457 + }
1.458 + puts ready
1.459 + puts [lindex [fconfigure $f -sockname] 2]
1.460 + vwait x
1.461 + after cancel $timer
1.462 + close $f
1.463 + puts $x
1.464 + }
1.465 + close $f
1.466 + set f [open "|[list [interpreter] $path(script)]" r]
1.467 + gets $f
1.468 + gets $f listen
1.469 + set s [socket 127.0.0.1 $listen]
1.470 + fconfigure $s -buffering line -translation lf
1.471 + puts $s "hello abcdefghijklmnop"
1.472 + after 1000
1.473 + set x [gets $s]
1.474 + close $s
1.475 + set y [gets $f]
1.476 + close $f
1.477 + list $x $y
1.478 +} {{hello abcdefghijklmnop} done}
1.479 +removeFile script
1.480 +test socket-2.8 {echo server, loop 50 times, single connection} -constraints {socket stdio} -setup {
1.481 + set path(script) [makeFile {
1.482 + set f [socket -server accept 0]
1.483 + proc accept {s a p} {
1.484 + fileevent $s readable [list echo $s]
1.485 + fconfigure $s -buffering line
1.486 + }
1.487 + proc echo {s} {
1.488 + global i
1.489 + set l [gets $s]
1.490 + if {[eof $s]} {
1.491 + global x
1.492 + close $s
1.493 + set x done
1.494 + } else {
1.495 + incr i
1.496 + puts $s $l
1.497 + }
1.498 + }
1.499 + set i 0
1.500 + puts ready
1.501 + puts [lindex [fconfigure $f -sockname] 2]
1.502 + set timer [after 20000 "set x done"]
1.503 + vwait x
1.504 + after cancel $timer
1.505 + close $f
1.506 + puts "done $i"
1.507 + } script]
1.508 +} -body {
1.509 + set f [open "|[list [interpreter] $path(script)]" r]
1.510 + gets $f
1.511 + gets $f listen
1.512 + set s [socket 127.0.0.1 $listen]
1.513 + fconfigure $s -buffering line
1.514 + catch {
1.515 + for {set x 0} {$x < 50} {incr x} {
1.516 + puts $s "hello abcdefghijklmnop"
1.517 + gets $s
1.518 + }
1.519 + }
1.520 + close $s
1.521 + catch {set x [gets $f]}
1.522 + close $f
1.523 + set x
1.524 +} -cleanup {
1.525 + removeFile script
1.526 +} -result {done 50}
1.527 +set path(script) [makeFile {} script]
1.528 +test socket-2.9 {socket conflict} {socket stdio} {
1.529 + set s [socket -server accept 0]
1.530 + file delete $path(script)
1.531 + set f [open $path(script) w]
1.532 + puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]"
1.533 + close $f
1.534 + set f [open "|[list [interpreter] $path(script)]" r]
1.535 + gets $f
1.536 + after 100
1.537 + set x [list [catch {close $f} msg]]
1.538 + regsub "\n.*$" $msg {} msg ; # cut part of the error message containing the port number
1.539 + lappend x $msg
1.540 + close $s
1.541 + set x
1.542 +} {1 {couldn't open socket: address already in use}}
1.543 +test socket-2.10 {close on accept, accepted socket lives} {socket} {
1.544 + set done 0
1.545 + set timer [after 20000 "set done timed_out"]
1.546 + set ss [socket -server accept 0]
1.547 + proc accept {s a p} {
1.548 + global ss
1.549 + close $ss
1.550 + fileevent $s readable "readit $s"
1.551 + fconfigure $s -trans lf
1.552 + }
1.553 + proc readit {s} {
1.554 + global done
1.555 + gets $s
1.556 + close $s
1.557 + set done 1
1.558 + }
1.559 + set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
1.560 + puts $cs hello
1.561 + close $cs
1.562 + vwait done
1.563 + after cancel $timer
1.564 + set done
1.565 +} 1
1.566 +test socket-2.11 {detecting new data} {socket} {
1.567 + proc accept {s a p} {
1.568 + global sock
1.569 + set sock $s
1.570 + }
1.571 +
1.572 + set s [socket -server accept 0]
1.573 + set sock ""
1.574 + set s2 [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
1.575 + vwait sock
1.576 + puts $s2 one
1.577 + flush $s2
1.578 + after 500
1.579 + fconfigure $sock -blocking 0
1.580 + set result a:[gets $sock]
1.581 + lappend result b:[gets $sock]
1.582 + fconfigure $sock -blocking 1
1.583 + puts $s2 two
1.584 + flush $s2
1.585 + fconfigure $sock -blocking 0
1.586 + lappend result c:[gets $sock]
1.587 + fconfigure $sock -blocking 1
1.588 + close $s2
1.589 + close $s
1.590 + close $sock
1.591 + set result
1.592 +} {a:one b: c:two}
1.593 +
1.594 +
1.595 +test socket-3.1 {socket conflict} {socket stdio} {
1.596 + file delete $path(script)
1.597 + set f [open $path(script) w]
1.598 + puts $f {
1.599 + set f [socket -server accept 0]
1.600 + puts ready
1.601 + puts [lindex [fconfigure $f -sockname] 2]
1.602 + gets stdin
1.603 + close $f
1.604 + }
1.605 + close $f
1.606 + set f [open "|[list [interpreter] $path(script)]" r+]
1.607 + gets $f
1.608 + gets $f listen
1.609 + set x [list [catch {socket -server accept $listen} msg] \
1.610 + $msg]
1.611 + puts $f bye
1.612 + close $f
1.613 + set x
1.614 +} {1 {couldn't open socket: address already in use}}
1.615 +test socket-3.2 {server with several clients} {socket stdio} {
1.616 + file delete $path(script)
1.617 + set f [open $path(script) w]
1.618 + puts $f {
1.619 + set t1 [after 30000 "set x timed_out"]
1.620 + set t2 [after 31000 "set x timed_out"]
1.621 + set t3 [after 32000 "set x timed_out"]
1.622 + set counter 0
1.623 + set s [socket -server accept 0]
1.624 + proc accept {s a p} {
1.625 + fileevent $s readable [list echo $s]
1.626 + fconfigure $s -buffering line
1.627 + }
1.628 + proc echo {s} {
1.629 + global x
1.630 + set l [gets $s]
1.631 + if {[eof $s]} {
1.632 + close $s
1.633 + set x done
1.634 + } else {
1.635 + puts $s $l
1.636 + }
1.637 + }
1.638 + puts ready
1.639 + puts [lindex [fconfigure $s -sockname] 2]
1.640 + vwait x
1.641 + after cancel $t1
1.642 + vwait x
1.643 + after cancel $t2
1.644 + vwait x
1.645 + after cancel $t3
1.646 + close $s
1.647 + puts $x
1.648 + }
1.649 + close $f
1.650 + set f [open "|[list [interpreter] $path(script)]" r+]
1.651 + set x [gets $f]
1.652 + gets $f listen
1.653 + set s1 [socket 127.0.0.1 $listen]
1.654 + fconfigure $s1 -buffering line
1.655 + set s2 [socket 127.0.0.1 $listen]
1.656 + fconfigure $s2 -buffering line
1.657 + set s3 [socket 127.0.0.1 $listen]
1.658 + fconfigure $s3 -buffering line
1.659 + for {set i 0} {$i < 100} {incr i} {
1.660 + puts $s1 hello,s1
1.661 + gets $s1
1.662 + puts $s2 hello,s2
1.663 + gets $s2
1.664 + puts $s3 hello,s3
1.665 + gets $s3
1.666 + }
1.667 + close $s1
1.668 + close $s2
1.669 + close $s3
1.670 + lappend x [gets $f]
1.671 + close $f
1.672 + set x
1.673 +} {ready done}
1.674 +
1.675 +test socket-4.1 {server with several clients} {socket stdio} {
1.676 + file delete $path(script)
1.677 + set f [open $path(script) w]
1.678 + puts $f {
1.679 + set port [gets stdin]
1.680 + set s [socket 127.0.0.1 $port]
1.681 + fconfigure $s -buffering line
1.682 + for {set i 0} {$i < 100} {incr i} {
1.683 + puts $s hello
1.684 + gets $s
1.685 + }
1.686 + close $s
1.687 + puts bye
1.688 + gets stdin
1.689 + }
1.690 + close $f
1.691 + set p1 [open "|[list [interpreter] $path(script)]" r+]
1.692 + fconfigure $p1 -buffering line
1.693 + set p2 [open "|[list [interpreter] $path(script)]" r+]
1.694 + fconfigure $p2 -buffering line
1.695 + set p3 [open "|[list [interpreter] $path(script)]" r+]
1.696 + fconfigure $p3 -buffering line
1.697 + proc accept {s a p} {
1.698 + fconfigure $s -buffering line
1.699 + fileevent $s readable [list echo $s]
1.700 + }
1.701 + proc echo {s} {
1.702 + global x
1.703 + set l [gets $s]
1.704 + if {[eof $s]} {
1.705 + close $s
1.706 + set x done
1.707 + } else {
1.708 + puts $s $l
1.709 + }
1.710 + }
1.711 + set t1 [after 30000 "set x timed_out"]
1.712 + set t2 [after 31000 "set x timed_out"]
1.713 + set t3 [after 32000 "set x timed_out"]
1.714 + set s [socket -server accept 0]
1.715 + set listen [lindex [fconfigure $s -sockname] 2]
1.716 + puts $p1 $listen
1.717 + puts $p2 $listen
1.718 + puts $p3 $listen
1.719 + vwait x
1.720 + vwait x
1.721 + vwait x
1.722 + after cancel $t1
1.723 + after cancel $t2
1.724 + after cancel $t3
1.725 + close $s
1.726 + set l ""
1.727 + lappend l [list p1 [gets $p1] $x]
1.728 + lappend l [list p2 [gets $p2] $x]
1.729 + lappend l [list p3 [gets $p3] $x]
1.730 + puts $p1 bye
1.731 + puts $p2 bye
1.732 + puts $p3 bye
1.733 + close $p1
1.734 + close $p2
1.735 + close $p3
1.736 + set l
1.737 +} {{p1 bye done} {p2 bye done} {p3 bye done}}
1.738 +test socket-4.2 {byte order problems, socket numbers, htons} {socket} {
1.739 + set x ok
1.740 + if {[catch {socket -server dodo 0x3000} msg]} {
1.741 + set x $msg
1.742 + } else {
1.743 + close $msg
1.744 + }
1.745 + set x
1.746 +} ok
1.747 +
1.748 +test socket-5.1 {byte order problems, socket numbers, htons} \
1.749 + {socket unixOnly notRoot} {
1.750 + set x {couldn't open socket: not owner}
1.751 + if {![catch {socket -server dodo 0x1} msg]} {
1.752 + set x {htons problem, should be disallowed, are you running as SU?}
1.753 + close $msg
1.754 + }
1.755 + set x
1.756 +} {couldn't open socket: not owner}
1.757 +test socket-5.2 {byte order problems, socket numbers, htons} {socket} {
1.758 + set x {couldn't open socket: port number too high}
1.759 + if {![catch {socket -server dodo 0x10000} msg]} {
1.760 + set x {port resolution problem, should be disallowed}
1.761 + close $msg
1.762 + }
1.763 + set x
1.764 +} {couldn't open socket: port number too high}
1.765 +test socket-5.3 {byte order problems, socket numbers, htons} \
1.766 + {socket unixOnly notRoot} {
1.767 + set x {couldn't open socket: not owner}
1.768 + if {![catch {socket -server dodo 21} msg]} {
1.769 + set x {htons problem, should be disallowed, are you running as SU?}
1.770 + close $msg
1.771 + }
1.772 + set x
1.773 +} {couldn't open socket: not owner}
1.774 +
1.775 +test socket-6.1 {accept callback error} {socket stdio} {
1.776 + file delete $path(script)
1.777 + set f [open $path(script) w]
1.778 + puts $f {
1.779 + gets stdin port
1.780 + socket 127.0.0.1 $port
1.781 + }
1.782 + close $f
1.783 + set f [open "|[list [interpreter] $path(script)]" r+]
1.784 + proc bgerror args {
1.785 + global x
1.786 + set x $args
1.787 + }
1.788 + proc accept {s a p} {expr 10 / 0}
1.789 + set s [socket -server accept 0]
1.790 + puts $f [lindex [fconfigure $s -sockname] 2]
1.791 + close $f
1.792 + set timer [after 10000 "set x timed_out"]
1.793 + vwait x
1.794 + after cancel $timer
1.795 + close $s
1.796 + rename bgerror {}
1.797 + set x
1.798 +} {{divide by zero}}
1.799 +
1.800 +test socket-7.1 {testing socket specific options} {socket stdio} {
1.801 + file delete $path(script)
1.802 + set f [open $path(script) w]
1.803 + puts $f {
1.804 + set ss [socket -server accept 0]
1.805 + proc accept args {
1.806 + global x
1.807 + set x done
1.808 + }
1.809 + puts ready
1.810 + puts [lindex [fconfigure $ss -sockname] 2]
1.811 + set timer [after 10000 "set x timed_out"]
1.812 + vwait x
1.813 + after cancel $timer
1.814 + }
1.815 + close $f
1.816 + set f [open "|[list [interpreter] $path(script)]" r]
1.817 + gets $f
1.818 + gets $f listen
1.819 + set s [socket 127.0.0.1 $listen]
1.820 + set p [fconfigure $s -peername]
1.821 + close $s
1.822 + close $f
1.823 + set l ""
1.824 + lappend l [string compare [lindex $p 0] 127.0.0.1]
1.825 + lappend l [string compare [lindex $p 2] $listen]
1.826 + lappend l [llength $p]
1.827 +} {0 0 3}
1.828 +test socket-7.2 {testing socket specific options} {socket stdio} {
1.829 + file delete $path(script)
1.830 + set f [open $path(script) w]
1.831 + puts $f {
1.832 + set ss [socket -server accept 2821]
1.833 + proc accept args {
1.834 + global x
1.835 + set x done
1.836 + }
1.837 + puts ready
1.838 + puts [lindex [fconfigure $ss -sockname] 2]
1.839 + set timer [after 10000 "set x timed_out"]
1.840 + vwait x
1.841 + after cancel $timer
1.842 + }
1.843 + close $f
1.844 + set f [open "|[list [interpreter] $path(script)]" r]
1.845 + gets $f
1.846 + gets $f listen
1.847 + set s [socket 127.0.0.1 $listen]
1.848 + set p [fconfigure $s -sockname]
1.849 + close $s
1.850 + close $f
1.851 + list [llength $p] \
1.852 + [regexp {^(127\.0\.0\.1|0\.0\.0\.0)$} [lindex $p 0]] \
1.853 + [expr {[lindex $p 2] == $listen}]
1.854 +} {3 1 0}
1.855 +test socket-7.3 {testing socket specific options} {socket} {
1.856 + set s [socket -server accept 0]
1.857 + set l [fconfigure $s]
1.858 + close $s
1.859 + update
1.860 + llength $l
1.861 +} 14
1.862 +test socket-7.4 {testing socket specific options} {socket} {
1.863 + set s [socket -server accept 0]
1.864 + proc accept {s a p} {
1.865 + global x
1.866 + set x [fconfigure $s -sockname]
1.867 + close $s
1.868 + }
1.869 + set listen [lindex [fconfigure $s -sockname] 2]
1.870 + set s1 [socket [info hostname] $listen]
1.871 + set timer [after 10000 "set x timed_out"]
1.872 + vwait x
1.873 + after cancel $timer
1.874 + close $s
1.875 + close $s1
1.876 + set l ""
1.877 + lappend l [expr {[lindex $x 2] == $listen}] [llength $x]
1.878 +} {1 3}
1.879 +test socket-7.5 {testing socket specific options} {socket unixOrPc} {
1.880 + set s [socket -server accept 0]
1.881 + proc accept {s a p} {
1.882 + global x
1.883 + set x [fconfigure $s -sockname]
1.884 + close $s
1.885 + }
1.886 + set listen [lindex [fconfigure $s -sockname] 2]
1.887 + set s1 [socket 127.0.0.1 $listen]
1.888 + set timer [after 10000 "set x timed_out"]
1.889 + vwait x
1.890 + after cancel $timer
1.891 + close $s
1.892 + close $s1
1.893 + set l ""
1.894 + lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x]
1.895 +} {127.0.0.1 1 3}
1.896 +
1.897 +test socket-8.1 {testing -async flag on sockets} {socket} {
1.898 + # NOTE: This test may fail on some Solaris 2.4 systems. If it does,
1.899 + # check that you have these patches installed (using showrev -p):
1.900 + #
1.901 + # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
1.902 + # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
1.903 + # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
1.904 + # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
1.905 + # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01,
1.906 + # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03
1.907 + #
1.908 + # If after installing these patches you are still experiencing a
1.909 + # problem, please email jyl@eng.sun.com. We have not observed this
1.910 + # failure on Solaris 2.5, so another option (instead of installing
1.911 + # these patches) is to upgrade to Solaris 2.5.
1.912 + set s [socket -server accept 0]
1.913 + proc accept {s a p} {
1.914 + global x
1.915 + puts $s bye
1.916 + close $s
1.917 + set x done
1.918 + }
1.919 + set s1 [socket -async [info hostname] [lindex [fconfigure $s -sockname] 2]]
1.920 + vwait x
1.921 + set z [gets $s1]
1.922 + close $s
1.923 + close $s1
1.924 + set z
1.925 +} bye
1.926 +
1.927 +test socket-9.1 {testing spurious events} {socket} {
1.928 + set len 0
1.929 + set spurious 0
1.930 + set done 0
1.931 + proc readlittle {s} {
1.932 + global spurious done len
1.933 + set l [read $s 1]
1.934 + if {[string length $l] == 0} {
1.935 + if {![eof $s]} {
1.936 + incr spurious
1.937 + } else {
1.938 + close $s
1.939 + set done 1
1.940 + }
1.941 + } else {
1.942 + incr len [string length $l]
1.943 + }
1.944 + }
1.945 + proc accept {s a p} {
1.946 + fconfigure $s -buffering none -blocking off
1.947 + fileevent $s readable [list readlittle $s]
1.948 + }
1.949 + set s [socket -server accept 0]
1.950 + set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
1.951 + puts -nonewline $c 01234567890123456789012345678901234567890123456789
1.952 + close $c
1.953 + set timer [after 10000 "set done timed_out"]
1.954 + vwait done
1.955 + after cancel $timer
1.956 + close $s
1.957 + list $spurious $len
1.958 +} {0 50}
1.959 +test socket-9.2 {testing async write, fileevents, flush on close} {socket} {
1.960 + set firstblock ""
1.961 + for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
1.962 + set secondblock ""
1.963 + for {set i 0} {$i < 16} {incr i} {
1.964 + set secondblock "b$secondblock$secondblock"
1.965 + }
1.966 + set l [socket -server accept 0]
1.967 + proc accept {s a p} {
1.968 + fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
1.969 + -buffering line
1.970 + fileevent $s readable "readable $s"
1.971 + }
1.972 + proc readable {s} {
1.973 + set l [gets $s]
1.974 + fileevent $s readable {}
1.975 + after 1000 respond $s
1.976 + }
1.977 + proc respond {s} {
1.978 + global firstblock
1.979 + puts -nonewline $s $firstblock
1.980 + after 1000 writedata $s
1.981 + }
1.982 + proc writedata {s} {
1.983 + global secondblock
1.984 + puts -nonewline $s $secondblock
1.985 + close $s
1.986 + }
1.987 + set s [socket [info hostname] [lindex [fconfigure $l -sockname] 2]]
1.988 + fconfigure $s -blocking 0 -trans lf -buffering line
1.989 + set count 0
1.990 + puts $s hello
1.991 + proc readit {s} {
1.992 + global count done
1.993 + set l [read $s]
1.994 + incr count [string length $l]
1.995 + if {[eof $s]} {
1.996 + close $s
1.997 + set done 1
1.998 + }
1.999 + }
1.1000 + fileevent $s readable "readit $s"
1.1001 + set timer [after 10000 "set done timed_out"]
1.1002 + vwait done
1.1003 + after cancel $timer
1.1004 + close $l
1.1005 + set count
1.1006 +} 65566
1.1007 +test socket-9.3 {testing EOF stickyness} {socket} {
1.1008 + proc count_to_eof {s} {
1.1009 + global count done timer
1.1010 + set l [gets $s]
1.1011 + if {[eof $s]} {
1.1012 + incr count
1.1013 + if {$count > 9} {
1.1014 + close $s
1.1015 + set done true
1.1016 + set count {eof is sticky}
1.1017 + after cancel $timer
1.1018 + }
1.1019 + }
1.1020 + }
1.1021 + proc timerproc {} {
1.1022 + global done count c
1.1023 + set done true
1.1024 + set count {timer went off, eof is not sticky}
1.1025 + close $c
1.1026 + }
1.1027 + set count 0
1.1028 + set done false
1.1029 + proc write_then_close {s} {
1.1030 + puts $s bye
1.1031 + close $s
1.1032 + }
1.1033 + proc accept {s a p} {
1.1034 + fconfigure $s -buffering line -translation lf
1.1035 + fileevent $s writable "write_then_close $s"
1.1036 + }
1.1037 + set s [socket -server accept 0]
1.1038 + set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
1.1039 + fconfigure $c -blocking off -buffering line -translation lf
1.1040 + fileevent $c readable "count_to_eof $c"
1.1041 + set timer [after 1000 timerproc]
1.1042 + vwait done
1.1043 + close $s
1.1044 + set count
1.1045 +} {eof is sticky}
1.1046 +
1.1047 +removeFile script
1.1048 +
1.1049 +test socket-10.1 {testing socket accept callback error handling} {socket} {
1.1050 + set goterror 0
1.1051 + proc bgerror args {global goterror; set goterror 1}
1.1052 + set s [socket -server accept 0]
1.1053 + proc accept {s a p} {close $s; error}
1.1054 + set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
1.1055 + vwait goterror
1.1056 + close $s
1.1057 + close $c
1.1058 + set goterror
1.1059 +} 1
1.1060 +
1.1061 +test socket-11.1 {tcp connection} {socket doTestsWithRemoteServer} {
1.1062 + sendCommand {
1.1063 + set socket9_1_test_server [socket -server accept 2834]
1.1064 + proc accept {s a p} {
1.1065 + puts $s done
1.1066 + close $s
1.1067 + }
1.1068 + }
1.1069 + set s [socket $remoteServerIP 2834]
1.1070 + set r [gets $s]
1.1071 + close $s
1.1072 + sendCommand {close $socket9_1_test_server}
1.1073 + set r
1.1074 +} done
1.1075 +test socket-11.2 {client specifies its port} {socket doTestsWithRemoteServer} {
1.1076 + if {[info exists port]} {
1.1077 + incr port
1.1078 + } else {
1.1079 + set port [expr 2048 + [pid]%1024]
1.1080 + }
1.1081 + sendCommand {
1.1082 + set socket9_2_test_server [socket -server accept 2835]
1.1083 + proc accept {s a p} {
1.1084 + puts $s $p
1.1085 + close $s
1.1086 + }
1.1087 + }
1.1088 + set s [socket -myport $port $remoteServerIP 2835]
1.1089 + set r [gets $s]
1.1090 + close $s
1.1091 + sendCommand {close $socket9_2_test_server}
1.1092 + if {$r == $port} {
1.1093 + set result ok
1.1094 + } else {
1.1095 + set result broken
1.1096 + }
1.1097 + set result
1.1098 +} ok
1.1099 +test socket-11.3 {trying to connect, no server} {socket doTestsWithRemoteServer} {
1.1100 + set status ok
1.1101 + if {![catch {set s [socket $remoteServerIp 2836]}]} {
1.1102 + if {![catch {gets $s}]} {
1.1103 + set status broken
1.1104 + }
1.1105 + close $s
1.1106 + }
1.1107 + set status
1.1108 +} ok
1.1109 +test socket-11.4 {remote echo, one line} {socket doTestsWithRemoteServer} {
1.1110 + sendCommand {
1.1111 + set socket10_6_test_server [socket -server accept 2836]
1.1112 + proc accept {s a p} {
1.1113 + fileevent $s readable [list echo $s]
1.1114 + fconfigure $s -buffering line -translation crlf
1.1115 + }
1.1116 + proc echo {s} {
1.1117 + set l [gets $s]
1.1118 + if {[eof $s]} {
1.1119 + close $s
1.1120 + } else {
1.1121 + puts $s $l
1.1122 + }
1.1123 + }
1.1124 + }
1.1125 + set f [socket $remoteServerIP 2836]
1.1126 + fconfigure $f -translation crlf -buffering line
1.1127 + puts $f hello
1.1128 + set r [gets $f]
1.1129 + close $f
1.1130 + sendCommand {close $socket10_6_test_server}
1.1131 + set r
1.1132 +} hello
1.1133 +test socket-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} {
1.1134 + sendCommand {
1.1135 + set socket10_7_test_server [socket -server accept 2836]
1.1136 + proc accept {s a p} {
1.1137 + fileevent $s readable [list echo $s]
1.1138 + fconfigure $s -buffering line -translation crlf
1.1139 + }
1.1140 + proc echo {s} {
1.1141 + set l [gets $s]
1.1142 + if {[eof $s]} {
1.1143 + close $s
1.1144 + } else {
1.1145 + puts $s $l
1.1146 + }
1.1147 + }
1.1148 + }
1.1149 + set f [socket $remoteServerIP 2836]
1.1150 + fconfigure $f -translation crlf -buffering line
1.1151 + for {set cnt 0} {$cnt < 50} {incr cnt} {
1.1152 + puts $f "hello, $cnt"
1.1153 + if {[string compare [gets $f] "hello, $cnt"] != 0} {
1.1154 + break
1.1155 + }
1.1156 + }
1.1157 + close $f
1.1158 + sendCommand {close $socket10_7_test_server}
1.1159 + set cnt
1.1160 +} 50
1.1161 +# Macintosh sockets can have more than one server per port
1.1162 +if {$tcl_platform(platform) == "macintosh"} {
1.1163 + set conflictResult {0 2836}
1.1164 +} else {
1.1165 + set conflictResult {1 {couldn't open socket: address already in use}}
1.1166 +}
1.1167 +test socket-11.6 {socket conflict} {socket doTestsWithRemoteServer} {
1.1168 + set s1 [socket -server accept 2836]
1.1169 + if {[catch {set s2 [socket -server accept 2836]} msg]} {
1.1170 + set result [list 1 $msg]
1.1171 + } else {
1.1172 + set result [list 0 [lindex [fconfigure $s2 -sockname] 2]]
1.1173 + close $s2
1.1174 + }
1.1175 + close $s1
1.1176 + set result
1.1177 +} $conflictResult
1.1178 +test socket-11.7 {server with several clients} {socket doTestsWithRemoteServer} {
1.1179 + sendCommand {
1.1180 + set socket10_9_test_server [socket -server accept 2836]
1.1181 + proc accept {s a p} {
1.1182 + fconfigure $s -buffering line
1.1183 + fileevent $s readable [list echo $s]
1.1184 + }
1.1185 + proc echo {s} {
1.1186 + set l [gets $s]
1.1187 + if {[eof $s]} {
1.1188 + close $s
1.1189 + } else {
1.1190 + puts $s $l
1.1191 + }
1.1192 + }
1.1193 + }
1.1194 + set s1 [socket $remoteServerIP 2836]
1.1195 + fconfigure $s1 -buffering line
1.1196 + set s2 [socket $remoteServerIP 2836]
1.1197 + fconfigure $s2 -buffering line
1.1198 + set s3 [socket $remoteServerIP 2836]
1.1199 + fconfigure $s3 -buffering line
1.1200 + for {set i 0} {$i < 100} {incr i} {
1.1201 + puts $s1 hello,s1
1.1202 + gets $s1
1.1203 + puts $s2 hello,s2
1.1204 + gets $s2
1.1205 + puts $s3 hello,s3
1.1206 + gets $s3
1.1207 + }
1.1208 + close $s1
1.1209 + close $s2
1.1210 + close $s3
1.1211 + sendCommand {close $socket10_9_test_server}
1.1212 + set i
1.1213 +} 100
1.1214 +test socket-11.8 {client with several servers} {socket doTestsWithRemoteServer} {
1.1215 + sendCommand {
1.1216 + set s1 [socket -server "accept 4003" 4003]
1.1217 + set s2 [socket -server "accept 4004" 4004]
1.1218 + set s3 [socket -server "accept 4005" 4005]
1.1219 + proc accept {mp s a p} {
1.1220 + puts $s $mp
1.1221 + close $s
1.1222 + }
1.1223 + }
1.1224 + set s1 [socket $remoteServerIP 4003]
1.1225 + set s2 [socket $remoteServerIP 4004]
1.1226 + set s3 [socket $remoteServerIP 4005]
1.1227 + set l ""
1.1228 + lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \
1.1229 + [gets $s3] [gets $s3] [eof $s3]
1.1230 + close $s1
1.1231 + close $s2
1.1232 + close $s3
1.1233 + sendCommand {
1.1234 + close $s1
1.1235 + close $s2
1.1236 + close $s3
1.1237 + }
1.1238 + set l
1.1239 +} {4003 {} 1 4004 {} 1 4005 {} 1}
1.1240 +test socket-11.9 {accept callback error} {socket doTestsWithRemoteServer} {
1.1241 + set s [socket -server accept 2836]
1.1242 + proc accept {s a p} {expr 10 / 0}
1.1243 + proc bgerror args {
1.1244 + global x
1.1245 + set x $args
1.1246 + }
1.1247 + if {[catch {sendCommand {
1.1248 + set peername [fconfigure $callerSocket -peername]
1.1249 + set s [socket [lindex $peername 0] 2836]
1.1250 + close $s
1.1251 + }} msg]} {
1.1252 + close $s
1.1253 + error $msg
1.1254 + }
1.1255 + set timer [after 10000 "set x timed_out"]
1.1256 + vwait x
1.1257 + after cancel $timer
1.1258 + close $s
1.1259 + rename bgerror {}
1.1260 + set x
1.1261 +} {{divide by zero}}
1.1262 +test socket-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} {
1.1263 + sendCommand {
1.1264 + set socket10_12_test_server [socket -server accept 2836]
1.1265 + proc accept {s a p} {close $s}
1.1266 + }
1.1267 + set s [socket $remoteServerIP 2836]
1.1268 + set p [fconfigure $s -peername]
1.1269 + set n [fconfigure $s -sockname]
1.1270 + set l ""
1.1271 + lappend l [lindex $p 2] [llength $p] [llength $p]
1.1272 + close $s
1.1273 + sendCommand {close $socket10_12_test_server}
1.1274 + set l
1.1275 +} {2836 3 3}
1.1276 +test socket-11.11 {testing spurious events} {socket doTestsWithRemoteServer} {
1.1277 + sendCommand {
1.1278 + set socket10_13_test_server [socket -server accept 2836]
1.1279 + proc accept {s a p} {
1.1280 + fconfigure $s -translation "auto lf"
1.1281 + after 100 writesome $s
1.1282 + }
1.1283 + proc writesome {s} {
1.1284 + for {set i 0} {$i < 100} {incr i} {
1.1285 + puts $s "line $i from remote server"
1.1286 + }
1.1287 + close $s
1.1288 + }
1.1289 + }
1.1290 + set len 0
1.1291 + set spurious 0
1.1292 + set done 0
1.1293 + proc readlittle {s} {
1.1294 + global spurious done len
1.1295 + set l [read $s 1]
1.1296 + if {[string length $l] == 0} {
1.1297 + if {![eof $s]} {
1.1298 + incr spurious
1.1299 + } else {
1.1300 + close $s
1.1301 + set done 1
1.1302 + }
1.1303 + } else {
1.1304 + incr len [string length $l]
1.1305 + }
1.1306 + }
1.1307 + set c [socket $remoteServerIP 2836]
1.1308 + fileevent $c readable "readlittle $c"
1.1309 + set timer [after 40000 "set done timed_out"]
1.1310 + vwait done
1.1311 + after cancel $timer
1.1312 + sendCommand {close $socket10_13_test_server}
1.1313 + list $spurious $len $done
1.1314 +} {0 2690 1}
1.1315 +
1.1316 +test socket-11.12 {testing EOF stickyness} {socket doTestsWithRemoteServer} {
1.1317 + set counter 0
1.1318 + set done 0
1.1319 + proc count_up {s} {
1.1320 + global counter done after_id
1.1321 + set l [gets $s]
1.1322 + if {[eof $s]} {
1.1323 + incr counter
1.1324 + if {$counter > 9} {
1.1325 + set done {EOF is sticky}
1.1326 + after cancel $after_id
1.1327 + close $s
1.1328 + }
1.1329 + }
1.1330 + }
1.1331 + proc timed_out {} {
1.1332 + global c done
1.1333 + set done {timed_out, EOF is not sticky}
1.1334 + close $c
1.1335 + }
1.1336 + sendCommand {
1.1337 + set socket10_14_test_server [socket -server accept 2836]
1.1338 + proc accept {s a p} {
1.1339 + after 100 close $s
1.1340 + }
1.1341 + }
1.1342 + set c [socket $remoteServerIP 2836]
1.1343 + fileevent $c readable [list count_up $c]
1.1344 + set after_id [after 1000 timed_out]
1.1345 + vwait done
1.1346 + sendCommand {close $socket10_14_test_server}
1.1347 + set done
1.1348 +} {EOF is sticky}
1.1349 +
1.1350 +test socket-11.13 {testing async write, async flush, async close} \
1.1351 + {socket doTestsWithRemoteServer} {
1.1352 + proc readit {s} {
1.1353 + global count done
1.1354 + set l [read $s]
1.1355 + incr count [string length $l]
1.1356 + if {[eof $s]} {
1.1357 + close $s
1.1358 + set done 1
1.1359 + }
1.1360 + }
1.1361 + sendCommand {
1.1362 + set firstblock ""
1.1363 + for {set i 0} {$i < 5} {incr i} {
1.1364 + set firstblock "a$firstblock$firstblock"
1.1365 + }
1.1366 + set secondblock ""
1.1367 + for {set i 0} {$i < 16} {incr i} {
1.1368 + set secondblock "b$secondblock$secondblock"
1.1369 + }
1.1370 + set l [socket -server accept 2845]
1.1371 + proc accept {s a p} {
1.1372 + fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
1.1373 + -buffering line
1.1374 + fileevent $s readable "readable $s"
1.1375 + }
1.1376 + proc readable {s} {
1.1377 + set l [gets $s]
1.1378 + fileevent $s readable {}
1.1379 + after 1000 respond $s
1.1380 + }
1.1381 + proc respond {s} {
1.1382 + global firstblock
1.1383 + puts -nonewline $s $firstblock
1.1384 + after 1000 writedata $s
1.1385 + }
1.1386 + proc writedata {s} {
1.1387 + global secondblock
1.1388 + puts -nonewline $s $secondblock
1.1389 + close $s
1.1390 + }
1.1391 + }
1.1392 + set s [socket $remoteServerIP 2845]
1.1393 + fconfigure $s -blocking 0 -trans lf -buffering line
1.1394 + set count 0
1.1395 + puts $s hello
1.1396 + fileevent $s readable "readit $s"
1.1397 + set timer [after 10000 "set done timed_out"]
1.1398 + vwait done
1.1399 + after cancel $timer
1.1400 + sendCommand {close $l}
1.1401 + set count
1.1402 +} 65566
1.1403 +
1.1404 +set path(script1) [makeFile {} script1]
1.1405 +set path(script2) [makeFile {} script2]
1.1406 +
1.1407 +test socket-12.1 {testing inheritance of server sockets} {socket stdio exec} {
1.1408 + file delete $path(script1)
1.1409 + file delete $path(script2)
1.1410 +
1.1411 + # Script1 is just a 10 second delay. If the server socket
1.1412 + # is inherited, it will be held open for 10 seconds
1.1413 +
1.1414 + set f [open $path(script1) w]
1.1415 + puts $f {
1.1416 + after 10000 exit
1.1417 + vwait forever
1.1418 + }
1.1419 + close $f
1.1420 +
1.1421 + # Script2 creates the server socket, launches script1,
1.1422 + # waits a second, and exits. The server socket will now
1.1423 + # be closed unless script1 inherited it.
1.1424 +
1.1425 + set f [open $path(script2) w]
1.1426 + puts $f [list set tcltest [interpreter]]
1.1427 + puts -nonewline $f {
1.1428 + set f [socket -server accept 0]
1.1429 + puts [lindex [fconfigure $f -sockname] 2]
1.1430 + proc accept { file addr port } {
1.1431 + close $file
1.1432 + }
1.1433 + exec $tcltest }
1.1434 + puts $f [list $path(script1) &]
1.1435 + puts $f {
1.1436 + close $f
1.1437 + after 1000 exit
1.1438 + vwait forever
1.1439 + }
1.1440 + close $f
1.1441 +
1.1442 + # Launch script2 and wait 5 seconds
1.1443 +
1.1444 + ### exec [interpreter] script2 &
1.1445 + set p [open "|[list [interpreter] $path(script2)]" r]
1.1446 + gets $p listen
1.1447 +
1.1448 + after 5000 { set ok_to_proceed 1 }
1.1449 + vwait ok_to_proceed
1.1450 +
1.1451 + # If we can still connect to the server, the socket got inherited.
1.1452 +
1.1453 + if {[catch {socket 127.0.0.1 $listen} msg]} {
1.1454 + set x {server socket was not inherited}
1.1455 + } else {
1.1456 + close $msg
1.1457 + set x {server socket was inherited}
1.1458 + }
1.1459 +
1.1460 + close $p
1.1461 + set x
1.1462 +} {server socket was not inherited}
1.1463 +test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} {
1.1464 + file delete $path(script1)
1.1465 + file delete $path(script2)
1.1466 +
1.1467 + # Script1 is just a 20 second delay. If the server socket
1.1468 + # is inherited, it will be held open for 10 seconds
1.1469 +
1.1470 + set f [open $path(script1) w]
1.1471 + puts $f {
1.1472 + after 20000 exit
1.1473 + vwait forever
1.1474 + }
1.1475 + close $f
1.1476 +
1.1477 + # Script2 opens the client socket and writes to it. It then
1.1478 + # launches script1 and exits. If the child process inherited the
1.1479 + # client socket, the socket will still be open.
1.1480 +
1.1481 + set f [open $path(script2) w]
1.1482 + puts $f [list set tcltest [interpreter]]
1.1483 + puts -nonewline $f {
1.1484 + gets stdin port
1.1485 + set f [socket 127.0.0.1 $port]
1.1486 + exec $tcltest }
1.1487 + puts $f [list $path(script1) &]
1.1488 + puts $f {
1.1489 + puts $f testing
1.1490 + flush $f
1.1491 + after 1000 exit
1.1492 + vwait forever
1.1493 + }
1.1494 + close $f
1.1495 +
1.1496 + # Create the server socket
1.1497 +
1.1498 + set server [socket -server accept 0]
1.1499 + proc accept { file host port } {
1.1500 + # When the client connects, establish the read handler
1.1501 + global server
1.1502 + close $server
1.1503 + fileevent $file readable [list getdata $file]
1.1504 + fconfigure $file -buffering line -blocking 0
1.1505 + return
1.1506 + }
1.1507 + proc getdata { file } {
1.1508 + # Read handler on the accepted socket.
1.1509 + global x
1.1510 + global failed
1.1511 + set status [catch {read $file} data]
1.1512 + if {$status != 0} {
1.1513 + set x {read failed, error was $data}
1.1514 + catch { close $file }
1.1515 + } elseif {[string compare {} $data]} {
1.1516 + } elseif {[fblocked $file]} {
1.1517 + } elseif {[eof $file]} {
1.1518 + if {$failed} {
1.1519 + set x {client socket was inherited}
1.1520 + } else {
1.1521 + set x {client socket was not inherited}
1.1522 + }
1.1523 + catch { close $file }
1.1524 + } else {
1.1525 + set x {impossible case}
1.1526 + catch { close $file }
1.1527 + }
1.1528 + return
1.1529 + }
1.1530 +
1.1531 + # If the socket doesn't hit end-of-file in 10 seconds, the
1.1532 + # script1 process must have inherited the client.
1.1533 +
1.1534 + set failed 0
1.1535 + after 10000 [list set failed 1]
1.1536 +
1.1537 + # Launch the script2 process
1.1538 + ### exec [interpreter] script2 &
1.1539 +
1.1540 + set p [open "|[list [interpreter] $path(script2)]" w]
1.1541 + puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p
1.1542 +
1.1543 + vwait x
1.1544 + if {!$failed} {
1.1545 + vwait failed
1.1546 + }
1.1547 + close $p
1.1548 + set x
1.1549 +} {client socket was not inherited}
1.1550 +test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} {
1.1551 + file delete $path(script1)
1.1552 + file delete $path(script2)
1.1553 +
1.1554 + set f [open $path(script1) w]
1.1555 + puts $f {
1.1556 + after 10000 exit
1.1557 + vwait forever
1.1558 + }
1.1559 + close $f
1.1560 +
1.1561 + set f [open $path(script2) w]
1.1562 + puts $f [list set tcltest [interpreter]]
1.1563 + puts -nonewline $f {
1.1564 + set server [socket -server accept 0]
1.1565 + puts stdout [lindex [fconfigure $server -sockname] 2]
1.1566 + proc accept { file host port } }
1.1567 + puts $f \{
1.1568 + puts -nonewline $f {
1.1569 + global tcltest
1.1570 + puts $file {test data on socket}
1.1571 + exec $tcltest }
1.1572 + puts $f [list $path(script1) &]
1.1573 + puts $f {
1.1574 + after 1000 exit
1.1575 + }
1.1576 + puts $f \}
1.1577 + puts $f {
1.1578 + vwait forever
1.1579 + }
1.1580 + close $f
1.1581 +
1.1582 + # Launch the script2 process and connect to it. See how long
1.1583 + # the socket stays open
1.1584 +
1.1585 + ## exec [interpreter] script2 &
1.1586 + set p [open "|[list [interpreter] $path(script2)]" r]
1.1587 + gets $p listen
1.1588 +
1.1589 + after 1000 set ok_to_proceed 1
1.1590 + vwait ok_to_proceed
1.1591 +
1.1592 + set f [socket 127.0.0.1 $listen]
1.1593 + fconfigure $f -buffering full -blocking 0
1.1594 + fileevent $f readable [list getdata $f]
1.1595 +
1.1596 + # If the socket is still open after 5 seconds, the script1 process
1.1597 + # must have inherited the accepted socket.
1.1598 +
1.1599 + set failed 0
1.1600 + after 5000 set failed 1
1.1601 +
1.1602 + proc getdata { file } {
1.1603 + # Read handler on the client socket.
1.1604 + global x
1.1605 + global failed
1.1606 + set status [catch {read $file} data]
1.1607 + if {$status != 0} {
1.1608 + set x {read failed, error was $data}
1.1609 + catch { close $file }
1.1610 + } elseif {[string compare {} $data]} {
1.1611 + } elseif {[fblocked $file]} {
1.1612 + } elseif {[eof $file]} {
1.1613 + if {$failed} {
1.1614 + set x {accepted socket was inherited}
1.1615 + } else {
1.1616 + set x {accepted socket was not inherited}
1.1617 + }
1.1618 + catch { close $file }
1.1619 + } else {
1.1620 + set x {impossible case}
1.1621 + catch { close $file }
1.1622 + }
1.1623 + return
1.1624 + }
1.1625 +
1.1626 + vwait x
1.1627 +
1.1628 + close $p
1.1629 + set x
1.1630 +} {accepted socket was not inherited}
1.1631 +
1.1632 +test socket-13.1 {Testing use of shared socket between two threads} \
1.1633 + -constraints {socket testthread} -setup {
1.1634 +
1.1635 + threadReap
1.1636 +
1.1637 + set path(script) [makeFile {
1.1638 + set f [socket -server accept 0]
1.1639 + set listen [lindex [fconfigure $f -sockname] 2]
1.1640 + proc accept {s a p} {
1.1641 + fileevent $s readable [list echo $s]
1.1642 + fconfigure $s -buffering line
1.1643 + }
1.1644 + proc echo {s} {
1.1645 + global i
1.1646 + set l [gets $s]
1.1647 + if {[eof $s]} {
1.1648 + global x
1.1649 + close $s
1.1650 + set x done
1.1651 + } else {
1.1652 + incr i
1.1653 + puts $s $l
1.1654 + }
1.1655 + }
1.1656 + set i 0
1.1657 + vwait x
1.1658 + close $f
1.1659 +
1.1660 + # thread cleans itself up.
1.1661 + testthread exit
1.1662 + } script]
1.1663 +
1.1664 +} -body {
1.1665 + # create a thread
1.1666 + set serverthread [testthread create [list source $path(script) ] ]
1.1667 + update
1.1668 + set port [testthread send $serverthread {set listen}]
1.1669 + update
1.1670 +
1.1671 + after 1000
1.1672 + set s [socket 127.0.0.1 $port]
1.1673 + fconfigure $s -buffering line
1.1674 +
1.1675 + catch {
1.1676 + puts $s "hello"
1.1677 + gets $s result
1.1678 + }
1.1679 + close $s
1.1680 + update
1.1681 +
1.1682 + after 2000
1.1683 + lappend result [threadReap]
1.1684 +} -cleanup {
1.1685 + removeFile script
1.1686 +} -result {hello 1}
1.1687 +
1.1688 +removeFile script1
1.1689 +removeFile script2
1.1690 +
1.1691 +# cleanup
1.1692 +if {[string match sock* $commandSocket] == 1} {
1.1693 + puts $commandSocket exit
1.1694 + flush $commandSocket
1.1695 +}
1.1696 +catch {close $commandSocket}
1.1697 +catch {close $remoteProcChan}
1.1698 +::tcltest::cleanupTests
1.1699 +flush stdout
1.1700 +return