utilities/shellbox.tcl

#!/usr/bin/tclsh

# shellbox.tcl
#
# This program serves as a box that runs a shell in it.
# stdout and stdin of the shell are connected to the box.
# If the shell uses stderr, you should wrap it in a script
# that redirects stderr to stdout.
#
# Whenever the shell dies, it will be restarted.
#
# Clients can connect to the box via TCP (e.g. with telnet).
# Any number of clients can connect at the same time. Input
# of all clients is merged. Output of the shell is broadcasted
# to all clients and to stdout of the box.
#
# When started with the -paranoid option, the box only accepts
# connections from localhost.
#
# The box intercepts the following commands:
#    exit or quit disconnect from the box
#    clients gives a list of all connected clients
#    kill terminates the shell
#

regsub -all {\$} {shellbox.tcl by Dirk Zimoch
$Source: /cvs/G/EPICS/App/scripts/shellbox.tcl,v $
$Revision: 1.6 $
$Date: 2003/06/26 12:55:49 $} {} version

proc createServer {port} {
    global paranoid
    if [catch {
        if $paranoid {
            socket -server connectionHandler -myaddr localhost $port
        } else {
            socket -server connectionHandler $port
        }
    } msg] {
        puts stderr "Can't install server on port $port"
        puts stderr $msg
        exit 2
    }
    puts "server started on port $port"
}

proc bgerror {args} {
    global errorInfo
    catch {puts stderr $errorInfo}
}

set channels {}

proc connectionHandler {channel addr port} {
    global channels command clientinfo
    set peer [fconfigure $channel -peername]
    set clientinfo($channel) [lindex $peer 1]:[lindex $peer 2]
    fconfigure $channel -blocking no -buffering none
    fileevent $channel readable "inputHandler $channel"
    forwardOutput "**** new client $clientinfo($channel) ****\n"
    catch {puts $channel "**** '$command' running ****"}
    lappend channels $channel
    catch {puts $channel "clients:\n[getClientlist]"}
    forwardInput "\n"
}

proc closeChannel {channel} {
    global channels clientinfo
    catch {puts $channel "**** see you later ****"}
    set index [lsearch $channels $channel]
    set channels [lreplace $channels $index $index]
    forwardOutput "**** client $clientinfo($channel) logged out ****\n"
    close $channel
    unset clientinfo($channel)
}

proc inputHandler {channel} {
    global echo
    set data [read $channel]
    if [eof $channel] {
        closeChannel $channel
        return
    }
    if $echo {forwardOutput $data $channel}
    binary scan $data H* hex
    switch $data {
        "clients\n" {forwardOutput "clients:\n[getClientlist]"}
        "exit\n"    {closeChannel $channel}
        "quit\n"    {closeChannel $channel}
        "kill\n"    {killProgram}
        default   {
            switch $hex {
                fff4fffd06 {closeChannel $channel}
                04         {closeChannel $channel}
                ffedfffd06 {closeChannel $channel}
                default    {forwardInput $data}
            }
        }
    }
}

proc forwardInput {data} {
    global pipe
    catch {puts -nonewline $pipe $data}
}

proc outputHandler {channel} {
    set data [read $channel]
    if [eof $channel] {
        global command diedyoung
        if $diedyoung {
            forwardOutput "**** first run of '$command' died within first 10 seconds. I will quit. ****\n"
            exit 4
        }
        forwardOutput "**** '$command' died ****\n"
        startProgram
        return
    }
    forwardOutput $data
}

proc forwardOutput {data {exclude ""}} {
    global channels
    catch {puts -nonewline $data}
    foreach channel $channels {
        if {$channel != $exclude} {
            catch {puts -nonewline $channel $data}
        }
    }
}

proc getClientlist {} {
    global channels clientinfo
    set result ""
    foreach channel $channels {
        append result "$clientinfo($channel)\n"
    }
    return $result
}

set diedyoung 1
proc startProgram {} {
    global command pipe diedyoung
    catch {close $pipe}
    after 10000 set diedyoung 0
    if [catch {
        set pipe [open |$command RDWR]
    } msg] {
        catch {puts stderr $msg}
        exit 3
    }
    fconfigure $pipe -blocking no -buffering none
    gets $pipe
    if [eof $pipe] {
        forwardOutput "**** '$command' died immediately. I will quit ****\n"
        exit 5
    }
    fileevent $pipe readable "outputHandler $pipe"
    forwardOutput "**** '$command' started ****\n"
}

proc killProgram {} {
    global pipe command
    close $pipe
    forwardOutput "**** '$command' killed ****\n"
    startProgram
}

set paranoid 0
set echo 0

while {[string match -* $argv]} {
    switch -exact -- [lindex $argv 0] {
        "-?" - "-help" {
                puts "usage: shellbox.tcl \[options\] port command ..."
                puts "options: -help     : show this text"
                puts "         -version  : show cvs release"
                puts "         -paranoid : allow connections from localhost only"
                puts "         -echo     : echo input of one client to all others"
                exit 0
            }
        "-v" - "-version" {puts $version; exit 0}
        "-paranoid" {set paranoid 1}
        "-echo" {set echo 1}
        default {puts stderr "unknown option [lindex $argv 0]"; exit 1}
    }
    set argv [lrange $argv 1 end]
}

set port [lindex $argv 0]
set command [lrange $argv 1 end]
if {![regexp {^[0-9]+$} $port] || [llength $command] == 0} {
    puts stderr "usage: [file tail $argv0] \[-paranoid\] <port> <command> \[args\]"
    exit 1
}

fconfigure stdout -buffering none
startProgram
createServer $port
vwait forever