PageRenderTime 5ms CodeModel.GetById 111ms app.highlight 94ms RepoModel.GetById 2ms app.codeStats 0ms

/jni/tcl8.6a3/tests/socket.test

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