#/bin/sh # \ exec tclsh "$0" ${1+"$@"}
# --- server.tcl --- A server that does not do much
# Configure a socket for use with a relay link
proc ConfigureSocket { fd } {
global Connections
fconfigure $fd -blocking 0 -buffering $Connections(Buffering) -buffersize $Connections(BufSize) -translation binary
return $fd
}# Handle a new client connection
proc HandleClientConnect { client address port } {
global Connections
ConfigureSocket $client
fileevent $client readable "CopyClientData $client"
puts stdout "server: Connected from $address on $port\n"
set Connections($client,Start) [clock clicks -milliseconds]
set Connections($client,Count) 0
}
# Disconnect a link
proc Disconnect { fd } {
global Connections
if { ![catch { fileevent $fd readable {} }] } {
close $fd
}
}# Handle a disconnection
proc HandleClientDisconnect { fd } {
global Connections
set Connections($fd,End) [clock clicks -milliseconds]
set time [expr $Connections($fd,End) - $Connections($fd,Start)]
set speed [expr $Connections($fd,Count)/$time]
puts "Transferred $Connections($fd,Count) bytes in [expr $Connections($fd,End) - $Connections($fd,Start)] milliseconds."
puts "Transfer rate is $speed KBytes/sec"
Disconnect $fd
}# Copy data between the source and destination channels
proc CopyClientData { from } {
global Connections
set line [read $from 1500]
if { ! [eof $from] } {
if { [string range $line 0 3] == "mode" } {
puts stdout [string range $line 0 32]
}# puts stdout "server: $line"
incr Connections($from,Count) [string length $line]
} else {
if [eof $from] {
puts "server: $from Client disconnected!"
HandleClientDisconnect $from
}
}
}if { 0 } {
wm title . "Server ..."
catch { destroy .f }
set f [frame .f]
button $f.b -width 8 -text Quit -command exit
pack $f.b -side left
pack $f}
# Some default options
set Connections(Port) 14210 set Connections(Buffering) full set Connections(BufSize) 10000
# Process the parameter list
foreach { key opt } $argv {
switch -exact -- [string tolower $key] {
"-p" - "-port" { set Connections(Port) $opt }
"-b" - "-buffering" { set Connections(Buffering) $opt }
"-s" - "-size" { set Connections(BufSize) $opt }
default { puts stderr "Keyword $key is not supported!"
exit
}
}
}catch { close $Connections(Server) }
set Connections(Server) socket -server HandleClientConnect $Connections(Port)
set forever 1
vwait forever
exit