#!/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