PageRenderTime 142ms CodeModel.GetById 16ms app.highlight 115ms RepoModel.GetById 1ms app.codeStats 0ms

/tcl/tests/socket.test

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