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