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