#!/usr/bin/wish # vi: set ts=4 sts=4 sw=4: # C2003 Uwe Klein Habertwedt
# simpler Socket Server mit TCL , gewonnen aus Mfs Socket Server , basiert unter anderem auf # einigen im Netz und auf dem Wiki gefunden Vorlagen.
# gebraucht wird # 1. ein Script/Proc das input bearbeitet und antwortet # es ist nachher wurscht ob das auf stdin liest und auf stdout antwortet. # wenn man schlau ist hat dieses proc mind 2 argumente : fdin und fdout # als Kommandozeilen interpreter bekommt es dann stdin und stdout # als socket bearbeiter 2 mal den socket!
# 2. ein Script/Proc das eine eingehende Verbindung akzeptiert und das Proc # aus 1 auf diesen Input per "fileevent" ansetzt
# 3. ein "socket -server" starten mit dem Proc aus 2
# 4. kein punkt 4 : ist schon alles fertig
# was es nicht macht: authentifizierung, anzahl verbindungen begrenzen, Input auf Muell pruefen. # ( man n socket ) # was es macht: lauschen auf tcp port 9999(default) # Verbindungen annehmen von Clients # ( man n fileevent, man n fconfigure ) # input solange annehmen bis "msg" als tcl Script komplett ist # sprich Klammern rund/eckig Quoting balanciert. # ( man n info ) # und dann im globalen Kontext ausführen # man n eval, man n namespace # Sagen ob ausführung OK oder mit Fehler # ( man n catch ) # und return Wert an den Client zurueckgeben. # Wenn man es sicherer machen will wurde man z.B. # das Script in einem separaten (sicheren) Interpreter ausführen lassen # ( man n interp )
package provide SockServ 1.0
# create a namespace namespace eval ::sockServ {
variable status
set status(server,started) {}
variable config
set config(port,default) 9999
set config(server,port) 9999
variable msg {}
variable cerr {}
proc create args {
variable status
variable config
foreach {arg val} $args {
set arg [ string trimm left $arg - ]
set config($arg) $val
}
if { "$status(server,started)" == "OK" } {
puts stderr "SockServ allready started!"
return 1;
}
# Create a server socket on port $config(server,port)
# Call proc accept when a client attempts a connection.
if {[catch { socket -server ::sockServ::accept $config(server,port) } cerr]} {
puts stderr "SockServ : cannot create: ServerSocket on Port $config(server,port) ERR: $cerr "
set status(server,started) OK
}
return 0;
}
# accept a call to the server socket
proc accept {sock addr port} {
variable status
variable config
# Setup handler for future communication on client socket
fileevent $sock readable [list ::sockServ::action $sock $sock]
# Note we've accepted a connection (show how get peer info fm socket)
puts stderr "Accepted Connection from [fconfigure $sock -peername]"
# Read client input in lines, disable blocking I/O
fconfigure $sock -buffering line -blocking 0
# Send Acceptance string to client
puts $sock "$addr:$port, You are connected to the Sock Server."
puts -nonewline $sock "it is [ clock format [ clock seconds ]] : \nShoot : "
flush $sock
set status($sock) "ACCEPT"
set status($sock,peer) "[fconfigure $sock -peername]"
}
proc action {fdin fdout} {
variable status
variable config
variable msg
variable cerr
set ret OK
if {[eof $fdin]} {
puts stderr EOF:$fdin
close $fdin
return
}
append msg [ gets $fdin ]
if {[ string equal -nocase "$msg" "exit" ]} {
puts $fdout "goodbye"
flush $fdout
close $fdout
set msg {}
return
}
if { [info complete $msg] } {
if {[ catch {namespace eval :: $msg} ::sockServ::cerr]} {
set ret ERR
}
puts -nonewline $fdout "$ret: $::sockServ::cerr\nShoot : "
set msg {}
} else {
puts -nonewline $fdout "\n > "
}
flush $fdout
}}
sockServ::create ;# 1234
# end