util/src/TclTk/tcl8.6.12/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 built-in
   4 # commands. Sourcing this file into Tcl runs the tests and generates output
   5 # 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 of
  11 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12
  13 # Running socket tests with a remote server:
  14 # ------------------------------------------
  15 #
  16 # Some tests in socket.test depend on the existence of a remote server to
  17 # which they connect. The remote server must be an instance of tcltest and it
  18 # must run the script found in the file "remote.tcl" in this directory. You
  19 # can start the remote server on any machine reachable from the machine on
  20 # which you want to run the socket tests, by issuing:
  21 #
  22 #     tcltest remote.tcl -port 2048     # Or choose another port number.
  23 #
  24 # If the machine you are running the remote server on has several IP
  25 # interfaces, you can choose which interface the server listens on for
  26 # connections by specifying the -address command line flag, so:
  27 #
  28 #     tcltest remote.tcl -address your.machine.com
  29 #
  30 # These options can also be set by environment variables. On Unix, you can
  31 # type these commands to the shell from which the remote server is started:
  32 #
  33 #     shell% setenv serverPort 2048
  34 #     shell% setenv serverAddress your.machine.com
  35 #
  36 # and subsequently you can start the remote server with:
  37 #
  38 #     tcltest remote.tcl
  39 #
  40 # to have it listen on port 2048 on the interface your.machine.com.
  41 #
  42 # When the server starts, it prints out a detailed message containing its
  43 # configuration information, and it will block until killed with a Ctrl-C.
  44 # Once the remote server exists, you can run the tests in socket.test with the
  45 # server by setting two Tcl variables:
  46 #
  47 #     % set remoteServerIP <name or address of machine on which server runs>
  48 #     % set remoteServerPort 2048
  49 #
  50 # These variables are also settable from the environment. On Unix, you can:
  51 #
  52 #     shell% setenv remoteServerIP machine.where.server.runs
  53 #     shell% senetv remoteServerPort 2048
  54 #
  55 # The preamble of the socket.test file checks to see if the variables are set
  56 # either in Tcl or in the environment; if they are, it attempts to connect to
  57 # the server. If the connection is successful, the tests using the remote
  58 # server will be performed; otherwise, it will attempt to start the remote
  59 # server (via exec) on platforms that support this, on the local host,
  60 # listening at port 2048. If all fails, a message is printed and the tests
  61 # using the remote server are not performed.
  62
  63 if {"::tcltest" ni [namespace children]} {
  64     package require tcltest 2.5
  65     namespace import -force ::tcltest::*
  66 }
  67
  68 ::tcltest::loadTestedCommands
  69
  70 # A bad interaction between socket creation, macOS, and unattended CI
  71 # environments make this whole file impractical to run; too many weird hangs.
  72 if {[info exists ::env(MAC_CI)]} {
  73     return
  74 }
  75
  76 # Some tests require the Thread package or exec command
  77 testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
  78 testConstraint exec [llength [info commands exec]]
  79
  80 # Produce a random port number in the Dynamic/Private range
  81 # from 49152 through 65535.
  82 proc randport {} {
  83     # firstly try dynamic port via server-socket(0):
  84     set port 0x7fffffff
  85     catch {
  86         set port [lindex [fconfigure [set s [socket -server {} 0]] -sockname] 2]
  87         close $s
  88     }
  89     while {[catch {
  90         close [socket -server {} $port]
  91     } msg]} {
  92         if {[incr i] > 1000} {return -code error "too many iterations to get free random port: $msg"}
  93         # try random port:
  94         set port [expr {int(rand()*16383+49152)}]
  95     }
  96     return $port
  97 }
  98
  99 # Test the latency of tcp connections over the loopback interface. Some OSes
 100 # (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes
 101 # up to 200ms for a packet sent to localhost to arrive. We're measuring this
 102 # here, so that OSes that don't have this problem can run the tests at full
 103 # speed.
 104 set server [socket -server {apply {{s a p} {set ::s1 $s}}} 0]
 105 set s2 [socket localhost [lindex [fconfigure $server -sockname] 2]]
 106 vwait s1; close $server
 107 fconfigure $s1 -buffering line
 108 fconfigure $s2 -buffering line
 109 set t1 [clock milliseconds]
 110 puts $s2 test1; gets $s1
 111 puts $s2 test2; gets $s1
 112 close $s1; close $s2
 113 set t2 [clock milliseconds]
 114 set lat1 [expr {($t2-$t1)*2}]; # doubled as a safety margin
 115
 116 # Test the latency of failed connection attempts over the loopback
 117 # interface. They can take more than a second under Windowos and requres
 118 # additional [after]s in some tests that are not needed on systems that fail
 119 # immediately.
 120 set t1 [clock milliseconds]
 121 catch {socket 127.0.0.1 [randport]}
 122 set t2 [clock milliseconds]
 123 set lat2 [expr {($t2-$t1)*3}]
 124
 125 # Use the maximum of the two latency calculations, but at least 200ms
 126 set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}]
 127 set latency [expr {$latency > 200 ? $latency : 200}]
 128 unset t1 t2 s1 s2 lat1 lat2 server
 129
 130 # If remoteServerIP or remoteServerPort are not set, check in the environment
 131 # variables for externally set values.
 132 #
 133
 134 if {![info exists remoteServerIP]} {
 135     if {[info exists env(remoteServerIP)]} {
 136         set remoteServerIP $env(remoteServerIP)
 137     }
 138 }
 139 if {![info exists remoteServerPort]} {
 140     if {[info exists env(remoteServerPort)]} {
 141         set remoteServerPort $env(remoteServerPort)
 142     } else {
 143         if {[info exists remoteServerIP]} {
 144             set remoteServerPort 2048
 145         }
 146     }
 147 }
 148
 149 if 0 {
 150     # activate this to time the tests
 151     proc test {args} {
 152         set name [lindex $args 0]
 153         puts "[lindex [time {uplevel [linsert $args 0 tcltest::test]}] 0] @@@ $name"
 154     }
 155 }
 156
 157 foreach {af localhost} {
 158     inet 127.0.0.1
 159     inet6 ::1
 160 } {
 161     # Check if the family is supported and set the constraint accordingly
 162     testConstraint supported_$af [expr {![catch {socket -server foo -myaddr $localhost 0} sock]}]
 163     catch {close $sock}
 164 }
 165
 166 set sock [socket -server foo -myaddr localhost 0]
 167 set sockname [fconfigure $sock -sockname]
 168 close $sock
 169 testConstraint localhost_v4 [expr {"127.0.0.1" in $sockname}]
 170 testConstraint localhost_v6 [expr {"::1" in $sockname}]
 171
 172
 173 foreach {af localhost} {
 174     any 127.0.0.1
 175     inet 127.0.0.1
 176     inet6 ::1
 177 } {
 178     if {![testConstraint supported_$af]} {
 179         continue
 180     }
 181     set ::tcl::unsupported::socketAF $af
 182 #
 183 # Check if we're supposed to do tests against the remote server
 184 #
 185
 186 set doTestsWithRemoteServer 1
 187 if {![info exists remoteServerIP]} {
 188     set remoteServerIP $localhost
 189 }
 190 if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
 191     set remoteServerPort [randport]
 192 }
 193
 194 # Attempt to connect to a remote server if one is already running. If it is
 195 # not running or for some other reason the connect fails, attempt to start the
 196 # remote server on the local host listening on port 2048. This is only done on
 197 # platforms that support exec (i.e. not on the Mac). On platforms that do not
 198 # support exec, the remote server must be started by the user before running
 199 # the tests.
 200
 201 set remoteProcChan ""
 202 set commandSocket ""
 203 if {$doTestsWithRemoteServer} {
 204     catch {close $commandSocket}
 205     if {![catch {
 206         set commandSocket [socket $remoteServerIP $remoteServerPort]
 207     }]} then {
 208         fconfigure $commandSocket -translation crlf -buffering line
 209     } elseif {![testConstraint exec]} {
 210         set noRemoteTestReason "can't exec"
 211         set doTestsWithRemoteServer 0
 212     } else {
 213         set remoteServerIP $localhost
 214         # Be *extra* careful in case this file is sourced from
 215         # a directory other than the current one...
 216         set remoteFile [file join [pwd] [file dirname [info script]] \
 217                 remote.tcl]
 218         if {![catch {
 219             set remoteProcChan [open "|[list \
 220                     [interpreter] $remoteFile -serverIsSilent \
 221                     -port $remoteServerPort -address $remoteServerIP]" w+]
 222         } msg]} then {
 223             gets $remoteProcChan
 224             if {[catch {
 225                 set commandSocket [socket $remoteServerIP $remoteServerPort]
 226             } msg] == 0} then {
 227                 fconfigure $commandSocket -translation crlf -buffering line
 228             } else {
 229                 set noRemoteTestReason $msg
 230                 set doTestsWithRemoteServer 0
 231             }
 232         } else {
 233             set noRemoteTestReason "$msg [interpreter]"
 234             set doTestsWithRemoteServer 0
 235         }
 236     }
 237 }
 238
 239 # Some tests are run only if we are doing testing against a remote server.
 240 testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer
 241 if {!$doTestsWithRemoteServer} {
 242     if {[string first s $::tcltest::verbose] >= 0} {
 243         puts "Skipping tests with remote server. See tests/socket.test for"
 244         puts "information on how to run remote server."
 245         puts "Reason for not doing remote tests: $noRemoteTestReason"
 246     }
 247 }
 248
 249 #
 250 # If we do the tests, define a command to send a command to the remote server.
 251 #
 252
 253 if {[testConstraint doTestsWithRemoteServer]} {
 254     proc sendCommand {c} {
 255         global commandSocket
 256
 257         if {[eof $commandSocket]} {
 258             error "remote server disappeared"
 259         }
 260         if {[catch {puts $commandSocket $c} msg]} {
 261             error "remote server disappaered: $msg"
 262         }
 263         if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} {
 264             error "remote server disappeared: $msg"
 265         }
 266
 267         while {1} {
 268             set line [gets $commandSocket]
 269             if {[eof $commandSocket]} {
 270                 error "remote server disappaered"
 271             }
 272             if {$line eq "--Marker--Marker--Marker--"} {
 273                 lassign $result code info value
 274                 return -code $code -errorinfo $info $value
 275             }
 276             append result $line "\n"
 277         }
 278     }
 279 }
 280
 281 proc getPort sock {
 282     lindex [fconfigure $sock -sockname] 2
 283 }
 284
 285 # Some tests in this file are known to hang *occasionally* on OSX; stop the
 286 # worst offenders.
 287 testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
 288 # Here "Windows" means derived platforms as Cygwin or Msys2 too.
 289 testConstraint notWindows [expr {![regexp {^(Windows|MSYS|CYGWIN)} $::tcl_platform(os)]}]
 290 \f
 291 # ----------------------------------------------------------------------
 292
 293 test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 294     socket -server
 295 } -returnCodes error -result {no argument given for -server option}
 296 test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 297     socket -server foo
 298 } -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
 299 test socket_$af-1.3 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 300     socket -myaddr
 301 } -returnCodes error -result {no argument given for -myaddr option}
 302 test socket_$af-1.4 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 303     socket -myaddr $localhost
 304 } -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
 305 test socket_$af-1.5 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 306     socket -myport
 307 } -returnCodes error -result {no argument given for -myport option}
 308 test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 309     socket -myport xxxx
 310 } -returnCodes error -result {expected integer but got "xxxx"}
 311 test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 312     socket -myport 2522
 313 } -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
 314 test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 315     socket -froboz
 316 } -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, or -server}
 317 test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 318     socket -server foo -myport 2521 3333
 319 } -returnCodes error -result {option -myport is not valid for servers}
 320 test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 321     socket host 2528 -junk
 322 } -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
 323 test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 324     socket -server callback 2520 --
 325 } -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
 326 test socket_$af-1.12 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 327     socket foo badport
 328 } -returnCodes error -result {expected integer but got "badport"}
 329 test socket_$af-1.13 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 330     socket -async -server
 331 } -returnCodes error -result {cannot set -async option for server sockets}
 332 test socket_$af-1.14 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
 333     socket -server foo -async
 334 } -returnCodes error -result {cannot set -async option for server sockets}
 335
 336 set path(script) [makeFile {} script]
 337
 338 test socket_$af-2.1 {tcp connection} -constraints [list socket supported_$af stdio] -setup {
 339     file delete $path(script)
 340     set f [open $path(script) w]
 341     puts $f {
 342         set timer [after 10000 "set x timed_out"]
 343         set f [socket -server accept 0]
 344         proc accept {file addr port} {
 345             global x
 346             set x done
 347             close $file
 348         }
 349         puts ready
 350         puts [lindex [fconfigure $f -sockname] 2]
 351         vwait x
 352         after cancel $timer
 353         close $f
 354         puts $x
 355     }
 356     close $f
 357     set f [open "|[list [interpreter] $path(script)]" r]
 358     gets $f x
 359     gets $f listen
 360 } -body {
 361     # $x == "ready" at this point
 362     set sock [socket $localhost $listen]
 363     lappend x [gets $f]
 364     close $sock
 365     lappend x [gets $f]
 366 } -cleanup {
 367     close $f
 368 } -result {ready done {}}
 369 test socket_$af-2.2 {tcp connection with client port specified} -setup {
 370     set port [randport]
 371     file delete $path(script)
 372     set f [open $path(script) w]
 373     puts $f {
 374         set timer [after 10000 "set x timeout"]
 375         set f [socket -server accept 0]
 376         proc accept {file addr port} {
 377             global x
 378             puts "[gets $file] $port"
 379             close $file
 380             set x done
 381         }
 382         puts ready
 383         puts [lindex [fconfigure $f -sockname] 2]
 384         vwait x
 385         after cancel $timer
 386         close $f
 387     }
 388     close $f
 389     set f [open "|[list [interpreter] $path(script)]" r]
 390     gets $f x
 391     gets $f listen
 392 } -constraints [list socket supported_$af stdio] -body {
 393     # $x == "ready" at this point
 394     set sock [socket -myport $port $localhost $listen]
 395     puts $sock hello
 396     flush $sock
 397     lappend x [expr {[gets $f] eq "hello $port"}]
 398     close $sock
 399     return $x
 400 } -cleanup {
 401     catch {close [socket $localhost $listen]}
 402     close $f
 403 } -result {ready 1}
 404 test socket_$af-2.3 {tcp connection with client interface specified} -setup {
 405     file delete $path(script)
 406     set f [open $path(script) w]
 407     puts $f {
 408         set timer [after 2000 "set x done"]
 409         set f [socket  -server accept 0]
 410         proc accept {file addr port} {
 411             global x
 412             puts "[gets $file] $addr"
 413             close $file
 414             set x done
 415         }
 416         puts [lindex [fconfigure $f -sockname] 2]
 417         puts ready
 418         vwait x
 419         after cancel $timer
 420         close $f
 421     }
 422     close $f
 423     set f [open "|[list [interpreter] $path(script)]" r]
 424     gets $f listen
 425     gets $f x
 426 } -constraints [list socket supported_$af stdio] -body {
 427     # $x == "ready" at this point
 428     set sock [socket -myaddr $localhost $localhost $listen]
 429     puts $sock hello
 430     flush $sock
 431     lappend x [gets $f]
 432     close $sock
 433     return $x
 434 } -cleanup {
 435     close $f
 436 } -result [list ready [list hello $localhost]]
 437 test socket_$af-2.4 {tcp connection with server interface specified} -setup {
 438     file delete $path(script)
 439     set f [open $path(script) w]
 440     puts $f [list set localhost $localhost]
 441     puts $f {
 442         set timer [after 2000 "set x done"]
 443         set f [socket -server accept -myaddr $localhost 0]
 444         proc accept {file addr port} {
 445             global x
 446             puts "[gets $file]"
 447             close $file
 448             set x done
 449         }
 450         puts ready
 451         puts [lindex [fconfigure $f -sockname] 2]
 452         vwait x
 453         after cancel $timer
 454         close $f
 455     }
 456     close $f
 457     set f [open "|[list [interpreter] $path(script)]" r]
 458     gets $f x
 459     gets $f listen
 460 } -constraints [list socket supported_$af stdio] -body {
 461     # $x == "ready" at this point
 462     set sock [socket $localhost $listen]
 463     puts $sock hello
 464     flush $sock
 465     lappend x [gets $f]
 466     close $sock
 467     return $x
 468 } -cleanup {
 469     close $f
 470 } -result {ready hello}
 471 test socket_$af-2.5 {tcp connection with redundant server port} -setup {
 472     file delete $path(script)
 473     set f [open $path(script) w]
 474     puts $f {
 475         set timer [after 10000 "set x timeout"]
 476         set f [socket -server accept 0]
 477         proc accept {file addr port} {
 478             global x
 479             puts "[gets $file]"
 480             close $file
 481             set x done
 482         }
 483         puts ready
 484         puts [lindex [fconfigure $f -sockname] 2]
 485         vwait x
 486         after cancel $timer
 487         close $f
 488     }
 489     close $f
 490     set f [open "|[list [interpreter] $path(script)]" r]
 491     gets $f x
 492     gets $f listen
 493 } -constraints [list socket supported_$af stdio] -body {
 494     # $x == "ready" at this point
 495     set sock [socket $localhost $listen]
 496     puts $sock hello
 497     flush $sock
 498     lappend x [gets $f]
 499     close $sock
 500     return $x
 501 } -cleanup {
 502     close $f
 503 } -result {ready hello}
 504 test socket_$af-2.6 {tcp connection} -constraints [list socket supported_$af] -body {
 505     set status ok
 506     if {![catch {set sock [socket $localhost [randport]]}]} {
 507         if {![catch {gets $sock}]} {
 508             set status broken
 509         }
 510         close $sock
 511     }
 512     set status
 513 } -result ok
 514 test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_$af stdio] -setup {
 515     file delete $path(script)
 516     set f [open $path(script) w]
 517     puts $f {
 518         set timer [after 10000 "set x timeout"]
 519         set f [socket -server accept 0]
 520         proc accept {s a p} {
 521             fileevent $s readable [list echo $s]
 522             fconfigure $s -translation lf -buffering line
 523         }
 524         proc echo {s} {
 525              set l [gets $s]
 526              if {[eof $s]} {
 527                  global x
 528                  close $s
 529                  set x done
 530              } else {
 531                  puts $s $l
 532              }
 533         }
 534         puts ready
 535         puts [lindex [fconfigure $f -sockname] 2]
 536         vwait x
 537         after cancel $timer
 538         close $f
 539         puts $x
 540     }
 541     close $f
 542     set f [open "|[list [interpreter] $path(script)]" r]
 543     gets $f
 544     gets $f listen
 545 } -body {
 546     set s [socket $localhost $listen]
 547     fconfigure $s -buffering line -translation lf
 548     puts $s "hello abcdefghijklmnop"
 549     set x [gets $s]
 550     close $s
 551     list $x [gets $f]
 552 } -cleanup {
 553     close $f
 554 } -result {{hello abcdefghijklmnop} done}
 555 removeFile script
 556 test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup {
 557     set path(script) [makeFile {
 558         set f [socket -server accept 0]
 559         proc accept {s a p} {
 560             fileevent $s readable [list echo $s]
 561             fconfigure $s -buffering line
 562         }
 563         proc echo {s} {
 564              global i
 565              set l [gets $s]
 566              if {[eof $s]} {
 567                  global x
 568                  close $s
 569                  set x done
 570              } else {
 571                  incr i
 572                  puts $s $l
 573              }
 574         }
 575         set i 0
 576         puts ready
 577         puts [lindex [fconfigure $f -sockname] 2]
 578         set timer [after 20000 "set x done"]
 579         vwait x
 580         after cancel $timer
 581         close $f
 582         puts "done $i"
 583     } script]
 584     set f [open "|[list [interpreter] $path(script)]" r]
 585     gets $f
 586     gets $f listen
 587 } -constraints [list socket supported_$af stdio] -body {
 588     set s [socket $localhost $listen]
 589     fconfigure $s -buffering line
 590     catch {
 591         for {set x 0} {$x < 50} {incr x} {
 592             puts $s "hello abcdefghijklmnop"
 593             gets $s
 594         }
 595     }
 596     close $s
 597     catch {set x [gets $f]}
 598     return $x
 599 } -cleanup {
 600     close $f
 601     removeFile script
 602 } -result {done 50}
 603 set path(script) [makeFile {} script]
 604 test socket_$af-2.9 {socket conflict} -constraints [list socket supported_$af stdio] -body {
 605     set s [socket -server accept 0]
 606     file delete $path(script)
 607     set f [open $path(script) w]
 608     puts $f [list set ::tcl::unsupported::socketAF $::tcl::unsupported::socketAF]
 609     puts $f "socket -server accept [lindex [fconfigure $s -sockname] 2]"
 610     close $f
 611     set f [open "|[list [interpreter] $path(script)]" r]
 612     gets $f
 613     after 100
 614     close $f
 615 } -returnCodes error -cleanup {
 616     close $s
 617 } -match glob -result {couldn't open socket: address already in use*}
 618 test socket_$af-2.10 {close on accept, accepted socket lives} -setup {
 619     set done 0
 620     set timer [after 20000 "set done timed_out"]
 621 } -constraints [list socket supported_$af] -body {
 622     set ss [socket -server accept 0]
 623     proc accept {s a p} {
 624         global ss
 625         close $ss
 626         fileevent $s readable "readit $s"
 627         fconfigure $s -trans lf
 628     }
 629     proc readit {s} {
 630         global done
 631         gets $s
 632         close $s
 633         set done 1
 634     }
 635     set cs [socket $localhost [lindex [fconfigure $ss -sockname] 2]]
 636     puts $cs hello
 637     close $cs
 638     vwait done
 639     return $done
 640 } -cleanup {
 641     after cancel $timer
 642 } -result 1
 643 test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$af] -setup {
 644     proc accept {s a p} {
 645         global sock
 646         set sock $s
 647     }
 648     set s [socket -server accept 0]
 649     set sock ""
 650 } -body {
 651     set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]]
 652     vwait sock
 653     puts $s2 one
 654     flush $s2
 655     after $latency {set x 1}; # Spurious failures in Travis CI, if we do [after idle]
 656     vwait x
 657     fconfigure $sock -blocking 0
 658     set result a:[gets $sock]
 659     lappend result b:[gets $sock]
 660     fconfigure $sock -blocking 1
 661     puts $s2 two
 662     flush $s2
 663     after $latency {set x 1}; # NetBSD fails here if we do [after idle]
 664     vwait x
 665     fconfigure $sock -blocking 0
 666     lappend result c:[gets $sock]
 667 } -cleanup {
 668     fconfigure $sock -blocking 1
 669     close $s2
 670     close $s
 671     close $sock
 672 } -result {a:one b: c:two}
 673 test socket_$af-2.12 {} [list socket stdio supported_$af] {
 674     file delete $path(script)
 675     set f [open $path(script) w]
 676     puts $f {
 677         set server [socket -server accept_client 0]
 678         puts [lindex [chan configure $server -sockname] 2]
 679         proc accept_client { client host port } {
 680             chan configure $client -blocking  0 -buffering line
 681             write_line $client
 682         }
 683         proc write_line client {
 684             if { [catch { chan puts $client [string repeat . 720000]}] } {
 685                 puts [catch {chan close $client}]
 686             } else {
 687                 puts signal1
 688                 after 0 write_line $client
 689             }
 690         }
 691         chan event stdin readable {set forever now}
 692         vwait forever
 693         exit
 694     }
 695     close $f
 696     set f [open "|[list [interpreter] $path(script)]" r+]
 697     gets $f port
 698     set sock [socket $localhost $port]
 699     chan event $sock readable [list read_lines $sock $f]
 700     proc read_lines { sock pipe } {
 701         gets $pipe
 702         chan close $sock
 703         chan event $pipe readable [list readpipe $pipe]
 704     }
 705     proc readpipe {pipe} {
 706         while {![string is integer [set ::done [gets $pipe]]]} {}
 707     }
 708     vwait ::done
 709     close $f
 710     set ::done
 711 } 0
 712 test socket_$af-2.13 {Bug 1758a0b603} {socket stdio} {
 713     file delete $path(script)
 714     set f [open $path(script) w]
 715     puts $f {
 716         set server [socket -server accept 0]
 717         puts [lindex [chan configure $server -sockname] 2]
 718         proc accept { client host port } {
 719             chan configure $client -blocking  0 -buffering line -buffersize 1
 720             puts $client [string repeat . 720000]
 721             puts ready
 722             chan event $client writable [list setup $client]
 723         }
 724         proc setup client {
 725             chan event $client writable {set forever write}
 726             after 5 {set forever timeout}
 727         }
 728         vwait forever
 729         puts $forever
 730     }
 731     close $f
 732     set pipe [open |[list [interpreter] $path(script)] r]
 733     gets $pipe port
 734     set sock [socket $localhost $port]
 735     chan configure $sock -blocking  0 -buffering line
 736     chan event $sock readable [list read_lines $sock $pipe ]
 737     proc read_lines { sock pipe } {
 738         gets $pipe
 739         gets $sock line
 740         after idle [list stop $sock $pipe]
 741         chan event $sock readable {}
 742     }
 743     proc stop {sock pipe} {
 744         variable done
 745         close $sock
 746         set done [gets $pipe]
 747     }
 748     variable done
 749     vwait [namespace which -variable done]
 750     close $pipe
 751     set done
 752 } write
 753
 754 test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup {
 755     file delete $path(script)
 756     set f [open $path(script) w]
 757     puts $f [list set localhost $localhost]
 758     puts $f {
 759         set f [socket -server accept -myaddr $localhost 0]
 760         puts ready
 761         puts [lindex [fconfigure $f -sockname] 2]
 762         gets stdin
 763         close $f
 764     }
 765     close $f
 766     set f [open "|[list [interpreter] $path(script)]" r+]
 767     gets $f
 768     gets $f listen
 769 } -body {
 770     socket -server accept -myaddr $localhost $listen
 771 } -cleanup {
 772     puts $f bye
 773     close $f
 774 } -returnCodes error -result {couldn't open socket: address already in use}
 775 test socket_$af-3.2 {server with several clients} -setup {
 776     file delete $path(script)
 777     set f [open $path(script) w]
 778     puts $f [list set localhost $localhost]
 779     puts $f {
 780         set t1 [after 30000 "set x timed_out"]
 781         set t2 [after 31000 "set x timed_out"]
 782         set t3 [after 32000 "set x timed_out"]
 783         set counter 0
 784         set s [socket -server accept -myaddr $localhost 0]
 785         proc accept {s a p} {
 786             fileevent $s readable [list echo $s]
 787             fconfigure $s -buffering line
 788         }
 789         proc echo {s} {
 790              global x
 791              set l [gets $s]
 792              if {[eof $s]} {
 793                  close $s
 794                  set x done
 795              } else {
 796                  puts $s $l
 797              }
 798         }
 799         puts ready
 800         puts [lindex [fconfigure $s -sockname] 2]
 801         vwait x
 802         after cancel $t1
 803         vwait x
 804         after cancel $t2
 805         vwait x
 806         after cancel $t3
 807         close $s
 808         puts $x
 809     }
 810     close $f
 811     set f [open "|[list [interpreter] $path(script)]" r+]
 812     set x [gets $f]
 813     gets $f listen
 814 } -constraints [list socket supported_$af stdio] -body {
 815     # $x == "ready" here
 816     set s1 [socket $localhost $listen]
 817     fconfigure $s1 -buffering line
 818     set s2 [socket $localhost $listen]
 819     fconfigure $s2 -buffering line
 820     set s3 [socket $localhost $listen]
 821     fconfigure $s3 -buffering line
 822     for {set i 0} {$i < 100} {incr i} {
 823         puts $s1 hello,s1
 824         gets $s1
 825         puts $s2 hello,s2
 826         gets $s2
 827         puts $s3 hello,s3
 828         gets $s3
 829     }
 830     close $s1
 831     close $s2
 832     close $s3
 833     lappend x [gets $f]
 834 } -cleanup {
 835     close $f
 836 } -result {ready done}
 837
 838 test socket_$af-4.1 {server with several clients} -setup {
 839     file delete $path(script)
 840     set f [open $path(script) w]
 841     puts $f [list set localhost $localhost]
 842     puts $f {
 843         set port [gets stdin]
 844         set s [socket $localhost $port]
 845         fconfigure $s -buffering line
 846         for {set i 0} {$i < 100} {incr i} {
 847             puts $s hello
 848             gets $s
 849         }
 850         close $s
 851         puts bye
 852         gets stdin
 853     }
 854     close $f
 855     set p1 [open "|[list [interpreter] $path(script)]" r+]
 856     fconfigure $p1 -buffering line
 857     set p2 [open "|[list [interpreter] $path(script)]" r+]
 858     fconfigure $p2 -buffering line
 859     set p3 [open "|[list [interpreter] $path(script)]" r+]
 860     fconfigure $p3 -buffering line
 861 } -constraints [list socket supported_$af stdio] -body {
 862     proc accept {s a p} {
 863         fconfigure $s -buffering line
 864         fileevent $s readable [list echo $s]
 865     }
 866     proc echo {s} {
 867         global x
 868         set l [gets $s]
 869         if {[eof $s]} {
 870             close $s
 871             set x done
 872         } else {
 873             puts $s $l
 874         }
 875     }
 876     set t1 [after 30000 "set x timed_out"]
 877     set t2 [after 31000 "set x timed_out"]
 878     set t3 [after 32000 "set x timed_out"]
 879     set s [socket -server accept -myaddr $localhost 0]
 880     set listen [lindex [fconfigure $s -sockname] 2]
 881     puts $p1 $listen
 882     puts $p2 $listen
 883     puts $p3 $listen
 884     vwait x
 885     vwait x
 886     vwait x
 887     after cancel $t1
 888     after cancel $t2
 889     after cancel $t3
 890     close $s
 891     set l ""
 892     lappend l [list p1 [gets $p1] $x]
 893     lappend l [list p2 [gets $p2] $x]
 894     lappend l [list p3 [gets $p3] $x]
 895 } -cleanup {
 896     puts $p1 bye
 897     puts $p2 bye
 898     puts $p3 bye
 899     close $p1
 900     close $p2
 901     close $p3
 902 } -result {{p1 bye done} {p2 bye done} {p3 bye done}}
 903 test socket_$af-4.2 {byte order problems, socket numbers, htons} -body {
 904     close [socket -server dodo -myaddr $localhost 0x3000]
 905     return ok
 906 } -constraints [list socket supported_$af] -result ok
 907
 908 test socket_$af-5.1 {byte order problems, socket numbers, htons} -body {
 909     if {![catch {socket -server dodo 0x1} msg]} {
 910         close $msg
 911         return {htons problem, should be disallowed, are you running as SU?}
 912     }
 913     return {couldn't open socket: not owner}
 914 } -constraints [list socket supported_$af unix notRoot notOSX notWindows] -result {couldn't open socket: not owner}
 915 test socket_$af-5.2 {byte order problems, socket numbers, htons} -body {
 916     if {![catch {socket -server dodo 0x10000} msg]} {
 917         close $msg
 918         return {port resolution problem, should be disallowed}
 919     }
 920     return {couldn't open socket: port number too high}
 921 } -constraints [list socket supported_$af] -result {couldn't open socket: port number too high}
 922 test socket_$af-5.3 {byte order problems, socket numbers, htons} -body {
 923     if {![catch {socket -server dodo 21} msg]} {
 924         close $msg
 925         return {htons problem, should be disallowed, are you running as SU?}
 926     }
 927     return {couldn't open socket: not owner}
 928 } -constraints [list socket supported_$af unix notRoot notOSX notWindows] -result {couldn't open socket: not owner}
 929
 930 test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup {
 931     proc myHandler {msg options} {
 932         variable x $msg
 933     }
 934     set handler [interp bgerror {}]
 935     interp bgerror {} [namespace which myHandler]
 936     file delete $path(script)
 937 } -body {
 938     set f [open $path(script) w]
 939     puts $f [list set localhost $localhost]
 940     puts $f {
 941         gets stdin port
 942         socket $localhost $port
 943     }
 944     close $f
 945     set f [open "|[list [interpreter] $path(script)]" r+]
 946     proc accept {s a p} {expr {10 / 0}}
 947     set s [socket -server accept -myaddr $localhost 0]
 948     puts $f [lindex [fconfigure $s -sockname] 2]
 949     close $f
 950     set timer [after 10000 "set x timed_out"]
 951     vwait x
 952     after cancel $timer
 953     close $s
 954     return $x
 955 } -cleanup {
 956     interp bgerror {} $handler
 957 } -result {divide by zero}
 958
 959 test socket_$af-6.2 {
 960     readable fileevent on server socket
 961 } -setup {
 962     set sock [socket -server dummy 0]
 963 } -constraints [list socket supported_$af] -body {
 964     fileevent $sock readable dummy
 965 } -cleanup {
 966     close $sock
 967 } -returnCodes 1 -result "channel is not readable"
 968
 969 test socket_$af-6.3 {writable fileevent on server socket} -setup {
 970     set sock [socket -server dummy 0]
 971 } -constraints [list socket supported_$af] -body {
 972     fileevent $sock writable dummy
 973 } -cleanup {
 974     close $sock
 975 } -returnCodes 1 -result "channel is not writable"
 976
 977 test socket_$af-7.1 {testing socket specific options} -setup {
 978     file delete $path(script)
 979     set f [open $path(script) w]
 980     puts $f {
 981         set ss [socket -server accept 0]
 982         proc accept args {
 983             global x
 984             set x done
 985         }
 986         puts ready
 987         puts [lindex [fconfigure $ss -sockname] 2]
 988         set timer [after 10000 "set x timed_out"]
 989         vwait x
 990         after cancel $timer
 991     }
 992     close $f
 993     set f [open "|[list [interpreter] $path(script)]" r]
 994     gets $f
 995     gets $f listen
 996     set l ""
 997 } -constraints [list socket supported_$af stdio] -body {
 998     set s [socket $localhost $listen]
 999     set p [fconfigure $s -peername]
1000     close $s
1001     lappend l [string compare [lindex $p 0] $localhost]
1002     lappend l [string compare [lindex $p 2] $listen]
1003     lappend l [llength $p]
1004 } -cleanup {
1005     close $f
1006 } -result {0 0 3}
1007 test socket_$af-7.2 {testing socket specific options} -setup {
1008     file delete $path(script)
1009     set f [open $path(script) w]
1010     puts $f [list set ::tcl::unsupported::socketAF $::tcl::unsupported::socketAF]
1011     puts $f {
1012         set ss [socket -server accept 0]
1013         proc accept args {
1014             global x
1015             set x done
1016         }
1017         puts ready
1018         puts [lindex [fconfigure $ss -sockname] 2]
1019         set timer [after 10000 "set x timed_out"]
1020         vwait x
1021         after cancel $timer
1022     }
1023     close $f
1024     set f [open "|[list [interpreter] $path(script)]" r]
1025     gets $f
1026     gets $f listen
1027 } -constraints [list socket supported_$af stdio] -body {
1028     set s [socket $localhost $listen]
1029     set p [fconfigure $s -sockname]
1030     close $s
1031     list [llength $p] \
1032             [regexp {^(127\.0\.0\.1|0\.0\.0\.0|::1)$} [lindex $p 0]] \
1033             [expr {[lindex $p 2] == $listen}]
1034 } -cleanup {
1035     close $f
1036 } -result {3 1 0}
1037 test socket_$af-7.3 {testing socket specific options} -constraints [list socket supported_$af] -body {
1038     set s [socket -server accept -myaddr $localhost 0]
1039     set l [fconfigure $s]
1040     close $s
1041     update
1042     llength $l
1043 } -result 14
1044 test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup {
1045     set timer [after 10000 "set x timed_out"]
1046     set l ""
1047 } -body {
1048     set s [socket -server accept -myaddr $localhost 0]
1049     proc accept {s a p} {
1050         global x
1051         set x [fconfigure $s -sockname]
1052         close $s
1053     }
1054     set listen [lindex [fconfigure $s -sockname] 2]
1055     set s1 [socket $localhost $listen]
1056     vwait x
1057     lappend l [expr {[lindex $x 2] == $listen}] [llength $x]
1058 } -cleanup {
1059     after cancel $timer
1060     close $s
1061     close $s1
1062 } -result {1 3}
1063 test socket_$af-7.5 {testing socket specific options} -setup {
1064     set timer [after 10000 "set x timed_out"]
1065     set l ""
1066 } -constraints [list socket supported_$af unixOrWin] -body {
1067     set s [socket -server accept 0]
1068     proc accept {s a p} {
1069         global x
1070         set x [fconfigure $s -sockname]
1071         close $s
1072     }
1073     set listen [lindex [fconfigure $s -sockname] 2]
1074     set s1 [socket $localhost $listen]
1075     vwait x
1076     lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x]
1077 } -cleanup {
1078     after cancel $timer
1079     close $s
1080     close $s1
1081 } -result [list $localhost 1 3]
1082
1083 test socket_$af-8.1 {testing -async flag on sockets} -constraints [list socket supported_$af] -body {
1084     # NOTE: This test may fail on some Solaris 2.4 systems. If it does, check
1085     # that you have these patches installed (using showrev -p):
1086     #
1087     # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
1088     # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
1089     # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
1090     # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
1091     # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01,
1092     # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03
1093     #
1094     # If after installing these patches you are still experiencing a problem,
1095     # please email jyl@eng.sun.com. We have not observed this failure on
1096     # Solaris 2.5, so another option (instead of installing these patches) is
1097     # to upgrade to Solaris 2.5.
1098     set s [socket -server accept -myaddr $localhost 0]
1099     proc accept {s a p} {
1100         global x
1101         puts $s bye
1102         close $s
1103         set x done
1104     }
1105     set s1 [socket -async $localhost [lindex [fconfigure $s -sockname] 2]]
1106     vwait x
1107     gets $s1
1108 } -cleanup {
1109     close $s
1110     close $s1
1111 } -result bye
1112
1113 test socket_$af-9.1 {testing spurious events} -constraints [list socket supported_$af] -setup {
1114     set len 0
1115     set spurious 0
1116     set done 0
1117     set timer [after 10000 "set done timed_out"]
1118 } -body {
1119     proc readlittle {s} {
1120         global spurious done len
1121         set l [read $s 1]
1122         if {[string length $l] == 0} {
1123             if {![eof $s]} {
1124                 incr spurious
1125             } else {
1126                 close $s
1127                 set done 1
1128             }
1129         } else {
1130             incr len [string length $l]
1131         }
1132     }
1133     proc accept {s a p} {
1134         fconfigure $s -buffering none -blocking off
1135         fileevent $s readable [list readlittle $s]
1136     }
1137     set s [socket -server accept -myaddr $localhost 0]
1138     set c [socket $localhost [lindex [fconfigure $s -sockname] 2]]
1139     puts -nonewline $c 01234567890123456789012345678901234567890123456789
1140     close $c
1141     vwait done
1142     close $s
1143     list $spurious $len
1144 } -cleanup {
1145     after cancel $timer
1146 } -result {0 50}
1147 test socket_$af-9.2 {testing async write, fileevents, flush on close} -constraints [list socket supported_$af] -setup {
1148     set firstblock ""
1149     for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
1150     set secondblock ""
1151     for {set i 0} {$i < 16} {incr i} {
1152         set secondblock "b$secondblock$secondblock"
1153     }
1154     set timer [after 10000 "set done timed_out"]
1155     set l [socket -server accept -myaddr $localhost 0]
1156     proc accept {s a p} {
1157         fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
1158                 -buffering line
1159         fileevent $s readable "readable $s"
1160     }
1161     proc readable {s} {
1162         set l [gets $s]
1163         fileevent $s readable {}
1164         after idle respond $s
1165     }
1166     proc respond {s} {
1167         global firstblock
1168         puts -nonewline $s $firstblock
1169         after idle writedata $s
1170     }
1171     proc writedata {s} {
1172         global secondblock
1173         puts -nonewline $s $secondblock
1174         close $s
1175     }
1176 } -body {
1177     set s [socket $localhost [lindex [fconfigure $l -sockname] 2]]
1178     fconfigure $s -blocking 0 -trans lf -buffering line
1179     set count 0
1180     puts $s hello
1181     proc readit {s} {
1182         global count done
1183         set l [read $s]
1184         incr count [string length $l]
1185         if {[eof $s]} {
1186             close $s
1187             set done 1
1188         }
1189     }
1190     fileevent $s readable "readit $s"
1191     vwait done
1192     return $count
1193 } -cleanup {
1194     close $l
1195     after cancel $timer
1196 } -result 65566
1197 test socket_$af-9.3 {testing EOF stickyness} -constraints [list socket supported_$af] -setup {
1198     set count 0
1199     set done false
1200     proc write_then_close {s} {
1201         puts $s bye
1202         close $s
1203     }
1204     proc accept {s a p} {
1205         fconfigure $s -buffering line -translation lf
1206         fileevent $s writable "write_then_close $s"
1207     }
1208     set s [socket -server accept -myaddr $localhost 0]
1209 } -body {
1210     proc count_to_eof {s} {
1211         global count done
1212         set l [gets $s]
1213         if {[eof $s]} {
1214             incr count
1215             if {$count > 9} {
1216                 close $s
1217                 set done true
1218                 set count {eof is sticky}
1219             }
1220         }
1221     }
1222     proc timerproc {s} {
1223         global done count
1224         set done true
1225         set count {timer went off, eof is not sticky}
1226         close $s
1227     }
1228     set c [socket $localhost [lindex [fconfigure $s -sockname] 2]]
1229     fconfigure $c -blocking off -buffering line -translation lf
1230     fileevent $c readable "count_to_eof $c"
1231     set timer [after 1000 timerproc $c]
1232     vwait done
1233     return $count
1234 } -cleanup {
1235     close $s
1236     after cancel $timer
1237 } -result {eof is sticky}
1238
1239 removeFile script
1240
1241 test socket_$af-10.1 {testing socket accept callback error handling} \
1242     -constraints [list socket supported_$af] -setup {
1243     variable goterror 0
1244     proc myHandler {msg options} {
1245         variable goterror 1
1246     }
1247     set handler [interp bgerror {}]
1248     interp bgerror {} [namespace which myHandler]
1249 } -body {
1250     set s [socket -server accept -myaddr $localhost 0]
1251     proc accept {s a p} {close $s; error}
1252     set c [socket $localhost [lindex [fconfigure $s -sockname] 2]]
1253     vwait goterror
1254     close $s
1255     close $c
1256     return $goterror
1257 } -cleanup {
1258     interp bgerror {} $handler
1259 } -result 1
1260
1261 test socket_$af-11.1 {tcp connection} -setup {
1262     set port [sendCommand {
1263         set server [socket -server accept 0]
1264         proc accept {s a p} {
1265             puts $s done
1266             close $s
1267         }
1268         getPort $server
1269     }]
1270 } -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
1271     set s [socket $remoteServerIP $port]
1272     gets $s
1273 } -cleanup {
1274     close $s
1275     sendCommand {close $server}
1276 } -result done
1277 test socket_$af-11.2 {client specifies its port} -setup {
1278     set lport [randport]
1279     set rport [sendCommand {
1280         set server [socket -server accept 0]
1281         proc accept {s a p} {
1282             puts $s $p
1283             close $s
1284         }
1285         getPort $server
1286     }]
1287 } -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
1288     set s [socket -myport $lport $remoteServerIP $rport]
1289     set r [gets $s]
1290     expr {$r==$lport ? "ok" : "broken: $r != $port"}
1291 } -cleanup {
1292     close $s
1293     sendCommand {close $server}
1294 } -result ok
1295 test socket_$af-11.3 {trying to connect, no server} -body {
1296     set status ok
1297     if {![catch {set s [socket $remoteServerIp [randport]]}]} {
1298         if {![catch {gets $s}]} {
1299             set status broken
1300         }
1301         close $s
1302     }
1303     return $status
1304 } -constraints [list socket supported_$af doTestsWithRemoteServer] -result ok
1305 test socket_$af-11.4 {remote echo, one line} -setup {
1306     set port [sendCommand {
1307         set server [socket -server accept 0]
1308         proc accept {s a p} {
1309             fileevent $s readable [list echo $s]
1310             fconfigure $s -buffering line -translation crlf
1311         }
1312         proc echo {s} {
1313             set l [gets $s]
1314             if {[eof $s]} {
1315                 close $s
1316             } else {
1317                 puts $s $l
1318             }
1319         }
1320         getPort $server
1321     }]
1322 } -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
1323     set f [socket $remoteServerIP $port]
1324     fconfigure $f -translation crlf -buffering line
1325     puts $f hello
1326     gets $f
1327 } -cleanup {
1328     catch {close $f}
1329     sendCommand {close $server}
1330 } -result hello
1331 test socket_$af-11.5 {remote echo, 50 lines} -setup {
1332     set port [sendCommand {
1333         set server [socket -server accept 0]
1334         proc accept {s a p} {
1335             fileevent $s readable [list echo $s]
1336             fconfigure $s -buffering line -translation crlf
1337         }
1338         proc echo {s} {
1339             set l [gets $s]
1340             if {[eof $s]} {
1341                 close $s
1342             } else {
1343                 puts $s $l
1344             }
1345         }
1346         getPort $server
1347     }]
1348 } -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
1349     set f [socket $remoteServerIP $port]
1350     fconfigure $f -translation crlf -buffering line
1351     for {set cnt 0} {$cnt < 50} {incr cnt} {
1352         puts $f "hello, $cnt"
1353         if {[gets $f] != "hello, $cnt"} {
1354             break
1355         }
1356     }
1357     return $cnt
1358 } -cleanup {
1359     close $f
1360     sendCommand {close $server}
1361 } -result 50
1362 test socket_$af-11.6 {socket conflict} -setup {
1363     set s1 [socket -server accept -myaddr $localhost 0]
1364 } -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
1365     set s2 [socket -server accept -myaddr $localhost [getPort $s1]]
1366     list [getPort $s2] [close $s2]
1367 } -cleanup {
1368     close $s1
1369 } -returnCodes error -result {couldn't open socket: address already in use}
1370 test socket_$af-11.7 {server with several clients} -setup {
1371     set port [sendCommand {
1372         set server [socket -server accept 0]
1373         proc accept {s a p} {
1374             fconfigure $s -buffering line
1375             fileevent $s readable [list echo $s]
1376         }
1377         proc echo {s} {
1378             set l [gets $s]
1379             if {[eof $s]} {
1380                 close $s
1381             } else {
1382                 puts $s $l
1383             }
1384         }
1385         getPort $server
1386     }]
1387 } -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
1388     set s1 [socket $remoteServerIP $port]
1389     fconfigure $s1 -buffering line
1390     set s2 [socket $remoteServerIP $port]
1391     fconfigure $s2 -buffering line
1392     set s3 [socket $remoteServerIP $port]
1393     fconfigure $s3 -buffering line
1394     for {set i 0} {$i < 100} {incr i} {
1395         puts $s1 hello,s1
1396         gets $s1
1397         puts $s2 hello,s2
1398         gets $s2
1399         puts $s3 hello,s3
1400         gets $s3
1401     }
1402     return $i
1403 } -cleanup {
1404     close $s1
1405     close $s2
1406     close $s3
1407     sendCommand {close $server}
1408 } -result 100
1409 test socket_$af-11.8 {client with several servers} -setup {
1410     lassign [sendCommand {
1411         set s1 [socket -server "accept server1" 0]
1412         set s2 [socket -server "accept server2" 0]
1413         set s3 [socket -server "accept server3" 0]
1414         proc accept {mp s a p} {
1415             puts $s $mp
1416             close $s
1417         }
1418         list [getPort $s1] [getPort $s2] [getPort $s3]
1419     }] p1 p2 p3
1420 } -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
1421     set s1 [socket $remoteServerIP $p1]
1422     set s2 [socket $remoteServerIP $p2]
1423     set s3 [socket $remoteServerIP $p3]
1424     list [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \
1425         [gets $s3] [gets $s3] [eof $s3]
1426 } -cleanup {
1427     close $s1
1428     close $s2
1429     close $s3
1430     sendCommand {
1431         close $s1
1432         close $s2
1433         close $s3
1434     }
1435 } -result {server1 {} 1 server2 {} 1 server3 {} 1}
1436 test socket_$af-11.9 {accept callback error} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup {
1437     proc myHandler {msg options} {
1438         variable x $msg
1439     }
1440     set handler [interp bgerror {}]
1441     interp bgerror {} [namespace which myHandler]
1442     set timer [after 10000 "set x timed_out"]
1443 } -body {
1444     set s [socket -server accept 0]
1445     proc accept {s a p} {expr {10 / 0}}
1446     sendCommand "set port [getPort $s]"
1447     if {[catch {
1448         sendCommand {
1449             set peername [fconfigure $callerSocket -peername]
1450             set s [socket [lindex $peername 0] $port]
1451             close $s
1452          }
1453     } msg]} then {
1454         close $s
1455         error $msg
1456     }
1457     vwait x
1458     return $x
1459 } -cleanup {
1460     close $s
1461     after cancel $timer
1462     interp bgerror {} $handler
1463 } -result {divide by zero}
1464 test socket_$af-11.10 {testing socket specific options} -setup {
1465     set port [sendCommand {
1466         set server [socket -server accept 0]
1467         proc accept {s a p} {close $s}
1468         getPort $server
1469     }]
1470 } -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
1471     set s [socket $remoteServerIP $port]
1472     set p [fconfigure $s -peername]
1473     set n [fconfigure $s -sockname]
1474     list [expr {[lindex $p 2] == $port}] [llength $p] [llength $n]
1475 } -cleanup {
1476     close $s
1477     sendCommand {close $server}
1478 } -result {1 3 3}
1479 test socket_$af-11.11 {testing spurious events} -setup {
1480     set port [sendCommand {
1481         set server [socket -server accept 0]
1482         proc accept {s a p} {
1483             fconfigure $s -translation "auto lf"
1484             after idle writesome $s
1485         }
1486         proc writesome {s} {
1487             for {set i 0} {$i < 100} {incr i} {
1488                 puts $s "line $i from remote server"
1489             }
1490             close $s
1491         }
1492         getPort $server
1493     }]
1494     set len 0
1495     set spurious 0
1496     set done 0
1497     set timer [after 40000 "set done timed_out"]
1498 } -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
1499     proc readlittle {s} {
1500         global spurious done len
1501         set l [read $s 1]
1502         if {[string length $l] == 0} {
1503             if {![eof $s]} {
1504                 incr spurious
1505             } else {
1506                 close $s
1507                 set done 1
1508             }
1509         } else {
1510             incr len [string length $l]
1511         }
1512     }
1513     set c [socket $remoteServerIP $port]
1514     fileevent $c readable "readlittle $c"
1515     vwait done
1516     list $spurious $len $done
1517 } -cleanup {
1518     after cancel $timer
1519     sendCommand {close $server}
1520 } -result {0 2690 1}
1521 test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup {
1522     set counter 0
1523     set done 0
1524     set port [sendCommand {
1525         set server [socket -server accept 0]
1526         proc accept {s a p} {
1527             after idle close $s
1528         }
1529         getPort $server
1530     }]
1531     proc timed_out {} {
1532         global c done
1533         set done {timed_out, EOF is not sticky}
1534         close $c
1535     }
1536     set after_id [after 1000 timed_out]
1537 } -body {
1538     proc count_up {s} {
1539         global counter done
1540         set l [gets $s]
1541         if {[eof $s]} {
1542             incr counter
1543             if {$counter > 9} {
1544                 set done {EOF is sticky}
1545                 close $s
1546             }
1547         }
1548     }
1549     set c [socket $remoteServerIP $port]
1550     fileevent $c readable [list count_up $c]
1551     vwait done
1552     return $done
1553 } -cleanup {
1554     after cancel $after_id
1555     sendCommand {close $server}
1556 } -result {EOF is sticky}
1557 test socket_$af-11.13 {testing async write, async flush, async close} -setup {
1558     set port [sendCommand {
1559         set firstblock ""
1560         for {set i 0} {$i < 5} {incr i} {
1561                 set firstblock "a$firstblock$firstblock"
1562         }
1563         set secondblock ""
1564         for {set i 0} {$i < 16} {incr i} {
1565             set secondblock "b$secondblock$secondblock"
1566         }
1567         set l [socket -server accept 0]
1568         proc accept {s a p} {
1569             fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
1570                 -buffering line
1571             fileevent $s readable "readable $s"
1572         }
1573         proc readable {s} {
1574             set l [gets $s]
1575             fileevent $s readable {}
1576             after idle respond $s
1577         }
1578         proc respond {s} {
1579             global firstblock
1580             puts -nonewline $s $firstblock
1581             after idle writedata $s
1582         }
1583         proc writedata {s} {
1584             global secondblock
1585             puts -nonewline $s $secondblock
1586             close $s
1587         }
1588         getPort $l
1589     }]
1590     set timer [after 10000 "set done timed_out"]
1591 } -constraints [list socket supported_$af doTestsWithRemoteServer] -body {
1592     proc readit {s} {
1593         global count done
1594         set l [read $s]
1595         incr count [string length $l]
1596         if {[eof $s]} {
1597             close $s
1598             set done 1
1599         }
1600     }
1601     set s [socket $remoteServerIP $port]
1602     fconfigure $s -blocking 0 -trans lf -buffering line
1603     set count 0
1604     puts $s hello
1605     fileevent $s readable "readit $s"
1606     vwait done
1607     return $count
1608 } -cleanup {
1609     after cancel $timer
1610     sendCommand {close $l}
1611 } -result 65566
1612
1613 set path(script1) [makeFile {} script1]
1614 set path(script2) [makeFile {} script2]
1615
1616 test socket_$af-12.1 {testing inheritance of server sockets} -setup {
1617     file delete $path(script1)
1618     file delete $path(script2)
1619     # Script1 is just a 10 second delay. If the server socket is inherited, it
1620     # will be held open for 10 seconds
1621     set f [open $path(script1) w]
1622     puts $f {
1623         fileevent stdin readable exit
1624         after 10000 exit
1625         vwait forever
1626     }
1627     close $f
1628     # Script2 creates the server socket, launches script1, and exits.
1629     # The server socket will now be closed unless script1 inherited it.
1630     set f [open $path(script2) w]
1631     puts $f [list set tcltest [interpreter]]
1632     puts $f [list set delay $path(script1)]
1633     puts $f [list set localhost $localhost]
1634     puts $f {
1635         set f [socket -server accept -myaddr $localhost 0]
1636         proc accept { file addr port } {
1637             close $file
1638         }
1639         exec $tcltest $delay &
1640         puts [lindex [fconfigure $f -sockname] 2]
1641         close $f
1642         exit
1643     }
1644     close $f
1645 } -constraints [list socket supported_$af stdio exec] -body {
1646     # Launch script2 and wait 5 seconds
1647     ### exec [interpreter] script2 &
1648     set p [open "|[list [interpreter] $path(script2)]" r]
1649     # If we can still connect to the server, the socket got inherited.
1650     if {[catch {close [socket $localhost $listen]}]} {
1651         return {server socket was not inherited}
1652     } else {
1653         return {server socket was inherited}
1654     }
1655 } -cleanup {
1656     catch {close $p}
1657 } -result {server socket was not inherited}
1658 test socket_$af-12.2 {testing inheritance of client sockets} -setup {
1659     file delete $path(script1)
1660     file delete $path(script2)
1661     # Script1 is just a 20 second delay. If the server socket is inherited, it
1662     # will be held open for 20 seconds
1663     set f [open $path(script1) w]
1664     puts $f {
1665         fileevent stdin readable exit
1666         after 20000 exit
1667         vwait forever
1668     }
1669     close $f
1670     # Script2 opens the client socket and writes to it. It then launches
1671     # script1 and exits. If the child process inherited the client socket, the
1672     # socket will still be open.
1673     set f [open $path(script2) w]
1674     puts $f [list set tcltest [interpreter]]
1675     puts $f [list set delay $path(script1)]
1676     puts $f [list set localhost $localhost]
1677     puts $f {
1678         gets stdin port
1679         set f [socket $localhost $port]
1680         exec $tcltest $delay &
1681         puts $f testing
1682         flush $f
1683         exit
1684     }
1685     close $f
1686     # If the socket doesn't hit end-of-file in 10 seconds, the script1 process
1687     # must have inherited the client.
1688     set timeout 0
1689     set after [after 10000 {set x "client socket was inherited"}]
1690 } -constraints [list socket supported_$af stdio exec] -body {
1691     # Create the server socket
1692     set server [socket -server accept -myaddr $localhost 0]
1693     proc accept { file host port } {
1694         # When the client connects, establish the read handler
1695         global server
1696         close $server
1697         fileevent $file readable [list getdata $file]
1698         fconfigure $file -buffering line -blocking 0
1699         set ::f $file
1700     }
1701     proc getdata { file } {
1702         # Read handler on the accepted socket.
1703         global x
1704         set status [catch {read $file} data]
1705         if {$status != 0} {
1706             set x "read failed, error was $data"
1707         } elseif {$data ne ""} {
1708         } elseif {[fblocked $file]} {
1709         } elseif {[eof $file]} {
1710             set x "client socket was not inherited"
1711         } else {
1712             set x "impossible case"
1713         }
1714     }
1715     # Launch the script2 process
1716     ### exec [interpreter] script2 &
1717     set p [open "|[list [interpreter] $path(script2)]" w]
1718     puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p
1719     vwait x
1720     return $x
1721 } -cleanup {
1722     fconfigure $f -blocking 1
1723     close $f
1724     after cancel $after
1725     close $p
1726 } -result {client socket was not inherited}
1727 test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
1728     file delete $path(script1)
1729     file delete $path(script2)
1730     set f [open $path(script1) w]
1731     puts $f {
1732         fileevent stdin readable exit
1733         after 10000 exit
1734         vwait forever
1735     }
1736     close $f
1737     set f [open $path(script2) w]
1738     puts $f [list set tcltest [interpreter]]
1739     puts $f [list set delay $path(script1)]
1740     puts $f [list set localhost $localhost]
1741     puts $f {
1742         set server [socket -server accept -myaddr $localhost 0]
1743         proc accept { file host port } {
1744             global tcltest delay
1745             puts $file {test data on socket}
1746             exec $tcltest $delay &
1747             after idle exit
1748         }
1749         puts stdout [lindex [fconfigure $server -sockname] 2]
1750         vwait forever
1751     }
1752     close $f
1753 } -constraints [list socket supported_$af stdio exec] -body {
1754     # Launch the script2 process and connect to it. See how long the socket
1755     # stays open
1756     ## exec [interpreter] script2 &
1757     set p [open "|[list [interpreter] $path(script2)]" r]
1758     gets $p listen
1759     set f [socket $localhost $listen]
1760     fconfigure $f -buffering full -blocking 0
1761     fileevent $f readable [list getdata $f]
1762     # If the socket is still open after 5 seconds, the script1 process must
1763     # have inherited the accepted socket.
1764     set failed 0
1765     set after [after 5000 [list set x "accepted socket was inherited"]]
1766     proc getdata { file } {
1767         # Read handler on the client socket.
1768         global x
1769         global failed
1770         set status [catch {read $file} data]
1771         if {$status != 0} {
1772             set x "read failed, error was $data"
1773         } elseif {[string compare {} $data]} {
1774         } elseif {[fblocked $file]} {
1775         } elseif {[eof $file]} {
1776             set x "accepted socket was not inherited"
1777         } else {
1778             set x "impossible case"
1779         }
1780         return
1781     }
1782     vwait x
1783     set x
1784 } -cleanup {
1785     fconfigure $f -blocking 1
1786     close $f
1787     after cancel $after
1788     close $p
1789 } -result {accepted socket was not inherited}
1790
1791 test socket_$af-13.1 {Testing use of shared socket between two threads} -body {
1792     # create a thread
1793     set serverthread [thread::create -preserved [string map [list @localhost@ $localhost] {
1794         set f [socket -server accept -myaddr @localhost@ 0]
1795         set listen [lindex [fconfigure $f -sockname] 2]
1796         proc accept {s a p} {
1797             fileevent $s readable [list echo $s]
1798             fconfigure $s -buffering line
1799         }
1800         proc echo {s} {
1801              global i
1802              set l [gets $s]
1803              if {[eof $s]} {
1804                  global x
1805                  close $s
1806                  set x done
1807              } else {
1808                  incr i
1809                  puts $s $l
1810              }
1811         }
1812         set i 0
1813         vwait x
1814         close $f
1815     }]]
1816     set port [thread::send $serverthread {set listen}]
1817     set s [socket $localhost $port]
1818     fconfigure $s -buffering line
1819     catch {
1820         puts $s "hello"
1821         gets $s result
1822     }
1823     close $s
1824     thread::release $serverthread
1825     append result " " [llength [thread::names]]
1826 } -result {hello 1} -constraints [list socket supported_$af thread]
1827
1828 proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} {
1829   try {
1830     set ::count 0
1831     set ::testmode $testmode
1832     set port 0
1833     set srvsock {}
1834     # if binding on port 0 is not possible (system related, blocked on ISPs etc):
1835     if {[catch {close [socket -async $::localhost $port]}]} {
1836       # simplest server on random port (immediatelly closing a connect):
1837       set port [randport]
1838       set srvsock [socket -server {apply {{ch args} {close $ch}}} -myaddr $::localhost $port]
1839       # socket on windows has some issues yet (e. g. bug [b6d0d8cc2c]), so we simply decrease iteration count (to 1/4):
1840       if {$::tcl_platform(platform) eq "windows" && $maxIter > 50} {
1841         set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations
1842       }
1843     }
1844     tcltest::DebugPuts 2 "== test \[$::localhost\]:$port $testmode =="
1845     set ::parent [thread::id]
1846     # helper thread creating async connection and initiating transfer (detach) to parent:
1847     set ::helper [thread::create]
1848     thread::send -async $::helper [list \
1849       lassign [list $::parent $::localhost $port $testmode] \
1850                      ::parent ::localhost ::port ::testmode
1851     ]
1852     thread::send -async $::helper {
1853       set ::helper [thread::id]
1854       proc iteration {args} {
1855         set fd [socket -async $::localhost $::port]
1856         if {"helper-writable" in $::testmode} {;# to test both sides during connect
1857           fileevent $fd writable [list apply {{fd} {
1858             if {[thread::id] ne $::helper} {
1859               thread::send -async $::parent {set ::count "ERROR: invalid thread, $::helper is expecting"}
1860               close $fd
1861               return
1862             }
1863           }} $fd]
1864         };#
1865         thread::detach $fd
1866         thread::send -async $::parent [list transf_parent $fd {*}$args]
1867       }
1868       iteration first
1869     }
1870     # parent proc commiting transfer attempt (attach) and checking acquire was successful:
1871     proc transf_parent {fd args} {
1872       tcltest::DebugPuts 2 "** trma / $::count ** $args **"
1873       thread::attach $fd
1874       if {"parent-close" in $::testmode} {;# to test close during connect
1875         set ::count $::count
1876         close $fd
1877         return
1878       };#
1879       fileevent $fd writable [list apply {{fd} {
1880         if {[thread::id] ne $::parent} {
1881           thread::send -async $::parent {set ::count "ERROR: invalid thread, $::parent is expecting"}
1882           close $fd
1883           return
1884         }
1885         set ::count $::count
1886         close $fd
1887       }} $fd]
1888     }
1889     # repeat maxIter times (up to maxTime ms as timeout):
1890     set tout [after $maxTime {set ::count "TIMEOUT"}]
1891     while 1 {
1892       vwait ::count
1893       if {![string is integer $::count]} {
1894         # if timeout just skip (test was successful until now):
1895         if {$::count eq "TIMEOUT"} {::tcltest::Skip "timing issue"}
1896         break
1897       }
1898       if {[incr ::count] >= $maxIter} break
1899       tcltest::DebugPuts 2 "** iter / $::count **"
1900       thread::send -async $::helper [list iteration nr $::count]
1901     }
1902     update
1903     set ::count
1904   } finally {
1905     catch {after cancel $tout}
1906     if {$srvsock ne {}} {close $srvsock}
1907     if {[info exists ::helper]} {thread::release -wait $::helper}
1908     tcltest::DebugPuts 2 "== stop / $::count =="
1909     unset -nocomplain ::count ::testmode ::parent ::helper
1910   }
1911 }
1912 test socket_$af-13.2.tr1 {Testing socket transfer between threads during async connect} -body {
1913     transf_test {transfer} 1000
1914 } -result 1000 -constraints [list socket supported_$af thread]
1915 test socket_$af-13.2.tr2 {Testing socket transfer between threads during async connect} -body {
1916     transf_test {transfer helper-writable} 100
1917 } -result 100 -constraints [list socket supported_$af thread]
1918 test socket_$af-13.2.cl1 {Testing socket transfer between threads during async connect} -body {
1919     transf_test {parent-close} 100
1920 } -result 100 -constraints [list socket supported_$af thread]
1921 test socket_$af-13.2.cl2 {Testing socket transfer between threads during async connect} -body {
1922     transf_test {parent-close helper-writable} 100
1923 } -result 100 -constraints [list socket supported_$af thread]
1924 catch {rename transf_parent {}}
1925 rename transf_test {}
1926 \f
1927 # ----------------------------------------------------------------------
1928
1929 removeFile script1
1930 removeFile script2
1931
1932 # cleanup
1933 if {$remoteProcChan ne ""} {
1934     catch {sendCommand exit}
1935 }
1936 catch {close $commandSocket}
1937 catch {close $remoteProcChan}
1938 }
1939 unset ::tcl::unsupported::socketAF
1940 test socket-14.0.0 {[socket -async] when server only listens on IPv4} -setup {
1941     proc accept {s a p} {
1942         global x
1943         puts $s bye
1944         close $s
1945         set x ok
1946     }
1947     set server [socket -server accept -myaddr 127.0.0.1 0]
1948     set port [lindex [fconfigure $server -sockname] 2]
1949 } -constraints {socket supported_inet localhost_v4} -body {
1950     set client [socket -async localhost $port]
1951     set after [after $latency {set x [fconfigure $client -error]}]
1952     vwait x
1953     set x
1954 } -cleanup {
1955     catch {after cancel $after}
1956     catch {close $server}
1957     catch {close $client}
1958     unset -nocomplain x
1959 } -result ok
1960 test socket-14.0.1 {[socket -async] when server only listens on IPv6} -setup {
1961     proc accept {s a p} {
1962         global x
1963         puts $s bye
1964         close $s
1965         set x ok
1966     }
1967     set server [socket -server accept -myaddr ::1 0]
1968     set port [lindex [fconfigure $server -sockname] 2]
1969 } -constraints {socket supported_inet6 localhost_v6} -body {
1970     set client [socket -async localhost $port]
1971     set after [after $latency {set x [fconfigure $client -error]}]
1972     vwait x
1973     set x
1974 } -cleanup {
1975     catch {after cancel $after}
1976     catch {close $server}
1977     catch {close $client}
1978     unset -nocomplain x
1979 } -result ok
1980 test socket-14.1 {[socket -async] fileevent while still connecting} -setup {
1981     proc accept {s a p} {
1982         global x
1983         puts $s bye
1984         close $s
1985         lappend x ok
1986     }
1987     set server [socket -server accept -myaddr localhost 0]
1988     set port [lindex [fconfigure $server -sockname] 2]
1989     set x ""
1990 } -constraints socket -body {
1991     set client [socket -async localhost $port]
1992     fileevent $client writable {
1993         lappend x [fconfigure $client -error]
1994         fileevent $client writable {}
1995     }
1996     set after [after $latency {lappend x timeout}]
1997     while {[llength $x] < 2 && "timeout" ni $x} {
1998         vwait x
1999     }
2000     lsort $x; # we only want to see both events, the order doesn't matter
2001 } -cleanup {
2002     catch {after cancel $after}
2003     catch {close $server}
2004     catch {close $client}
2005     unset -nocomplain x
2006 } -result {{} ok}
2007 test socket-14.2 {[socket -async] fileevent connection refused} -setup {
2008     set after [after $latency set x timeout]
2009 } -body {
2010     set client [socket -async localhost [randport]]
2011     fileevent $client writable {set x ok}
2012     vwait x
2013     lappend x [fconfigure $client -error]
2014 } -constraints socket -cleanup {
2015     catch {after cancel $after}
2016     catch {close $client}
2017     unset -nocomplain x after client
2018 } -result {ok {connection refused}}
2019 test socket-14.3 {[socket -async] when server only listens on IPv6} -setup {
2020     proc accept {s a p} {
2021         global x
2022         puts $s bye
2023         close $s
2024         set x ok
2025     }
2026     set server [socket -server accept -myaddr ::1 0]
2027     set port [lindex [fconfigure $server -sockname] 2]
2028 } -constraints {socket supported_inet6 localhost_v6} -body {
2029     set client [socket -async localhost $port]
2030     set after [after $latency {set x [fconfigure $client -error]}]
2031     vwait x
2032     set x
2033 } -cleanup {
2034     catch {after cancel $after}
2035     catch {close $server}
2036     catch {close $client}
2037     unset -nocomplain x
2038 } -result ok
2039 test socket-14.4 {[socket -async] and both, readdable and writable fileevents} -setup {
2040     proc accept {s a p} {
2041         puts $s bye
2042         close $s
2043     }
2044     set server [socket -server accept -myaddr localhost 0]
2045     set port [lindex [fconfigure $server -sockname] 2]
2046     set x ""
2047 } -constraints socket -body {
2048     set client [socket -async localhost $port]
2049     fileevent $client writable {
2050         lappend x [fconfigure $client -error]
2051         fileevent $client writable {}
2052     }
2053     fileevent $client readable {lappend x [gets $client]}
2054     set after [after $latency {lappend x timeout}]
2055     while {[llength $x] < 2 && "timeout" ni $x} {
2056         vwait x
2057     }
2058     lsort $x
2059 } -cleanup {
2060     catch {after cancel $after}
2061     catch {close $client}
2062     catch {close $server}
2063     unset -nocomplain x
2064 } -result {{} bye}
2065 # FIXME: we should also have an IPv6 counterpart of this
2066 test socket-14.5 {[socket -async] which fails before any connect() can be made} -body {
2067     # address from rfc5737
2068     socket -async -myaddr 192.0.2.42 127.0.0.1 [randport]
2069 } -constraints {socket supported_inet notOSX} -returnCodes 1 \
2070     -result {couldn't open socket: cannot assign requested address}
2071 test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} -setup {
2072     proc accept {s a p} {
2073         global x
2074         puts $s bye
2075         close $s
2076         set x ok
2077     }
2078     set server [socket -server accept -myaddr 127.0.0.1 0]
2079     set port [lindex [fconfigure $server -sockname] 2]
2080     set x ""
2081 } -constraints {socket supported_inet localhost_v4} -body {
2082     set client [socket -async localhost $port]
2083     for {set i 0} {$i < 50} {incr i } {
2084         update
2085         if {$x ne ""} {
2086             lappend x [gets $client]
2087             break
2088         }
2089         after 100
2090     }
2091     set x
2092 } -cleanup {
2093     catch {close $server}
2094     catch {close $client}
2095     unset -nocomplain x
2096 } -result {ok bye}
2097 test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} -setup {
2098     proc accept {s a p} {
2099         global x
2100         puts $s bye
2101         close $s
2102         set x ok
2103     }
2104     set server [socket -server accept -myaddr ::1 0]
2105     set port [lindex [fconfigure $server -sockname] 2]
2106     set x ""
2107 } -constraints {socket supported_inet6 localhost_v6} -body {
2108     set client [socket -async localhost $port]
2109     for {set i 0} {$i < 50} {incr i } {
2110         update
2111         if {$x ne ""} {
2112             lappend x [gets $client]
2113             break
2114         }
2115         after 100
2116     }
2117     set x
2118 } -cleanup {
2119     catch {close $server}
2120     catch {close $client}
2121     unset -nocomplain x
2122 } -result {ok bye}
2123 test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} -setup {
2124     makeFile {
2125         fileevent stdin readable exit
2126         set server [socket -server accept -myaddr 127.0.0.1 0]
2127         proc accept {s h p} {puts $s ok; close $s; set ::x 1}
2128         puts [lindex [fconfigure $server -sockname] 2]
2129         flush stdout
2130         vwait x
2131     } script
2132     set fd [open |[list [interpreter] script] RDWR]
2133     set port [gets $fd]
2134 } -constraints {socket supported_inet localhost_v4 notOSX} -body {
2135     set sock [socket -async localhost $port]
2136     list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
2137 } -cleanup {
2138     catch {close $fd}
2139     catch {close $sock}
2140     removeFile script
2141 } -result {{} ok {}}
2142 test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} -setup {
2143     makeFile {
2144         fileevent stdin readable exit
2145         set server [socket -server accept -myaddr ::1 0]
2146         proc accept {s h p} {puts $s ok; close $s; set ::x 1}
2147         puts [lindex [fconfigure $server -sockname] 2]
2148         flush stdout
2149         vwait x
2150     } script
2151     set fd [open |[list [interpreter] script] RDWR]
2152     set port [gets $fd]
2153 } -constraints {socket supported_inet6 localhost_v6 notOSX} -body {
2154     set sock [socket -async localhost $port]
2155     list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
2156 } -cleanup {
2157     catch {close $fd}
2158     catch {close $sock}
2159     removeFile script
2160 } -result {{} ok {}}
2161 test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} -setup {
2162     set sock [socket -server error 0]
2163     set unusedPort [lindex [fconfigure $sock -sockname] 2]
2164     close $sock
2165 } -body {
2166     set sock [socket -async localhost $unusedPort]
2167     catch {gets $sock} x
2168     list $x [fconfigure $sock -error] [fconfigure $sock -error]
2169 } -constraints {socket notOSX} -cleanup {
2170     catch {close $sock}
2171 } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}}
2172 test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} -setup {
2173     makeFile {
2174         fileevent stdin readable exit
2175         set server [socket -server accept -myaddr 127.0.0.1 0]
2176         proc accept {s h p} {puts $s ok; close $s; set ::x 1}
2177         puts [lindex [fconfigure $server -sockname] 2]
2178         flush stdout
2179         vwait x
2180     } script
2181     set fd [open |[list [interpreter] script] RDWR]
2182     set port [gets $fd]
2183 } -constraints {socket supported_inet localhost_v4} -body {
2184     set sock [socket -async localhost $port]
2185     fconfigure $sock -blocking 0
2186     for {set i 0} {$i < 50} {incr i } {
2187         if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
2188         after 200
2189     }
2190     set x
2191 } -cleanup {
2192     catch {close $fd}
2193     catch {close $sock}
2194     removeFile script
2195 } -result {ok}
2196 test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} -setup {
2197     makeFile {
2198         fileevent stdin readable exit
2199         set server [socket -server accept -myaddr ::1 0]
2200         proc accept {s h p} {puts $s ok; close $s; set ::x 1}
2201         puts [lindex [fconfigure $server -sockname] 2]
2202         flush stdout
2203         vwait x
2204     } script
2205     set fd [open |[list [interpreter] script] RDWR]
2206     set port [gets $fd]
2207 } -constraints {socket supported_inet6 localhost_v6} -body {
2208     set sock [socket -async localhost $port]
2209     fconfigure $sock -blocking 0
2210     for {set i 0} {$i < 50} {incr i } {
2211         if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
2212         after 200
2213     }
2214     set x
2215 } -cleanup {
2216     catch {close $fd}
2217     catch {close $sock}
2218     removeFile script
2219 } -result {ok}
2220 test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} -body {
2221     set sock [socket -async localhost [randport]]
2222     fconfigure $sock -blocking 0
2223     for {set i 0} {$i < 50} {incr i } {
2224         if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
2225         after 200
2226     }
2227     list $x [fconfigure $sock -error] [fconfigure $sock -error]
2228 } -constraints socket -cleanup {
2229     catch {close $sock}
2230 } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}}
2231 test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} -setup {
2232     makeFile {
2233         fileevent stdin readable exit
2234         after 10000 exit
2235         set server [socket -server accept -myaddr 127.0.0.1 0]
2236         proc accept {s h p} {set ::x $s}
2237         puts [lindex [fconfigure $server -sockname] 2]
2238         flush stdout
2239         vwait x
2240         puts [gets $x]
2241     } script
2242     set fd [open |[list [interpreter] script] RDWR]
2243     set port [gets $fd]
2244 } -constraints {socket supported_inet localhost_v4 notOSX} -body {
2245     set sock [socket -async localhost $port]
2246     puts $sock ok
2247     flush $sock
2248     list [fconfigure $sock -error] [gets $fd]
2249 } -cleanup {
2250     catch {close $fd}
2251     catch {close $sock}
2252     removeFile script
2253 } -result {{} ok}
2254 test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} -setup {
2255     makeFile {
2256         fileevent stdin readable exit
2257         after 10000 exit
2258         set server [socket -server accept -myaddr ::1 0]
2259         proc accept {s h p} {set ::x $s}
2260         puts [lindex [fconfigure $server -sockname] 2]
2261         flush stdout
2262         vwait x
2263         puts [gets $x]
2264     } script
2265     set fd [open |[list [interpreter] script] RDWR]
2266     set port [gets $fd]
2267 } -constraints {socket supported_inet6 localhost_v6 notOSX} -body {
2268     set sock [socket -async localhost $port]
2269     puts $sock ok
2270     flush $sock
2271     list [fconfigure $sock -error] [gets $fd]
2272 } -cleanup {
2273     catch {close $fd}
2274     catch {close $sock}
2275     removeFile script
2276 } -result {{} ok}
2277 test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} -setup {
2278     makeFile {
2279         fileevent stdin readable exit
2280         set server [socket -server accept -myaddr 127.0.0.1 0]
2281         proc accept {s h p} {set ::x $s}
2282         puts [lindex [fconfigure $server -sockname] 2]
2283         flush stdout
2284         vwait x
2285         puts [gets $x]
2286     } script
2287     set fd [open |[list [interpreter] script] RDWR]
2288     set port [gets $fd]
2289     set after [after $latency set x timeout]
2290 } -constraints {socket supported_inet localhost_v4} -body {
2291     set sock [socket -async localhost $port]
2292     fconfigure $sock -blocking 0
2293     puts $sock ok
2294     flush $sock
2295     fileevent $fd readable {set x 1}
2296     vwait x
2297     list [fconfigure $sock -error] [gets $fd]
2298 } -cleanup {
2299     after cancel $after
2300     catch {close $fd}
2301     catch {close $sock}
2302     removeFile script
2303 } -result {{} ok}
2304 test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} -setup {
2305     makeFile {
2306         fileevent stdin readable exit
2307         set server [socket -server accept -myaddr ::1 0]
2308         proc accept {s h p} {set ::x $s}
2309         puts [lindex [fconfigure $server -sockname] 2]
2310         flush stdout
2311         vwait x
2312         puts [gets $x]
2313     } script
2314     set fd [open |[list [interpreter] script] RDWR]
2315     set port [gets $fd]
2316     set after [after $latency set x timeout]
2317 } -constraints {socket supported_inet6 localhost_v6} -body {
2318     set sock [socket -async localhost $port]
2319     fconfigure $sock -blocking 0
2320     puts $sock ok
2321     flush $sock
2322     fileevent $fd readable {set x 1}
2323     vwait x
2324     list [fconfigure $sock -error] [gets $fd]
2325 } -cleanup {
2326     after cancel $after
2327     catch {close $fd}
2328     catch {close $sock}
2329     removeFile script
2330 } -result {{} ok}
2331 test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} -setup {
2332     set after [after $latency set x timeout]
2333 } -body {
2334     set sock [socket -async localhost [randport]]
2335     fconfigure $sock -blocking 0
2336     puts $sock ok
2337     fileevent $sock writable {set x 1}
2338     vwait x
2339     close $sock
2340 } -constraints socket -cleanup {
2341     after cancel $after
2342     catch {close $sock}
2343     unset -nocomplain x
2344 } -result {socket is not connected} -returnCodes 1
2345 test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} -setup {
2346     set after [after $latency set x timeout]
2347 } -body {
2348     set sock [socket -async localhost [randport]]
2349     fconfigure $sock -blocking 0
2350     puts $sock ok
2351     flush $sock
2352     fileevent $sock writable {set x 1}
2353     vwait x
2354     close $sock
2355 } -constraints {socket nonPortable} -cleanup {
2356     after cancel $timeout
2357     catch {close $sock}
2358     unset -nocomplain x
2359 } -result {socket is not connected} -returnCodes 1
2360 test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} -body {
2361     set s [socket -async localhost [randport]]
2362     for {set i 0} {$i < 50} {incr i} {
2363         set x [fconfigure $s -error]
2364         if {$x != ""} break
2365         after 200
2366     }
2367     set x
2368 } -constraints socket -cleanup {
2369     catch {close $s}
2370     unset -nocomplain x s
2371 } -result {connection refused}
2372 test socket-14.13 {testing writable event when quick failure} -body {
2373     # Test for bug 336441ed59 where a quick background fail was ignored
2374     #
2375     # Test only for windows as socket -async 255.255.255.255 fails
2376     # directly on unix
2377     #
2378     # The following connect should fail very quickly
2379     set a1 [after $latency {set x timeout}]
2380     set s [socket -async 255.255.255.255 43434]
2381     fileevent $s writable {set x writable}
2382     vwait x
2383     set x
2384 } -constraints {socket win supported_inet} -cleanup {
2385     catch {close $s}
2386     after cancel $a1
2387 } -result writable
2388 test socket-14.14 {testing fileevent readable on failed async socket connect} -body {
2389     # Test for bug 581937ab1e
2390     set a1 [after $latency {set x timeout}]
2391     # This connect should fail
2392     set s [socket -async localhost [randport]]
2393     fileevent $s readable {set x readable}
2394     vwait x
2395     set x
2396 } -constraints socket -cleanup {
2397     catch {close $s}
2398     after cancel $a1
2399 } -result readable
2400 test socket-14.15 {blocking read on async socket should not trigger event handlers} -setup {
2401     set subprocess [open "|[list [interpreter]]" r+]
2402     fconfigure $subprocess -blocking 0 -buffering none
2403 } -constraints socket -body {
2404     puts $subprocess {
2405         set s [socket -async localhost [randport]]
2406         set x ok
2407         fileevent $s writable {set x fail}
2408         catch {read $s}
2409         close $s
2410         puts $x
2411         exit
2412     }
2413     set after [after $latency set x timeout]
2414     fileevent $subprocess readable [list gets $subprocess x]
2415     vwait x
2416     return $x
2417 } -cleanup {
2418     catch {after cancel $after}
2419     if {![testConstraint win]} {
2420         catch {exec kill [pid $subprocess]}
2421     }
2422     catch {close $subprocess}
2423     unset -nocomplain x
2424 } -result ok
2425 # v4 and v6 is required to prevent that the async connect does not terminate
2426 # before the fconfigure command. There is always an additional ip to try.
2427 test socket-14.16 {empty -peername while [socket -async] connecting} -body {
2428     set client [socket -async localhost [randport]]
2429     fconfigure $client -peername
2430 } -constraints {socket localhost_v4 localhost_v6 notOSX} -cleanup {
2431     catch {close $client}
2432 } -result {}
2433 # v4 and v6 is required to prevent that the async connect does not terminate
2434 # before the fconfigure command. There is always an additional ip to try.
2435 test socket-14.17 {empty -sockname while [socket -async] connecting} -body {
2436     set client [socket -async localhost [randport]]
2437     fconfigure $client -sockname
2438 } -constraints {socket localhost_v4 localhost_v6 notOSX} -cleanup {
2439     catch {close $client}
2440 } -result {}
2441 # test for bug c6ed4acfd8: running async socket connect with other connect
2442 # established will block tcl as it goes in an infinite loop in vwait
2443 test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} -body {
2444     proc accept {channel address port} {}
2445     set port [randport]
2446     set ssock [socket -server accept $port]
2447     set csock1 [socket -async localhost [randport]]
2448     set csock2 [socket localhost $port]
2449     after 1000 {set done ok}
2450     vwait done
2451 } -constraints {socket notOSX} -cleanup {
2452     catch {close $ssock}
2453     catch {close $csock1}
2454     catch {close $csock2}
2455 } -result {}
2456
2457 set num 0
2458
2459 set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}}
2460 set resultok {-result "sock*" -match glob}
2461 set resulterr {
2462     -result {couldn't open socket: connection refused}
2463     -returnCodes 1
2464 }
2465 foreach {servip sc} $x {
2466     foreach {cliip cc} $x {
2467         set constraints [list socket $sc $cc]
2468         set result $resulterr
2469         switch -- [lsort -unique [list $servip $cliip]] {
2470             localhost - 127.0.0.1 - ::1 {
2471                 set result $resultok
2472             }
2473             {127.0.0.1 localhost} {
2474                 if {[testConstraint localhost_v4]} {
2475                     set result $resultok
2476                 }
2477             }
2478             {::1 localhost} {
2479                 if {[testConstraint localhost_v6]} {
2480                     set result $resultok
2481                 }
2482             }
2483         }
2484         test socket-15.1.$num "Connect to $servip from $cliip" -setup {
2485             set server [socket -server accept -myaddr $servip 0]
2486             proc accept {s h p} { close $s }
2487             set port [lindex [fconfigure $server -sockname] 2]
2488         } -constraints $constraints -body {
2489             set s [socket $cliip $port]
2490         } -cleanup {
2491             close $server
2492             catch {close $s}
2493         } {*}$result
2494         incr num
2495     }
2496 }
2497
2498 ::tcltest::cleanupTests
2499 flush stdout
2500 return
2501
2502 # Local Variables:
2503 # mode: tcl
2504 # fill-column: 78
2505 # End: