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