[hkoba] Basic idea: [ssh] has port forwarding. It is ready-to-run MUX (multiplexer). With this, we can avoid re-inventing a MUX protocol on single ssh stream. Also, we already have proven package for script remoting: [comm]. So, I simply glued these two. ====== #!/usr/bin/tclsh # -*- mode: tcl; tab-width: 8 -*- # $Id: 13351,v 1.7 2005-12-19 07:01:24 jcw Exp $ # # Usage: # # set num [sshcomm::client::create $host] # comm::comm send $num {script...} package provide sshcomm 0.1 namespace eval ::sshcomm { namespace eval server {} namespace eval client { variable SCRIPT [info script] } } proc ::sshcomm::definition-of-proc {proc} { set args {} foreach var [info args $proc] { if {[info default $proc $var default]} { lappend args [list $var $default] } else { lappend args $var } } list proc $proc $args [info body $proc] } proc ::sshcomm::definition {{ns {}}} { if {$ns == ""} { return [definition [namespace current]] } else { set result {} append result [list namespace eval $ns {}]\n foreach proc [info procs [set ns]::*] { append result [definition-of-proc $proc]\n } foreach ns [namespace children $ns] { # puts "ns=$ns" append result [definition $ns]\n } set result } } proc ::sshcomm::sshcmd {} { set cmdName [namespace current]::sshcmd/$::tcl_platform(platform) if {[info procs $cmdName] != ""} { $cmdName } else { return "ssh -T" } } proc ::sshcomm::sshcmd/windows {} { return plink } ######################################### # Server # proc ::sshcomm::create-comm {port listen args} { lappend args -port $port -listen $listen if {[info exists ::comm::comm]} { eval [list ::comm::comm config] $args } else { namespace eval ::comm {variable comm; array set comm {comm,port 0}} package require comm unset ::comm::comm(comm,port) eval [list ::comm::comm new ::comm::comm] $args } } proc ::sshcomm::server::create {port args} { ::sshcomm::create-comm $port 1 puts "OK port $port" fileevent stdin readable [list [namespace current]::terminator stdin] keepalive vwait [namespace current]::forever } proc ::sshcomm::server::keepalive {{sec 30}} { puts [clock seconds] variable keepalive_id [after [expr {$sec * 1000}] \ [namespace code [info level 0]]] } proc ::sshcomm::server::terminator {fh args} { set count [gets $fh line] if {$count < 0} { close $fh exit } if {$count > 0} { uplevel \#0 $line } } ######################################### # Client # proc ::sshcomm::client::probe-available-port host { package require comm # To recycle local listener port set local [comm::comm self] comm::comm destroy ::comm::comm new ::comm::comm eval [list lappend cmd] [sshcomm::sshcmd] lappend cmd $host tclsh lappend cmd << { package require comm puts [comm::comm self] } set remote [eval [list exec] $cmd] list $local $host $remote } # ::sshcomm::client::create -- # # # # Arguments: # host remote hostname. # # Results: # comm id. proc ::sshcomm::client::create host { set forward [probe-available-port $host] if {[llength $forward] != 3} { error "Can't detect available ports for $host" } eval [list create-forward] $forward } proc ::sshcomm::client::create-forward {lport host rport} { set fh [connect $lport $host $rport] setup-server $fh $rport wait-server $lport $fh $rport } proc ::sshcomm::client::connect {lport host rport} { variable $lport; upvar 0 $lport data set cmd "| [sshcomm::sshcmd] -L $lport:localhost:$rport $host" append cmd " tclsh" set fh [open $cmd w+] fconfigure $fh -buffering line array set data [list fh $fh host $host rport $rport] set fh } proc ::sshcomm::client::setup-server {fh rport} { puts $fh { fconfigure stdout -buffering line fconfigure stderr -buffering line } puts $fh [sshcomm::definition] puts $fh {} puts $fh [list ::sshcomm::server::create $rport] flush $fh } proc ::sshcomm::client::wait-server {lport fh rport} { if {[gets $fh line] <= 0} { error "Can't invoke sshcomm!" } if {$line != "OK port $rport"} { error "Unknown result: $line" } fileevent $fh readable [list gets $fh [namespace current]::last-click] comm::comm connect $lport set lport } proc ::sshcomm::client::last-click {} { variable last-click set last-click } proc ::sshcomm::fread {fn} { set fh [open $fn] set data [read $fh] close $fh set data } ====== <> Package | Interprocess communication | Internet