#!/bin/sh
#
# multissh.tcl (version 0.1)
#
# Copyright 2005 Andy Goth <unununium@openverse.com>
# See http://ioioio.net/devel/multissh/ for the latest version.
# Or use the Wiki!  http://wiki.tcl.tk/multissh
#
#
#
# multissh allows you to simultaneously execute commands on multiple hosts.  It
# duplicates its stdin to each remote host, and it combines all stdout and
# stderr received from each host into its own stdout and stderr, prefixing each
# line with the host name.
#
#
#
# Changelog:
#
# Fri, Sep 23, 2005:
# - Created Wiki page
# - Wrote this header
# - Version 0.1
# Thu, Sep 22, 2005:
# - Initial coding
#
#
#
# This program is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
# details.
#
# A copy of the GNU General Public License can be obtained online at URL:
# http://www.gnu.org./licenses/gpl.txt
# or write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
# Boston, MA  02110-1301  USA
#
#
#
# Restart with tclsh\
exec tclsh "$0" ${1+"$@"}

# Adds a node to the list.
proc node_create {id chan name} {
    array set ::nodes [list\
        $id,chan $chan     \
        $id,name $name     \
    ]
    lappend ::nodes(dir) $id
}

# Removes a node from the list.
proc node_delete {id} {
    array unset ::nodes $id,*
    set index [lsearch -exact $::nodes(dir) $id]
    set ::nodes(dir) [lreplace $::nodes(dir) $index $index]
}

# Returns the number of nodes in the list.
proc node_count {} {
    return [llength $::nodes(dir)]
}

# Returns a list of all node ids.
proc node_list {} {
     return $::nodes(dir)
}

# Returns the channel associated with a node.
proc node_chan {id} {
    return $::nodes($id,chan)
}

# Returns the name of a node.
proc node_name {id} {
    return $::nodes($id,name)
}

# Waits for an update to the node list.
proc node_wait {} {
    vwait ::nodes
}

# Broadcasts data to all nodes.
proc node_broadcast {data} {
    # Send input data to all children.
    foreach id [node_list] {
        node_send $id $data
    }
}

# Sends data to a node.
proc node_send {id data} {
    if {[catch {
        # Send the data.
        puts -nonewline [node_chan $id] $data
        flush [node_chan $id]
    }]} {
        # Uh oh, error writing to child.
        node_close $id
    }
}

# Gets one line of data from a node
proc node_gets {id} {
    gets [node_chan $id]
}

# Closes a node.
proc node_close {id} {
    # Blocking must be reenabled in order to kill the child and get stderr.
    fconfigure [node_chan $id] -blocking true
    if {[catch {close [node_chan $id]} result]} {
        puts stderr "[node_name $id]: $result"
    }
    node_delete $id
}

# Returns true if a node's channel is blocked.
proc node_blocked {id} {
    return [fblocked [node_chan $id]]
}

# Returns true if a node's channel is at end of file.
proc node_eof {id} {
    return [eof [node_chan $id]]
}

# Broadcasts data to all remaining children.
proc broadcast {} {
    # Get the data.
    set data [read stdin]

    if {[eof stdin]} {
        # No more input data.
        close stdin

        # Filthy hack to work around Tcl's lack of support for closing
        # individual file descriptors in a read-write channel...
        #
        # BUG: This doesn't do the right thing, only an approximation thereof.
        # It should be closing the stdins of the children, but this isn't
        # possible with the current version of the Tcl commands.
        if {[info exists ::broadcast_seen_data]} {
            # Kill everything.
            foreach id [node_list] {
                node_close $id
            }
        }
    } else {
        # Send!
        set ::broadcast_seen_data true
        node_broadcast $data
    }
}

# Receives data from a child.
proc receive {id} {
    # Get the data.
    set data [node_gets $id]

    if {[node_blocked $id]} {
        # Don't have a complete line yet.
        return
    }

    if {![node_eof $id] || $data ne ""} {
        # Send received data to stdout.
        puts stdout "[node_name $id]: $data"
    }

    if {[node_eof $id]} {
        # Child quit.
        node_close $id
    }
}

proc main {argv} {
    if {[llength $argv] != 2} {
        puts stderr "Usage: multissh \"list of nodes\" \"command to execute\""
        exit 1
    }

    # Grab arguments.
    set node_list [lindex $argv 0]
    set command_line [lindex $argv 1]

    # Create child processes.
    set id 0
    foreach name $node_list {
        if {[catch {open |[list ssh -e none $name $command_line] a+} result]} {
            # Failure to start ssh. 
            puts stderr "$name: $result"
        } else {
            # Success.
            fconfigure $result -blocking false -buffering line\
                    -translation binary
            node_create $id $result $name
            fileevent $result readable [list receive $id]
            incr id
        }
    }

    # Arrange to broadcast all data from stdin to all children.
    fconfigure stdin -blocking false -buffering none -translation binary
    fileevent stdin readable broadcast

    # Wait for all children to quit.
    while {[node_count] != 0} {
        node_wait
    }
}

main $argv

# vim: set ts=4 sts=4 sw=4 tw=80 et ft=tcl: