sl@0: # This file contains Tcl code to implement a remote server that can be
sl@0: # used during testing of Tcl socket code. This server is used by some
sl@0: # of the tests in socket.test.
sl@0: #
sl@0: # Source this file in the remote server you are using to test Tcl against.
sl@0: #
sl@0: # Copyright (c) 1995-1996 Sun Microsystems, Inc.
sl@0: #
sl@0: # See the file "license.terms" for information on usage and redistribution
sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0: #
sl@0: # RCS: @(#) $Id: remote.tcl,v 1.3 1999/04/16 00:47:33 stanton Exp $
sl@0: 
sl@0: # Initialize message delimitor
sl@0: 
sl@0: # Initialize command array
sl@0: catch {unset command}
sl@0: set command(0) ""
sl@0: set callerSocket ""
sl@0: 
sl@0: # Detect whether we should print out connection messages etc.
sl@0: if {![info exists VERBOSE]} {
sl@0:     set VERBOSE 0
sl@0: }
sl@0: 
sl@0: proc __doCommands__ {l s} {
sl@0:     global callerSocket VERBOSE
sl@0: 
sl@0:     if {$VERBOSE} {
sl@0: 	puts "--- Server executing the following for socket $s:"
sl@0: 	puts $l
sl@0: 	puts "---"
sl@0:     }
sl@0:     set callerSocket $s
sl@0:     if {[catch {uplevel #0 $l} msg]} {
sl@0: 	list error $msg
sl@0:     } else {
sl@0: 	list success $msg
sl@0:     }
sl@0: }
sl@0: 
sl@0: proc __readAndExecute__ {s} {
sl@0:     global command VERBOSE
sl@0: 
sl@0:     set l [gets $s]
sl@0:     if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
sl@0: 	if {[info exists command($s)]} {
sl@0: 	    puts $s [list error incomplete_command]
sl@0: 	}
sl@0: 	puts $s "--Marker--Marker--Marker--"
sl@0: 	return
sl@0:     }
sl@0:     if {[string compare $l ""] == 0} {
sl@0: 	if {[eof $s]} {
sl@0: 	    if {$VERBOSE} {
sl@0: 		puts "Server closing $s, eof from client"
sl@0: 	    }
sl@0: 	    close $s
sl@0: 	}
sl@0: 	return
sl@0:     }
sl@0:     append command($s) $l "\n"
sl@0:     if {[info complete $command($s)]} {
sl@0: 	set cmds $command($s)
sl@0: 	unset command($s)
sl@0: 	puts $s [__doCommands__ $cmds $s]
sl@0:     }
sl@0:     if {[eof $s]} {
sl@0: 	if {$VERBOSE} {
sl@0: 	    puts "Server closing $s, eof from client"
sl@0: 	}
sl@0: 	close $s
sl@0:     }
sl@0: }
sl@0: 
sl@0: proc __accept__ {s a p} {
sl@0:     global VERBOSE
sl@0: 
sl@0:     if {$VERBOSE} {
sl@0: 	puts "Server accepts new connection from $a:$p on $s"
sl@0:     }
sl@0:     fileevent $s readable [list __readAndExecute__ $s]
sl@0:     fconfigure $s -buffering line -translation crlf
sl@0: }
sl@0: 
sl@0: set serverIsSilent 0
sl@0: for {set i 0} {$i < $argc} {incr i} {
sl@0:     if {[string compare -serverIsSilent [lindex $argv $i]] == 0} {
sl@0: 	set serverIsSilent 1
sl@0: 	break
sl@0:     }
sl@0: }
sl@0: if {![info exists serverPort]} {
sl@0:     if {[info exists env(serverPort)]} {
sl@0: 	set serverPort $env(serverPort)
sl@0:     }
sl@0: }
sl@0: if {![info exists serverPort]} {
sl@0:     for {set i 0} {$i < $argc} {incr i} {
sl@0: 	if {[string compare -port [lindex $argv $i]] == 0} {
sl@0: 	    if {$i < [expr $argc - 1]} {
sl@0: 		set serverPort [lindex $argv [expr $i + 1]]
sl@0: 	    }
sl@0: 	    break
sl@0: 	}
sl@0:     }
sl@0: }
sl@0: if {![info exists serverPort]} {
sl@0:     set serverPort 2048
sl@0: }
sl@0: 
sl@0: if {![info exists serverAddress]} {
sl@0:     if {[info exists env(serverAddress)]} {
sl@0: 	set serverAddress $env(serverAddress)
sl@0:     }
sl@0: }
sl@0: if {![info exists serverAddress]} {
sl@0:     for {set i 0} {$i < $argc} {incr i} {
sl@0: 	if {[string compare -address [lindex $argv $i]] == 0} {
sl@0: 	    if {$i < [expr $argc - 1]} {
sl@0: 		set serverAddress [lindex $argv [expr $i + 1]]
sl@0: 	    }
sl@0: 	    break
sl@0: 	}
sl@0:     }
sl@0: }
sl@0: if {![info exists serverAddress]} {
sl@0:     set serverAddress 0.0.0.0
sl@0: }
sl@0: 
sl@0: if {$serverIsSilent == 0} {
sl@0:     set l "Remote server listening on port $serverPort, IP $serverAddress."
sl@0:     puts ""
sl@0:     puts $l
sl@0:     for {set c [string length $l]} {$c > 0} {incr c -1} {puts -nonewline "-"}
sl@0:     puts ""
sl@0:     puts ""
sl@0:     puts "You have set the Tcl variables serverAddress to $serverAddress and"
sl@0:     puts "serverPort to $serverPort. You can set these with the -address and"
sl@0:     puts "-port command line options, or as environment variables in your"
sl@0:     puts "shell."
sl@0:     puts ""
sl@0:     puts "NOTE: The tests will not work properly if serverAddress is set to"
sl@0:     puts "\"localhost\" or 127.0.0.1."
sl@0:     puts ""
sl@0:     puts "When you invoke tcltest to run the tests, set the variables"
sl@0:     puts "remoteServerPort to $serverPort and remoteServerIP to"
sl@0:     puts "[info hostname]. You can set these as environment variables"
sl@0:     puts "from the shell. The tests will not work properly if you set"
sl@0:     puts "remoteServerIP to \"localhost\" or 127.0.0.1."
sl@0:     puts ""
sl@0:     puts -nonewline "Type Ctrl-C to terminate--> "
sl@0:     flush stdout
sl@0: }
sl@0: 
sl@0: if {[catch {set serverSocket \
sl@0: 	[socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
sl@0:     puts "Server on $serverAddress:$serverPort cannot start: $msg"
sl@0: } else {
sl@0:     vwait __server_wait_variable__
sl@0: }
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: