os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/remote.tcl
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/remote.tcl Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,172 @@
1.4 +# This file contains Tcl code to implement a remote server that can be
1.5 +# used during testing of Tcl socket code. This server is used by some
1.6 +# of the tests in socket.test.
1.7 +#
1.8 +# Source this file in the remote server you are using to test Tcl against.
1.9 +#
1.10 +# Copyright (c) 1995-1996 Sun Microsystems, Inc.
1.11 +#
1.12 +# See the file "license.terms" for information on usage and redistribution
1.13 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.14 +#
1.15 +# RCS: @(#) $Id: remote.tcl,v 1.3 1999/04/16 00:47:33 stanton Exp $
1.16 +
1.17 +# Initialize message delimitor
1.18 +
1.19 +# Initialize command array
1.20 +catch {unset command}
1.21 +set command(0) ""
1.22 +set callerSocket ""
1.23 +
1.24 +# Detect whether we should print out connection messages etc.
1.25 +if {![info exists VERBOSE]} {
1.26 + set VERBOSE 0
1.27 +}
1.28 +
1.29 +proc __doCommands__ {l s} {
1.30 + global callerSocket VERBOSE
1.31 +
1.32 + if {$VERBOSE} {
1.33 + puts "--- Server executing the following for socket $s:"
1.34 + puts $l
1.35 + puts "---"
1.36 + }
1.37 + set callerSocket $s
1.38 + if {[catch {uplevel #0 $l} msg]} {
1.39 + list error $msg
1.40 + } else {
1.41 + list success $msg
1.42 + }
1.43 +}
1.44 +
1.45 +proc __readAndExecute__ {s} {
1.46 + global command VERBOSE
1.47 +
1.48 + set l [gets $s]
1.49 + if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
1.50 + if {[info exists command($s)]} {
1.51 + puts $s [list error incomplete_command]
1.52 + }
1.53 + puts $s "--Marker--Marker--Marker--"
1.54 + return
1.55 + }
1.56 + if {[string compare $l ""] == 0} {
1.57 + if {[eof $s]} {
1.58 + if {$VERBOSE} {
1.59 + puts "Server closing $s, eof from client"
1.60 + }
1.61 + close $s
1.62 + }
1.63 + return
1.64 + }
1.65 + append command($s) $l "\n"
1.66 + if {[info complete $command($s)]} {
1.67 + set cmds $command($s)
1.68 + unset command($s)
1.69 + puts $s [__doCommands__ $cmds $s]
1.70 + }
1.71 + if {[eof $s]} {
1.72 + if {$VERBOSE} {
1.73 + puts "Server closing $s, eof from client"
1.74 + }
1.75 + close $s
1.76 + }
1.77 +}
1.78 +
1.79 +proc __accept__ {s a p} {
1.80 + global VERBOSE
1.81 +
1.82 + if {$VERBOSE} {
1.83 + puts "Server accepts new connection from $a:$p on $s"
1.84 + }
1.85 + fileevent $s readable [list __readAndExecute__ $s]
1.86 + fconfigure $s -buffering line -translation crlf
1.87 +}
1.88 +
1.89 +set serverIsSilent 0
1.90 +for {set i 0} {$i < $argc} {incr i} {
1.91 + if {[string compare -serverIsSilent [lindex $argv $i]] == 0} {
1.92 + set serverIsSilent 1
1.93 + break
1.94 + }
1.95 +}
1.96 +if {![info exists serverPort]} {
1.97 + if {[info exists env(serverPort)]} {
1.98 + set serverPort $env(serverPort)
1.99 + }
1.100 +}
1.101 +if {![info exists serverPort]} {
1.102 + for {set i 0} {$i < $argc} {incr i} {
1.103 + if {[string compare -port [lindex $argv $i]] == 0} {
1.104 + if {$i < [expr $argc - 1]} {
1.105 + set serverPort [lindex $argv [expr $i + 1]]
1.106 + }
1.107 + break
1.108 + }
1.109 + }
1.110 +}
1.111 +if {![info exists serverPort]} {
1.112 + set serverPort 2048
1.113 +}
1.114 +
1.115 +if {![info exists serverAddress]} {
1.116 + if {[info exists env(serverAddress)]} {
1.117 + set serverAddress $env(serverAddress)
1.118 + }
1.119 +}
1.120 +if {![info exists serverAddress]} {
1.121 + for {set i 0} {$i < $argc} {incr i} {
1.122 + if {[string compare -address [lindex $argv $i]] == 0} {
1.123 + if {$i < [expr $argc - 1]} {
1.124 + set serverAddress [lindex $argv [expr $i + 1]]
1.125 + }
1.126 + break
1.127 + }
1.128 + }
1.129 +}
1.130 +if {![info exists serverAddress]} {
1.131 + set serverAddress 0.0.0.0
1.132 +}
1.133 +
1.134 +if {$serverIsSilent == 0} {
1.135 + set l "Remote server listening on port $serverPort, IP $serverAddress."
1.136 + puts ""
1.137 + puts $l
1.138 + for {set c [string length $l]} {$c > 0} {incr c -1} {puts -nonewline "-"}
1.139 + puts ""
1.140 + puts ""
1.141 + puts "You have set the Tcl variables serverAddress to $serverAddress and"
1.142 + puts "serverPort to $serverPort. You can set these with the -address and"
1.143 + puts "-port command line options, or as environment variables in your"
1.144 + puts "shell."
1.145 + puts ""
1.146 + puts "NOTE: The tests will not work properly if serverAddress is set to"
1.147 + puts "\"localhost\" or 127.0.0.1."
1.148 + puts ""
1.149 + puts "When you invoke tcltest to run the tests, set the variables"
1.150 + puts "remoteServerPort to $serverPort and remoteServerIP to"
1.151 + puts "[info hostname]. You can set these as environment variables"
1.152 + puts "from the shell. The tests will not work properly if you set"
1.153 + puts "remoteServerIP to \"localhost\" or 127.0.0.1."
1.154 + puts ""
1.155 + puts -nonewline "Type Ctrl-C to terminate--> "
1.156 + flush stdout
1.157 +}
1.158 +
1.159 +if {[catch {set serverSocket \
1.160 + [socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
1.161 + puts "Server on $serverAddress:$serverPort cannot start: $msg"
1.162 +} else {
1.163 + vwait __server_wait_variable__
1.164 +}
1.165 +
1.166 +
1.167 +
1.168 +
1.169 +
1.170 +
1.171 +
1.172 +
1.173 +
1.174 +
1.175 +