[Orxonox-commit 847] r2214 - media/tcl
landauf at orxonox.net
landauf at orxonox.net
Tue Jul 28 16:54:37 CEST 2009
Author: landauf
Date: 2009-07-28 16:54:36 +0200 (Tue, 28 Jul 2009)
New Revision: 2214
Modified:
media/tcl/init.tcl
media/tcl/irc.tcl
media/tcl/remote.tcl
media/tcl/telnet_server.tcl
Log:
eol-style:native
Modified: media/tcl/init.tcl
===================================================================
--- media/tcl/init.tcl 2009-07-28 14:53:48 UTC (rev 2213)
+++ media/tcl/init.tcl 2009-07-28 14:54:36 UTC (rev 2214)
@@ -1,275 +1,275 @@
-# Check if Tcl was properly initialized
-info library
-
-# Create orxonox namespace
-namespace eval orxonox {}
-
-# query --
-# Sends a query to the CommandExecutor of Orxonox and waits for the response.
-# This dummy procedure will be changed to it's real implementation by Orxonox itself.
-#
-# Arguments:
-# args - The command to send to Orxonox
-
-proc query args {
- return -code error "Can't query Orxonox now"
-}
-
-
-# crossquery --
-# Sends a query to another Tcl-interpreter in Orxonox and waits for the response.
-# This dummy procedure will be changed to it's real implementation by Orxonox itself.
-#
-# Arguments:
-# id - The ID of the other interpreter
-# args - The command to send to Orxonox
-
-proc crossquery {id args} {
- return -code error "Can't query interpreter with ID $id now"
-}
-
-
-# execute --
-# Sends a command to the queue of Orxonox where it will be executed by the CommandExecutor after some time
-# This dummy procedure will be changed to it's real implementation by Orxonox itself.
-#
-# Arguments:
-# args - The command
-
-proc execute args {
- return -code error "Can't execute a command now"
-}
-
-
-# crossexecute --
-# Sends a command to the queue of another Tcl-interpreter where it will be executed by after some time
-# This dummy procedure will be changed to it's real implementation by Orxonox itself.
-#
-# Arguments:
-# id - The ID of the other interpreter
-# args - The command
-
-proc crossexecute {id args} {
- return -code error "Can't execute a command now"
-}
-
-
-# running --
-# Returns true if the interpreter is still suposed to be running
-# This dummy procedure will be changed to it's real implementation by Orxonox itself.
-
-proc running {} {
- return 1
-}
-
-
-# orxonox::while --
-# Works like while but breaks the loop if orxonox::running returns false
-
-proc ::orxonox::while {condition body} {
- set condition_cmd [list expr $condition]
- ::tcl::while {1} {
- if {![uplevel 1 $condition_cmd] || ![::running]} {
- break
- }
- uplevel 1 $body
- }
-}
-
-
-# orxonox::for --
-# Works like for but breaks the loop if orxonox::running returns false
-
-proc ::orxonox::for {start condition step body} {
- set condition_cmd [list expr $condition]
- uplevel 1 $start
- ::tcl::while {1} {
- if {![uplevel 1 $condition_cmd] || ![::running]} {
- break
- }
- uplevel 1 $body
- uplevel 1 $step
- }
-}
-
-
-# add the path to this file to the auto path
-
-set filepath [info script]
-#set ::orxonox::mediapath [string range $filepath 0 [string last "/" $filepath]]
-set ::orxonox::mediapath [file dirname $filepath]
-if {[lsearch $auto_path $::orxonox::mediapath] == -1} {
- lappend auto_path $::orxonox::mediapath
-}
-unset filepath
-
-
-# save the start directory and the library directory
-
-proc psd {} "return [pwd]"
-proc pld {} "return $::orxonox::mediapath"
-
-set pwd [pwd]
-set psd [psd]
-set pld [pld]
-
-
-# modify cd to automatically set $pwd
-
-if {[llength [info command ::tcl::cd]] == 0} {
- rename cd ::tcl::cd
-}
-proc cd {{path "~"}} {
- global pwd
- ::tcl::cd $path
- set pwd [pwd]
-}
-
-
-# change the working directory to the media path
-
-cd $::orxonox::mediapath
-
-
-# Redefines puts to write directly into the Orxonox console if the channel is stdout or stderr.
-
-if {[llength [info command ::tcl::puts]] == 0} {
- rename puts ::tcl::puts
-}
-proc puts args {
- set argc [llength $args]
- if {$argc < 1 || $argc > 3} {
- error "wrong # args: should be \"puts ?-nonewline? ?channelId? string\""
- }
-
- set newline 1
- set input $args
-
- if {$argc > 1 && [lindex $input 0] == "-nonewline"} {
- set newline 0
- set input [lrange $input 1 end]
- } elseif {$argc == 3} {
- if {[lindex $input 2] == "nonewline"} {
- set newline 0
- set input [lrange $input 0 1]
- } else {
- error "bad argument \"[lindex $input 2]\": should be \"nonewline\""
- }
- }
-
- if {[llength $input] == 1} {
- set input [list stdout [join $input]]
- }
-
- foreach {channel s} $input break
-
- if {$channel == "stdout" || $channel == "stderr"} {
- execute puts $newline $s
- } else {
- eval [concat ::tcl::puts $args]
- }
-}
-
-
-# Redefines unknown to send unknown commands back to orxonox
-
-if {[llength [info commands unknown]] != 0} {
- # check if a command named "undefined_proc" exists, if yes rename it temporarily
- set undefined_was_defined 0
- if {[llength [info commands undefined_proc]] != 0} {
- set undefined_was_defined 0
- rename undefined_proc _undefined
- }
-
- # get the returned errormessage if an undefined_proc command is called
- if {[llength [info commands ::tcl::unknown]] == 0} {
- set errorcode [catch {unknown undefined_proc} result]
- } else {
- set errorcode [catch {::tcl::unknown undefined_proc} result]
- }
-
- if {$errorcode} {
- set result_list [split $result]
- set ::orxonox::errormessage_unknown [list]
-
- # parse the error message (the original message was something like "invalid command name "undefined_proc"" but we just want "invalid command name")
- foreach token $result_list {
- if {![string match "*undefined_proc*" $token]} {
- lappend ::orxonox::errormessage_unknown $token
- }
- }
-
- unset result_list
- unset token
-
- set ::orxonox::errormessage_unknown_length [llength $::orxonox::errormessage_unknown]
-
- # rename the original unknown procedure
- if {[llength [info commands ::tcl::unknown]] == 0} {
- rename unknown ::tcl::unknown
- }
-
- # define the modified version of unknown
- proc unknown args {
- global ::orxonox::errormessage_unknown ::orxonox::errormessage_unknown_length
-
- set cmd [concat ::tcl::unknown $args]
- if {[info tclversion] < 8.5} {
- set errorcode [catch {eval $cmd} result]
- } else {
- set errorcode [catch {eval $cmd} result options]
- }
- set resultlist [split $result]
- set success 1
-
- if {$errorcode && [llength $resultlist] >= $::orxonox::errormessage_unknown_length} {
- for {set i 0} {$i < $::orxonox::errormessage_unknown_length} {incr i} {
- if {[lindex $::orxonox::errormessage_unknown $i] != [lindex $resultlist $i]} {
- set success 0
- break
- }
- }
- } else {
- set success 0
- }
-
- if {!$success} {
- if {[info tclversion] < 8.5} {
- return -code $errorcode $result
- } else {
- return -code $errorcode -options $options $result
- }
- } else {
- return [query $args]
- }
- }
-
- set success 1
- } else {
- set success 0
- }
-
- unset errorcode
- unset result
-
- # if the "undefined_proc" command was renamed previously, undo this
- if {$undefined_was_defined} {
- rename _undefined undefined_proc
- }
-
- unset undefined_was_defined
-
- if {!$success} {
- unset success
- # something went wrong, use the default method
- proc unknown args {
- return [query $args]
- }
- }
- unset success
-} else {
- # no original unknown procedure defined, use the default method
- proc unknown args {
- return [query $args]
- }
-}
+# Check if Tcl was properly initialized
+info library
+
+# Create orxonox namespace
+namespace eval orxonox {}
+
+# query --
+# Sends a query to the CommandExecutor of Orxonox and waits for the response.
+# This dummy procedure will be changed to it's real implementation by Orxonox itself.
+#
+# Arguments:
+# args - The command to send to Orxonox
+
+proc query args {
+ return -code error "Can't query Orxonox now"
+}
+
+
+# crossquery --
+# Sends a query to another Tcl-interpreter in Orxonox and waits for the response.
+# This dummy procedure will be changed to it's real implementation by Orxonox itself.
+#
+# Arguments:
+# id - The ID of the other interpreter
+# args - The command to send to Orxonox
+
+proc crossquery {id args} {
+ return -code error "Can't query interpreter with ID $id now"
+}
+
+
+# execute --
+# Sends a command to the queue of Orxonox where it will be executed by the CommandExecutor after some time
+# This dummy procedure will be changed to it's real implementation by Orxonox itself.
+#
+# Arguments:
+# args - The command
+
+proc execute args {
+ return -code error "Can't execute a command now"
+}
+
+
+# crossexecute --
+# Sends a command to the queue of another Tcl-interpreter where it will be executed by after some time
+# This dummy procedure will be changed to it's real implementation by Orxonox itself.
+#
+# Arguments:
+# id - The ID of the other interpreter
+# args - The command
+
+proc crossexecute {id args} {
+ return -code error "Can't execute a command now"
+}
+
+
+# running --
+# Returns true if the interpreter is still suposed to be running
+# This dummy procedure will be changed to it's real implementation by Orxonox itself.
+
+proc running {} {
+ return 1
+}
+
+
+# orxonox::while --
+# Works like while but breaks the loop if orxonox::running returns false
+
+proc ::orxonox::while {condition body} {
+ set condition_cmd [list expr $condition]
+ ::tcl::while {1} {
+ if {![uplevel 1 $condition_cmd] || ![::running]} {
+ break
+ }
+ uplevel 1 $body
+ }
+}
+
+
+# orxonox::for --
+# Works like for but breaks the loop if orxonox::running returns false
+
+proc ::orxonox::for {start condition step body} {
+ set condition_cmd [list expr $condition]
+ uplevel 1 $start
+ ::tcl::while {1} {
+ if {![uplevel 1 $condition_cmd] || ![::running]} {
+ break
+ }
+ uplevel 1 $body
+ uplevel 1 $step
+ }
+}
+
+
+# add the path to this file to the auto path
+
+set filepath [info script]
+#set ::orxonox::mediapath [string range $filepath 0 [string last "/" $filepath]]
+set ::orxonox::mediapath [file dirname $filepath]
+if {[lsearch $auto_path $::orxonox::mediapath] == -1} {
+ lappend auto_path $::orxonox::mediapath
+}
+unset filepath
+
+
+# save the start directory and the library directory
+
+proc psd {} "return [pwd]"
+proc pld {} "return $::orxonox::mediapath"
+
+set pwd [pwd]
+set psd [psd]
+set pld [pld]
+
+
+# modify cd to automatically set $pwd
+
+if {[llength [info command ::tcl::cd]] == 0} {
+ rename cd ::tcl::cd
+}
+proc cd {{path "~"}} {
+ global pwd
+ ::tcl::cd $path
+ set pwd [pwd]
+}
+
+
+# change the working directory to the media path
+
+cd $::orxonox::mediapath
+
+
+# Redefines puts to write directly into the Orxonox console if the channel is stdout or stderr.
+
+if {[llength [info command ::tcl::puts]] == 0} {
+ rename puts ::tcl::puts
+}
+proc puts args {
+ set argc [llength $args]
+ if {$argc < 1 || $argc > 3} {
+ error "wrong # args: should be \"puts ?-nonewline? ?channelId? string\""
+ }
+
+ set newline 1
+ set input $args
+
+ if {$argc > 1 && [lindex $input 0] == "-nonewline"} {
+ set newline 0
+ set input [lrange $input 1 end]
+ } elseif {$argc == 3} {
+ if {[lindex $input 2] == "nonewline"} {
+ set newline 0
+ set input [lrange $input 0 1]
+ } else {
+ error "bad argument \"[lindex $input 2]\": should be \"nonewline\""
+ }
+ }
+
+ if {[llength $input] == 1} {
+ set input [list stdout [join $input]]
+ }
+
+ foreach {channel s} $input break
+
+ if {$channel == "stdout" || $channel == "stderr"} {
+ execute puts $newline $s
+ } else {
+ eval [concat ::tcl::puts $args]
+ }
+}
+
+
+# Redefines unknown to send unknown commands back to orxonox
+
+if {[llength [info commands unknown]] != 0} {
+ # check if a command named "undefined_proc" exists, if yes rename it temporarily
+ set undefined_was_defined 0
+ if {[llength [info commands undefined_proc]] != 0} {
+ set undefined_was_defined 0
+ rename undefined_proc _undefined
+ }
+
+ # get the returned errormessage if an undefined_proc command is called
+ if {[llength [info commands ::tcl::unknown]] == 0} {
+ set errorcode [catch {unknown undefined_proc} result]
+ } else {
+ set errorcode [catch {::tcl::unknown undefined_proc} result]
+ }
+
+ if {$errorcode} {
+ set result_list [split $result]
+ set ::orxonox::errormessage_unknown [list]
+
+ # parse the error message (the original message was something like "invalid command name "undefined_proc"" but we just want "invalid command name")
+ foreach token $result_list {
+ if {![string match "*undefined_proc*" $token]} {
+ lappend ::orxonox::errormessage_unknown $token
+ }
+ }
+
+ unset result_list
+ unset token
+
+ set ::orxonox::errormessage_unknown_length [llength $::orxonox::errormessage_unknown]
+
+ # rename the original unknown procedure
+ if {[llength [info commands ::tcl::unknown]] == 0} {
+ rename unknown ::tcl::unknown
+ }
+
+ # define the modified version of unknown
+ proc unknown args {
+ global ::orxonox::errormessage_unknown ::orxonox::errormessage_unknown_length
+
+ set cmd [concat ::tcl::unknown $args]
+ if {[info tclversion] < 8.5} {
+ set errorcode [catch {eval $cmd} result]
+ } else {
+ set errorcode [catch {eval $cmd} result options]
+ }
+ set resultlist [split $result]
+ set success 1
+
+ if {$errorcode && [llength $resultlist] >= $::orxonox::errormessage_unknown_length} {
+ for {set i 0} {$i < $::orxonox::errormessage_unknown_length} {incr i} {
+ if {[lindex $::orxonox::errormessage_unknown $i] != [lindex $resultlist $i]} {
+ set success 0
+ break
+ }
+ }
+ } else {
+ set success 0
+ }
+
+ if {!$success} {
+ if {[info tclversion] < 8.5} {
+ return -code $errorcode $result
+ } else {
+ return -code $errorcode -options $options $result
+ }
+ } else {
+ return [query $args]
+ }
+ }
+
+ set success 1
+ } else {
+ set success 0
+ }
+
+ unset errorcode
+ unset result
+
+ # if the "undefined_proc" command was renamed previously, undo this
+ if {$undefined_was_defined} {
+ rename _undefined undefined_proc
+ }
+
+ unset undefined_was_defined
+
+ if {!$success} {
+ unset success
+ # something went wrong, use the default method
+ proc unknown args {
+ return [query $args]
+ }
+ }
+ unset success
+} else {
+ # no original unknown procedure defined, use the default method
+ proc unknown args {
+ return [query $args]
+ }
+}
Property changes on: media/tcl/init.tcl
___________________________________________________________________
Added: svn:eol-style
+ native
Modified: media/tcl/irc.tcl
===================================================================
--- media/tcl/irc.tcl 2009-07-28 14:53:48 UTC (rev 2213)
+++ media/tcl/irc.tcl 2009-07-28 14:54:36 UTC (rev 2214)
@@ -1,6 +1,6 @@
-proc every {ms body} { eval $body; after $ms [list every $ms $body] }
-package require irk
-set conn [irk::connect orxonox $nickname]
-irk::join $conn #orxonox
-every 25 {}
-vwait termination
+proc every {ms body} { eval $body; after $ms [list every $ms $body] }
+package require irk
+set conn [irk::connect orxonox $nickname]
+irk::join $conn #orxonox
+every 25 {}
+vwait termination
Property changes on: media/tcl/irc.tcl
___________________________________________________________________
Added: svn:eol-style
+ native
Modified: media/tcl/remote.tcl
===================================================================
--- media/tcl/remote.tcl 2009-07-28 14:53:48 UTC (rev 2213)
+++ media/tcl/remote.tcl 2009-07-28 14:54:36 UTC (rev 2214)
@@ -1,2 +1,2 @@
-set telnetserverthreadid [TclThreadManager create]
-TclThreadManager execute $telnetserverthreadid source $pld/telnet_server.tcl
+set telnetserverthreadid [TclThreadManager create]
+TclThreadManager execute $telnetserverthreadid source $pld/telnet_server.tcl
Property changes on: media/tcl/remote.tcl
___________________________________________________________________
Added: svn:eol-style
+ native
Modified: media/tcl/telnet_server.tcl
===================================================================
--- media/tcl/telnet_server.tcl 2009-07-28 14:53:48 UTC (rev 2213)
+++ media/tcl/telnet_server.tcl 2009-07-28 14:54:36 UTC (rev 2214)
@@ -1,213 +1,213 @@
- #!/usr/bin/env tclsh
- # Pseudo-telnet server. Includes basic auth, but no separate identities
- # or proper multi-threaded operation, so whoever runs this had better
- # trust those he gives identities/passwords to and they had better trust
- # each other too. Note this script does not support command-line arguments.
-
- ## The names of this array are IP addresses of hosts that are not permitted
- ## to connect to any of our services. Admin account(s) can change this
- ## at run-time, though this info is not maintained across whole-server shutdowns.
- array set denyHosts {}
-
- ## Keep the Tcl-thread busy
- proc every {ms body} { eval $body; after $ms [list every $ms $body] }
- every 200 {}
-
- ## Create a server on the given port with the given name/password map
- ## and the given core interaction handler.
- proc telnetServer {port {passmap} {handlerCmd remoteCommand}} {
- if {$port == 0} {
- return -code error "Only non-zero port numbers are supported"
- }
- set server [socket -server [list connect $port $handlerCmd] $port]
- global passwords services
- foreach {id pass} $passmap {set passwords($port,$id) $pass}
- set services($server) $handlerCmd
- return $server
- }
-
- ## Removes the server on the given port, cleaning up the extra state too.
- proc closedownServer {server} {
- global services passwords connections auth
- set port [lindex [fconfigure $server -sockname] 2]
- catch {close $server}
- unset services($server)
- foreach passmap [array names passwords $port,*] {
- unset passwords($passmap)
- }
- # Hmph! Have to remove unauthorized connections too, though any
- # connection which has been authorized can continue safely.
- foreach {client data} [array get connections] {
- if {$port == [lindex $data 0] && !$auth($client)} {
- disconnect $client
- }
- }
- }
-
- ## Handle an incoming connection to the given server
- proc connect {serverport handlerCmd client clienthost clientport} {
- global auth cmd denyHosts connections
- if {[info exist denyHosts($clienthost)]} {
- puts stdout "${clienthost}:${clientport} attempted connection"
- catch {puts $client "Connection denied"}
- catch {close $client}
- return
- }
- puts stdout "${clienthost}:${clientport} connected on $client"
- fileevent $client readable "handle $serverport $client"
- set auth($client) 0
- set cmd($client) $handlerCmd
- set connections($client) [list $serverport $clienthost $clientport]
- fconfigure $client -buffering none
- catch {puts -nonewline $client "Login: "}
- }
-
- ## Disconnect the given client, cleaning up any connection-specific data
- proc disconnect {client} {
- catch {close $client}
- global auth cmd connections
- unset auth($client)
- unset cmd($client)
- unset connections($client)
- puts stdout "$client disconnected"
- }
-
- ## Handle data sent from the client. Log-in is handled directly by this
- ## procedure, and requires the name and password on the same line
- proc handle {serverport client} {
- global passwords auth cmd
- if {[gets $client line] < 0} {
- disconnect $client
- return
- }
- if {[string equal $line "logout"] || [string equal $line "quit"]} {
- disconnect $client
- return
- }
- if {[string equal $line "exit"]} {
- set ::termination 1
- return
- }
- if {$auth($client)} {
- eval $cmd($client) [list $client $line 0]
- eval $cmd($client) [list $client $line 1]
- return
- }
- foreach {id pass} [split $line] {break}
- if {![info exist pass]} {
- catch {puts -nonewline $client "Login: "}
- return
- }
- if {
- [info exist passwords($serverport,$id)] &&
- [string equal $passwords($serverport,$id) $pass]
- } then {
- set auth($client) 1
- puts stdout "$id logged in on $client"
- catch {puts $client "Welcome, $id!"}
- eval $cmd($client) [list $client $line 1]
- return
- }
- puts stdout "AUTH FAILURE ON $client"
- catch {puts $client "Unknown name or password"}
- disconnect $client
- }
-
- ## Standard handler for logged-in conversations and prompt-generation.
- proc execCommand {client line prompt} {
- global tcl_platform
- if {$prompt} {
- catch {puts -nonewline $client "\$ "}
- return
- }
- switch $tcl_platform(platform) {
- unix {
- catch {exec sh -c $line <@$client >@$client 2>@$client}
- }
- default {
- catch {exec $line} data
- puts $client $data
- }
- }
- }
-
- ## Administration service handler. Chains to the normal handler for
- ## everything it doesn't recognise itself.
- proc admin {client line prompt} {
- if {$prompt} {
- catch {puts -nonewline $client "# "}
- return
- }
- set cmd [split $line]
- global denyHosts connections services
- if {[string equal $line "shutdown"]} {
- set ::termination 1
- puts stdout "Shutdown requested on $client"
- catch {puts $client "System will shut down as soon as possible"}
- return -code return "SHUTTING DOWN"
- } elseif {[string equal [lindex $cmd 0] "deny"]} {
- set denyHosts([lindex $cmd 1]) 1
- } elseif {[string equal [lindex $cmd 0] "allow"]} {
- catch {unset denyHosts([lindex $cmd 1])}
- } elseif {[string equal $line "denied"]} {
- foreach host [array names denyHosts] {
- catch {puts $client $host}
- }
- } elseif {[string equal $line "connections"]} {
- set len 0
- foreach conn [array names connections] {
- if {$len < [string length $conn]} {
- set len [string length $conn]
- }
- }
- foreach {conn details} [array get connections] {
- catch {puts $client [format "%-*s = %s" $len $conn $details]}
- }
- } elseif {[string equal [lindex $cmd 0] "close"]} {
- set sock [lindex $cmd 1]
- if {[info exist connections($sock)]} {
- disconnect $sock
- }
- } elseif {[string equal $line "services"]} {
- set len 0
- foreach serv [array names services] {
- if {$len < [string length $serv]} {
- set len [string length $serv]
- }
- }
- foreach {serv handler} [array get services] {
- set port [lindex [fconfigure $serv -sockname] 2]
- catch {puts $client [format "%-*s (port %d) = handler %s" $len $serv $port $handler]}
- }
- } elseif {[string equal [lindex $cmd 0] "addService"]} {
- set service [eval telnetServer [lrange $cmd 1 end]]
- catch {puts $client "Created service as $service"}
- } elseif {[string equal [lindex $cmd 0] "removeService"]} {
- set service [lindex $cmd 1]
- if {[info exist services($service)]} {
- closedownServer $service
- }
- } else {
- # CHAIN TO DEFAULT
- execCommand $client $line 0
- }
- }
-
- ## Executes a given command
- proc remoteCommand {client line prompt} {
- global tcl_platform
- if {$prompt} {
- catch {puts -nonewline $client "\$ "}
- return
- }
- catch {eval $line} data
- puts $client $data
- }
-
- telnetServer 2560 {orxonox rocks} remoteCommand
- telnetServer 2561 {orxadmin *****} admin
-
- puts stdout "Ready for service"
-
- vwait termination
- execute exit
+ #!/usr/bin/env tclsh
+ # Pseudo-telnet server. Includes basic auth, but no separate identities
+ # or proper multi-threaded operation, so whoever runs this had better
+ # trust those he gives identities/passwords to and they had better trust
+ # each other too. Note this script does not support command-line arguments.
+
+ ## The names of this array are IP addresses of hosts that are not permitted
+ ## to connect to any of our services. Admin account(s) can change this
+ ## at run-time, though this info is not maintained across whole-server shutdowns.
+ array set denyHosts {}
+
+ ## Keep the Tcl-thread busy
+ proc every {ms body} { eval $body; after $ms [list every $ms $body] }
+ every 200 {}
+
+ ## Create a server on the given port with the given name/password map
+ ## and the given core interaction handler.
+ proc telnetServer {port {passmap} {handlerCmd remoteCommand}} {
+ if {$port == 0} {
+ return -code error "Only non-zero port numbers are supported"
+ }
+ set server [socket -server [list connect $port $handlerCmd] $port]
+ global passwords services
+ foreach {id pass} $passmap {set passwords($port,$id) $pass}
+ set services($server) $handlerCmd
+ return $server
+ }
+
+ ## Removes the server on the given port, cleaning up the extra state too.
+ proc closedownServer {server} {
+ global services passwords connections auth
+ set port [lindex [fconfigure $server -sockname] 2]
+ catch {close $server}
+ unset services($server)
+ foreach passmap [array names passwords $port,*] {
+ unset passwords($passmap)
+ }
+ # Hmph! Have to remove unauthorized connections too, though any
+ # connection which has been authorized can continue safely.
+ foreach {client data} [array get connections] {
+ if {$port == [lindex $data 0] && !$auth($client)} {
+ disconnect $client
+ }
+ }
+ }
+
+ ## Handle an incoming connection to the given server
+ proc connect {serverport handlerCmd client clienthost clientport} {
+ global auth cmd denyHosts connections
+ if {[info exist denyHosts($clienthost)]} {
+ puts stdout "${clienthost}:${clientport} attempted connection"
+ catch {puts $client "Connection denied"}
+ catch {close $client}
+ return
+ }
+ puts stdout "${clienthost}:${clientport} connected on $client"
+ fileevent $client readable "handle $serverport $client"
+ set auth($client) 0
+ set cmd($client) $handlerCmd
+ set connections($client) [list $serverport $clienthost $clientport]
+ fconfigure $client -buffering none
+ catch {puts -nonewline $client "Login: "}
+ }
+
+ ## Disconnect the given client, cleaning up any connection-specific data
+ proc disconnect {client} {
+ catch {close $client}
+ global auth cmd connections
+ unset auth($client)
+ unset cmd($client)
+ unset connections($client)
+ puts stdout "$client disconnected"
+ }
+
+ ## Handle data sent from the client. Log-in is handled directly by this
+ ## procedure, and requires the name and password on the same line
+ proc handle {serverport client} {
+ global passwords auth cmd
+ if {[gets $client line] < 0} {
+ disconnect $client
+ return
+ }
+ if {[string equal $line "logout"] || [string equal $line "quit"]} {
+ disconnect $client
+ return
+ }
+ if {[string equal $line "exit"]} {
+ set ::termination 1
+ return
+ }
+ if {$auth($client)} {
+ eval $cmd($client) [list $client $line 0]
+ eval $cmd($client) [list $client $line 1]
+ return
+ }
+ foreach {id pass} [split $line] {break}
+ if {![info exist pass]} {
+ catch {puts -nonewline $client "Login: "}
+ return
+ }
+ if {
+ [info exist passwords($serverport,$id)] &&
+ [string equal $passwords($serverport,$id) $pass]
+ } then {
+ set auth($client) 1
+ puts stdout "$id logged in on $client"
+ catch {puts $client "Welcome, $id!"}
+ eval $cmd($client) [list $client $line 1]
+ return
+ }
+ puts stdout "AUTH FAILURE ON $client"
+ catch {puts $client "Unknown name or password"}
+ disconnect $client
+ }
+
+ ## Standard handler for logged-in conversations and prompt-generation.
+ proc execCommand {client line prompt} {
+ global tcl_platform
+ if {$prompt} {
+ catch {puts -nonewline $client "\$ "}
+ return
+ }
+ switch $tcl_platform(platform) {
+ unix {
+ catch {exec sh -c $line <@$client >@$client 2>@$client}
+ }
+ default {
+ catch {exec $line} data
+ puts $client $data
+ }
+ }
+ }
+
+ ## Administration service handler. Chains to the normal handler for
+ ## everything it doesn't recognise itself.
+ proc admin {client line prompt} {
+ if {$prompt} {
+ catch {puts -nonewline $client "# "}
+ return
+ }
+ set cmd [split $line]
+ global denyHosts connections services
+ if {[string equal $line "shutdown"]} {
+ set ::termination 1
+ puts stdout "Shutdown requested on $client"
+ catch {puts $client "System will shut down as soon as possible"}
+ return -code return "SHUTTING DOWN"
+ } elseif {[string equal [lindex $cmd 0] "deny"]} {
+ set denyHosts([lindex $cmd 1]) 1
+ } elseif {[string equal [lindex $cmd 0] "allow"]} {
+ catch {unset denyHosts([lindex $cmd 1])}
+ } elseif {[string equal $line "denied"]} {
+ foreach host [array names denyHosts] {
+ catch {puts $client $host}
+ }
+ } elseif {[string equal $line "connections"]} {
+ set len 0
+ foreach conn [array names connections] {
+ if {$len < [string length $conn]} {
+ set len [string length $conn]
+ }
+ }
+ foreach {conn details} [array get connections] {
+ catch {puts $client [format "%-*s = %s" $len $conn $details]}
+ }
+ } elseif {[string equal [lindex $cmd 0] "close"]} {
+ set sock [lindex $cmd 1]
+ if {[info exist connections($sock)]} {
+ disconnect $sock
+ }
+ } elseif {[string equal $line "services"]} {
+ set len 0
+ foreach serv [array names services] {
+ if {$len < [string length $serv]} {
+ set len [string length $serv]
+ }
+ }
+ foreach {serv handler} [array get services] {
+ set port [lindex [fconfigure $serv -sockname] 2]
+ catch {puts $client [format "%-*s (port %d) = handler %s" $len $serv $port $handler]}
+ }
+ } elseif {[string equal [lindex $cmd 0] "addService"]} {
+ set service [eval telnetServer [lrange $cmd 1 end]]
+ catch {puts $client "Created service as $service"}
+ } elseif {[string equal [lindex $cmd 0] "removeService"]} {
+ set service [lindex $cmd 1]
+ if {[info exist services($service)]} {
+ closedownServer $service
+ }
+ } else {
+ # CHAIN TO DEFAULT
+ execCommand $client $line 0
+ }
+ }
+
+ ## Executes a given command
+ proc remoteCommand {client line prompt} {
+ global tcl_platform
+ if {$prompt} {
+ catch {puts -nonewline $client "\$ "}
+ return
+ }
+ catch {eval $line} data
+ puts $client $data
+ }
+
+ telnetServer 2560 {orxonox rocks} remoteCommand
+ telnetServer 2561 {orxadmin *****} admin
+
+ puts stdout "Ready for service"
+
+ vwait termination
+ execute exit
Property changes on: media/tcl/telnet_server.tcl
___________________________________________________________________
Added: svn:eol-style
+ native
More information about the Orxonox-commit
mailing list