diff options
Diffstat (limited to 'tests/remote.tcl')
| -rw-r--r-- | tests/remote.tcl | 161 |
1 files changed, 161 insertions, 0 deletions
diff --git a/tests/remote.tcl b/tests/remote.tcl new file mode 100644 index 0000000..3ede61a --- /dev/null +++ b/tests/remote.tcl @@ -0,0 +1,161 @@ +# 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. +# +# @(#) remote.tcl 1.5 96/04/17 08:21:19" + +# Initialize message delimitor + +# Initialize command array +catch {unset command} +set command(0) "" +set callerSocket "" + +# Detect whether we should print out connection messages etc. +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 "---" + } + set callerSocket $s + if {[catch {uplevel #0 $l} msg]} { + list error $msg + } else { + list success $msg + } +} + +proc __readAndExecute__ {s} { + global command VERBOSE + + set l [gets $s] + if {[string compare $l "--Marker--Marker--Marker--"] == 0} { + if {[info exists command($s)]} { + puts $s [list error incomplete_command] + } + puts $s "--Marker--Marker--Marker--" + return + } + if {[string compare $l ""] == 0} { + 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" + } + fileevent $s readable [list __readAndExecute__ $s] + fconfigure $s -buffering line -translation crlf +} + +set serverIsSilent 0 +for {set i 0} {$i < $argc} {incr i} { + if {[string compare -serverIsSilent [lindex $argv $i]] == 0} { + 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 {[string compare -port [lindex $argv $i]] == 0} { + if {$i < [expr $argc - 1]} { + set serverPort [lindex $argv [expr $i + 1]] + } + break + } + } +} +if {![info exists serverPort]} { + set serverPort 2048 +} + +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 {[string compare -address [lindex $argv $i]] == 0} { + 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 +} + +if {[catch {set serverSocket \ + [socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} { + puts "Server on $serverAddress:$serverPort cannot start: $msg" +} else { + vwait __server_wait_variable__ +} |