tcl/tests/socket.test

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