summaryrefslogtreecommitdiffstats
path: root/tcl8.6/tests/remote.tcl
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2016-12-21 22:13:18 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2016-12-21 22:13:18 (GMT)
commit07e464099b99459d0a37757771791598ef3395d9 (patch)
tree4ba7d8aad13735e52f59bdce7ca5ba3151ebd7e3 /tcl8.6/tests/remote.tcl
parentdeb3650e37f26f651f280e480c4df3d7dde87bae (diff)
downloadblt-07e464099b99459d0a37757771791598ef3395d9.zip
blt-07e464099b99459d0a37757771791598ef3395d9.tar.gz
blt-07e464099b99459d0a37757771791598ef3395d9.tar.bz2
new subtree for tcl/tk
Diffstat (limited to 'tcl8.6/tests/remote.tcl')
-rw-r--r--tcl8.6/tests/remote.tcl159
1 files changed, 0 insertions, 159 deletions
diff --git a/tcl8.6/tests/remote.tcl b/tcl8.6/tests/remote.tcl
deleted file mode 100644
index 097e41f..0000000
--- a/tcl8.6/tests/remote.tcl
+++ /dev/null
@@ -1,159 +0,0 @@
-# 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.
-
-# 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
- set ::errorInfo ""
- set code [catch {uplevel "#0" $l} msg]
- return [list $code $::errorInfo $msg]
-}
-
-proc __readAndExecute__ {s} {
- global command VERBOSE
-
- set l [gets $s]
- if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
- puts $s [__doCommands__ $command($s) $s]
- puts $s "--Marker--Marker--Marker--"
- set command($s) ""
- return
- }
- if {[string compare $l ""] == 0} {
- if {[eof $s]} {
- if {$VERBOSE} {
- puts "Server closing $s, eof from client"
- }
- close $s
- }
- return
- }
- if {[eof $s]} {
- if {$VERBOSE} {
- puts "Server closing $s, eof from client"
- }
- close $s
- unset command($s)
- return
- }
- append command($s) $l "\n"
-}
-
-proc __accept__ {s a p} {
- global command VERBOSE
-
- if {$VERBOSE} {
- puts "Server accepts new connection from $a:$p on $s"
- }
- set command($s) ""
- fconfigure $s -buffering line -translation crlf
- fileevent $s readable [list __readAndExecute__ $s]
-}
-
-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
-}
-
-proc getPort sock {
- lindex [fconfigure $sock -sockname] 2
-}
-
-if {[catch {set serverSocket \
- [socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
- puts "Server on $serverAddress:$serverPort cannot start: $msg"
-} else {
- puts ready
- vwait __server_wait_variable__
-}