# -*- tcl -*- Tcl Module ########## Repository Information Block ### # @@ Meta Begin # Package comm 4.4 # Meta as::origin http://sf.net/projects/tcllib # Meta category Remote communication # Meta description A remote communication facility for Tcl (7.6, 8.0, and # Meta description later) # Meta license BSD # Meta platform tcl # Meta require {Tcl 8} # @@ Meta End ########## ########## Requirements Enforcement Code ### package require Tcl 8 ########## ########## Package Declaration Code ### package provide comm 4.4 ########## # comm.tcl -- # # socket-based 'send'ing of commands between interpreters. # # %%_OSF_FREE_COPYRIGHT_%% # Copyright (C) 1995-1998 The Open Group. All Rights Reserved. # (Please see the file "comm.LICENSE" that accompanied this source, # or http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html) # Copyright (c) 2003 ActiveState Corporation # # This is the 'comm' package written by Jon Robert LoVerso, placed # into its own namespace during integration into tcllib. # # Note that the actual code was changed in several places (Reordered, # eval speedup) # # comm works just like Tk's send, except that it uses sockets. # These commands work just like "send" and "winfo interps": # # comm send ?-async? ? ...? # comm interps # # See the manual page comm.n for further details on this package. # # RCS: @(#) $Id: comm.tcl,v 1.22 2006/09/19 23:36:15 andreas_kupries Exp $ package require Tcl 8.2 namespace eval ::comm { namespace export comm comm_send variable comm array set comm {} if {![info exists comm(chans)]} { array set comm { debug 0 chans {} localhost 127.0.0.1 connecting,hook 1 connected,hook 1 incoming,hook 1 eval,hook 1 callback,hook 1 reply,hook 1 lost,hook 1 offerVers {3 2} acceptVers {3 2} defVers 2 defaultEncoding "utf-8" defaultSilent 0 } set comm(lastport) [expr {[pid] % 32768 + 9999}] # fast check for acceptable versions foreach comm(_x) $comm(acceptVers) { set comm($comm(_x),vers) 1 } catch {unset comm(_x)} } # Class variables: # lastport saves last default listening port allocated # debug enable debug output # chans list of allocated channels # # Channel instance variables: # comm() # $ch,port listening port (our id) # $ch,socket listening socket # $ch,silent boolean to indicate whether to throw error on # protocol negotiation failure # $ch,local boolean to indicate if port is local # $ch,interp interpreter to run received scripts in. # If not empty we own it! = We destroy it # with the channel # $ch,events List of hoks to run in the 'interp', if defined # $ch,serial next serial number for commands # # $ch,hook,$hook script for hook $hook # # $ch,peers,$id open connections to peers; ch,id=>fid # $ch,fids,$fid reverse mapping for peers; ch,fid=>id # $ch,vers,$id negotiated protocol version for id # $ch,pending,$id list of outstanding send serial numbers for id # # $ch,buf,$fid buffer to collect incoming data # $ch,result,$serial result value set here to wake up sender # $ch,return,$serial return codes to go along with result if {0} { # Propagate result, code, and errorCode. Can't just eval # otherwise TCL_BREAK gets turned into TCL_ERROR. global errorInfo errorCode set code [catch [concat commSend $args] res] return -code $code -errorinfo $errorInfo -errorcode $errorCode $res } } # ::comm::comm_send -- # # Convenience command. Replaces Tk 'send' and 'winfo' with # versions using the 'comm' variants. Multiple calls are # allowed, only the first one will have an effect. # # Arguments: # None. # # Results: # None. proc ::comm::comm_send {} { proc send {args} { # Use pure lists to speed this up. uplevel 1 [linsert $args 0 ::comm::comm send] } rename winfo tk_winfo proc winfo {cmd args} { if {![string match in* $cmd]} { # Use pure lists to speed this up ... return [uplevel 1 [linsert $args 0 tk_winfo $cmd]] } return [::comm::comm interps] } proc ::comm::comm_send {} {} } # ::comm::comm -- # # See documentation for public methods of "comm". # This procedure is followed by the definition of # the public methods themselves. # # Arguments: # cmd Invoked method # args Arguments to method. # # Results: # As of the invoked method. proc ::comm::comm {cmd args} { set method [info commands ::comm::comm_cmd_$cmd*] if {[llength $method] == 1} { set chan ::comm::comm; # passed to methods return [uplevel 1 [linsert $args 0 $method $chan]] } else { foreach c [info commands ::comm::comm_cmd_*] { # remove ::comm::comm_cmd_ lappend cmds [string range $c 17 end] } return -code error "unknown subcommand \"$cmd\":\ must be one of [join [lsort $cmds] {, }]" } } proc ::comm::comm_cmd_connect {chan args} { uplevel 1 [linsert $args 0 [namespace current]::commConnect $chan] } proc ::comm::comm_cmd_self {chan args} { variable comm return $comm($chan,port) } proc ::comm::comm_cmd_channels {chan args} { variable comm return $comm(chans) } proc ::comm::comm_cmd_configure {chan args} { uplevel 1 [linsert $args 0 [namespace current]::commConfigure $chan 0] } proc ::comm::comm_cmd_ids {chan args} { variable comm set res $comm($chan,port) foreach {i id} [array get comm $chan,fids,*] {lappend res $id} return $res } interp alias {} ::comm::comm_cmd_interps {} ::comm::comm_cmd_ids proc ::comm::comm_cmd_remoteid {chan args} { variable comm if {[info exists comm($chan,remoteid)]} { set comm($chan,remoteid) } else { return -code error "No remote commands processed yet" } } proc ::comm::comm_cmd_debug {chan bool} { variable comm return [set comm(debug) [string is true -strict $bool]] } # hook -- # # Internal command. Implements 'comm hook'. # # Arguments: # hook hook to modify # script Script to add/remove to/from the hook # # Results: # None. # proc ::comm::comm_cmd_hook {chan hook {script +}} { variable comm if {![info exists comm($hook,hook)]} { return -code error "Unknown hook invoked" } if {!$comm($hook,hook)} { return -code error "Unimplemented hook invoked" } if {[string equal + $script]} { if {[catch {set comm($chan,hook,$hook)} ret]} { return } return $ret } if {[string match +* $script]} { append comm($chan,hook,$hook) \n [string range $script 1 end] } else { set comm($chan,hook,$hook) $script } return } # abort -- # # Close down all peer connections. # Implements the 'comm abort' method. # # Arguments: # None. # # Results: # None. proc ::comm::comm_cmd_abort {chan} { variable comm foreach pid [array names comm $chan,peers,*] { commLostConn $chan $comm($pid) "Connection aborted by request" } } # destroy -- # # Destroy the channel invoking it. # Implements the 'comm destroy' method. # # Arguments: # None. # # Results: # None. # proc ::comm::comm_cmd_destroy {chan} { variable comm catch {close $comm($chan,socket)} comm_cmd_abort $chan if {$comm($chan,interp) != {}} { interp delete $comm($chan,interp) } catch {unset comm($chan,port)} catch {unset comm($chan,local)} catch {unset comm($chan,silent)} catch {unset comm($chan,interp)} catch {unset comm($chan,events)} catch {unset comm($chan,socket)} catch {unset comm($chan,remoteid)} unset comm($chan,serial) unset comm($chan,chan) unset comm($chan,encoding) unset comm($chan,listen) # array unset would have been nicer, but is not available in # 8.2/8.3 foreach pattern {hook,* interp,* vers,*} { foreach k [array names comm $chan,$pattern] {unset comm($k)} } set pos [lsearch -exact $comm(chans) $chan] set comm(chans) [lreplace $comm(chans) $pos $pos] if {![string equal ::comm::comm $chan]} { rename $chan {} } return } # shutdown -- # # Close down a peer connection. # Implements the 'comm shutdown' method. # # Arguments: # id Reference to the remote interp # # Results: # None. # proc ::comm::comm_cmd_shutdown {chan id} { variable comm if {[info exists comm($chan,peers,$id)]} { commLostConn $chan $comm($chan,peers,$id) \ "Connection shutdown by request" } } # new -- # # Create a new comm channel/instance. # Implements the 'comm new' method. # # Arguments: # ch Name of the new channel # args Configuration, in the form of -option value pairs. # # Results: # None. # proc ::comm::comm_cmd_new {chan ch args} { variable comm if {[lsearch -exact $comm(chans) $ch] >= 0} { return -code error "Already existing channel: $ch" } if {([llength $args] % 2) != 0} { return -code error "Must have an even number of config arguments" } # ensure that the new channel name is fully qualified set ch ::[string trimleft $ch :] if {[string equal ::comm::comm $ch]} { # allow comm to be recreated after destroy } elseif {[string equal $ch [info commands $ch]]} { return -code error "Already existing command: $ch" } else { # Create the new channel with fully qualified proc name proc $ch {cmd args} { set method [info commands ::comm::comm_cmd_$cmd*] if {[llength $method] == 1} { # this should work right even if aliased # it is passed to methods to identify itself set chan [namespace origin [lindex [info level 0] 0]] return [uplevel 1 [linsert $args 0 $method $chan]] } else { foreach c [info commands ::comm::comm_cmd_*] { # remove ::comm::comm_cmd_ lappend cmds [string range $c 17 end] } return -code error "unknown subcommand \"$cmd\":\ must be one of [join [lsort $cmds] {, }]" } } } lappend comm(chans) $ch set chan $ch set comm($chan,serial) 0 set comm($chan,chan) $chan set comm($chan,port) 0 set comm($chan,listen) 0 set comm($chan,socket) "" set comm($chan,local) 1 set comm($chan,silent) $comm(defaultSilent) set comm($chan,encoding) $comm(defaultEncoding) set comm($chan,interp) {} set comm($chan,events) {} if {[llength $args] > 0} { if {[catch [linsert $args 0 commConfigure $chan 1] err]} { comm_cmd_destroy $chan return -code error $err } } return $chan } # send -- # # Send command to a specified channel. # Implements the 'comm send' method. # # Arguments: # args see inside # # Results: # varies. # proc ::comm::comm_cmd_send {chan args} { variable comm set cmd send # args = ?-async | -command command? id cmd ?arg arg ...? set i 0 set opt [lindex $args $i] if {[string equal -async $opt]} { set cmd async incr i } elseif {[string equal -command $opt]} { set cmd command set callback [lindex $args [incr i]] incr i } # args = id cmd ?arg arg ...? set id [lindex $args $i] incr i set args [lrange $args $i end] if {![info complete $args]} { return -code error "Incomplete command" } if {![llength $args]} { return -code error \ "wrong # args: should be \"send ?-async? id arg ?arg ...?\"" } if {[catch {commConnect $chan $id} fid]} { return -code error "Connect to remote failed: $fid" } set ser [incr comm($chan,serial)] # This is unneeded - wraps from 2147483647 to -2147483648 ### if {$comm($chan,serial) == 0x7fffffff} {set comm($chan,serial) 0} commDebug {puts stderr "<$chan> send <[list [list $cmd $ser $args]]>"} # The double list assures that the command is a single list when read. puts $fid [list [list $cmd $ser $args]] flush $fid commDebug {puts stderr "<$chan> sent"} # wait for reply if so requested if {[string equal command $cmd]} { # In this case, don't wait on the command result. Set the callback # in the return and that will be invoked by the result. lappend comm($chan,pending,$id) [list $ser callback] set comm($chan,return,$ser) $callback return $ser } elseif {[string equal send $cmd]} { upvar 0 comm($chan,pending,$id) pending ;# shorter variable name lappend pending $ser set comm($chan,return,$ser) "" ;# we're waiting commDebug {puts stderr "<$chan> --<>--"} vwait ::comm::comm($chan,result,$ser) # if connection was lost, pending is gone if {[info exists pending]} { set pos [lsearch -exact $pending $ser] set pending [lreplace $pending $pos $pos] } commDebug { puts stderr "<$chan> result\ <$comm($chan,return,$ser);$comm($chan,result,$ser)>" } after idle unset ::comm::comm($chan,result,$ser) array set return $comm($chan,return,$ser) unset comm($chan,return,$ser) switch -- $return(-code) { "" - 0 {return $comm($chan,result,$ser)} 1 { return -code $return(-code) \ -errorinfo $return(-errorinfo) \ -errorcode $return(-errorcode) \ $comm($chan,result,$ser) } default {return -code $return(-code) $comm($chan,result,$ser)} } } } ############################################################################### # ::comm::commDebug -- # # Internal command. Conditionally executes debugging # statements. Currently this are only puts commands logging the # various interactions. These could be replaced with calls into # the 'log' module. # # Arguments: # arg Tcl script to execute. # # Results: # None. proc ::comm::commDebug {cmd} { variable comm if {$comm(debug)} { uplevel 1 $cmd } } # ::comm::commConfVars -- # # Internal command. Used to declare configuration options. # # Arguments: # v Name of configuration option. # t Default value. # # Results: # None. proc ::comm::commConfVars {v t} { variable comm set comm($v,var) $t set comm(vars) {} foreach c [array names comm *,var] { lappend comm(vars) [lindex [split $c ,] 0] } return } ::comm::commConfVars port p ::comm::commConfVars local b ::comm::commConfVars listen b ::comm::commConfVars socket ro ::comm::commConfVars chan ro ::comm::commConfVars serial ro ::comm::commConfVars encoding enc ::comm::commConfVars silent b ::comm::commConfVars interp interp ::comm::commConfVars events ev # ::comm::commConfigure -- # # Internal command. Implements 'comm configure'. # # Arguments: # force Boolean flag. If set the socket is reinitialized. # args New configuration, as -option value pairs. # # Results: # None. proc ::comm::commConfigure {chan {force 0} args} { variable comm # query if {[llength $args] == 0} { foreach v $comm(vars) {lappend res -$v $comm($chan,$v)} return $res } elseif {[llength $args] == 1} { set arg [lindex $args 0] set var [string range $arg 1 end] if {![string match -* $arg] || ![info exists comm($var,var)]} { return -code error "Unknown configuration option: $arg" } return $comm($chan,$var) } # set set opt 0 foreach arg $args { incr opt if {[info exists skip]} {unset skip; continue} set var [string range $arg 1 end] if {![string match -* $arg] || ![info exists comm($var,var)]} { return -code error "Unknown configuration option: $arg" } set optval [lindex $args $opt] switch $comm($var,var) { ev { if {![string equal $optval ""]} { set err 0 if {[catch { foreach ev $optval { if {[lsearch -exact {connecting connected incoming eval callback reply lost} $ev] < 0} { set err 1 break } } }]} { set err 1 } if {$err} { return -code error \ "Non-event to configuration option: -$var" } } # FRINK: nocheck set $var $optval set skip 1 } interp { if { ![string equal $optval ""] && ![interp exists $optval] } { return -code error \ "Non-interpreter to configuration option: -$var" } # FRINK: nocheck set $var $optval set skip 1 } b { # FRINK: nocheck set $var [string is true -strict $optval] set skip 1 } v { # FRINK: nocheck set $var $optval set skip 1 } p { if { ![string equal $optval ""] && ![string is integer $optval] } { return -code error \ "Non-port to configuration option: -$var" } # FRINK: nocheck set $var $optval set skip 1 } i { if {![string is integer $optval]} { return -code error \ "Non-integer to configuration option: -$var" } # FRINK: nocheck set $var $optval set skip 1 } enc { # to configure encodings, we will need to extend the # protocol to allow for handshaked encoding changes return -code error "encoding not configurable" if {[lsearch -exact [encoding names] $optval] == -1} { return -code error \ "Unknown encoding to configuration option: -$var" } set $var $optval set skip 1 } ro { return -code error "Readonly configuration option: -$var" } } } if {[info exists skip]} { return -code error "Missing value for option: $arg" } foreach var {port listen local} { # FRINK: nocheck if {[info exists $var] && [set $var] != $comm($chan,$var)} { incr force # FRINK: nocheck set comm($chan,$var) [set $var] } } foreach var {silent interp events} { # FRINK: nocheck if {[info exists $var] && ([set $var] != $comm($chan,$var))} { # FRINK: nocheck set comm($chan,$var) [set ip [set $var]] if {[string equal $var "interp"] && ($ip != "")} { # Interrogate the interp about its capabilities. # # Like: set, array set, uplevel present ? # Or: The above, hidden ? # # This is needed to decide how to execute hook scripts # and regular scripts in this interpreter. set comm($chan,interp,set) [Capability $ip set] set comm($chan,interp,aset) [Capability $ip array] set comm($chan,interp,upl) [Capability $ip uplevel] } } } if {[info exists encoding] && ![string equal $encoding $comm($chan,encoding)]} { # This should not be entered yet set comm($chan,encoding) $encoding fconfigure $comm($chan,socket) -encoding $encoding foreach {i sock} [array get comm $chan,peers,*] { fconfigure $sock -encoding $encoding } } # do not re-init socket if {!$force} {return ""} # User is recycling object, possibly to change from local to !local if {[info exists comm($chan,socket)]} { comm_cmd_abort $chan catch {close $comm($chan,socket)} unset comm($chan,socket) } set comm($chan,socket) "" if {!$comm($chan,listen)} { set comm($chan,port) 0 return "" } if {[info exists port] && [string equal "" $comm($chan,port)]} { set nport [incr comm(lastport)] } else { set userport 1 set nport $comm($chan,port) } while {1} { set cmd [list socket -server [list ::comm::commIncoming $chan]] if {$comm($chan,local)} { lappend cmd -myaddr $comm(localhost) } lappend cmd $nport if {![catch $cmd ret]} { break } if {[info exists userport] || ![string match "*already in use" $ret]} { # don't eradicate the class if {![string equal ::comm::comm $chan]} { rename $chan {} } return -code error $ret } set nport [incr comm(lastport)] } set comm($chan,socket) $ret fconfigure $ret -translation lf -encoding $comm($chan,encoding) # If port was 0, system allocated it for us set comm($chan,port) [lindex [fconfigure $ret -sockname] 2] return "" } # ::comm::Capability -- # # Internal command. Interogate an interp for # the commands needed to execute regular and # hook scripts. proc ::comm::Capability {interp cmd} { if {[lsearch -exact [interp hidden $interp] $cmd] >= 0} { # The command is present, although hidden. return hidden } # The command is not a hidden command. Use info to determine if it # is present as regular command. Note that the 'info' command # itself might be hidden. if {[catch { set has [llength [interp eval $interp [list info commands $cmd]]] }] && [catch { set has [llength [interp invokehidden $interp info commands $cmd]] }]} { # Unable to interogate the interpreter in any way. Assume that # the command is not present. set has 0 } return [expr {$has ? "ok" : "no"}] } # ::comm::commConnect -- # # Internal command. Called to connect to a remote interp # # Arguments: # id Specification of the location of the remote interp. # A list containing either one or two elements. # One element = port, host is localhost. # Two elements = port and host, in this order. # # Results: # fid channel handle of the socket the connection goes through. proc ::comm::commConnect {chan id} { variable comm commDebug {puts stderr "<$chan> commConnect $id"} # process connecting hook now CommRunHook $chan connecting if {[info exists comm($chan,peers,$id)]} { return $comm($chan,peers,$id) } if {[lindex $id 0] == 0} { return -code error "Remote comm is anonymous; cannot connect" } if {[llength $id] > 1} { set host [lindex $id 1] } else { set host $comm(localhost) } set port [lindex $id 0] set fid [socket $host $port] # process connected hook now if {[catch { CommRunHook $chan connected } err]} { global errorInfo set ei $errorInfo close $fid error $err $ei } # commit new connection commNewConn $chan $id $fid # send offered protocols versions and id to identify ourselves to remote puts $fid [list $comm(offerVers) $comm($chan,port)] set comm($chan,vers,$id) $comm(defVers) ;# default proto vers flush $fid return $fid } # ::comm::commIncoming -- # # Internal command. Called for an incoming new connection. # Handles connection setup and initialization. # # Arguments: # chan logical channel handling the connection. # fid channel handle of the socket running the connection. # addr ip address of the socket channel 'fid' # remport remote port for the socket channel 'fid' # # Results: # None. proc ::comm::commIncoming {chan fid addr remport} { variable comm commDebug {puts stderr "<$chan> commIncoming $fid $addr $remport"} # process incoming hook now if {[catch { CommRunHook $chan incoming } err]} { global errorInfo set ei $errorInfo close $fid error $err $ei } # a list of offered proto versions is the first word of first line # remote id is the second word of first line # rest of first line is ignored set protoline [gets $fid] set offeredvers [lindex $protoline 0] set remid [lindex $protoline 1] commDebug {puts stderr "<$chan> offered <$protoline>"} # use the first supported version in the offered list foreach v $offeredvers { if {[info exists comm($v,vers)]} { set vers $v break } } if {![info exists vers]} { close $fid if {[info exists comm($chan,silent)] && [string is true -strict $comm($chan,silent)]} then return error "Unknown offered protocols \"$protoline\" from $addr/$remport" } # If the remote host addr isn't our local host addr, # then add it to the remote id. if {[string equal [lindex [fconfigure $fid -sockname] 0] $addr]} { set id $remid } else { set id [list $remid $addr] } # Detect race condition of two comms connecting to each other # simultaneously. It is OK when we are talking to ourselves. if {[info exists comm($chan,peers,$id)] && $id != $comm($chan,port)} { puts stderr "commIncoming race condition: $id" puts stderr "peers=$comm($chan,peers,$id) port=$comm($chan,port)" # To avoid the race, we really want to terminate one connection. # However, both sides are committed to using it. # commConnect needs to be synchronous and detect the close. # close $fid # return $comm($chan,peers,$id) } # Make a protocol response. Avoid any temptation to use {$vers > 2} # - this forces forwards compatibility issues on protocol versions # that haven't been invented yet. DON'T DO IT! Instead, test for # each supported version explicitly. I.e., {$vers >2 && $vers < 5} is OK. switch $vers { 3 { # Respond with the selected version number puts $fid [list [list vers $vers]] flush $fid } } # commit new connection commNewConn $chan $id $fid set comm($chan,vers,$id) $vers } # ::comm::commNewConn -- # # Internal command. Common new connection processing # # Arguments: # id Reference to the remote interp # fid channel handle of the socket running the connection. # # Results: # None. proc ::comm::commNewConn {chan id fid} { variable comm commDebug {puts stderr "<$chan> commNewConn $id $fid"} # There can be a race condition two where comms connect to each other # simultaneously. This code favors our outgoing connection. if {[info exists comm($chan,peers,$id)]} { # abort this connection, use the existing one # close $fid # return -code return $comm($chan,peers,$id) } else { set comm($chan,pending,$id) {} set comm($chan,peers,$id) $fid } set comm($chan,fids,$fid) $id fconfigure $fid -translation lf -encoding $comm($chan,encoding) -blocking 0 fileevent $fid readable [list ::comm::commCollect $chan $fid] } # ::comm::commLostConn -- # # Internal command. Called to tidy up a lost connection, # including aborting ongoing sends. Each send should clean # themselves up in pending/result. # # Arguments: # fid Channel handle of the socket which got lost. # reason Message describing the reason of the loss. # # Results: # reason proc ::comm::commLostConn {chan fid reason} { variable comm commDebug {puts stderr "<$chan> commLostConn $fid $reason"} catch {close $fid} set id $comm($chan,fids,$fid) foreach s $comm($chan,pending,$id) { if {[string equal "callback" [lindex $s end]]} { set ser [lindex $s 0] if {[info exists comm($chan,return,$ser)]} { set args [list -id $id \ -serial $ser \ -chan $chan \ -code -1 \ -errorcode NONE \ -errorinfo "" \ -result $reason \ ] if {[catch {uplevel #0 $comm($chan,return,$ser) $args} err]} { commBgerror $err } } } else { set comm($chan,return,$s) {-code error} set comm($chan,result,$s) $reason } } unset comm($chan,pending,$id) unset comm($chan,fids,$fid) catch {unset comm($chan,peers,$id)} ;# race condition catch {unset comm($chan,buf,$fid)} # process lost hook now catch {CommRunHook $chan lost} return $reason } proc ::comm::commBgerror {err} { # SF Tcllib Patch #526499 # (See http://sourceforge.net/tracker/?func=detail&aid=526499&group_id=12883&atid=312883 # for initial request and comments) # # Error in async call. Look for [bgerror] to report it. Same # logic as in Tcl itself. Errors thrown by bgerror itself get # reported to stderr. if {[catch {bgerror $err} msg]} { puts stderr "bgerror failed to handle background error." puts stderr " Original error: $err" puts stderr " Error in bgerror: $msg" flush stderr } } ############################################################################### # ::comm::commCollect -- # # Internal command. Called from the fileevent to read from fid # and append to the buffer. This continues until we get a whole # command, which we then invoke. # # Arguments: # chan logical channel collecting the data # fid channel handle of the socket we collect. # # Results: # None. proc ::comm::commCollect {chan fid} { variable comm upvar #0 comm($chan,buf,$fid) data # Tcl8 may return an error on read after a close if {[catch {read $fid} nbuf] || [eof $fid]} { commDebug {puts stderr "<$chan> collect/lost eof $fid = [eof $fid]"} commDebug {puts stderr "<$chan> collect/lost nbuf = <$nbuf>"} commDebug {puts stderr "<$chan> collect/lost [fconfigure $fid]"} fileevent $fid readable {} ;# be safe commLostConn $chan $fid "target application died or connection lost" return } append data $nbuf commDebug {puts stderr "<$chan> collect <$data>"} # If data contains at least one complete command, we will # be able to take off the first element, which is a list holding # the command. This is true even if data isn't a well-formed # list overall, with unmatched open braces. This works because # each command in the protocol ends with a newline, thus allowing # lindex and lreplace to work. # # This isn't true with Tcl8.0, which will return an error until # the whole buffer is a valid list. This is probably OK, although # it could potentially cause a deadlock. while {![catch {set cmd [lindex $data 0]}]} { commDebug {puts stderr "<$chan> cmd <$data>"} if {[string equal "" $cmd]} break if {[info complete $cmd]} { set data [lreplace $data 0 0] after idle \ [list ::comm::commExec $chan $fid $comm($chan,fids,$fid) $cmd] } } } # ::comm::commExec -- # # Internal command. Receives and executes a remote command, # returning the result and/or error. Unknown protocol commands # are silently discarded # # Arguments: # chan logical channel collecting the data # fid channel handle of the socket we collect. # remoteid id of the other side. # buf buffer containing the command to execute. # # Results: # None. proc ::comm::commExec {chan fid remoteid buf} { variable comm # buffer should contain: # send # {cmd} execute cmd and send reply with serial # # async # {cmd} execute cmd but send no reply # reply # {cmd} execute cmd as reply to serial # # these variables are documented in the hook interface set cmd [lindex $buf 0] set ser [lindex $buf 1] set buf [lrange $buf 2 end] set buffer [lindex $buf 0] # Save remoteid for "comm remoteid". This will only be valid # if retrieved before any additional events occur # on this channel. # N.B. we could have already lost the connection to remote, making # this id be purely informational! set comm($chan,remoteid) [set id $remoteid] commDebug {puts stderr "<$chan> exec <$cmd,$ser,$buf>"} switch -- $cmd { send - async - command {} callback { if {![info exists comm($chan,return,$ser)]} { commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""} return } # Decompose reply command to assure it only uses "return" # with no side effects. array set return {-code "" -errorinfo "" -errorcode ""} set ret [lindex $buffer end] set len [llength $buffer] incr len -2 foreach {sw val} [lrange $buffer 1 $len] { if {![info exists return($sw)]} continue set return($sw) $val } catch {CommRunHook $chan callback} # this wakes up the sender commDebug {puts stderr "<$chan> --<>--"} # the return holds the callback command # string map the optional %-subs set args [list -id $id \ -serial $ser \ -chan $chan \ -code $return(-code) \ -errorcode $return(-errorcode) \ -errorinfo $return(-errorinfo) \ -result $ret \ ] set code [catch {uplevel \#0 $comm($chan,return,$ser) $args} err] catch {unset comm($chan,return,$ser)} # remove pending serial upvar 0 comm($chan,pending,$id) pending if {[info exists pending]} { set pos [lsearch -exact $pending [list $ser callback]] if {$pos != -1} { set pending [lreplace $pending $pos $pos] } } if {$code} { commBgerror $err } return } reply { if {![info exists comm($chan,return,$ser)]} { commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""} return } # Decompose reply command to assure it only uses "return" # with no side effects. array set return {-code "" -errorinfo "" -errorcode ""} set ret [lindex $buffer end] set len [llength $buffer] incr len -2 foreach {sw val} [lrange $buffer 1 $len] { if {![info exists return($sw)]} continue set return($sw) $val } catch {CommRunHook $chan reply} # this wakes up the sender commDebug {puts stderr "<$chan> --<>--"} set comm($chan,result,$ser) $ret set comm($chan,return,$ser) [array get return] return } vers { set ::comm::comm($chan,vers,$id) $ser return } default { commDebug {puts stderr "<$chan> unknown command; discard \"$cmd\""} return } } # process eval hook now set done 0 set err 0 if {[info exists comm($chan,hook,eval)]} { set err [catch {CommRunHook $chan eval} ret] commDebug {puts stderr "<$chan> eval hook res <$err,$ret>"} switch $err { 1 { # error set done 1 } 2 - 3 { # return / break set err 0 set done 1 } } } commDebug {puts stderr "<$chan> hook(eval) done=$done, err=$err"} # exec command if {!$done} { commDebug {puts stderr "<$chan> exec ($buffer)"} # Sadly, the uplevel needs to be in the catch to access the local # variables buffer and ret. These cannot simply be global because # commExec is reentrant (i.e., they could be linked to an allocated # serial number). if {$comm($chan,interp) == {}} { # Main interpreter set thecmd [concat [list uplevel #0] $buffer] set err [catch $thecmd ret] } else { # Redirect execution into the configured slave # interpreter. The exact command used depends on the # capabilities of the interpreter. A best effort is made # to execute the script in the global namespace. set interp $comm($chan,interp) if {$comm($chan,interp,upl) == "ok"} { set thecmd [concat [list uplevel #0] $buffer] set err [catch {interp eval $interp $thecmd} ret] } elseif {$comm($chan,interp,aset) == "hidden"} { set thecmd [linsert $buffer 0 interp invokehidden $interp uplevel \#0] set err [catch $thecmd ret] } else { set err [catch {interp eval $interp $buffer} ret] } } } commDebug {puts stderr "<$chan> res <$err,$ret> /$cmd"} # The double list assures that the command is a single list when read. if {[string equal send $cmd] || [string equal command $cmd]} { # The catch here is just in case we lose the target. Consider: # comm send $other comm send [comm self] exit catch { set return [list return -code $err] # send error or result if {$err == 1} { global errorInfo errorCode lappend return -errorinfo $errorInfo -errorcode $errorCode } lappend return $ret if {[string equal send $cmd]} { set reply reply } else { set reply callback } puts $fid [list [list $reply $ser $return]] flush $fid } commDebug {puts stderr "<$chan> reply sent"} } if {$err == 1} { commBgerror $ret } commDebug {puts stderr "<$chan> exec complete"} return } proc ::comm::CommRunHook {chan event} { variable comm # The documentation promises the hook scripts to have access to a # number of internal variables. For a regular hook we simply # execute it in the calling level to fulfill this. When the hook # is redirected into an interpreter however we do a best-effort # copying of the variable values into the interpreter. Best-effort # because the 'set' command may not be available in the # interpreter, not even hidden. if {![info exists comm($chan,hook,$event)]} return set cmd $comm($chan,hook,$event) set interp $comm($chan,interp) commDebug {puts stderr "<$chan> hook($event) run <$cmd>"} if { ($interp != {}) && ([lsearch -exact $comm($chan,events) $event] >= 0) } { # Best-effort to copy the context into the interpreter for # access by the hook script. set vars { addr buffer chan cmd fid host id port reason remport ret var } if {$comm($chan,interp,set) == "ok"} { foreach v $vars { upvar 1 $v V if {![info exists V]} continue interp eval $interp [list set $v $V] } } elseif {$comm($chan,interp,set) == "hidden"} { foreach v $vars { upvar 1 $v V if {![info exists V]} continue interp invokehidden $interp set $v $V } } upvar 1 return AV if {[info exists AV]} { if {$comm($chan,interp,aset) == "ok"} { interp eval $interp [list array set return [array get AV]] } elseif {$comm($chan,interp,aset) == "hidden"} { interp invokehidden $interp array set return [array get AV] } } commDebug {puts stderr "<$chan> /interp $interp"} set code [catch {interp eval $interp $cmd} res] } else { commDebug {puts stderr "<$chan> /main"} set code [catch {uplevel 1 $cmd} res] } eval $cmd # Perform the return code propagation promised # to the hook scripts. switch -exact -- $code { 0 {} 1 { return -errorinfo $::errorInfo -errorcode $::errorCode -code error $result } 3 {return} 4 {} default {return -code $code $res} } return } ############################################################################### # # Finish creating "comm" using the default port for this interp. # if {![info exists ::comm::comm(comm,port)]} { if {[string equal macintosh $tcl_platform(platform)]} { ::comm::comm new ::comm::comm -port 0 -local 0 -listen 1 set ::comm::comm(localhost) \ [lindex [fconfigure $::comm::comm(::comm::comm,socket) -sockname] 0] ::comm::comm config -local 1 } else { ::comm::comm new ::comm::comm -port 0 -local 1 -listen 1 } } #eof package provide comm 4.4