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