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