[25] | 1 | # Commands tested in this file: socket. |
---|
| 2 | # |
---|
| 3 | # This file contains a collection of tests for one or more of the Tcl |
---|
| 4 | # built-in commands. Sourcing this file into Tcl runs the tests and |
---|
| 5 | # generates output for errors. No output means no errors were found. |
---|
| 6 | # |
---|
| 7 | # Copyright (c) 1994-1996 Sun Microsystems, Inc. |
---|
| 8 | # Copyright (c) 1998-2000 Ajuba Solutions. |
---|
| 9 | # |
---|
| 10 | # See the file "license.terms" for information on usage and redistribution |
---|
| 11 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 12 | # |
---|
| 13 | # RCS: @(#) $Id: socket.test,v 1.41 2008/03/11 22:23:33 das Exp $ |
---|
| 14 | |
---|
| 15 | # Running socket tests with a remote server: |
---|
| 16 | # ------------------------------------------ |
---|
| 17 | # |
---|
| 18 | # Some tests in socket.test depend on the existence of a remote server to |
---|
| 19 | # which they connect. The remote server must be an instance of tcltest and it |
---|
| 20 | # must run the script found in the file "remote.tcl" in this directory. You |
---|
| 21 | # can start the remote server on any machine reachable from the machine on |
---|
| 22 | # which you want to run the socket tests, by issuing: |
---|
| 23 | # |
---|
| 24 | # tcltest remote.tcl -port 2048 # Or choose another port number. |
---|
| 25 | # |
---|
| 26 | # If the machine you are running the remote server on has several IP |
---|
| 27 | # interfaces, you can choose which interface the server listens on for |
---|
| 28 | # connections by specifying the -address command line flag, so: |
---|
| 29 | # |
---|
| 30 | # tcltest remote.tcl -address your.machine.com |
---|
| 31 | # |
---|
| 32 | # These options can also be set by environment variables. On Unix, you can |
---|
| 33 | # type these commands to the shell from which the remote server is started: |
---|
| 34 | # |
---|
| 35 | # shell% setenv serverPort 2048 |
---|
| 36 | # shell% setenv serverAddress your.machine.com |
---|
| 37 | # |
---|
| 38 | # and subsequently you can start the remote server with: |
---|
| 39 | # |
---|
| 40 | # tcltest remote.tcl |
---|
| 41 | # |
---|
| 42 | # to have it listen on port 2048 on the interface your.machine.com. |
---|
| 43 | # |
---|
| 44 | # When the server starts, it prints out a detailed message containing its |
---|
| 45 | # configuration information, and it will block until killed with a Ctrl-C. |
---|
| 46 | # Once the remote server exists, you can run the tests in socket.test with |
---|
| 47 | # the server by setting two Tcl variables: |
---|
| 48 | # |
---|
| 49 | # % set remoteServerIP <name or address of machine on which server runs> |
---|
| 50 | # % set remoteServerPort 2048 |
---|
| 51 | # |
---|
| 52 | # These variables are also settable from the environment. On Unix, you can: |
---|
| 53 | # |
---|
| 54 | # shell% setenv remoteServerIP machine.where.server.runs |
---|
| 55 | # shell% senetv remoteServerPort 2048 |
---|
| 56 | # |
---|
| 57 | # The preamble of the socket.test file checks to see if the variables are set |
---|
| 58 | # either in Tcl or in the environment; if they are, it attempts to connect to |
---|
| 59 | # the server. If the connection is successful, the tests using the remote |
---|
| 60 | # server will be performed; otherwise, it will attempt to start the remote |
---|
| 61 | # server (via exec) on platforms that support this, on the local host, |
---|
| 62 | # listening at port 2048. If all fails, a message is printed and the tests |
---|
| 63 | # using the remote server are not performed. |
---|
| 64 | |
---|
| 65 | package require tcltest 2 |
---|
| 66 | namespace import -force ::tcltest::* |
---|
| 67 | |
---|
| 68 | # Some tests require the testthread and exec commands |
---|
| 69 | testConstraint testthread [llength [info commands testthread]] |
---|
| 70 | testConstraint exec [llength [info commands exec]] |
---|
| 71 | |
---|
| 72 | # If remoteServerIP or remoteServerPort are not set, check in the |
---|
| 73 | # environment variables for externally set values. |
---|
| 74 | # |
---|
| 75 | |
---|
| 76 | if {![info exists remoteServerIP]} { |
---|
| 77 | if {[info exists env(remoteServerIP)]} { |
---|
| 78 | set remoteServerIP $env(remoteServerIP) |
---|
| 79 | } |
---|
| 80 | } |
---|
| 81 | if {![info exists remoteServerPort]} { |
---|
| 82 | if {[info exists env(remoteServerIP)]} { |
---|
| 83 | set remoteServerPort $env(remoteServerPort) |
---|
| 84 | } else { |
---|
| 85 | if {[info exists remoteServerIP]} { |
---|
| 86 | set remoteServerPort 2048 |
---|
| 87 | } |
---|
| 88 | } |
---|
| 89 | } |
---|
| 90 | |
---|
| 91 | # |
---|
| 92 | # Check if we're supposed to do tests against the remote server |
---|
| 93 | # |
---|
| 94 | |
---|
| 95 | set doTestsWithRemoteServer 1 |
---|
| 96 | if {![info exists remoteServerIP]} { |
---|
| 97 | set remoteServerIP 127.0.0.1 |
---|
| 98 | } |
---|
| 99 | if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { |
---|
| 100 | set remoteServerPort 2048 |
---|
| 101 | } |
---|
| 102 | |
---|
| 103 | # Attempt to connect to a remote server if one is already running. If it |
---|
| 104 | # is not running or for some other reason the connect fails, attempt to |
---|
| 105 | # start the remote server on the local host listening on port 2048. This |
---|
| 106 | # is only done on platforms that support exec (i.e. not on the Mac). On |
---|
| 107 | # platforms that do not support exec, the remote server must be started |
---|
| 108 | # by the user before running the tests. |
---|
| 109 | |
---|
| 110 | set remoteProcChan "" |
---|
| 111 | set commandSocket "" |
---|
| 112 | if {$doTestsWithRemoteServer} { |
---|
| 113 | catch {close $commandSocket} |
---|
| 114 | if {![catch { |
---|
| 115 | set commandSocket [socket $remoteServerIP $remoteServerPort] |
---|
| 116 | }]} then { |
---|
| 117 | fconfigure $commandSocket -translation crlf -buffering line |
---|
| 118 | } elseif {![testConstraint exec]} { |
---|
| 119 | set noRemoteTestReason "can't exec" |
---|
| 120 | set doTestsWithRemoteServer 0 |
---|
| 121 | } else { |
---|
| 122 | set remoteServerIP 127.0.0.1 |
---|
| 123 | # Be *extra* careful in case this file is sourced from |
---|
| 124 | # a directory other than the current one... |
---|
| 125 | set remoteFile [file join [pwd] [file dirname [info script]] \ |
---|
| 126 | remote.tcl] |
---|
| 127 | if {![catch { |
---|
| 128 | set remoteProcChan [open "|[list \ |
---|
| 129 | [interpreter] $remoteFile -serverIsSilent \ |
---|
| 130 | -port $remoteServerPort -address $remoteServerIP]" w+] |
---|
| 131 | } msg]} then { |
---|
| 132 | after 1000 |
---|
| 133 | if {[catch { |
---|
| 134 | set commandSocket [socket $remoteServerIP $remoteServerPort] |
---|
| 135 | } msg] == 0} then { |
---|
| 136 | fconfigure $commandSocket -translation crlf -buffering line |
---|
| 137 | } else { |
---|
| 138 | set noRemoteTestReason $msg |
---|
| 139 | set doTestsWithRemoteServer 0 |
---|
| 140 | } |
---|
| 141 | } else { |
---|
| 142 | set noRemoteTestReason "$msg [interpreter]" |
---|
| 143 | set doTestsWithRemoteServer 0 |
---|
| 144 | } |
---|
| 145 | } |
---|
| 146 | } |
---|
| 147 | |
---|
| 148 | # Some tests are run only if we are doing testing against a remote server. |
---|
| 149 | testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer |
---|
| 150 | if {!$doTestsWithRemoteServer} { |
---|
| 151 | if {[string first s $::tcltest::verbose] != -1} { |
---|
| 152 | puts "Skipping tests with remote server. See tests/socket.test for" |
---|
| 153 | puts "information on how to run remote server." |
---|
| 154 | puts "Reason for not doing remote tests: $noRemoteTestReason" |
---|
| 155 | } |
---|
| 156 | } |
---|
| 157 | |
---|
| 158 | # |
---|
| 159 | # If we do the tests, define a command to send a command to the |
---|
| 160 | # remote server. |
---|
| 161 | # |
---|
| 162 | |
---|
| 163 | if {[testConstraint doTestsWithRemoteServer]} { |
---|
| 164 | proc sendCommand {c} { |
---|
| 165 | global commandSocket |
---|
| 166 | |
---|
| 167 | if {[eof $commandSocket]} { |
---|
| 168 | error "remote server disappeared" |
---|
| 169 | } |
---|
| 170 | if {[catch {puts $commandSocket $c} msg]} { |
---|
| 171 | error "remote server disappaered: $msg" |
---|
| 172 | } |
---|
| 173 | if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} { |
---|
| 174 | error "remote server disappeared: $msg" |
---|
| 175 | } |
---|
| 176 | |
---|
| 177 | set resp "" |
---|
| 178 | while {1} { |
---|
| 179 | set line [gets $commandSocket] |
---|
| 180 | if {[eof $commandSocket]} { |
---|
| 181 | error "remote server disappaered" |
---|
| 182 | } |
---|
| 183 | if {[string compare $line "--Marker--Marker--Marker--"] == 0} { |
---|
| 184 | if {[string compare [lindex $resp 0] error] == 0} { |
---|
| 185 | error [lindex $resp 1] |
---|
| 186 | } else { |
---|
| 187 | return [lindex $resp 1] |
---|
| 188 | } |
---|
| 189 | } else { |
---|
| 190 | append resp $line "\n" |
---|
| 191 | } |
---|
| 192 | } |
---|
| 193 | } |
---|
| 194 | } |
---|
| 195 | |
---|
| 196 | test socket-1.1 {arg parsing for socket command} {socket} { |
---|
| 197 | list [catch {socket -server} msg] $msg |
---|
| 198 | } {1 {no argument given for -server option}} |
---|
| 199 | test socket-1.2 {arg parsing for socket command} {socket} { |
---|
| 200 | list [catch {socket -server foo} msg] $msg |
---|
| 201 | } {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} |
---|
| 202 | test socket-1.3 {arg parsing for socket command} {socket} { |
---|
| 203 | list [catch {socket -myaddr} msg] $msg |
---|
| 204 | } {1 {no argument given for -myaddr option}} |
---|
| 205 | test socket-1.4 {arg parsing for socket command} {socket} { |
---|
| 206 | list [catch {socket -myaddr 127.0.0.1} msg] $msg |
---|
| 207 | } {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} |
---|
| 208 | test socket-1.5 {arg parsing for socket command} {socket} { |
---|
| 209 | list [catch {socket -myport} msg] $msg |
---|
| 210 | } {1 {no argument given for -myport option}} |
---|
| 211 | test socket-1.6 {arg parsing for socket command} {socket} { |
---|
| 212 | list [catch {socket -myport xxxx} msg] $msg |
---|
| 213 | } {1 {expected integer but got "xxxx"}} |
---|
| 214 | test socket-1.7 {arg parsing for socket command} {socket} { |
---|
| 215 | list [catch {socket -myport 2522} msg] $msg |
---|
| 216 | } {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} |
---|
| 217 | test socket-1.8 {arg parsing for socket command} {socket} { |
---|
| 218 | list [catch {socket -froboz} msg] $msg |
---|
| 219 | } {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}} |
---|
| 220 | test socket-1.9 {arg parsing for socket command} {socket} { |
---|
| 221 | list [catch {socket -server foo -myport 2521 3333} msg] $msg |
---|
| 222 | } {1 {option -myport is not valid for servers}} |
---|
| 223 | test socket-1.10 {arg parsing for socket command} {socket} { |
---|
| 224 | list [catch {socket host 2528 -junk} msg] $msg |
---|
| 225 | } {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} |
---|
| 226 | test socket-1.11 {arg parsing for socket command} {socket} { |
---|
| 227 | list [catch {socket -server callback 2520 --} msg] $msg |
---|
| 228 | } {1 {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}} |
---|
| 229 | test socket-1.12 {arg parsing for socket command} {socket} { |
---|
| 230 | list [catch {socket foo badport} msg] $msg |
---|
| 231 | } {1 {expected integer but got "badport"}} |
---|
| 232 | test socket-1.13 {arg parsing for socket command} {socket} { |
---|
| 233 | list [catch {socket -async -server} msg] $msg |
---|
| 234 | } {1 {cannot set -async option for server sockets}} |
---|
| 235 | test socket-1.14 {arg parsing for socket command} {socket} { |
---|
| 236 | list [catch {socket -server foo -async} msg] $msg |
---|
| 237 | } {1 {cannot set -async option for server sockets}} |
---|
| 238 | |
---|
| 239 | set path(script) [makeFile {} script] |
---|
| 240 | |
---|
| 241 | test socket-2.1 {tcp connection} {socket stdio} { |
---|
| 242 | file delete $path(script) |
---|
| 243 | set f [open $path(script) w] |
---|
| 244 | puts $f { |
---|
| 245 | set timer [after 10000 "set x timed_out"] |
---|
| 246 | set f [socket -server accept 0] |
---|
| 247 | proc accept {file addr port} { |
---|
| 248 | global x |
---|
| 249 | set x done |
---|
| 250 | close $file |
---|
| 251 | } |
---|
| 252 | puts ready |
---|
| 253 | puts [lindex [fconfigure $f -sockname] 2] |
---|
| 254 | vwait x |
---|
| 255 | after cancel $timer |
---|
| 256 | close $f |
---|
| 257 | puts $x |
---|
| 258 | } |
---|
| 259 | close $f |
---|
| 260 | set f [open "|[list [interpreter] $path(script)]" r] |
---|
| 261 | gets $f x |
---|
| 262 | gets $f listen |
---|
| 263 | if {[catch {socket 127.0.0.1 $listen} msg]} { |
---|
| 264 | set x $msg |
---|
| 265 | } else { |
---|
| 266 | lappend x [gets $f] |
---|
| 267 | close $msg |
---|
| 268 | } |
---|
| 269 | lappend x [gets $f] |
---|
| 270 | close $f |
---|
| 271 | set x |
---|
| 272 | } {ready done {}} |
---|
| 273 | |
---|
| 274 | if [info exists port] { |
---|
| 275 | incr port |
---|
| 276 | } else { |
---|
| 277 | set port [expr 2048 + [pid]%1024] |
---|
| 278 | } |
---|
| 279 | test socket-2.2 {tcp connection with client port specified} {socket stdio} { |
---|
| 280 | file delete $path(script) |
---|
| 281 | set f [open $path(script) w] |
---|
| 282 | puts $f { |
---|
| 283 | set timer [after 10000 "set x timeout"] |
---|
| 284 | set f [socket -server accept 0] |
---|
| 285 | proc accept {file addr port} { |
---|
| 286 | global x |
---|
| 287 | puts "[gets $file] $port" |
---|
| 288 | close $file |
---|
| 289 | set x done |
---|
| 290 | } |
---|
| 291 | puts ready |
---|
| 292 | puts [lindex [fconfigure $f -sockname] 2] |
---|
| 293 | vwait x |
---|
| 294 | after cancel $timer |
---|
| 295 | close $f |
---|
| 296 | } |
---|
| 297 | close $f |
---|
| 298 | set f [open "|[list [interpreter] $path(script)]" r] |
---|
| 299 | gets $f x |
---|
| 300 | gets $f listen |
---|
| 301 | global port |
---|
| 302 | if {[catch {socket -myport $port 127.0.0.1 $listen} sock]} { |
---|
| 303 | set x $sock |
---|
| 304 | close [socket 127.0.0.1 $listen] |
---|
| 305 | puts stderr $sock |
---|
| 306 | } else { |
---|
| 307 | puts $sock hello |
---|
| 308 | flush $sock |
---|
| 309 | lappend x [gets $f] |
---|
| 310 | close $sock |
---|
| 311 | } |
---|
| 312 | close $f |
---|
| 313 | set x |
---|
| 314 | } [list ready "hello $port"] |
---|
| 315 | test socket-2.3 {tcp connection with client interface specified} {socket stdio} { |
---|
| 316 | file delete $path(script) |
---|
| 317 | set f [open $path(script) w] |
---|
| 318 | puts $f { |
---|
| 319 | set timer [after 2000 "set x done"] |
---|
| 320 | set f [socket -server accept 2830] |
---|
| 321 | proc accept {file addr port} { |
---|
| 322 | global x |
---|
| 323 | puts "[gets $file] $addr" |
---|
| 324 | close $file |
---|
| 325 | set x done |
---|
| 326 | } |
---|
| 327 | puts ready |
---|
| 328 | vwait x |
---|
| 329 | after cancel $timer |
---|
| 330 | close $f |
---|
| 331 | } |
---|
| 332 | close $f |
---|
| 333 | set f [open "|[list [interpreter] $path(script)]" r] |
---|
| 334 | gets $f x |
---|
| 335 | if {[catch {socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} { |
---|
| 336 | set x $sock |
---|
| 337 | } else { |
---|
| 338 | puts $sock hello |
---|
| 339 | flush $sock |
---|
| 340 | lappend x [gets $f] |
---|
| 341 | close $sock |
---|
| 342 | } |
---|
| 343 | close $f |
---|
| 344 | set x |
---|
| 345 | } {ready {hello 127.0.0.1}} |
---|
| 346 | test socket-2.4 {tcp connection with server interface specified} {socket stdio} { |
---|
| 347 | file delete $path(script) |
---|
| 348 | set f [open $path(script) w] |
---|
| 349 | puts $f { |
---|
| 350 | set timer [after 2000 "set x done"] |
---|
| 351 | set f [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 352 | proc accept {file addr port} { |
---|
| 353 | global x |
---|
| 354 | puts "[gets $file]" |
---|
| 355 | close $file |
---|
| 356 | set x done |
---|
| 357 | } |
---|
| 358 | puts ready |
---|
| 359 | puts [lindex [fconfigure $f -sockname] 2] |
---|
| 360 | vwait x |
---|
| 361 | after cancel $timer |
---|
| 362 | close $f |
---|
| 363 | } |
---|
| 364 | close $f |
---|
| 365 | set f [open "|[list [interpreter] $path(script)]" r] |
---|
| 366 | gets $f x |
---|
| 367 | gets $f listen |
---|
| 368 | if {[catch {socket 127.0.0.1 $listen} sock]} { |
---|
| 369 | set x $sock |
---|
| 370 | } else { |
---|
| 371 | puts $sock hello |
---|
| 372 | flush $sock |
---|
| 373 | lappend x [gets $f] |
---|
| 374 | close $sock |
---|
| 375 | } |
---|
| 376 | close $f |
---|
| 377 | set x |
---|
| 378 | } {ready hello} |
---|
| 379 | test socket-2.5 {tcp connection with redundant server port} {socket stdio} { |
---|
| 380 | file delete $path(script) |
---|
| 381 | set f [open $path(script) w] |
---|
| 382 | puts $f { |
---|
| 383 | set timer [after 10000 "set x timeout"] |
---|
| 384 | set f [socket -server accept 0] |
---|
| 385 | proc accept {file addr port} { |
---|
| 386 | global x |
---|
| 387 | puts "[gets $file]" |
---|
| 388 | close $file |
---|
| 389 | set x done |
---|
| 390 | } |
---|
| 391 | puts ready |
---|
| 392 | puts [lindex [fconfigure $f -sockname] 2] |
---|
| 393 | vwait x |
---|
| 394 | after cancel $timer |
---|
| 395 | close $f |
---|
| 396 | } |
---|
| 397 | close $f |
---|
| 398 | set f [open "|[list [interpreter] $path(script)]" r] |
---|
| 399 | gets $f x |
---|
| 400 | gets $f listen |
---|
| 401 | if {[catch {socket 127.0.0.1 $listen} sock]} { |
---|
| 402 | set x $sock |
---|
| 403 | } else { |
---|
| 404 | puts $sock hello |
---|
| 405 | flush $sock |
---|
| 406 | lappend x [gets $f] |
---|
| 407 | close $sock |
---|
| 408 | } |
---|
| 409 | close $f |
---|
| 410 | set x |
---|
| 411 | } {ready hello} |
---|
| 412 | test socket-2.6 {tcp connection} {socket} { |
---|
| 413 | set status ok |
---|
| 414 | if {![catch {set sock [socket 127.0.0.1 2833]}]} { |
---|
| 415 | if {![catch {gets $sock}]} { |
---|
| 416 | set status broken |
---|
| 417 | } |
---|
| 418 | close $sock |
---|
| 419 | } |
---|
| 420 | set status |
---|
| 421 | } ok |
---|
| 422 | test socket-2.7 {echo server, one line} {socket stdio} { |
---|
| 423 | file delete $path(script) |
---|
| 424 | set f [open $path(script) w] |
---|
| 425 | puts $f { |
---|
| 426 | set timer [after 10000 "set x timeout"] |
---|
| 427 | set f [socket -server accept 0] |
---|
| 428 | proc accept {s a p} { |
---|
| 429 | fileevent $s readable [list echo $s] |
---|
| 430 | fconfigure $s -translation lf -buffering line |
---|
| 431 | } |
---|
| 432 | proc echo {s} { |
---|
| 433 | set l [gets $s] |
---|
| 434 | if {[eof $s]} { |
---|
| 435 | global x |
---|
| 436 | close $s |
---|
| 437 | set x done |
---|
| 438 | } else { |
---|
| 439 | puts $s $l |
---|
| 440 | } |
---|
| 441 | } |
---|
| 442 | puts ready |
---|
| 443 | puts [lindex [fconfigure $f -sockname] 2] |
---|
| 444 | vwait x |
---|
| 445 | after cancel $timer |
---|
| 446 | close $f |
---|
| 447 | puts $x |
---|
| 448 | } |
---|
| 449 | close $f |
---|
| 450 | set f [open "|[list [interpreter] $path(script)]" r] |
---|
| 451 | gets $f |
---|
| 452 | gets $f listen |
---|
| 453 | set s [socket 127.0.0.1 $listen] |
---|
| 454 | fconfigure $s -buffering line -translation lf |
---|
| 455 | puts $s "hello abcdefghijklmnop" |
---|
| 456 | after 1000 |
---|
| 457 | set x [gets $s] |
---|
| 458 | close $s |
---|
| 459 | set y [gets $f] |
---|
| 460 | close $f |
---|
| 461 | list $x $y |
---|
| 462 | } {{hello abcdefghijklmnop} done} |
---|
| 463 | removeFile script |
---|
| 464 | test socket-2.8 {echo server, loop 50 times, single connection} -constraints {socket stdio} -setup { |
---|
| 465 | set path(script) [makeFile { |
---|
| 466 | set f [socket -server accept 0] |
---|
| 467 | proc accept {s a p} { |
---|
| 468 | fileevent $s readable [list echo $s] |
---|
| 469 | fconfigure $s -buffering line |
---|
| 470 | } |
---|
| 471 | proc echo {s} { |
---|
| 472 | global i |
---|
| 473 | set l [gets $s] |
---|
| 474 | if {[eof $s]} { |
---|
| 475 | global x |
---|
| 476 | close $s |
---|
| 477 | set x done |
---|
| 478 | } else { |
---|
| 479 | incr i |
---|
| 480 | puts $s $l |
---|
| 481 | } |
---|
| 482 | } |
---|
| 483 | set i 0 |
---|
| 484 | puts ready |
---|
| 485 | puts [lindex [fconfigure $f -sockname] 2] |
---|
| 486 | set timer [after 20000 "set x done"] |
---|
| 487 | vwait x |
---|
| 488 | after cancel $timer |
---|
| 489 | close $f |
---|
| 490 | puts "done $i" |
---|
| 491 | } script] |
---|
| 492 | } -body { |
---|
| 493 | set f [open "|[list [interpreter] $path(script)]" r] |
---|
| 494 | gets $f |
---|
| 495 | gets $f listen |
---|
| 496 | set s [socket 127.0.0.1 $listen] |
---|
| 497 | fconfigure $s -buffering line |
---|
| 498 | catch { |
---|
| 499 | for {set x 0} {$x < 50} {incr x} { |
---|
| 500 | puts $s "hello abcdefghijklmnop" |
---|
| 501 | gets $s |
---|
| 502 | } |
---|
| 503 | } |
---|
| 504 | close $s |
---|
| 505 | catch {set x [gets $f]} |
---|
| 506 | close $f |
---|
| 507 | set x |
---|
| 508 | } -cleanup { |
---|
| 509 | removeFile script |
---|
| 510 | } -result {done 50} |
---|
| 511 | set path(script) [makeFile {} script] |
---|
| 512 | test socket-2.9 {socket conflict} {socket stdio} { |
---|
| 513 | set s [socket -server accept 0] |
---|
| 514 | file delete $path(script) |
---|
| 515 | set f [open $path(script) w] |
---|
| 516 | puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]" |
---|
| 517 | close $f |
---|
| 518 | set f [open "|[list [interpreter] $path(script)]" r] |
---|
| 519 | gets $f |
---|
| 520 | after 100 |
---|
| 521 | set x [list [catch {close $f} msg]] |
---|
| 522 | regsub "\n.*$" $msg {} msg ; # cut part of the error message containing the port number |
---|
| 523 | lappend x $msg |
---|
| 524 | close $s |
---|
| 525 | set x |
---|
| 526 | } {1 {couldn't open socket: address already in use}} |
---|
| 527 | test socket-2.10 {close on accept, accepted socket lives} {socket} { |
---|
| 528 | set done 0 |
---|
| 529 | set timer [after 20000 "set done timed_out"] |
---|
| 530 | set ss [socket -server accept 0] |
---|
| 531 | proc accept {s a p} { |
---|
| 532 | global ss |
---|
| 533 | close $ss |
---|
| 534 | fileevent $s readable "readit $s" |
---|
| 535 | fconfigure $s -trans lf |
---|
| 536 | } |
---|
| 537 | proc readit {s} { |
---|
| 538 | global done |
---|
| 539 | gets $s |
---|
| 540 | close $s |
---|
| 541 | set done 1 |
---|
| 542 | } |
---|
| 543 | set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]] |
---|
| 544 | puts $cs hello |
---|
| 545 | close $cs |
---|
| 546 | vwait done |
---|
| 547 | after cancel $timer |
---|
| 548 | set done |
---|
| 549 | } 1 |
---|
| 550 | test socket-2.11 {detecting new data} {socket} { |
---|
| 551 | proc accept {s a p} { |
---|
| 552 | global sock |
---|
| 553 | set sock $s |
---|
| 554 | } |
---|
| 555 | |
---|
| 556 | set s [socket -server accept 0] |
---|
| 557 | set sock "" |
---|
| 558 | set s2 [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] |
---|
| 559 | vwait sock |
---|
| 560 | puts $s2 one |
---|
| 561 | flush $s2 |
---|
| 562 | after 500 |
---|
| 563 | fconfigure $sock -blocking 0 |
---|
| 564 | set result a:[gets $sock] |
---|
| 565 | lappend result b:[gets $sock] |
---|
| 566 | fconfigure $sock -blocking 1 |
---|
| 567 | puts $s2 two |
---|
| 568 | flush $s2 |
---|
| 569 | after 500 |
---|
| 570 | fconfigure $sock -blocking 0 |
---|
| 571 | lappend result c:[gets $sock] |
---|
| 572 | fconfigure $sock -blocking 1 |
---|
| 573 | close $s2 |
---|
| 574 | close $s |
---|
| 575 | close $sock |
---|
| 576 | set result |
---|
| 577 | } {a:one b: c:two} |
---|
| 578 | |
---|
| 579 | |
---|
| 580 | test socket-3.1 {socket conflict} {socket stdio} { |
---|
| 581 | file delete $path(script) |
---|
| 582 | set f [open $path(script) w] |
---|
| 583 | puts $f { |
---|
| 584 | set f [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 585 | puts ready |
---|
| 586 | puts [lindex [fconfigure $f -sockname] 2] |
---|
| 587 | gets stdin |
---|
| 588 | close $f |
---|
| 589 | } |
---|
| 590 | close $f |
---|
| 591 | set f [open "|[list [interpreter] $path(script)]" r+] |
---|
| 592 | gets $f |
---|
| 593 | gets $f listen |
---|
| 594 | set x [list [catch {socket -server accept -myaddr 127.0.0.1 $listen} msg] \ |
---|
| 595 | $msg] |
---|
| 596 | puts $f bye |
---|
| 597 | close $f |
---|
| 598 | set x |
---|
| 599 | } {1 {couldn't open socket: address already in use}} |
---|
| 600 | test socket-3.2 {server with several clients} {socket stdio} { |
---|
| 601 | file delete $path(script) |
---|
| 602 | set f [open $path(script) w] |
---|
| 603 | puts $f { |
---|
| 604 | set t1 [after 30000 "set x timed_out"] |
---|
| 605 | set t2 [after 31000 "set x timed_out"] |
---|
| 606 | set t3 [after 32000 "set x timed_out"] |
---|
| 607 | set counter 0 |
---|
| 608 | set s [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 609 | proc accept {s a p} { |
---|
| 610 | fileevent $s readable [list echo $s] |
---|
| 611 | fconfigure $s -buffering line |
---|
| 612 | } |
---|
| 613 | proc echo {s} { |
---|
| 614 | global x |
---|
| 615 | set l [gets $s] |
---|
| 616 | if {[eof $s]} { |
---|
| 617 | close $s |
---|
| 618 | set x done |
---|
| 619 | } else { |
---|
| 620 | puts $s $l |
---|
| 621 | } |
---|
| 622 | } |
---|
| 623 | puts ready |
---|
| 624 | puts [lindex [fconfigure $s -sockname] 2] |
---|
| 625 | vwait x |
---|
| 626 | after cancel $t1 |
---|
| 627 | vwait x |
---|
| 628 | after cancel $t2 |
---|
| 629 | vwait x |
---|
| 630 | after cancel $t3 |
---|
| 631 | close $s |
---|
| 632 | puts $x |
---|
| 633 | } |
---|
| 634 | close $f |
---|
| 635 | set f [open "|[list [interpreter] $path(script)]" r+] |
---|
| 636 | set x [gets $f] |
---|
| 637 | gets $f listen |
---|
| 638 | set s1 [socket 127.0.0.1 $listen] |
---|
| 639 | fconfigure $s1 -buffering line |
---|
| 640 | set s2 [socket 127.0.0.1 $listen] |
---|
| 641 | fconfigure $s2 -buffering line |
---|
| 642 | set s3 [socket 127.0.0.1 $listen] |
---|
| 643 | fconfigure $s3 -buffering line |
---|
| 644 | for {set i 0} {$i < 100} {incr i} { |
---|
| 645 | puts $s1 hello,s1 |
---|
| 646 | gets $s1 |
---|
| 647 | puts $s2 hello,s2 |
---|
| 648 | gets $s2 |
---|
| 649 | puts $s3 hello,s3 |
---|
| 650 | gets $s3 |
---|
| 651 | } |
---|
| 652 | close $s1 |
---|
| 653 | close $s2 |
---|
| 654 | close $s3 |
---|
| 655 | lappend x [gets $f] |
---|
| 656 | close $f |
---|
| 657 | set x |
---|
| 658 | } {ready done} |
---|
| 659 | |
---|
| 660 | test socket-4.1 {server with several clients} {socket stdio} { |
---|
| 661 | file delete $path(script) |
---|
| 662 | set f [open $path(script) w] |
---|
| 663 | puts $f { |
---|
| 664 | set port [gets stdin] |
---|
| 665 | set s [socket 127.0.0.1 $port] |
---|
| 666 | fconfigure $s -buffering line |
---|
| 667 | for {set i 0} {$i < 100} {incr i} { |
---|
| 668 | puts $s hello |
---|
| 669 | gets $s |
---|
| 670 | } |
---|
| 671 | close $s |
---|
| 672 | puts bye |
---|
| 673 | gets stdin |
---|
| 674 | } |
---|
| 675 | close $f |
---|
| 676 | set p1 [open "|[list [interpreter] $path(script)]" r+] |
---|
| 677 | fconfigure $p1 -buffering line |
---|
| 678 | set p2 [open "|[list [interpreter] $path(script)]" r+] |
---|
| 679 | fconfigure $p2 -buffering line |
---|
| 680 | set p3 [open "|[list [interpreter] $path(script)]" r+] |
---|
| 681 | fconfigure $p3 -buffering line |
---|
| 682 | proc accept {s a p} { |
---|
| 683 | fconfigure $s -buffering line |
---|
| 684 | fileevent $s readable [list echo $s] |
---|
| 685 | } |
---|
| 686 | proc echo {s} { |
---|
| 687 | global x |
---|
| 688 | set l [gets $s] |
---|
| 689 | if {[eof $s]} { |
---|
| 690 | close $s |
---|
| 691 | set x done |
---|
| 692 | } else { |
---|
| 693 | puts $s $l |
---|
| 694 | } |
---|
| 695 | } |
---|
| 696 | set t1 [after 30000 "set x timed_out"] |
---|
| 697 | set t2 [after 31000 "set x timed_out"] |
---|
| 698 | set t3 [after 32000 "set x timed_out"] |
---|
| 699 | set s [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 700 | set listen [lindex [fconfigure $s -sockname] 2] |
---|
| 701 | puts $p1 $listen |
---|
| 702 | puts $p2 $listen |
---|
| 703 | puts $p3 $listen |
---|
| 704 | vwait x |
---|
| 705 | vwait x |
---|
| 706 | vwait x |
---|
| 707 | after cancel $t1 |
---|
| 708 | after cancel $t2 |
---|
| 709 | after cancel $t3 |
---|
| 710 | close $s |
---|
| 711 | set l "" |
---|
| 712 | lappend l [list p1 [gets $p1] $x] |
---|
| 713 | lappend l [list p2 [gets $p2] $x] |
---|
| 714 | lappend l [list p3 [gets $p3] $x] |
---|
| 715 | puts $p1 bye |
---|
| 716 | puts $p2 bye |
---|
| 717 | puts $p3 bye |
---|
| 718 | close $p1 |
---|
| 719 | close $p2 |
---|
| 720 | close $p3 |
---|
| 721 | set l |
---|
| 722 | } {{p1 bye done} {p2 bye done} {p3 bye done}} |
---|
| 723 | test socket-4.2 {byte order problems, socket numbers, htons} {socket} { |
---|
| 724 | set x ok |
---|
| 725 | if {[catch {socket -server dodo -myaddr 127.0.0.1 0x3000} msg]} { |
---|
| 726 | set x $msg |
---|
| 727 | } else { |
---|
| 728 | close $msg |
---|
| 729 | } |
---|
| 730 | set x |
---|
| 731 | } ok |
---|
| 732 | |
---|
| 733 | test socket-5.1 {byte order problems, socket numbers, htons} \ |
---|
| 734 | {socket unix notRoot} { |
---|
| 735 | set x {couldn't open socket: not owner} |
---|
| 736 | if {![catch {socket -server dodo 0x1} msg]} { |
---|
| 737 | set x {htons problem, should be disallowed, are you running as SU?} |
---|
| 738 | close $msg |
---|
| 739 | } |
---|
| 740 | set x |
---|
| 741 | } {couldn't open socket: not owner} |
---|
| 742 | test socket-5.2 {byte order problems, socket numbers, htons} {socket} { |
---|
| 743 | set x {couldn't open socket: port number too high} |
---|
| 744 | if {![catch {socket -server dodo 0x10000} msg]} { |
---|
| 745 | set x {port resolution problem, should be disallowed} |
---|
| 746 | close $msg |
---|
| 747 | } |
---|
| 748 | set x |
---|
| 749 | } {couldn't open socket: port number too high} |
---|
| 750 | test socket-5.3 {byte order problems, socket numbers, htons} \ |
---|
| 751 | {socket unix notRoot} { |
---|
| 752 | set x {couldn't open socket: not owner} |
---|
| 753 | if {![catch {socket -server dodo 21} msg]} { |
---|
| 754 | set x {htons problem, should be disallowed, are you running as SU?} |
---|
| 755 | close $msg |
---|
| 756 | } |
---|
| 757 | set x |
---|
| 758 | } {couldn't open socket: not owner} |
---|
| 759 | |
---|
| 760 | test socket-6.1 {accept callback error} -constraints {socket stdio} -setup { |
---|
| 761 | proc myHandler {msg options} { |
---|
| 762 | variable x $msg |
---|
| 763 | } |
---|
| 764 | set handler [interp bgerror {}] |
---|
| 765 | interp bgerror {} [namespace which myHandler] |
---|
| 766 | file delete $path(script) |
---|
| 767 | } -body { |
---|
| 768 | set f [open $path(script) w] |
---|
| 769 | puts $f { |
---|
| 770 | gets stdin port |
---|
| 771 | socket 127.0.0.1 $port |
---|
| 772 | } |
---|
| 773 | close $f |
---|
| 774 | set f [open "|[list [interpreter] $path(script)]" r+] |
---|
| 775 | proc accept {s a p} {expr 10 / 0} |
---|
| 776 | set s [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 777 | puts $f [lindex [fconfigure $s -sockname] 2] |
---|
| 778 | close $f |
---|
| 779 | set timer [after 10000 "set x timed_out"] |
---|
| 780 | vwait x |
---|
| 781 | after cancel $timer |
---|
| 782 | close $s |
---|
| 783 | set x |
---|
| 784 | } -cleanup { |
---|
| 785 | interp bgerror {} $handler |
---|
| 786 | } -result {divide by zero} |
---|
| 787 | |
---|
| 788 | test socket-7.1 {testing socket specific options} {socket stdio} { |
---|
| 789 | file delete $path(script) |
---|
| 790 | set f [open $path(script) w] |
---|
| 791 | puts $f { |
---|
| 792 | set ss [socket -server accept 0] |
---|
| 793 | proc accept args { |
---|
| 794 | global x |
---|
| 795 | set x done |
---|
| 796 | } |
---|
| 797 | puts ready |
---|
| 798 | puts [lindex [fconfigure $ss -sockname] 2] |
---|
| 799 | set timer [after 10000 "set x timed_out"] |
---|
| 800 | vwait x |
---|
| 801 | after cancel $timer |
---|
| 802 | } |
---|
| 803 | close $f |
---|
| 804 | set f [open "|[list [interpreter] $path(script)]" r] |
---|
| 805 | gets $f |
---|
| 806 | gets $f listen |
---|
| 807 | set s [socket 127.0.0.1 $listen] |
---|
| 808 | set p [fconfigure $s -peername] |
---|
| 809 | close $s |
---|
| 810 | close $f |
---|
| 811 | set l "" |
---|
| 812 | lappend l [string compare [lindex $p 0] 127.0.0.1] |
---|
| 813 | lappend l [string compare [lindex $p 2] $listen] |
---|
| 814 | lappend l [llength $p] |
---|
| 815 | } {0 0 3} |
---|
| 816 | test socket-7.2 {testing socket specific options} {socket stdio} { |
---|
| 817 | file delete $path(script) |
---|
| 818 | set f [open $path(script) w] |
---|
| 819 | puts $f { |
---|
| 820 | set ss [socket -server accept 2821] |
---|
| 821 | proc accept args { |
---|
| 822 | global x |
---|
| 823 | set x done |
---|
| 824 | } |
---|
| 825 | puts ready |
---|
| 826 | puts [lindex [fconfigure $ss -sockname] 2] |
---|
| 827 | set timer [after 10000 "set x timed_out"] |
---|
| 828 | vwait x |
---|
| 829 | after cancel $timer |
---|
| 830 | } |
---|
| 831 | close $f |
---|
| 832 | set f [open "|[list [interpreter] $path(script)]" r] |
---|
| 833 | gets $f |
---|
| 834 | gets $f listen |
---|
| 835 | set s [socket 127.0.0.1 $listen] |
---|
| 836 | set p [fconfigure $s -sockname] |
---|
| 837 | close $s |
---|
| 838 | close $f |
---|
| 839 | list [llength $p] \ |
---|
| 840 | [regexp {^(127\.0\.0\.1|0\.0\.0\.0)$} [lindex $p 0]] \ |
---|
| 841 | [expr {[lindex $p 2] == $listen}] |
---|
| 842 | } {3 1 0} |
---|
| 843 | test socket-7.3 {testing socket specific options} {socket} { |
---|
| 844 | set s [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 845 | set l [fconfigure $s] |
---|
| 846 | close $s |
---|
| 847 | update |
---|
| 848 | llength $l |
---|
| 849 | } 14 |
---|
| 850 | test socket-7.4 {testing socket specific options} {socket} { |
---|
| 851 | set s [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 852 | proc accept {s a p} { |
---|
| 853 | global x |
---|
| 854 | set x [fconfigure $s -sockname] |
---|
| 855 | close $s |
---|
| 856 | } |
---|
| 857 | set listen [lindex [fconfigure $s -sockname] 2] |
---|
| 858 | set s1 [socket 127.0.0.1 $listen] |
---|
| 859 | set timer [after 10000 "set x timed_out"] |
---|
| 860 | vwait x |
---|
| 861 | after cancel $timer |
---|
| 862 | close $s |
---|
| 863 | close $s1 |
---|
| 864 | set l "" |
---|
| 865 | lappend l [expr {[lindex $x 2] == $listen}] [llength $x] |
---|
| 866 | } {1 3} |
---|
| 867 | test socket-7.5 {testing socket specific options} {socket unixOrPc} { |
---|
| 868 | set s [socket -server accept 0] |
---|
| 869 | proc accept {s a p} { |
---|
| 870 | global x |
---|
| 871 | set x [fconfigure $s -sockname] |
---|
| 872 | close $s |
---|
| 873 | } |
---|
| 874 | set listen [lindex [fconfigure $s -sockname] 2] |
---|
| 875 | set s1 [socket 127.0.0.1 $listen] |
---|
| 876 | set timer [after 10000 "set x timed_out"] |
---|
| 877 | vwait x |
---|
| 878 | after cancel $timer |
---|
| 879 | close $s |
---|
| 880 | close $s1 |
---|
| 881 | set l "" |
---|
| 882 | lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x] |
---|
| 883 | } {127.0.0.1 1 3} |
---|
| 884 | |
---|
| 885 | test socket-8.1 {testing -async flag on sockets} {socket} { |
---|
| 886 | # NOTE: This test may fail on some Solaris 2.4 systems. If it does, |
---|
| 887 | # check that you have these patches installed (using showrev -p): |
---|
| 888 | # |
---|
| 889 | # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03, |
---|
| 890 | # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01, |
---|
| 891 | # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03, |
---|
| 892 | # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01, |
---|
| 893 | # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01, |
---|
| 894 | # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03 |
---|
| 895 | # |
---|
| 896 | # If after installing these patches you are still experiencing a |
---|
| 897 | # problem, please email jyl@eng.sun.com. We have not observed this |
---|
| 898 | # failure on Solaris 2.5, so another option (instead of installing |
---|
| 899 | # these patches) is to upgrade to Solaris 2.5. |
---|
| 900 | set s [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 901 | proc accept {s a p} { |
---|
| 902 | global x |
---|
| 903 | puts $s bye |
---|
| 904 | close $s |
---|
| 905 | set x done |
---|
| 906 | } |
---|
| 907 | set s1 [socket -async 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] |
---|
| 908 | vwait x |
---|
| 909 | set z [gets $s1] |
---|
| 910 | close $s |
---|
| 911 | close $s1 |
---|
| 912 | set z |
---|
| 913 | } bye |
---|
| 914 | |
---|
| 915 | test socket-9.1 {testing spurious events} {socket} { |
---|
| 916 | set len 0 |
---|
| 917 | set spurious 0 |
---|
| 918 | set done 0 |
---|
| 919 | proc readlittle {s} { |
---|
| 920 | global spurious done len |
---|
| 921 | set l [read $s 1] |
---|
| 922 | if {[string length $l] == 0} { |
---|
| 923 | if {![eof $s]} { |
---|
| 924 | incr spurious |
---|
| 925 | } else { |
---|
| 926 | close $s |
---|
| 927 | set done 1 |
---|
| 928 | } |
---|
| 929 | } else { |
---|
| 930 | incr len [string length $l] |
---|
| 931 | } |
---|
| 932 | } |
---|
| 933 | proc accept {s a p} { |
---|
| 934 | fconfigure $s -buffering none -blocking off |
---|
| 935 | fileevent $s readable [list readlittle $s] |
---|
| 936 | } |
---|
| 937 | set s [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 938 | set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] |
---|
| 939 | puts -nonewline $c 01234567890123456789012345678901234567890123456789 |
---|
| 940 | close $c |
---|
| 941 | set timer [after 10000 "set done timed_out"] |
---|
| 942 | vwait done |
---|
| 943 | after cancel $timer |
---|
| 944 | close $s |
---|
| 945 | list $spurious $len |
---|
| 946 | } {0 50} |
---|
| 947 | test socket-9.2 {testing async write, fileevents, flush on close} {socket} { |
---|
| 948 | set firstblock "" |
---|
| 949 | for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"} |
---|
| 950 | set secondblock "" |
---|
| 951 | for {set i 0} {$i < 16} {incr i} { |
---|
| 952 | set secondblock "b$secondblock$secondblock" |
---|
| 953 | } |
---|
| 954 | set l [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 955 | proc accept {s a p} { |
---|
| 956 | fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ |
---|
| 957 | -buffering line |
---|
| 958 | fileevent $s readable "readable $s" |
---|
| 959 | } |
---|
| 960 | proc readable {s} { |
---|
| 961 | set l [gets $s] |
---|
| 962 | fileevent $s readable {} |
---|
| 963 | after 1000 respond $s |
---|
| 964 | } |
---|
| 965 | proc respond {s} { |
---|
| 966 | global firstblock |
---|
| 967 | puts -nonewline $s $firstblock |
---|
| 968 | after 1000 writedata $s |
---|
| 969 | } |
---|
| 970 | proc writedata {s} { |
---|
| 971 | global secondblock |
---|
| 972 | puts -nonewline $s $secondblock |
---|
| 973 | close $s |
---|
| 974 | } |
---|
| 975 | set s [socket 127.0.0.1 [lindex [fconfigure $l -sockname] 2]] |
---|
| 976 | fconfigure $s -blocking 0 -trans lf -buffering line |
---|
| 977 | set count 0 |
---|
| 978 | puts $s hello |
---|
| 979 | proc readit {s} { |
---|
| 980 | global count done |
---|
| 981 | set l [read $s] |
---|
| 982 | incr count [string length $l] |
---|
| 983 | if {[eof $s]} { |
---|
| 984 | close $s |
---|
| 985 | set done 1 |
---|
| 986 | } |
---|
| 987 | } |
---|
| 988 | fileevent $s readable "readit $s" |
---|
| 989 | set timer [after 10000 "set done timed_out"] |
---|
| 990 | vwait done |
---|
| 991 | after cancel $timer |
---|
| 992 | close $l |
---|
| 993 | set count |
---|
| 994 | } 65566 |
---|
| 995 | test socket-9.3 {testing EOF stickyness} {socket} { |
---|
| 996 | proc count_to_eof {s} { |
---|
| 997 | global count done timer |
---|
| 998 | set l [gets $s] |
---|
| 999 | if {[eof $s]} { |
---|
| 1000 | incr count |
---|
| 1001 | if {$count > 9} { |
---|
| 1002 | close $s |
---|
| 1003 | set done true |
---|
| 1004 | set count {eof is sticky} |
---|
| 1005 | after cancel $timer |
---|
| 1006 | } |
---|
| 1007 | } |
---|
| 1008 | } |
---|
| 1009 | proc timerproc {} { |
---|
| 1010 | global done count c |
---|
| 1011 | set done true |
---|
| 1012 | set count {timer went off, eof is not sticky} |
---|
| 1013 | close $c |
---|
| 1014 | } |
---|
| 1015 | set count 0 |
---|
| 1016 | set done false |
---|
| 1017 | proc write_then_close {s} { |
---|
| 1018 | puts $s bye |
---|
| 1019 | close $s |
---|
| 1020 | } |
---|
| 1021 | proc accept {s a p} { |
---|
| 1022 | fconfigure $s -buffering line -translation lf |
---|
| 1023 | fileevent $s writable "write_then_close $s" |
---|
| 1024 | } |
---|
| 1025 | set s [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 1026 | set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] |
---|
| 1027 | fconfigure $c -blocking off -buffering line -translation lf |
---|
| 1028 | fileevent $c readable "count_to_eof $c" |
---|
| 1029 | set timer [after 1000 timerproc] |
---|
| 1030 | vwait done |
---|
| 1031 | close $s |
---|
| 1032 | set count |
---|
| 1033 | } {eof is sticky} |
---|
| 1034 | |
---|
| 1035 | removeFile script |
---|
| 1036 | |
---|
| 1037 | test socket-10.1 {testing socket accept callback error handling} -constraints { |
---|
| 1038 | socket |
---|
| 1039 | } -setup { |
---|
| 1040 | variable goterror 0 |
---|
| 1041 | proc myHandler {msg options} { |
---|
| 1042 | variable goterror 1 |
---|
| 1043 | } |
---|
| 1044 | set handler [interp bgerror {}] |
---|
| 1045 | interp bgerror {} [namespace which myHandler] |
---|
| 1046 | } -body { |
---|
| 1047 | set s [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 1048 | proc accept {s a p} {close $s; error} |
---|
| 1049 | set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] |
---|
| 1050 | vwait goterror |
---|
| 1051 | close $s |
---|
| 1052 | close $c |
---|
| 1053 | set goterror |
---|
| 1054 | } -cleanup { |
---|
| 1055 | interp bgerror {} $handler |
---|
| 1056 | } -result 1 |
---|
| 1057 | |
---|
| 1058 | test socket-11.1 {tcp connection} {socket doTestsWithRemoteServer} { |
---|
| 1059 | sendCommand { |
---|
| 1060 | set socket9_1_test_server [socket -server accept 2834] |
---|
| 1061 | proc accept {s a p} { |
---|
| 1062 | puts $s done |
---|
| 1063 | close $s |
---|
| 1064 | } |
---|
| 1065 | } |
---|
| 1066 | set s [socket $remoteServerIP 2834] |
---|
| 1067 | set r [gets $s] |
---|
| 1068 | close $s |
---|
| 1069 | sendCommand {close $socket9_1_test_server} |
---|
| 1070 | set r |
---|
| 1071 | } done |
---|
| 1072 | test socket-11.2 {client specifies its port} {socket doTestsWithRemoteServer} { |
---|
| 1073 | if {[info exists port]} { |
---|
| 1074 | incr port |
---|
| 1075 | } else { |
---|
| 1076 | set port [expr 2048 + [pid]%1024] |
---|
| 1077 | } |
---|
| 1078 | sendCommand { |
---|
| 1079 | set socket9_2_test_server [socket -server accept 2835] |
---|
| 1080 | proc accept {s a p} { |
---|
| 1081 | puts $s $p |
---|
| 1082 | close $s |
---|
| 1083 | } |
---|
| 1084 | } |
---|
| 1085 | set s [socket -myport $port $remoteServerIP 2835] |
---|
| 1086 | set r [gets $s] |
---|
| 1087 | close $s |
---|
| 1088 | sendCommand {close $socket9_2_test_server} |
---|
| 1089 | if {$r == $port} { |
---|
| 1090 | set result ok |
---|
| 1091 | } else { |
---|
| 1092 | set result broken |
---|
| 1093 | } |
---|
| 1094 | set result |
---|
| 1095 | } ok |
---|
| 1096 | test socket-11.3 {trying to connect, no server} {socket doTestsWithRemoteServer} { |
---|
| 1097 | set status ok |
---|
| 1098 | if {![catch {set s [socket $remoteServerIp 2836]}]} { |
---|
| 1099 | if {![catch {gets $s}]} { |
---|
| 1100 | set status broken |
---|
| 1101 | } |
---|
| 1102 | close $s |
---|
| 1103 | } |
---|
| 1104 | set status |
---|
| 1105 | } ok |
---|
| 1106 | test socket-11.4 {remote echo, one line} {socket doTestsWithRemoteServer} { |
---|
| 1107 | sendCommand { |
---|
| 1108 | set socket10_6_test_server [socket -server accept 2836] |
---|
| 1109 | proc accept {s a p} { |
---|
| 1110 | fileevent $s readable [list echo $s] |
---|
| 1111 | fconfigure $s -buffering line -translation crlf |
---|
| 1112 | } |
---|
| 1113 | proc echo {s} { |
---|
| 1114 | set l [gets $s] |
---|
| 1115 | if {[eof $s]} { |
---|
| 1116 | close $s |
---|
| 1117 | } else { |
---|
| 1118 | puts $s $l |
---|
| 1119 | } |
---|
| 1120 | } |
---|
| 1121 | } |
---|
| 1122 | set f [socket $remoteServerIP 2836] |
---|
| 1123 | fconfigure $f -translation crlf -buffering line |
---|
| 1124 | puts $f hello |
---|
| 1125 | set r [gets $f] |
---|
| 1126 | close $f |
---|
| 1127 | sendCommand {close $socket10_6_test_server} |
---|
| 1128 | set r |
---|
| 1129 | } hello |
---|
| 1130 | test socket-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} { |
---|
| 1131 | sendCommand { |
---|
| 1132 | set socket10_7_test_server [socket -server accept 2836] |
---|
| 1133 | proc accept {s a p} { |
---|
| 1134 | fileevent $s readable [list echo $s] |
---|
| 1135 | fconfigure $s -buffering line -translation crlf |
---|
| 1136 | } |
---|
| 1137 | proc echo {s} { |
---|
| 1138 | set l [gets $s] |
---|
| 1139 | if {[eof $s]} { |
---|
| 1140 | close $s |
---|
| 1141 | } else { |
---|
| 1142 | puts $s $l |
---|
| 1143 | } |
---|
| 1144 | } |
---|
| 1145 | } |
---|
| 1146 | set f [socket $remoteServerIP 2836] |
---|
| 1147 | fconfigure $f -translation crlf -buffering line |
---|
| 1148 | for {set cnt 0} {$cnt < 50} {incr cnt} { |
---|
| 1149 | puts $f "hello, $cnt" |
---|
| 1150 | if {[string compare [gets $f] "hello, $cnt"] != 0} { |
---|
| 1151 | break |
---|
| 1152 | } |
---|
| 1153 | } |
---|
| 1154 | close $f |
---|
| 1155 | sendCommand {close $socket10_7_test_server} |
---|
| 1156 | set cnt |
---|
| 1157 | } 50 |
---|
| 1158 | test socket-11.6 {socket conflict} {socket doTestsWithRemoteServer} { |
---|
| 1159 | set s1 [socket -server accept -myaddr 127.0.0.1 2836] |
---|
| 1160 | if {[catch {set s2 [socket -server accept -myaddr 127.0.0.1 2836]} msg]} { |
---|
| 1161 | set result [list 1 $msg] |
---|
| 1162 | } else { |
---|
| 1163 | set result [list 0 [lindex [fconfigure $s2 -sockname] 2]] |
---|
| 1164 | close $s2 |
---|
| 1165 | } |
---|
| 1166 | close $s1 |
---|
| 1167 | set result |
---|
| 1168 | } {1 {couldn't open socket: address already in use}} |
---|
| 1169 | test socket-11.7 {server with several clients} {socket doTestsWithRemoteServer} { |
---|
| 1170 | sendCommand { |
---|
| 1171 | set socket10_9_test_server [socket -server accept 2836] |
---|
| 1172 | proc accept {s a p} { |
---|
| 1173 | fconfigure $s -buffering line |
---|
| 1174 | fileevent $s readable [list echo $s] |
---|
| 1175 | } |
---|
| 1176 | proc echo {s} { |
---|
| 1177 | set l [gets $s] |
---|
| 1178 | if {[eof $s]} { |
---|
| 1179 | close $s |
---|
| 1180 | } else { |
---|
| 1181 | puts $s $l |
---|
| 1182 | } |
---|
| 1183 | } |
---|
| 1184 | } |
---|
| 1185 | set s1 [socket $remoteServerIP 2836] |
---|
| 1186 | fconfigure $s1 -buffering line |
---|
| 1187 | set s2 [socket $remoteServerIP 2836] |
---|
| 1188 | fconfigure $s2 -buffering line |
---|
| 1189 | set s3 [socket $remoteServerIP 2836] |
---|
| 1190 | fconfigure $s3 -buffering line |
---|
| 1191 | for {set i 0} {$i < 100} {incr i} { |
---|
| 1192 | puts $s1 hello,s1 |
---|
| 1193 | gets $s1 |
---|
| 1194 | puts $s2 hello,s2 |
---|
| 1195 | gets $s2 |
---|
| 1196 | puts $s3 hello,s3 |
---|
| 1197 | gets $s3 |
---|
| 1198 | } |
---|
| 1199 | close $s1 |
---|
| 1200 | close $s2 |
---|
| 1201 | close $s3 |
---|
| 1202 | sendCommand {close $socket10_9_test_server} |
---|
| 1203 | set i |
---|
| 1204 | } 100 |
---|
| 1205 | test socket-11.8 {client with several servers} {socket doTestsWithRemoteServer} { |
---|
| 1206 | sendCommand { |
---|
| 1207 | set s1 [socket -server "accept 4003" 4003] |
---|
| 1208 | set s2 [socket -server "accept 4004" 4004] |
---|
| 1209 | set s3 [socket -server "accept 4005" 4005] |
---|
| 1210 | proc accept {mp s a p} { |
---|
| 1211 | puts $s $mp |
---|
| 1212 | close $s |
---|
| 1213 | } |
---|
| 1214 | } |
---|
| 1215 | set s1 [socket $remoteServerIP 4003] |
---|
| 1216 | set s2 [socket $remoteServerIP 4004] |
---|
| 1217 | set s3 [socket $remoteServerIP 4005] |
---|
| 1218 | set l "" |
---|
| 1219 | lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \ |
---|
| 1220 | [gets $s3] [gets $s3] [eof $s3] |
---|
| 1221 | close $s1 |
---|
| 1222 | close $s2 |
---|
| 1223 | close $s3 |
---|
| 1224 | sendCommand { |
---|
| 1225 | close $s1 |
---|
| 1226 | close $s2 |
---|
| 1227 | close $s3 |
---|
| 1228 | } |
---|
| 1229 | set l |
---|
| 1230 | } {4003 {} 1 4004 {} 1 4005 {} 1} |
---|
| 1231 | test socket-11.9 {accept callback error} -constraints { |
---|
| 1232 | socket doTestsWithRemoteServer |
---|
| 1233 | } -setup { |
---|
| 1234 | proc myHandler {msg options} { |
---|
| 1235 | variable x $msg |
---|
| 1236 | } |
---|
| 1237 | set handler [interp bgerror {}] |
---|
| 1238 | interp bgerror {} [namespace which myHandler] |
---|
| 1239 | } -body { |
---|
| 1240 | set s [socket -server accept 2836] |
---|
| 1241 | proc accept {s a p} {expr 10 / 0} |
---|
| 1242 | if {[catch {sendCommand { |
---|
| 1243 | set peername [fconfigure $callerSocket -peername] |
---|
| 1244 | set s [socket [lindex $peername 0] 2836] |
---|
| 1245 | close $s |
---|
| 1246 | }} msg]} { |
---|
| 1247 | close $s |
---|
| 1248 | error $msg |
---|
| 1249 | } |
---|
| 1250 | set timer [after 10000 "set x timed_out"] |
---|
| 1251 | vwait x |
---|
| 1252 | after cancel $timer |
---|
| 1253 | close $s |
---|
| 1254 | set x |
---|
| 1255 | } -cleanup { |
---|
| 1256 | interp bgerror {} $handler |
---|
| 1257 | } -result {divide by zero} |
---|
| 1258 | test socket-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} { |
---|
| 1259 | sendCommand { |
---|
| 1260 | set socket10_12_test_server [socket -server accept 2836] |
---|
| 1261 | proc accept {s a p} {close $s} |
---|
| 1262 | } |
---|
| 1263 | set s [socket $remoteServerIP 2836] |
---|
| 1264 | set p [fconfigure $s -peername] |
---|
| 1265 | set n [fconfigure $s -sockname] |
---|
| 1266 | set l "" |
---|
| 1267 | lappend l [lindex $p 2] [llength $p] [llength $p] |
---|
| 1268 | close $s |
---|
| 1269 | sendCommand {close $socket10_12_test_server} |
---|
| 1270 | set l |
---|
| 1271 | } {2836 3 3} |
---|
| 1272 | test socket-11.11 {testing spurious events} {socket doTestsWithRemoteServer} { |
---|
| 1273 | sendCommand { |
---|
| 1274 | set socket10_13_test_server [socket -server accept 2836] |
---|
| 1275 | proc accept {s a p} { |
---|
| 1276 | fconfigure $s -translation "auto lf" |
---|
| 1277 | after 100 writesome $s |
---|
| 1278 | } |
---|
| 1279 | proc writesome {s} { |
---|
| 1280 | for {set i 0} {$i < 100} {incr i} { |
---|
| 1281 | puts $s "line $i from remote server" |
---|
| 1282 | } |
---|
| 1283 | close $s |
---|
| 1284 | } |
---|
| 1285 | } |
---|
| 1286 | set len 0 |
---|
| 1287 | set spurious 0 |
---|
| 1288 | set done 0 |
---|
| 1289 | proc readlittle {s} { |
---|
| 1290 | global spurious done len |
---|
| 1291 | set l [read $s 1] |
---|
| 1292 | if {[string length $l] == 0} { |
---|
| 1293 | if {![eof $s]} { |
---|
| 1294 | incr spurious |
---|
| 1295 | } else { |
---|
| 1296 | close $s |
---|
| 1297 | set done 1 |
---|
| 1298 | } |
---|
| 1299 | } else { |
---|
| 1300 | incr len [string length $l] |
---|
| 1301 | } |
---|
| 1302 | } |
---|
| 1303 | set c [socket $remoteServerIP 2836] |
---|
| 1304 | fileevent $c readable "readlittle $c" |
---|
| 1305 | set timer [after 40000 "set done timed_out"] |
---|
| 1306 | vwait done |
---|
| 1307 | after cancel $timer |
---|
| 1308 | sendCommand {close $socket10_13_test_server} |
---|
| 1309 | list $spurious $len $done |
---|
| 1310 | } {0 2690 1} |
---|
| 1311 | test socket-11.12 {testing EOF stickyness} {socket doTestsWithRemoteServer} { |
---|
| 1312 | set counter 0 |
---|
| 1313 | set done 0 |
---|
| 1314 | proc count_up {s} { |
---|
| 1315 | global counter done after_id |
---|
| 1316 | set l [gets $s] |
---|
| 1317 | if {[eof $s]} { |
---|
| 1318 | incr counter |
---|
| 1319 | if {$counter > 9} { |
---|
| 1320 | set done {EOF is sticky} |
---|
| 1321 | after cancel $after_id |
---|
| 1322 | close $s |
---|
| 1323 | } |
---|
| 1324 | } |
---|
| 1325 | } |
---|
| 1326 | proc timed_out {} { |
---|
| 1327 | global c done |
---|
| 1328 | set done {timed_out, EOF is not sticky} |
---|
| 1329 | close $c |
---|
| 1330 | } |
---|
| 1331 | sendCommand { |
---|
| 1332 | set socket10_14_test_server [socket -server accept 2836] |
---|
| 1333 | proc accept {s a p} { |
---|
| 1334 | after 100 close $s |
---|
| 1335 | } |
---|
| 1336 | } |
---|
| 1337 | set c [socket $remoteServerIP 2836] |
---|
| 1338 | fileevent $c readable [list count_up $c] |
---|
| 1339 | set after_id [after 1000 timed_out] |
---|
| 1340 | vwait done |
---|
| 1341 | sendCommand {close $socket10_14_test_server} |
---|
| 1342 | set done |
---|
| 1343 | } {EOF is sticky} |
---|
| 1344 | test socket-11.13 {testing async write, async flush, async close} \ |
---|
| 1345 | {socket doTestsWithRemoteServer} { |
---|
| 1346 | proc readit {s} { |
---|
| 1347 | global count done |
---|
| 1348 | set l [read $s] |
---|
| 1349 | incr count [string length $l] |
---|
| 1350 | if {[eof $s]} { |
---|
| 1351 | close $s |
---|
| 1352 | set done 1 |
---|
| 1353 | } |
---|
| 1354 | } |
---|
| 1355 | sendCommand { |
---|
| 1356 | set firstblock "" |
---|
| 1357 | for {set i 0} {$i < 5} {incr i} { |
---|
| 1358 | set firstblock "a$firstblock$firstblock" |
---|
| 1359 | } |
---|
| 1360 | set secondblock "" |
---|
| 1361 | for {set i 0} {$i < 16} {incr i} { |
---|
| 1362 | set secondblock "b$secondblock$secondblock" |
---|
| 1363 | } |
---|
| 1364 | set l [socket -server accept 2845] |
---|
| 1365 | proc accept {s a p} { |
---|
| 1366 | fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ |
---|
| 1367 | -buffering line |
---|
| 1368 | fileevent $s readable "readable $s" |
---|
| 1369 | } |
---|
| 1370 | proc readable {s} { |
---|
| 1371 | set l [gets $s] |
---|
| 1372 | fileevent $s readable {} |
---|
| 1373 | after 1000 respond $s |
---|
| 1374 | } |
---|
| 1375 | proc respond {s} { |
---|
| 1376 | global firstblock |
---|
| 1377 | puts -nonewline $s $firstblock |
---|
| 1378 | after 1000 writedata $s |
---|
| 1379 | } |
---|
| 1380 | proc writedata {s} { |
---|
| 1381 | global secondblock |
---|
| 1382 | puts -nonewline $s $secondblock |
---|
| 1383 | close $s |
---|
| 1384 | } |
---|
| 1385 | } |
---|
| 1386 | set s [socket $remoteServerIP 2845] |
---|
| 1387 | fconfigure $s -blocking 0 -trans lf -buffering line |
---|
| 1388 | set count 0 |
---|
| 1389 | puts $s hello |
---|
| 1390 | fileevent $s readable "readit $s" |
---|
| 1391 | set timer [after 10000 "set done timed_out"] |
---|
| 1392 | vwait done |
---|
| 1393 | after cancel $timer |
---|
| 1394 | sendCommand {close $l} |
---|
| 1395 | set count |
---|
| 1396 | } 65566 |
---|
| 1397 | |
---|
| 1398 | set path(script1) [makeFile {} script1] |
---|
| 1399 | set path(script2) [makeFile {} script2] |
---|
| 1400 | |
---|
| 1401 | test socket-12.1 {testing inheritance of server sockets} {socket stdio exec} { |
---|
| 1402 | file delete $path(script1) |
---|
| 1403 | file delete $path(script2) |
---|
| 1404 | |
---|
| 1405 | # Script1 is just a 10 second delay. If the server socket |
---|
| 1406 | # is inherited, it will be held open for 10 seconds |
---|
| 1407 | |
---|
| 1408 | set f [open $path(script1) w] |
---|
| 1409 | puts $f { |
---|
| 1410 | after 10000 exit |
---|
| 1411 | vwait forever |
---|
| 1412 | } |
---|
| 1413 | close $f |
---|
| 1414 | |
---|
| 1415 | # Script2 creates the server socket, launches script1, |
---|
| 1416 | # waits a second, and exits. The server socket will now |
---|
| 1417 | # be closed unless script1 inherited it. |
---|
| 1418 | |
---|
| 1419 | set f [open $path(script2) w] |
---|
| 1420 | puts $f [list set tcltest [interpreter]] |
---|
| 1421 | puts -nonewline $f { |
---|
| 1422 | set f [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 1423 | puts [lindex [fconfigure $f -sockname] 2] |
---|
| 1424 | proc accept { file addr port } { |
---|
| 1425 | close $file |
---|
| 1426 | } |
---|
| 1427 | exec $tcltest } |
---|
| 1428 | puts $f [list $path(script1) &] |
---|
| 1429 | puts $f { |
---|
| 1430 | close $f |
---|
| 1431 | after 1000 exit |
---|
| 1432 | vwait forever |
---|
| 1433 | } |
---|
| 1434 | close $f |
---|
| 1435 | |
---|
| 1436 | # Launch script2 and wait 5 seconds |
---|
| 1437 | |
---|
| 1438 | ### exec [interpreter] script2 & |
---|
| 1439 | set p [open "|[list [interpreter] $path(script2)]" r] |
---|
| 1440 | gets $p listen |
---|
| 1441 | |
---|
| 1442 | after 5000 { set ok_to_proceed 1 } |
---|
| 1443 | vwait ok_to_proceed |
---|
| 1444 | |
---|
| 1445 | # If we can still connect to the server, the socket got inherited. |
---|
| 1446 | |
---|
| 1447 | if {[catch {socket 127.0.0.1 $listen} msg]} { |
---|
| 1448 | set x {server socket was not inherited} |
---|
| 1449 | } else { |
---|
| 1450 | close $msg |
---|
| 1451 | set x {server socket was inherited} |
---|
| 1452 | } |
---|
| 1453 | |
---|
| 1454 | close $p |
---|
| 1455 | set x |
---|
| 1456 | } {server socket was not inherited} |
---|
| 1457 | test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} { |
---|
| 1458 | file delete $path(script1) |
---|
| 1459 | file delete $path(script2) |
---|
| 1460 | |
---|
| 1461 | # Script1 is just a 20 second delay. If the server socket |
---|
| 1462 | # is inherited, it will be held open for 10 seconds |
---|
| 1463 | |
---|
| 1464 | set f [open $path(script1) w] |
---|
| 1465 | puts $f { |
---|
| 1466 | after 20000 exit |
---|
| 1467 | vwait forever |
---|
| 1468 | } |
---|
| 1469 | close $f |
---|
| 1470 | |
---|
| 1471 | # Script2 opens the client socket and writes to it. It then |
---|
| 1472 | # launches script1 and exits. If the child process inherited the |
---|
| 1473 | # client socket, the socket will still be open. |
---|
| 1474 | |
---|
| 1475 | set f [open $path(script2) w] |
---|
| 1476 | puts $f [list set tcltest [interpreter]] |
---|
| 1477 | puts -nonewline $f { |
---|
| 1478 | gets stdin port |
---|
| 1479 | set f [socket 127.0.0.1 $port] |
---|
| 1480 | exec $tcltest } |
---|
| 1481 | puts $f [list $path(script1) &] |
---|
| 1482 | puts $f { |
---|
| 1483 | puts $f testing |
---|
| 1484 | flush $f |
---|
| 1485 | after 1000 exit |
---|
| 1486 | vwait forever |
---|
| 1487 | } |
---|
| 1488 | close $f |
---|
| 1489 | |
---|
| 1490 | # Create the server socket |
---|
| 1491 | |
---|
| 1492 | set server [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 1493 | proc accept { file host port } { |
---|
| 1494 | # When the client connects, establish the read handler |
---|
| 1495 | global server |
---|
| 1496 | close $server |
---|
| 1497 | fileevent $file readable [list getdata $file] |
---|
| 1498 | fconfigure $file -buffering line -blocking 0 |
---|
| 1499 | return |
---|
| 1500 | } |
---|
| 1501 | proc getdata { file } { |
---|
| 1502 | # Read handler on the accepted socket. |
---|
| 1503 | global x |
---|
| 1504 | global failed |
---|
| 1505 | set status [catch {read $file} data] |
---|
| 1506 | if {$status != 0} { |
---|
| 1507 | set x {read failed, error was $data} |
---|
| 1508 | catch { close $file } |
---|
| 1509 | } elseif {[string compare {} $data]} { |
---|
| 1510 | } elseif {[fblocked $file]} { |
---|
| 1511 | } elseif {[eof $file]} { |
---|
| 1512 | if {$failed} { |
---|
| 1513 | set x {client socket was inherited} |
---|
| 1514 | } else { |
---|
| 1515 | set x {client socket was not inherited} |
---|
| 1516 | } |
---|
| 1517 | catch { close $file } |
---|
| 1518 | } else { |
---|
| 1519 | set x {impossible case} |
---|
| 1520 | catch { close $file } |
---|
| 1521 | } |
---|
| 1522 | return |
---|
| 1523 | } |
---|
| 1524 | |
---|
| 1525 | # If the socket doesn't hit end-of-file in 10 seconds, the |
---|
| 1526 | # script1 process must have inherited the client. |
---|
| 1527 | |
---|
| 1528 | set failed 0 |
---|
| 1529 | after 10000 [list set failed 1] |
---|
| 1530 | |
---|
| 1531 | # Launch the script2 process |
---|
| 1532 | ### exec [interpreter] script2 & |
---|
| 1533 | |
---|
| 1534 | set p [open "|[list [interpreter] $path(script2)]" w] |
---|
| 1535 | puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p |
---|
| 1536 | |
---|
| 1537 | vwait x |
---|
| 1538 | if {!$failed} { |
---|
| 1539 | vwait failed |
---|
| 1540 | } |
---|
| 1541 | close $p |
---|
| 1542 | set x |
---|
| 1543 | } {client socket was not inherited} |
---|
| 1544 | test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} { |
---|
| 1545 | file delete $path(script1) |
---|
| 1546 | file delete $path(script2) |
---|
| 1547 | |
---|
| 1548 | set f [open $path(script1) w] |
---|
| 1549 | puts $f { |
---|
| 1550 | after 10000 exit |
---|
| 1551 | vwait forever |
---|
| 1552 | } |
---|
| 1553 | close $f |
---|
| 1554 | |
---|
| 1555 | set f [open $path(script2) w] |
---|
| 1556 | puts $f [list set tcltest [interpreter]] |
---|
| 1557 | puts -nonewline $f { |
---|
| 1558 | set server [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 1559 | puts stdout [lindex [fconfigure $server -sockname] 2] |
---|
| 1560 | proc accept { file host port } } |
---|
| 1561 | puts $f \{ |
---|
| 1562 | puts -nonewline $f { |
---|
| 1563 | global tcltest |
---|
| 1564 | puts $file {test data on socket} |
---|
| 1565 | exec $tcltest } |
---|
| 1566 | puts $f [list $path(script1) &] |
---|
| 1567 | puts $f { |
---|
| 1568 | after 1000 exit |
---|
| 1569 | } |
---|
| 1570 | puts $f \} |
---|
| 1571 | puts $f { |
---|
| 1572 | vwait forever |
---|
| 1573 | } |
---|
| 1574 | close $f |
---|
| 1575 | |
---|
| 1576 | # Launch the script2 process and connect to it. See how long |
---|
| 1577 | # the socket stays open |
---|
| 1578 | |
---|
| 1579 | ## exec [interpreter] script2 & |
---|
| 1580 | set p [open "|[list [interpreter] $path(script2)]" r] |
---|
| 1581 | gets $p listen |
---|
| 1582 | |
---|
| 1583 | after 1000 set ok_to_proceed 1 |
---|
| 1584 | vwait ok_to_proceed |
---|
| 1585 | |
---|
| 1586 | set f [socket 127.0.0.1 $listen] |
---|
| 1587 | fconfigure $f -buffering full -blocking 0 |
---|
| 1588 | fileevent $f readable [list getdata $f] |
---|
| 1589 | |
---|
| 1590 | # If the socket is still open after 5 seconds, the script1 process |
---|
| 1591 | # must have inherited the accepted socket. |
---|
| 1592 | |
---|
| 1593 | set failed 0 |
---|
| 1594 | after 5000 set failed 1 |
---|
| 1595 | |
---|
| 1596 | proc getdata { file } { |
---|
| 1597 | # Read handler on the client socket. |
---|
| 1598 | global x |
---|
| 1599 | global failed |
---|
| 1600 | set status [catch {read $file} data] |
---|
| 1601 | if {$status != 0} { |
---|
| 1602 | set x {read failed, error was $data} |
---|
| 1603 | catch { close $file } |
---|
| 1604 | } elseif {[string compare {} $data]} { |
---|
| 1605 | } elseif {[fblocked $file]} { |
---|
| 1606 | } elseif {[eof $file]} { |
---|
| 1607 | if {$failed} { |
---|
| 1608 | set x {accepted socket was inherited} |
---|
| 1609 | } else { |
---|
| 1610 | set x {accepted socket was not inherited} |
---|
| 1611 | } |
---|
| 1612 | catch { close $file } |
---|
| 1613 | } else { |
---|
| 1614 | set x {impossible case} |
---|
| 1615 | catch { close $file } |
---|
| 1616 | } |
---|
| 1617 | return |
---|
| 1618 | } |
---|
| 1619 | |
---|
| 1620 | vwait x |
---|
| 1621 | |
---|
| 1622 | close $p |
---|
| 1623 | set x |
---|
| 1624 | } {accepted socket was not inherited} |
---|
| 1625 | |
---|
| 1626 | test socket-13.1 {Testing use of shared socket between two threads} \ |
---|
| 1627 | -constraints {socket testthread} -setup { |
---|
| 1628 | threadReap |
---|
| 1629 | set path(script) [makeFile { |
---|
| 1630 | set f [socket -server accept -myaddr 127.0.0.1 0] |
---|
| 1631 | set listen [lindex [fconfigure $f -sockname] 2] |
---|
| 1632 | proc accept {s a p} { |
---|
| 1633 | fileevent $s readable [list echo $s] |
---|
| 1634 | fconfigure $s -buffering line |
---|
| 1635 | } |
---|
| 1636 | proc echo {s} { |
---|
| 1637 | global i |
---|
| 1638 | set l [gets $s] |
---|
| 1639 | if {[eof $s]} { |
---|
| 1640 | global x |
---|
| 1641 | close $s |
---|
| 1642 | set x done |
---|
| 1643 | } else { |
---|
| 1644 | incr i |
---|
| 1645 | puts $s $l |
---|
| 1646 | } |
---|
| 1647 | } |
---|
| 1648 | set i 0 |
---|
| 1649 | vwait x |
---|
| 1650 | close $f |
---|
| 1651 | # thread cleans itself up. |
---|
| 1652 | testthread exit |
---|
| 1653 | } script] |
---|
| 1654 | } -body { |
---|
| 1655 | # create a thread |
---|
| 1656 | set serverthread [testthread create [list source $path(script) ] ] |
---|
| 1657 | update |
---|
| 1658 | set port [testthread send $serverthread {set listen}] |
---|
| 1659 | update |
---|
| 1660 | |
---|
| 1661 | after 1000 |
---|
| 1662 | set s [socket 127.0.0.1 $port] |
---|
| 1663 | fconfigure $s -buffering line |
---|
| 1664 | |
---|
| 1665 | catch { |
---|
| 1666 | puts $s "hello" |
---|
| 1667 | gets $s result |
---|
| 1668 | } |
---|
| 1669 | close $s |
---|
| 1670 | update |
---|
| 1671 | |
---|
| 1672 | after 2000 |
---|
| 1673 | lappend result [threadReap] |
---|
| 1674 | } -cleanup { |
---|
| 1675 | removeFile script |
---|
| 1676 | } -result {hello 1} |
---|
| 1677 | |
---|
| 1678 | removeFile script1 |
---|
| 1679 | removeFile script2 |
---|
| 1680 | |
---|
| 1681 | # cleanup |
---|
| 1682 | if {[string match sock* $commandSocket] == 1} { |
---|
| 1683 | puts $commandSocket exit |
---|
| 1684 | flush $commandSocket |
---|
| 1685 | } |
---|
| 1686 | catch {close $commandSocket} |
---|
| 1687 | catch {close $remoteProcChan} |
---|
| 1688 | ::tcltest::cleanupTests |
---|
| 1689 | flush stdout |
---|
| 1690 | return |
---|