tcl/tests/remote.tcl

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