comm.tcl

Go to the documentation of this file.

/*  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-2007 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? <id> <cmd> ?<arg> ...?*/
/*      comm interps*/
/* */
/*  See the manual page comm.n for further details on this package.*/
/* */
/*  RCS: @(#) $Id: comm.tcl,v 1.30 2007/08/15 21:33:37 andreas_kupries Exp $*/

package require Tcl 8.3
package require snit ; /*  comm::future objects.*/

namespace ::comm {
    namespace export comm comm_send

    variable  comm
    array  comm =  {}

    if {![info exists comm(chans)]} {
    array  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
    }
     comm = (lastport) [expr {[pid] % 32768 + 9999}]
    /*  fast check for acceptable versions*/
    foreach comm(_x) $comm(acceptVers) {
         comm = ($comm(_x),vers) 1
    }
    catch {un comm = (_x)}
    }

    /*  Class variables:*/
    /*  lastport        saves last default listening port allocated*/
    /*  debug           enable debug output*/
    /*  chans           list of allocated channels*/
    /*    future,fid,$fid         List of futures a specific peer is waiting for.*/
    /* */
    /*  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
     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.*/

ret  ::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.*/

ret  ::comm::comm (type cmd , type 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] {, }]"
    }
}

ret  ::comm::comm_cmd_connect (type chan , type args) {
    uplevel 1 [linsert $args 0 [namespace current]::commConnect $chan]
}
ret  ::comm::comm_cmd_self (type chan , type args) {
    variable comm
    return $comm($chan,port)
}
ret  ::comm::comm_cmd_channels (type chan , type args) {
    variable comm
    return $comm(chans)
}
ret  ::comm::comm_cmd_configure (type chan , type args) {
    uplevel 1 [linsert $args 0 [namespace current]::commConfigure $chan 0]
}
ret  ::comm::comm_cmd_ids (type chan , type 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
ret  ::comm::comm_cmd_remoteid (type chan , type args) {
    variable comm
    if {[info exists comm($chan,remoteid)]} {
    set comm($chan,remoteid)
    } else {
    return -code error "No remote commands processed yet"
    }
}
ret  ::comm::comm_cmd_debug (type chan , type bool) {
    variable comm
    return [set comm(debug) [string is true -strict $bool]]
}

/*  ### ### ### ######### ######### #########*/
/*  API: Setup async result generation for a remotely invoked command.*/

/*  (future,fid,<fid>) -> list (future)*/
/*  (current,async)    -> bool (default 0) */
/*  (current,state)    -> list (chan fid cmd ser)*/

ret  ::comm::comm_cmd_return_async (type chan) {
    variable comm

    if {![info exists comm(current,async)]} {
    return -code error "No remote commands processed yet"
    }
    if {$comm(current,async)} {
    # Return the same future which were generated by the first
    # call.
    return $comm(current,state)
    }

    foreach {cmdchan cmdfid cmd ser} $comm(current,state) break

    # Assert that the channel performing the request and the channel
    # the current command came in are identical. Panic if not.

    if {![string equal $chan $cmdchan]} {
    return -code error "Internal error: Trying to activate\
        async return for a command on a different channel"
    }

    # Establish the future for the command and return a handle for
    # it. Remember the outstanding futures for a peer, so that we can
    # cancel them if the peer is lost before the promise implicit in
    # the future is redeemed.

    set future [::comm::future %AUTO% $chan $cmdfid $cmd $ser]

    lappend comm(future,fid,$cmdfid) $future
    set     comm(current,state)      $future

    # Mark the current command as using async result return. We do
    # this last to ensure that all errors in this method are reported
    # through the regular channels.

    set comm(current,async) 1

    return $future
}

/*  hook --*/
/* */
/*  Internal command. Implements 'comm hook'.*/
/* */
/*  Arguments:*/
/*  hook    hook to modify*/
/*  script  Script to add/remove to/from the hook*/
/* */
/*  Results:*/
/*  None.*/
/* */
ret  ::comm::comm_cmd_hook (type chan , type hook , optional 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.*/

ret  ::comm::comm_cmd_abort (type 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.*/
/* */
ret  ::comm::comm_cmd_destroy (type 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.*/
/* */
ret  ::comm::comm_cmd_shutdown (type chan , type 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.*/
/* */
ret  ::comm::comm_cmd_new (type chan , type ch , type 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.*/
/* */
ret  ::comm::comm_cmd_send (type chan , type 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> --<<waiting $ser>>--"}
    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)>"
    }

    array set return $comm($chan,return,$ser)
    unset comm($chan,return,$ser)
    set thisres $comm($chan,result,$ser)
    unset comm($chan,result,$ser)
    switch -- $return(-code) {
        "" - 0 {return $thisres}
        1 {
        return  -code $return(-code) \
            -errorinfo $return(-errorinfo) \
            -errorcode $return(-errorcode) \
            $thisres
        }
        default {return -code $return(-code) $thisres}
    }
    }
}

/* */

/*  ::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.*/

ret  ::comm::commDebug (type 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.*/

ret  ::comm::commConfVars (type v , type 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.*/

ret  ::comm::commConfigure (type chan , optional force =0 , type 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.*/

ret  ::comm::Capability (type interp , type 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.*/

ret  ::comm::commConnect (type chan , type 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.*/

ret  ::comm::commIncoming (type chan , type fid , type addr , type 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.*/

ret  ::comm::commNewConn (type chan , type id , type 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*/

ret  ::comm::commLostConn (type chan , type fid , type reason) {
    variable comm

    commDebug {puts stderr "<$chan> commLostConn $fid $reason"}

    catch {close $fid}

    set id $comm($chan,fids,$fid)

    # Invoke the callbacks of all commands which have such and are
    # still waiting for a response from the lost peer. Use an
    # appropriate error.

    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)}

    # Cancel all outstanding futures for requests which were made by
    # the lost peer, if there are any. This does not destroy
    # them. They will stay around until the long-running operations
    # they belong too kill them.

    CancelFutures $fid

    # process lost hook now
    catch {CommRunHook $chan lost}

    return $reason
}

ret  ::comm::commBgerror (type 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
    }
}

/*  CancelFutures: Mark futures associated with a comm channel as*/
/*  expired, done when the connection to the peer has been lost. The*/
/*  marked futures will not generate result anymore. They will also stay*/
/*  around until destroyed by the script they belong to.*/

ret  ::comm::CancelFutures (type fid) {
    variable comm
    if {![info exists comm(future,fid,$fid)]} return

    commDebug {puts stderr "\tCanceling futures: [join $comm(future,fid,$fid) \
                         "\n\t                 : "]"}

    foreach future $comm(future,fid,$fid) {
    $future Cancel
    }

    unset comm(future,fid,$fid)
    return
}

/* */

/*  ::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.*/

ret  ::comm::commCollect (type chan , type 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.*/

ret  ::comm::commExec (type chan , type fid , type remoteid , type 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]

    # Save state for possible async result generation
    AsyncPrepare $chan $fid $cmd $ser

    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> --<<wakeup $ser>>--"}

        # 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> --<<wakeup $ser>>--"}
        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 thecmd [concat [list interp eval $interp] $buffer]
        set err [catch $thecmd ret]
        }
    }
    }

    # Check and handle possible async result generation.
    if {[AsyncCheck]} return

    commSendReply $chan $fid $cmd $ser $err $ret
    return
}

/*  ::comm::commSendReply --*/
/* */
/*  Internal command. Executed to construct and send the reply*/
/*  for a command.*/
/* */
/*  Arguments:*/
/*  fid     channel handle of the socket we are replying to.*/
/*  cmd     The type of request (send, command) we are replying to.*/
/*  ser     Serial number of the request the reply is for.*/
/*  err     result code to place into the reply.*/
/*  ret     result value to place into the reply.*/
/* */
/*  Results:*/
/*  None.*/

ret  ::comm::commSendReply (type chan , type fid , type cmd , type ser , type err , type ret) {
    variable comm

    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
}

ret  ::comm::CommRunHook (type chan , type 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]
    }

    # Perform the return code propagation promised
    # to the hook scripts.
    switch -exact -- $code {
    0 {}
    1 {
        return -errorinfo $::errorInfo -errorcode $::errorCode -code error $res
    }
    3 {return}
    4 {}
    default {return -code $code $res}
    }
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Hooks to link async return and future processing into the regular*/
/*  system.*/

/*  AsyncPrepare, AsyncCheck: Initialize state information for async*/
/*  return upon start of a remote invokation, and checking the state for*/
/*  async return.*/

ret  ::comm::AsyncPrepare (type chan , type fid , type cmd , type ser) {
    variable comm
    set comm(current,async) 0
    set comm(current,state) [list $chan $fid $cmd $ser]
    return
}

ret  ::comm::AsyncCheck () {
    # Check if the executed command notified us of an async return. If
    # not we let the regular return processing handle the end of the
    # script. Otherwise we stop the caller from proceeding, preventing
    # a regular return.

    variable comm
    if {!$comm(current,async)} {return 0}
    return 1
}

/*  FutureDone: Action taken by an uncanceled future to deliver the*/
/*  generated result to the proper invoker. This also removes the future*/
/*  from the list of pending futures for the comm channel.*/

ret  comm::FutureDone (type future , type chan , type fid , type cmd , type sid , type rcode , type rvalue) {
    variable comm
    commSendReply $chan $fid $cmd $sid $rcode $rvalue

    set pos [lsearch -exact $comm(future,fid,$fid) $future]
    set comm(future,fid,$fid) [lreplace $comm(future,fid,$fid) $pos $pos]
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Hooks to save command state across nested eventloops a remotely*/
/*  invoked command may run before finally activating async result*/
/*  generation.*/

/*  DANGER !! We have to refer to comm internals using fully-qualified*/
/*  names because the wrappers will execute in the global namespace*/
/*  after their installation.*/

ret  ::comm::Vwait (type varname) {
    variable ::comm::comm

    set hasstate [info exists comm(current,async)]
    set hasremote 0
    if {$hasstate} {
    set chan     [lindex $comm(current,state) 0]
    set async    $comm(current,async)
    set state    $comm(current,state)
    set hasremote [info exists comm($chan,remoteid)]
    if {$hasremote} {
        set remoteid $comm($chan,remoteid)
    }
    }

    set code [catch {uplevel 1 [list ::comm::VwaitOrig $varname]} res]

    if {$hasstate} {
    set comm(current,async)  $async
    set comm(current,state)  $state
    }
    if {$hasremote} {
    set comm($chan,remoteid) $remoteid
    }

    return -code $code $res
}

ret  ::comm::Update (type args) {
    variable ::comm::comm

    set hasstate [info exists comm(current,async)]
    set hasremote 0
    if {$hasstate} {
    set chan     [lindex $comm(current,state) 0]
    set async    $comm(current,async)
    set state    $comm(current,state)

    set hasremote [info exists comm($chan,remoteid)]
    if {$hasremote} {
        set remoteid $comm($chan,remoteid)
    }
    }

    set code [catch {uplevel 1 [linsert $args 0 ::comm::UpdateOrig]} res]

    if {$hasstate} {
    set comm(current,async)  $async
    set comm(current,state)  $state
    }
    if {$hasremote} {
    set comm($chan,remoteid) $remoteid
    }

    return -code $code $res
}

/*  Install the wrappers.*/

ret  ::comm::InitWrappers () {
    rename ::vwait       ::comm::VwaitOrig
    rename ::comm::Vwait ::vwait

    rename ::update       ::comm::UpdateOrig
    rename ::comm::Update ::update

    proc ::comm::InitWrappers {} {}
    return
}

/*  ### ### ### ######### ######### #########*/
/*  API: Future objects.*/

snit::type comm::future {
    option -command -default {}

    constructor {chan fid cmd ser} {
     xfid =   $fid
     xcmd =   $cmd
     xser =   $ser
     xchan =  $chan
    return
    }

    destructor {
    if {!$canceled} {
        return -code error \
            "Illegal attempt to destroy unresolved future \"$self\""
    }
    }

    ret  return (type args) {
    # Syntax:             | 0
    #       : -code x     | 2
    #       : -code x val | 3
    #       :         val | 4
    # Allowing multiple -code settings, last one is taken.

    set rcode  0
    set rvalue {}

    while {[lindex $args 0] == "-code"} {
        set rcode [lindex $args 1]
        set args  [lrange $args 2 end]
    }
    if {[llength $args] > 1} {
        return -code error "wrong\#args, expected \"?-code errcode? ?result?\""
    }
    if {[llength $args] == 1} {
        set rvalue [lindex $args 0]
    }

    if {!$canceled} {
        comm::FutureDone $self $xchan $xfid $xcmd $xser $rcode $rvalue
        set canceled 1
    }
    # assert: canceled == 1
    $self destroy
    return
    }

    variable xfid  {}
    variable xcmd  {}
    variable xser  {}
    variable xchan {}
    variable canceled 0

    /*  Internal method for use by comm channels. Marks the future as*/
    /*  expired, no peer to return a result back to.*/

    ret  Cancel () {
    set canceled 1
    if {![llength $options(-command)]} {return}
    uplevel #0 [linsert $options(-command) end $self]
    return
    }
}

/*  ### ### ### ######### ######### #########*/
/*  Setup*/
::comm::InitWrappers

/* */
/* */
/*  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
	 ::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.5.6