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