1# This file contains Tcl code to implement a remote server that can be 2# used during testing of Tcl socket code. This server is used by some 3# of the tests in socket.test. 4# 5# Source this file in the remote server you are using to test Tcl against. 6# 7# Copyright © 1995-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# Initialize message delimitor 13 14# Initialize command array 15catch {unset command} 16set command(0) "" 17set callerSocket "" 18 19# Detect whether we should print out connection messages etc. 20if {![info exists VERBOSE]} { 21 set VERBOSE 0 22} 23 24proc __doCommands__ {l s} { 25 global callerSocket VERBOSE 26 27 if {$VERBOSE} { 28 puts "--- Server executing the following for socket $s:" 29 puts $l 30 puts "---" 31 } 32 set callerSocket $s 33 set ::errorInfo "" 34 set code [catch {uplevel "#0" $l} msg] 35 return [list $code $::errorInfo $msg] 36} 37 38proc __readAndExecute__ {s} { 39 global command VERBOSE 40 41 set l [gets $s] 42 if {[string compare $l "--Marker--Marker--Marker--"] == 0} { 43 puts $s [__doCommands__ $command($s) $s] 44 puts $s "--Marker--Marker--Marker--" 45 set command($s) "" 46 return 47 } 48 if {[string compare $l ""] == 0} { 49 if {[eof $s]} { 50 if {$VERBOSE} { 51 puts "Server closing $s, eof from client" 52 } 53 close $s 54 } 55 return 56 } 57 if {[eof $s]} { 58 if {$VERBOSE} { 59 puts "Server closing $s, eof from client" 60 } 61 close $s 62 unset command($s) 63 return 64 } 65 append command($s) $l "\n" 66} 67 68proc __accept__ {s a p} { 69 global command VERBOSE 70 71 if {$VERBOSE} { 72 puts "Server accepts new connection from $a:$p on $s" 73 } 74 set command($s) "" 75 fconfigure $s -buffering line -translation crlf 76 fileevent $s readable [list __readAndExecute__ $s] 77} 78 79set serverIsSilent 0 80for {set i 0} {$i < $argc} {incr i} { 81 if {[string compare -serverIsSilent [lindex $argv $i]] == 0} { 82 set serverIsSilent 1 83 break 84 } 85} 86if {![info exists serverPort]} { 87 if {[info exists env(serverPort)]} { 88 set serverPort $env(serverPort) 89 } 90} 91if {![info exists serverPort]} { 92 for {set i 0} {$i < $argc} {incr i} { 93 if {[string compare -port [lindex $argv $i]] == 0} { 94 if {$i < $argc - 1} { 95 set serverPort [lindex $argv [expr {$i + 1}]] 96 } 97 break 98 } 99 } 100} 101if {![info exists serverPort]} { 102 set serverPort 2048 103} 104 105if {![info exists serverAddress]} { 106 if {[info exists env(serverAddress)]} { 107 set serverAddress $env(serverAddress) 108 } 109} 110if {![info exists serverAddress]} { 111 for {set i 0} {$i < $argc} {incr i} { 112 if {[string compare -address [lindex $argv $i]] == 0} { 113 if {$i < $argc - 1} { 114 set serverAddress [lindex $argv [expr {$i + 1}]] 115 } 116 break 117 } 118 } 119} 120if {![info exists serverAddress]} { 121 set serverAddress 0.0.0.0 122} 123 124if {$serverIsSilent == 0} { 125 set l "Remote server listening on port $serverPort, IP $serverAddress." 126 puts "" 127 puts $l 128 for {set c [string length $l]} {$c > 0} {incr c -1} {puts -nonewline "-"} 129 puts "" 130 puts "" 131 puts "You have set the Tcl variables serverAddress to $serverAddress and" 132 puts "serverPort to $serverPort. You can set these with the -address and" 133 puts "-port command line options, or as environment variables in your" 134 puts "shell." 135 puts "" 136 puts "NOTE: The tests will not work properly if serverAddress is set to" 137 puts "\"localhost\" or 127.0.0.1." 138 puts "" 139 puts "When you invoke tcltest to run the tests, set the variables" 140 puts "remoteServerPort to $serverPort and remoteServerIP to" 141 puts "[info hostname]. You can set these as environment variables" 142 puts "from the shell. The tests will not work properly if you set" 143 puts "remoteServerIP to \"localhost\" or 127.0.0.1." 144 puts "" 145 puts -nonewline "Type Ctrl-C to terminate--> " 146 flush stdout 147} 148 149proc getPort sock { 150 lindex [fconfigure $sock -sockname] 2 151} 152 153if {[catch {set serverSocket \ 154 [socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} { 155 puts "Server on $serverAddress:$serverPort cannot start: $msg" 156} else { 157 puts ready 158 vwait __server_wait_variable__ 159} 160