PageRenderTime 59ms CodeModel.GetById 27ms app.highlight 22ms RepoModel.GetById 1ms app.codeStats 0ms

/Src/gnu/tcl/tests/socket.test

https://bitbucket.org/staceyoi/bb101repo
Unknown | 1381 lines | 1348 code | 33 blank | 0 comment | 0 complexity | 6e7772a8a143a5045d3a625bafdb3538 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#
   9# See the file "license.terms" for information on usage and redistribution
  10# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11#
  12# Running socket tests with a remote server:
  13# ------------------------------------------
  14# 
  15# Some tests in socket.test depend on the existence of a remote server to
  16# which they connect. The remote server must be an instance of tcltest and it
  17# must run the script found in the file "remote.tcl" in this directory. You
  18# can start the remote server on any machine reachable from the machine on
  19# which you want to run the socket tests, by issuing:
  20# 
  21#     tcltest remote.tcl -port 2048	# Or choose another port number.
  22# 
  23# If the machine you are running the remote server on has several IP
  24# interfaces, you can choose which interface the server listens on for
  25# connections by specifying the -address command line flag, so:
  26# 
  27#     tcltest remote.tcl -address your.machine.com
  28# 
  29# These options can also be set by environment variables. On Unix, you can
  30# type these commands to the shell from which the remote server is started:
  31# 
  32#     shell% setenv serverPort 2048
  33#     shell% setenv serverAddress your.machine.com
  34# 
  35# and subsequently you can start the remote server with:
  36# 
  37#     tcltest remote.tcl
  38# 
  39# to have it listen on port 2048 on the interface your.machine.com.
  40#     
  41# When the server starts, it prints out a detailed message containing its
  42# configuration information, and it will block until killed with a Ctrl-C.
  43# Once the remote server exists, you can run the tests in socket.test with
  44# the server by setting two Tcl variables:
  45# 
  46#     % set remoteServerIP <name or address of machine on which server runs>
  47#     % set remoteServerPort 2048
  48# 
  49# These variables are also settable from the environment. On Unix, you can:
  50# 
  51#     shell% setenv remoteServerIP machine.where.server.runs
  52#     shell% senetv remoteServerPort 2048
  53# 
  54# The preamble of the socket.test file checks to see if the variables are set
  55# either in Tcl or in the environment; if they are, it attempts to connect to
  56# the server. If the connection is successful, the tests using the remote
  57# server will be performed; otherwise, it will attempt to start the remote
  58# server (via exec) on platforms that support this, on the local host,
  59# listening at port 2048. If all fails, a message is printed and the tests
  60# using the remote server are not performed.
  61#
  62# RCS: @(#) $Id: socket.test,v 1.12 1999/01/26 03:53:34 jingham Exp $
  63
  64if {[string compare test [info procs test]] == 1} then {source defs}
  65
  66if {$testConfig(socket) == 0} {
  67    return
  68}
  69
  70#
  71# If remoteServerIP or remoteServerPort are not set, check in the
  72# environment variables for externally set values.
  73#
  74
  75if {![info exists remoteServerIP]} {
  76    if {[info exists env(remoteServerIP)]} {
  77	set remoteServerIP $env(remoteServerIP)
  78    }
  79}
  80if {![info exists remoteServerPort]} {
  81    if {[info exists env(remoteServerIP)]} {
  82	set remoteServerPort $env(remoteServerPort)
  83    } else {
  84        if {[info exists remoteServerIP]} {
  85	    set remoteServerPort 2048
  86        }
  87    }
  88}
  89
  90#
  91# Check if we're supposed to do tests against the remote server
  92#
  93
  94set doTestsWithRemoteServer 1
  95if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} {
  96    set remoteServerIP localhost
  97}
  98if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
  99    set remoteServerPort 2048
 100}
 101
 102# Attempt to connect to a remote server if one is already running. If it
 103# is not running or for some other reason the connect fails, attempt to
 104# start the remote server on the local host listening on port 2048. This
 105# is only done on platforms that support exec (i.e. not on the Mac). On
 106# platforms that do not support exec, the remote server must be started
 107# by the user before running the tests.
 108
 109set remoteProcChan ""
 110set commandSocket ""
 111if {$doTestsWithRemoteServer} {
 112    catch {close $commandSocket}
 113    if {[catch {set commandSocket [socket $remoteServerIP \
 114						$remoteServerPort]}] != 0} {
 115	if {[info commands exec] == ""} {
 116	    set noRemoteTestReason "can't exec"
 117	    set doTestsWithRemoteServer 0
 118	} elseif {$testConfig(win32s)} {
 119	    set noRemoteTestReason "\ncan't run multiple instances of tcltest under win32s."
 120	    set doTestsWithRemoteServer 0
 121	} else {
 122	    set remoteServerIP localhost
 123	    if {[catch {set remoteProcChan \
 124				[open "|[list $tcltest remote.tcl \
 125					-serverIsSilent \
 126					-port $remoteServerPort \
 127					-address $remoteServerIP]" \
 128					w+]} \
 129		   msg] == 0} {
 130		after 1000
 131		if {[catch {set commandSocket [socket $remoteServerIP \
 132				$remoteServerPort]} msg] == 0} {
 133		    fconfigure $commandSocket -translation crlf -buffering line
 134		} else {
 135		    set noRemoteTestReason $msg
 136		    set doTestsWithRemoteServer 0
 137		}
 138	    } else {
 139		set noRemoteTestReason "$msg $tcltest"
 140		set doTestsWithRemoteServer 0
 141	    }
 142	}
 143    } else {
 144	fconfigure $commandSocket -translation crlf -buffering line
 145    }
 146}
 147
 148if {$doTestsWithRemoteServer == 0} {
 149    puts "Skipping tests with remote server. See tests/socket.test for"
 150    puts "information on how to run remote server."
 151    if {[info exists VERBOSE] && ($VERBOSE != 0)} {
 152	puts "Reason for not doing remote tests: $noRemoteTestReason"
 153    }
 154}
 155
 156#
 157# If we do the tests, define a command to send a command to the
 158# remote server.
 159#
 160
 161if {$doTestsWithRemoteServer == 1} {
 162    proc sendCommand {c} {
 163	global commandSocket
 164
 165	if {[eof $commandSocket]} {
 166	    error "remote server disappeared"
 167	}
 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
 195test socket-1.1 {arg parsing for socket command} {
 196    list [catch {socket -server} msg] $msg
 197} {1 {no argument given for -server option}}
 198test socket-1.2 {arg parsing for socket command} {
 199    list [catch {socket -server foo} msg] $msg
 200} {1 {wrong # args: should be either:
 201socket ?-myaddr addr? ?-myport myport? ?-async? host port
 202socket -server command ?-myaddr addr? port}}
 203test socket-1.3 {arg parsing for socket command} {
 204    list [catch {socket -myaddr} msg] $msg
 205} {1 {no argument given for -myaddr option}}
 206test socket-1.4 {arg parsing for socket command} {
 207    list [catch {socket -myaddr 127.0.0.1} msg] $msg
 208} {1 {wrong # args: should be either:
 209socket ?-myaddr addr? ?-myport myport? ?-async? host port
 210socket -server command ?-myaddr addr? port}}
 211test socket-1.5 {arg parsing for socket command} {
 212    list [catch {socket -myport} msg] $msg
 213} {1 {no argument given for -myport option}}
 214test socket-1.6 {arg parsing for socket command} {
 215    list [catch {socket -myport xxxx} msg] $msg
 216} {1 {expected integer but got "xxxx"}}
 217test socket-1.7 {arg parsing for socket command} {
 218    list [catch {socket -myport 2522} msg] $msg
 219} {1 {wrong # args: should be either:
 220socket ?-myaddr addr? ?-myport myport? ?-async? host port
 221socket -server command ?-myaddr addr? port}}
 222test socket-1.8 {arg parsing for socket command} {
 223    list [catch {socket -froboz} msg] $msg
 224} {1 {bad option "-froboz", must be -async, -myaddr, -myport, or -server}}
 225test socket-1.9 {arg parsing for socket command} {
 226    list [catch {socket -server foo -myport 2521 3333} msg] $msg
 227} {1 {Option -myport is not valid for servers}}
 228test socket-1.10 {arg parsing for socket command} {
 229    list [catch {socket host 2528 -junk} msg] $msg
 230} {1 {wrong # args: should be either:
 231socket ?-myaddr addr? ?-myport myport? ?-async? host port
 232socket -server command ?-myaddr addr? port}}
 233test socket-1.11 {arg parsing for socket command} {
 234    list [catch {socket -server callback 2520 --} msg] $msg
 235} {1 {wrong # args: should be either:
 236socket ?-myaddr addr? ?-myport myport? ?-async? host port
 237socket -server command ?-myaddr addr? port}}
 238test socket-1.12 {arg parsing for socket command} {
 239    list [catch {socket foo badport} msg] $msg
 240} {1 {expected integer but got "badport"}}
 241
 242test socket-2.1 {tcp connection} {stdio} {
 243    removeFile script
 244    set f [open script w]
 245    puts $f {
 246	set timer [after 2000 "set x timed_out"]
 247	set f [socket -server accept 2828]
 248	proc accept {file addr port} {
 249	    global x
 250	    set x done
 251            close $file
 252	}
 253	puts ready
 254	vwait x
 255	after cancel $timer
 256	close $f
 257	puts $x
 258    }
 259    close $f
 260    set f [open "|[list $tcltest script]" r]
 261    gets $f x
 262    if {[catch {socket localhost 2828} msg]} {
 263        set x $msg
 264    } else {
 265        lappend x [gets $f]
 266        close $msg
 267    }
 268    lappend x [gets $f]
 269    close $f
 270    set x
 271} {ready done {}}
 272
 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} {stdio} {
 279    removeFile script
 280    set f [open script w]
 281    puts $f {
 282	set timer [after 2000 "set x done"]
 283        set f [socket -server accept 2828]
 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	vwait x
 292	after cancel $timer
 293	close $f
 294    }
 295    close $f
 296    set f [open "|[list $tcltest script]" r]
 297    gets $f x
 298    global port
 299    if {[catch {socket -myport $port localhost 2828} sock]} {
 300        set x $sock
 301	close [socket localhost 2828]
 302	puts stderr $sock
 303    } else {
 304        puts $sock hello
 305	flush $sock
 306        lappend x [gets $f]
 307        close $sock
 308    }
 309    close $f
 310    set x
 311} [list ready "hello $port"]
 312test socket-2.3 {tcp connection with client interface specified} {stdio} {
 313    removeFile script
 314    set f [open script w]
 315    puts $f {
 316	set timer [after 2000 "set x done"]
 317        set f [socket  -server accept 2828]
 318	proc accept {file addr port} {
 319            global x
 320            puts "[gets $file] $addr"
 321            close $file
 322            set x done
 323	}
 324	puts ready
 325	vwait x
 326	after cancel $timer
 327	close $f
 328    }
 329    close $f
 330    set f [open "|[list $tcltest script]" r]
 331    gets $f x
 332    if {[catch {socket -myaddr localhost localhost 2828} sock]} {
 333        set x $sock
 334    } else {
 335        puts $sock hello
 336	flush $sock
 337        lappend x [gets $f]
 338        close $sock
 339    }
 340    close $f
 341    set x
 342} {ready {hello 127.0.0.1}}
 343test socket-2.4 {tcp connection with server interface specified} {stdio} {
 344    removeFile script
 345    set f [open script w]
 346    puts $f {
 347	set timer [after 2000 "set x done"]
 348        set f [socket -server accept -myaddr [info hostname] 2828]
 349	proc accept {file addr port} {
 350            global x
 351            puts "[gets $file]"
 352            close $file
 353            set x done
 354	}
 355	puts ready
 356	vwait x
 357	after cancel $timer
 358	close $f
 359    }
 360    close $f
 361    set f [open "|[list $tcltest script]" r]
 362    gets $f x
 363    if {[catch {socket [info hostname] 2828} sock]} {
 364        set x $sock
 365    } else {
 366        puts $sock hello
 367	flush $sock
 368        lappend x [gets $f]
 369        close $sock
 370    }
 371    close $f
 372    set x
 373} {ready hello}
 374test socket-2.5 {tcp connection with redundant server port} {stdio} {
 375    removeFile script
 376    set f [open script w]
 377    puts $f {
 378	set timer [after 2000 "set x done"]
 379        set f [socket -server accept 2828]
 380	proc accept {file addr port} {
 381            global x
 382            puts "[gets $file]"
 383            close $file
 384            set x done
 385	}
 386	puts ready
 387	vwait x
 388	after cancel $timer
 389	close $f
 390    }
 391    close $f
 392    set f [open "|[list $tcltest script]" r]
 393    gets $f x
 394    if {[catch {socket localhost 2828} sock]} {
 395        set x $sock
 396    } else {
 397        puts $sock hello
 398	flush $sock
 399        lappend x [gets $f]
 400        close $sock
 401    }
 402    close $f
 403    set x
 404} {ready hello}
 405test socket-2.6 {tcp connection} {} {
 406    set status ok
 407    if {![catch {set sock [socket localhost 2828]}]} {
 408	if {![catch {gets $sock}]} {
 409	    set status broken
 410	}
 411	close $sock
 412    }
 413    set status
 414} ok
 415test socket-2.7 {echo server, one line} {stdio} {
 416    removeFile script
 417    set f [open script w]
 418    puts $f {
 419	set timer [after 2000 "set x done"]
 420	set f [socket -server accept 2828]
 421	proc accept {s a p} {
 422            fileevent $s readable [list echo $s]
 423	    fconfigure $s -translation lf -buffering line
 424        }
 425	proc echo {s} {
 426	     set l [gets $s]
 427             if {[eof $s]} {
 428                 global x
 429                 close $s
 430                 set x done
 431             } else {
 432                 puts $s $l
 433             }
 434	}
 435	puts ready
 436	vwait x
 437	after cancel $timer
 438	close $f
 439	puts done
 440    }
 441    close $f
 442    set f [open "|[list $tcltest script]" r]
 443    gets $f
 444    set s [socket localhost 2828]
 445    fconfigure $s -buffering line -translation lf
 446    puts $s "hello abcdefghijklmnop"
 447    set x [gets $s]
 448    close $s
 449    set y [gets $f]
 450    close $f
 451    list $x $y
 452} {{hello abcdefghijklmnop} done}
 453test socket-2.8 {echo server, loop 50 times, single connection} {stdio} {
 454    removeFile script
 455    set f [open script w]
 456    puts $f {
 457	set f [socket -server accept 2828]
 458	proc accept {s a p} {
 459            fileevent $s readable [list echo $s]
 460            fconfigure $s -buffering line
 461        }
 462	proc echo {s} {
 463	     global i
 464             set l [gets $s]
 465             if {[eof $s]} {
 466                 global x
 467                 close $s
 468                 set x done
 469             } else { 
 470	         incr i
 471                 puts $s $l
 472             }
 473	}
 474	set i 0
 475	puts ready
 476	set timer [after 20000 "set x done"]
 477	vwait x
 478	after cancel $timer
 479	close $f
 480	puts "done $i"
 481    }
 482    close $f
 483    set f [open "|[list $tcltest script]" r]
 484    gets $f
 485    set s [socket localhost 2828]
 486    fconfigure $s -buffering line
 487    for {set x 0} {$x < 50} {incr x} {
 488        puts $s "hello abcdefghijklmnop"
 489        gets $s
 490    }
 491    close $s
 492    set x [gets $f]
 493    close $f
 494    set x
 495} {done 50}
 496test socket-2.9 {socket conflict} {stdio} {
 497    set s [socket -server accept 2828]
 498    removeFile script
 499    set f [open script w]
 500    puts $f {set f [socket -server accept 2828]}
 501    close $f
 502    set f [open "|[list $tcltest script]" r]
 503    gets $f
 504    after 100
 505    set x [list [catch {close $f} msg] $msg]
 506    close $s
 507    set x
 508} {1 {couldn't open socket: address already in use
 509    while executing
 510"socket -server accept 2828"
 511    (file "script" line 1)}}
 512test socket-2.10 {close on accept, accepted socket lives} {
 513    set done 0
 514    set timer [after 20000 "set done timed_out"]
 515    set ss [socket -server accept 2830]
 516    proc accept {s a p} {
 517	global ss
 518	close $ss
 519	fileevent $s readable "readit $s"
 520	fconfigure $s -trans lf
 521    }
 522    proc readit {s} {
 523	global done
 524	gets $s
 525	close $s
 526	set done 1
 527    }
 528    set cs [socket [info hostname] 2830]
 529    puts $cs hello
 530    close $cs
 531    vwait done
 532    after cancel $timer
 533    set done
 534} 1
 535test socket-2.11 {detecting new data} {
 536    proc accept {s a p} {
 537	global sock
 538	set sock $s
 539    }
 540
 541    set s [socket -server accept 2400]
 542    set sock ""
 543    set s2 [socket localhost 2400]
 544    vwait sock
 545    puts $s2 one
 546    flush $s2
 547    after 500
 548    fconfigure $sock -blocking 0
 549    set result [gets $sock]
 550    lappend result [gets $sock]
 551    fconfigure $sock -blocking 1
 552    puts $s2 two
 553    flush $s2
 554    fconfigure $sock -blocking 0
 555    lappend result [gets $sock]
 556    fconfigure $sock -blocking 1
 557    close $s2
 558    close $s
 559    close $sock
 560    set result
 561} {one {} two}
 562
 563
 564test socket-3.1 {socket conflict} {stdio} {
 565    removeFile script
 566    set f [open script w]
 567    puts $f {
 568	set f [socket -server accept 2828]
 569	puts ready
 570	gets stdin
 571	close $f
 572    }
 573    close $f
 574    set f [open "|[list $tcltest script]" r+]
 575    gets $f
 576    set x [list [catch {socket -server accept 2828} msg] \
 577		$msg]
 578    puts $f bye
 579    close $f
 580    set x
 581} {1 {couldn't open socket: address already in use}}
 582test socket-3.2 {server with several clients} {stdio} {
 583    removeFile script
 584    set f [open script w]
 585    puts $f {
 586	set t1 [after 30000 "set x timed_out"]
 587	set t2 [after 31000 "set x timed_out"]
 588	set t3 [after 32000 "set x timed_out"]
 589	set counter 0
 590	set s [socket -server accept 2828]
 591	proc accept {s a p} {
 592	    fileevent $s readable [list echo $s]
 593	    fconfigure $s -buffering line
 594	}
 595	proc echo {s} {
 596	     global x
 597             set l [gets $s]
 598             if {[eof $s]} {
 599                 close $s
 600                 set x done
 601             } else {
 602                 puts $s $l
 603             }
 604	}
 605	puts ready
 606	vwait x
 607	after cancel $t1
 608	vwait x
 609	after cancel $t2
 610	vwait x
 611	after cancel $t3
 612	close $s
 613	puts $x
 614    }
 615    close $f
 616    set f [open "|[list $tcltest script]" r+]
 617    set x [gets $f]
 618    set s1 [socket localhost 2828]
 619    fconfigure $s1 -buffering line
 620    set s2 [socket localhost 2828]
 621    fconfigure $s2 -buffering line
 622    set s3 [socket localhost 2828]
 623    fconfigure $s3 -buffering line
 624    for {set i 0} {$i < 100} {incr i} {
 625	puts $s1 hello,s1
 626	gets $s1
 627	puts $s2 hello,s2
 628	gets $s2
 629	puts $s3 hello,s3
 630	gets $s3
 631    }
 632    close $s1
 633    close $s2
 634    close $s3
 635    lappend x [gets $f]
 636    close $f
 637    set x
 638} {ready done}
 639
 640test socket-4.1 {server with several clients} {stdio} {
 641    removeFile script
 642    set f [open script w]
 643    puts $f {
 644	gets stdin
 645	set s [socket localhost 2828]
 646	fconfigure $s -buffering line
 647	for {set i 0} {$i < 100} {incr i} {
 648	    puts $s hello
 649	    gets $s
 650	}
 651	close $s
 652	puts bye
 653	gets stdin
 654    }
 655    close $f
 656    set p1 [open "|[list $tcltest script]" r+]
 657    fconfigure $p1 -buffering line
 658    set p2 [open "|[list $tcltest script]" r+]
 659    fconfigure $p2 -buffering line
 660    set p3 [open "|[list $tcltest script]" r+]
 661    fconfigure $p3 -buffering line
 662    proc accept {s a p} {
 663	fconfigure $s -buffering line
 664	fileevent $s readable [list echo $s]
 665    }
 666    proc echo {s} {
 667	global x
 668        set l [gets $s]
 669        if {[eof $s]} {
 670            close $s
 671            set x done
 672        } else {
 673            puts $s $l
 674        }
 675    }
 676    set t1 [after 30000 "set x timed_out"]
 677    set t2 [after 31000 "set x timed_out"]
 678    set t3 [after 32000 "set x timed_out"]
 679    set s [socket -server accept 2828]
 680    puts $p1 open
 681    puts $p2 open
 682    puts $p3 open
 683    vwait x
 684    vwait x
 685    vwait x
 686    after cancel $t1
 687    after cancel $t2
 688    after cancel $t3
 689    close $s
 690    set l ""
 691    lappend l [list p1 [gets $p1] $x]
 692    lappend l [list p2 [gets $p2] $x]
 693    lappend l [list p3 [gets $p3] $x]
 694    puts $p1 bye
 695    puts $p2 bye
 696    puts $p3 bye
 697    close $p1
 698    close $p2
 699    close $p3
 700    set l
 701} {{p1 bye done} {p2 bye done} {p3 bye done}}
 702test socket-4.2 {byte order problems, socket numbers, htons} {
 703    set x ok
 704    if {[catch {socket -server dodo 0x3000} msg]} {
 705	set x $msg
 706    } else {
 707	close $msg
 708    }
 709    set x
 710} ok
 711
 712test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} {
 713    #
 714    # THIS TEST WILL FAIL if you are running as superuser.
 715    #
 716    set x {couldn't open socket: not owner}
 717    if {![catch {socket -server dodo 0x1} msg]} {
 718        set x {htons problem, should be disallowed, are you running as SU?}
 719	close $msg
 720    }
 721    set x
 722} {couldn't open socket: not owner}
 723test socket-5.2 {byte order problems, socket numbers, htons} {
 724    set x {couldn't open socket: port number too high}
 725    if {![catch {socket -server dodo 0x10000} msg]} {
 726	set x {port resolution problem, should be disallowed}
 727	close $msg
 728    }
 729    set x
 730} {couldn't open socket: port number too high}
 731test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} {
 732    #
 733    # THIS TEST WILL FAIL if you are running as superuser.
 734    #
 735    set x {couldn't open socket: not owner}
 736    if {![catch {socket -server dodo 21} msg]} {
 737	set x {htons problem, should be disallowed, are you running as SU?}
 738	close $msg
 739    }
 740    set x
 741} {couldn't open socket: not owner}
 742
 743test socket-6.1 {accept callback error} {stdio} {
 744    removeFile script
 745    set f [open script w]
 746    puts $f {
 747	gets stdin
 748	socket localhost 2848
 749    }
 750    close $f
 751    set f [open "|[list $tcltest script]" r+]
 752    proc bgerror args {
 753	global x
 754	set x $args
 755    }
 756    proc accept {s a p} {expr 10 / 0}
 757    set s [socket -server accept 2848]
 758    puts $f hello
 759    close $f
 760    set timer [after 10000 "set x timed_out"]
 761    vwait x
 762    after cancel $timer
 763    close $s
 764    rename bgerror {}
 765    set x
 766} {{divide by zero}}
 767
 768test socket-7.1 {testing socket specific options} {stdio} {
 769    removeFile script
 770    set f [open script w]
 771    puts $f {
 772	socket -server accept 2820
 773	proc accept args {
 774	    global x
 775	    set x done
 776	}
 777	puts ready
 778	set timer [after 10000 "set x timed_out"]
 779	vwait x
 780	after cancel $timer
 781    }
 782    close $f
 783    set f [open "|[list $tcltest script]" r]
 784    gets $f
 785    set s [socket localhost 2820]
 786    set p [fconfigure $s -peername]
 787    close $s
 788    close $f
 789    set l ""
 790    lappend l [string compare [lindex $p 0] 127.0.0.1]
 791    lappend l [string compare [lindex $p 2] 2820]
 792    lappend l [llength $p]
 793} {0 0 3}
 794test socket-7.2 {testing socket specific options} {stdio} {
 795    removeFile script
 796    set f [open script w]
 797    puts $f {
 798	socket -server accept 2821
 799	proc accept args {
 800	    global x
 801	    set x done
 802	}
 803	puts ready
 804	set timer [after 10000 "set x timed_out"]
 805	vwait x
 806	after cancel $timer
 807    }
 808    close $f
 809    set f [open "|[list $tcltest script]" r]
 810    gets $f
 811    set s [socket localhost 2821]
 812    set p [fconfigure $s -sockname]
 813    close $s
 814    close $f
 815    set l ""
 816    lappend l [llength $p]
 817    lappend l [lindex $p 0]
 818    lappend l [expr [lindex $p 2] == 2821]
 819} {3 127.0.0.1 0}
 820test socket-7.3 {testing socket specific options} {
 821    set s [socket -server accept 2822]
 822    set l [fconfigure $s]
 823    close $s
 824    update
 825    llength $l
 826} 10
 827test socket-7.4 {testing socket specific options} {
 828    set s [socket -server accept 2823]
 829    proc accept {s a p} {
 830	global x
 831	set x [fconfigure $s -sockname]
 832	close $s
 833    }
 834    set s1 [socket [info hostname] 2823]
 835    set timer [after 10000 "set x timed_out"]
 836    vwait x
 837    after cancel $timer
 838    close $s
 839    close $s1
 840    set l ""
 841    lappend l [lindex $x 2] [llength $x]
 842} {2823 3}
 843test socket-7.5 {testing socket specific options} {unixOrPc} {
 844    set s [socket -server accept 2829]
 845    proc accept {s a p} {
 846	global x
 847	set x [fconfigure $s -sockname]
 848	close $s
 849    }
 850    set s1 [socket localhost 2829]
 851    set timer [after 10000 "set x timed_out"]
 852    vwait x
 853    after cancel $timer
 854    close $s
 855    close $s1
 856    set l ""
 857    lappend l [lindex $x 0] [lindex $x 2] [llength $x]
 858} {127.0.0.1 2829 3}
 859
 860test socket-8.1 {testing -async flag on sockets} {
 861    # NOTE: This test may fail on some Solaris 2.4 systems. If it does,
 862    # check that you have these patches installed (using showrev -p):
 863    #
 864    # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
 865    # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
 866    # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
 867    # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
 868    # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01,
 869    # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03
 870    #
 871    # If after installing these patches you are still experiencing a
 872    # problem, please email jyl@eng.sun.com. We have not observed this
 873    # failure on Solaris 2.5, so another option (instead of installing
 874    # these patches) is to upgrade to Solaris 2.5.
 875    set s [socket -server accept 2830]
 876    proc accept {s a p} {
 877	global x
 878	puts $s bye
 879	close $s
 880	set x done
 881    }
 882    set s1 [socket -async [info hostname] 2830]
 883    vwait x
 884    set z [gets $s1]
 885    close $s
 886    close $s1
 887    set z
 888} bye
 889
 890test socket-9.1 {testing spurious events} {
 891    set len 0
 892    set spurious 0
 893    set done 0
 894    proc readlittle {s} {
 895	global spurious done len
 896	set l [read $s 1]
 897	if {[string length $l] == 0} {
 898	    if {![eof $s]} {
 899		incr spurious
 900	    } else {
 901		close $s
 902		set done 1
 903	    }
 904	} else {
 905	    incr len [string length $l]
 906	}
 907    }
 908    proc accept {s a p} {
 909	fconfigure $s -buffering none -blocking off
 910	fileevent $s readable [list readlittle $s]
 911    }
 912    set s [socket -server accept 2831]
 913    set c [socket [info hostname] 2831]
 914    puts -nonewline $c 01234567890123456789012345678901234567890123456789
 915    close $c
 916    set timer [after 10000 "set done timed_out"]
 917    vwait done
 918    after cancel $timer
 919    close $s
 920    list $spurious $len
 921} {0 50}
 922test socket-9.2 {testing async write, fileevents, flush on close} {} {
 923    set firstblock ""
 924    for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
 925    set secondblock ""
 926    for {set i 0} {$i < 16} {incr i} {
 927	set secondblock "b$secondblock$secondblock"
 928    }
 929    set l [socket -server accept 2832]
 930    proc accept {s a p} {
 931	fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
 932		-buffering line
 933	fileevent $s readable "readable $s"
 934    }
 935    proc readable {s} {
 936	set l [gets $s]
 937	fileevent $s readable {}
 938	after 1000 respond $s
 939    }
 940    proc respond {s} {
 941	global firstblock
 942	puts -nonewline $s $firstblock
 943	after 1000 writedata $s
 944    }
 945    proc writedata {s} {
 946	global secondblock
 947	puts -nonewline $s $secondblock
 948	close $s
 949    }
 950    set s [socket [info hostname] 2832]
 951    fconfigure $s -blocking 0 -trans lf -buffering line
 952    set count 0
 953    puts $s hello
 954    proc readit {s} {
 955	global count done
 956	set l [read $s]
 957	incr count [string length $l]
 958	if {[eof $s]} {
 959	    close $s
 960	    set done 1
 961	}
 962    }
 963    fileevent $s readable "readit $s"
 964    set timer [after 10000 "set done timed_out"]
 965    vwait done
 966    after cancel $timer
 967    close $l
 968    set count
 969} 65566
 970test socket-9.3 {testing EOF stickyness} {
 971    proc count_to_eof {s} {
 972	global count done timer
 973	set l [gets $s]
 974	if {[eof $s]} {
 975	    incr count
 976	    if {$count > 9} {
 977		close $s
 978		set done true
 979		set count {eof is sticky}
 980		after cancel $timer
 981	    }
 982	}
 983    }
 984    proc timerproc {} {
 985	global done count c
 986	set done true
 987	set count {timer went off, eof is not sticky}
 988	close $c
 989    }	
 990    set count 0
 991    set done false
 992    proc write_then_close {s} {
 993	puts $s bye
 994	close $s
 995    }
 996    proc accept {s a p} {
 997	fconfigure $s -buffering line -translation lf
 998	fileevent $s writable "write_then_close $s"
 999    }
1000    set s [socket -server accept 2833]
1001    set c [socket [info hostname] 2833]
1002    fconfigure $c -blocking off -buffering line -translation lf
1003    fileevent $c readable "count_to_eof $c"
1004    set timer [after 1000 timerproc]
1005    vwait done
1006    close $s
1007    set count
1008} {eof is sticky}
1009
1010test socket-10.1 {testing socket accept callback error handling} {
1011    set goterror 0
1012    proc bgerror args {global goterror; set goterror 1}
1013    set s [socket -server accept 2898]
1014    proc accept {s a p} {close $s; error}
1015    set c [socket localhost 2898]
1016    vwait goterror
1017    close $s
1018    close $c
1019    set goterror
1020} 1
1021
1022removeFile script
1023
1024#
1025# The rest of the tests are run only if we are doing testing against
1026# a remote server.
1027#
1028
1029if {$doTestsWithRemoteServer == 0} {
1030    return
1031}
1032
1033test socket-11.1 {tcp connection} {
1034    sendCommand {
1035	set socket9_1_test_server [socket -server accept 2834]
1036	proc accept {s a p} {
1037	    puts $s done
1038	    close $s
1039	}
1040    }
1041    set s [socket $remoteServerIP 2834]
1042    set r [gets $s]
1043    close $s
1044    sendCommand {close $socket9_1_test_server}
1045    set r
1046} done
1047test socket-11.2 {client specifies its port} {
1048    if {[info exists port]} {
1049	incr port
1050    } else {
1051	set port [expr 2048 + [pid]%1024]
1052    }
1053    sendCommand {
1054	set socket9_2_test_server [socket -server accept 2835]
1055	proc accept {s a p} {
1056	    puts $s $p
1057	    close $s
1058	}
1059    }
1060    set s [socket -myport $port $remoteServerIP 2835]
1061    set r [gets $s]
1062    close $s
1063    sendCommand {close $socket9_2_test_server}
1064    if {$r == $port} {
1065	set result ok
1066    } else {
1067	set result broken
1068    }
1069    set result
1070} ok
1071test socket-11.3 {trying to connect, no server} {
1072    set status ok
1073    if {![catch {set s [socket $remoteServerIp 2836]}]} {
1074	if {![catch {gets $s}]} {
1075	    set status broken
1076	}
1077	close $s
1078    }
1079    set status
1080} ok
1081test socket-11.4 {remote echo, one line} {
1082    sendCommand {
1083	set socket10_6_test_server [socket -server accept 2836]
1084	proc accept {s a p} {
1085	    fileevent $s readable [list echo $s]
1086	    fconfigure $s -buffering line -translation crlf
1087	}
1088	proc echo {s} {
1089	    set l [gets $s]
1090	    if {[eof $s]} {
1091		close $s
1092	    } else {
1093		puts $s $l
1094	    }
1095	}
1096    }
1097    set f [socket $remoteServerIP 2836]
1098    fconfigure $f -translation crlf -buffering line
1099    puts $f hello
1100    set r [gets $f]
1101    close $f
1102    sendCommand {close $socket10_6_test_server}
1103    set r
1104} hello
1105test socket-11.5 {remote echo, 50 lines} {
1106    sendCommand {
1107	set socket10_7_test_server [socket -server accept 2836]
1108	proc accept {s a p} {
1109	    fileevent $s readable [list echo $s]
1110	    fconfigure $s -buffering line -translation crlf
1111	}
1112	proc echo {s} {
1113	    set l [gets $s]
1114	    if {[eof $s]} {
1115		close $s
1116	    } else {
1117		puts $s $l
1118	    }
1119	}
1120    }
1121    set f [socket $remoteServerIP 2836]
1122    fconfigure $f -translation crlf -buffering line
1123    for {set cnt 0} {$cnt < 50} {incr cnt} {
1124	puts $f "hello, $cnt"
1125	if {[string compare [gets $f] "hello, $cnt"] != 0} {
1126	    break
1127	}
1128    }
1129    close $f
1130    sendCommand {close $socket10_7_test_server}
1131    set cnt
1132} 50
1133# Macintosh sockets can have more than one server per port
1134if {$tcl_platform(platform) == "macintosh"} {
1135    set conflictResult {0 2836}
1136} else {
1137    set conflictResult {1 {couldn't open socket: address already in use}}
1138}
1139test socket-11.6 {socket conflict} {
1140    set s1 [socket -server accept 2836]
1141    if {[catch {set s2 [socket -server accept 2836]} msg]} {
1142	set result [list 1 $msg]
1143    } else {
1144	set result [list 0 [lindex [fconfigure $s2 -sockname] 2]]
1145	close $s2
1146    }
1147    close $s1
1148    set result
1149} $conflictResult
1150test socket-11.7 {server with several clients} {
1151    sendCommand {
1152	set socket10_9_test_server [socket -server accept 2836]
1153	proc accept {s a p} {
1154	    fconfigure $s -buffering line
1155	    fileevent $s readable [list echo $s]
1156	}
1157	proc echo {s} {
1158	    set l [gets $s]
1159	    if {[eof $s]} {
1160		close $s
1161	    } else {
1162		puts $s $l
1163	    }
1164	}
1165    }
1166    set s1 [socket $remoteServerIP 2836]
1167    fconfigure $s1 -buffering line
1168    set s2 [socket $remoteServerIP 2836]
1169    fconfigure $s2 -buffering line
1170    set s3 [socket $remoteServerIP 2836]
1171    fconfigure $s3 -buffering line
1172    for {set i 0} {$i < 100} {incr i} {
1173	puts $s1 hello,s1
1174	gets $s1
1175	puts $s2 hello,s2
1176	gets $s2
1177	puts $s3 hello,s3
1178	gets $s3
1179    }
1180    close $s1
1181    close $s2
1182    close $s3
1183    sendCommand {close $socket10_9_test_server}
1184    set i
1185} 100    
1186test socket-11.8 {client with several servers} {
1187    sendCommand {
1188	set s1 [socket -server "accept 4003" 4003]
1189	set s2 [socket -server "accept 4004" 4004]
1190	set s3 [socket -server "accept 4005" 4005]
1191	proc accept {mp s a p} {
1192	    puts $s $mp
1193	    close $s
1194	}
1195    }
1196    set s1 [socket $remoteServerIP 4003]
1197    set s2 [socket $remoteServerIP 4004]
1198    set s3 [socket $remoteServerIP 4005]
1199    set l ""
1200    lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \
1201	[gets $s3] [gets $s3] [eof $s3]
1202    close $s1
1203    close $s2
1204    close $s3
1205    sendCommand {
1206	close $s1
1207	close $s2
1208	close $s3
1209    }
1210    set l
1211} {4003 {} 1 4004 {} 1 4005 {} 1}
1212test socket-11.9 {accept callback error} {
1213    set s [socket -server accept 2836]
1214    proc accept {s a p} {expr 10 / 0}
1215    proc bgerror args {
1216	global x
1217	set x $args
1218    }
1219    if {[catch {sendCommand {
1220	    set peername [fconfigure $callerSocket -peername]
1221	    set s [socket [lindex $peername 0] 2836]
1222	    close $s
1223    	 }} msg]} {
1224	close $s
1225	error $msg
1226    }
1227    set timer [after 10000 "set x timed_out"]
1228    vwait x
1229    after cancel $timer
1230    close $s
1231    rename bgerror {}
1232    set x
1233} {{divide by zero}}
1234test socket-11.10 {testing socket specific options} {
1235    sendCommand {
1236	set socket10_12_test_server [socket -server accept 2836]
1237	proc accept {s a p} {close $s}
1238    }
1239    set s [socket $remoteServerIP 2836]
1240    set p [fconfigure $s -peername]
1241    set n [fconfigure $s -sockname]
1242    set l ""
1243    lappend l [lindex $p 2] [llength $p] [llength $p]
1244    close $s
1245    sendCommand {close $socket10_12_test_server}
1246    set l
1247} {2836 3 3}
1248test socket-11.11 {testing spurious events} {
1249    sendCommand {
1250	set socket10_13_test_server [socket -server accept 2836]
1251	proc accept {s a p} {
1252	    fconfigure $s -translation "auto lf"
1253	    after 100 writesome $s
1254	}
1255	proc writesome {s} {
1256	    for {set i 0} {$i < 100} {incr i} {
1257		puts $s "line $i from remote server"
1258	    }
1259	    close $s
1260	}
1261    }
1262    set len 0
1263    set spurious 0
1264    set done 0
1265    proc readlittle {s} {
1266	global spurious done len
1267	set l [read $s 1]
1268	if {[string length $l] == 0} {
1269	    if {![eof $s]} {
1270		incr spurious
1271	    } else {
1272		close $s
1273		set done 1
1274	    }
1275	} else {
1276	    incr len [string length $l]
1277	}
1278    }
1279    set c [socket $remoteServerIP 2836]
1280    fileevent $c readable "readlittle $c"
1281    set timer [after 10000 "set done timed_out"]
1282    vwait done
1283    after cancel $timer
1284    sendCommand {close $socket10_13_test_server}
1285    list $spurious $len
1286} {0 2690}
1287test socket-11.12 {testing EOF stickyness} {
1288    set counter 0
1289    set done 0
1290    proc count_up {s} {
1291	global counter done after_id
1292	set l [gets $s]
1293	if {[eof $s]} {
1294	    incr counter
1295	    if {$counter > 9} {
1296		set done {EOF is sticky}
1297		after cancel $after_id
1298		close $s
1299	    }
1300	}
1301    }
1302    proc timed_out {} {
1303	global c done
1304	set done {timed_out, EOF is not sticky}
1305	close $c
1306    }
1307    sendCommand {
1308	set socket10_14_test_server [socket -server accept 2836]
1309	proc accept {s a p} {
1310	    after 100 close $s
1311	}
1312    }
1313    set c [socket $remoteServerIP 2836]
1314    fileevent $c readable "count_up $c"
1315    set after_id [after 1000 timed_out]
1316    vwait done
1317    sendCommand {close $socket10_14_test_server}
1318    set done
1319} {EOF is sticky}
1320test socket-11.13 {testing async write, async flush, async close} {
1321    proc readit {s} {
1322	global count done
1323	set l [read $s]
1324	incr count [string length $l]
1325	if {[eof $s]} {
1326	    close $s
1327	    set done 1
1328	}
1329    }
1330    sendCommand {
1331	set firstblock ""
1332	for {set i 0} {$i < 5} {incr i} {
1333		set firstblock "a$firstblock$firstblock"
1334	}
1335	set secondblock ""
1336	for {set i 0} {$i < 16} {incr i} {
1337	    set secondblock "b$secondblock$secondblock"
1338	}
1339	set l [socket -server accept 2845]
1340	proc accept {s a p} {
1341	    fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
1342		-buffering line
1343	    fileevent $s readable "readable $s"
1344	}
1345	proc readable {s} {
1346	    set l [gets $s]
1347	    fileevent $s readable {}
1348	    after 1000 respond $s
1349	}
1350	proc respond {s} {
1351	    global firstblock
1352	    puts -nonewline $s $firstblock
1353	    after 1000 writedata $s
1354	}
1355	proc writedata {s} {
1356	    global secondblock
1357	    puts -nonewline $s $secondblock
1358	    close $s
1359	}
1360    }
1361    set s [socket $remoteServerIP 2845]
1362    fconfigure $s -blocking 0 -trans lf -buffering line
1363    set count 0
1364    puts $s hello
1365    fileevent $s readable "readit $s"
1366    set timer [after 10000 "set done timed_out"]
1367    vwait done
1368    after cancel $timer
1369    sendCommand {close $l}
1370    set count
1371} 65566
1372
1373if {[string match sock* $commandSocket] == 1} {
1374   puts $commandSocket exit
1375   flush $commandSocket
1376}
1377catch {close $commandSocket}
1378catch {close $remoteProcChan}
1379
1380set x ""
1381unset x