# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake  to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2025
#
# @@ Meta Begin
# Application punk::icomm 999999.0a1.0
# Meta platform     tcl
# Meta license      <unspecified>
# @@ Meta End


# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::icomm 0 999999.0a1.0]
#[copyright "2025"]
#[titledesc {Module API}]  [comment {-- Name section and table of contents description --}]
#[moddesc {-}]             [comment {-- Description at end of page heading --}]
#[require punk::icomm]
#[keywords module]
#[description]
#[para] -

# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++

#*** !doctools
#[section Overview]
#[para] overview of punk::icomm
#[subsection Concepts]
#[para] -


# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
##  Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++

#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::icomm
#[list_begin itemized]

package require Tcl 8.6-
package require punk::args
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package {punk::args}]

#*** !doctools
#[list_end]

# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++

#*** !doctools
#[section API]

# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::icomm::class {
    #*** !doctools
    #[subsection {Namespace punk::icomm::class}]
    #[para] class definitions
    #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
        #*** !doctools
        #[list_begin enumerated]

        # oo::class create interface_sample1 {
        #     #*** !doctools
        #     #[enum] CLASS [class interface_sample1]
        #     #[list_begin definitions]

        #     method test {arg1} {
        #         #*** !doctools
        #         #[call class::interface_sample1    [method test] [arg arg1]]
        #         #[para] test method
        #         puts "test: $arg1"
        #     }

        #     #*** !doctools
        #     #[list_end] [comment {-- end definitions interface_sample1}]
        # }

        #*** !doctools
        #[list_end] [comment {--- end class enumeration ---}]
    #}
#}

# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# 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.

package require Tcl 8.6-
package require snit ; # comm::future objects.

namespace eval ::punk::icomm {
    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
    #   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,socketcmd		command to use to create sockets.
    #   $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
    }
}

namespace eval ::punk::icomm {
    # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
    # Base namespace
    # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
    #*** !doctools
    #[subsection {Namespace punk::icomm}]
    #[para] Core API functions for punk::icomm
    #[list_begin definitions]

    variable PUNKARGS

    # ::punk::icomm::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_send {} {
        proc send {args} {
            # Use pure lists to speed this up.
            uplevel 1 [linsert $args 0 ::punk::icomm::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 [::punk::icomm::comm interps]
        }
        proc ::punk::icomm::comm_send {} {}
    }




    #(Ensemble equivalent)

    # ::punk::icomm::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 {cmd args} {
        set method [info commands ::punk::icomm::comm_cmd_$cmd*]

        if {[llength $method] == 1} {
            set chan ::punk::icomm::comm; # passed to methods
            return [uplevel 1 [linsert $args 0 $method $chan]]
        } else {
            foreach c [info commands ::punk::icomm::comm_cmd_*] {
                # remove ::comm::comm_cmd_
                #lappend cmds [string range $c 17 end]
                lappend cmds [string range $c 24 end]
            }
            return -code error "unknown subcommand \"$cmd\":\
            must be one of [join [lsort $cmds] {, }]"
        }
    }


    #ensemble members
    proc comm_cmd_connect {chan args} {
        uplevel 1 [linsert $args 0 [namespace current]::commConnect $chan]
    }
    proc comm_cmd_self {chan args} {
        variable comm
        return $comm($chan,port)
    }
    proc comm_cmd_channels {chan args} {
        variable comm
        return $comm(chans)
    }
    proc comm_cmd_configure {chan args} {
        uplevel 1 [linsert $args 0 [namespace current]::commConfigure $chan 0]
    }
    proc 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
    }
    proc 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_cmd_debug {chan 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)

    proc comm_cmd_return_async {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
        lassign $comm(current,state) cmdchan cmdfid cmd ser

        # 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 [::punk::icomm::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.
    #
    proc 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_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_cmd_destroy {chan} {
        variable comm
        catch {close $comm($chan,socket)}
        comm_cmd_abort $chan
        if {$comm($chan,interp) != {}} {
            interp delete $comm($chan,interp)
        }
        array unset comm $chan,*

        #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,socketcmd)}
        #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,*} {
        #    array unset comm $chan,$pattern
        #    #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 ::punk::icomm::comm $chan] &&
        ![string equal [info proc $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_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:
    #	newchan	Name of the new channel
    #	args	Configuration, in the form of -option value pairs.
    #
    # Results:
    #	None.
    #
    proc comm_cmd_new {_irrelevant_chan newchan args} {
        variable comm

        if {[lsearch -exact $comm(chans) $newchan] >= 0} {
            return -code error "Already existing channel: $newchan"
        }
        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 newchan ::[string trimleft $newchan :]
        if {[string equal ::punk::icomm::comm $newchan]} {
            # allow comm to be recreated after destroy
        } elseif {[string equal $newchan [info commands $newchan]]} {
            return -code error "Already existing command: $newchan"
        } else {
            # Create the new channel with fully qualified proc name
            proc $newchan {cmd args} {
                set method [info commands ::punk::icomm::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 ::punk::icomm::comm_cmd_*] {
                        # remove ::comm::comm_cmd_
                        #lappend cmds [string range $c 17 end]
                        lappend cmds [string range $c 24 end]
                    }
                    return -code error "unknown subcommand \"$cmd\":\
                        must be one of [join [lsort $cmds] {, }]"
                }
            }
        }
        lappend comm(chans) $newchan
        set chan $newchan
        set comm($chan,serial) 0
        set comm($chan,chan)   $chan
        set comm($chan,tclchan) ""
        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)   {}
        set comm($chan,socketcmd) ::socket

        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_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> --<<waiting $ser>>--"}
            vwait ::punk::icomm::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}
            }
        }
    }

    ###############################################################################

    # ::punk::icomm::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 commDebug {cmd} {
        variable comm
        if {$comm(debug)} {
            uplevel 1 $cmd
        }
    }

    # ::punk::icomm::commConfVars --
    #
    #	Internal command. Used to declare configuration options.
    #
    # Arguments:
    #	v	Name of configuration option.
    #	t	Default value.
    #
    # Results:
    #	None.

    proc 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
    }
    commConfVars port     p
    commConfVars local    b
    commConfVars listen   b
    commConfVars socket   ro
    commConfVars socketcmd socketcmd
    commConfVars chan     ro
    commConfVars serial   ro
    commConfVars encoding enc
    commConfVars silent   b
    commConfVars interp   interp
    commConfVars events   ev
    commConfVars tclchan  tclchan

    # ::punk::icomm::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 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 {
                    ##nagelfar ignore
                    if {![string is integer -strict $optval]} {
                        return -code error \
                        "Non-port to configuration option: -$var"
                    }
                    # FRINK: nocheck
                    set $var [format %d $optval]
                    set skip 1
                }
                i {
                    ##nagelfar ignore
                    if {![string is integer $optval]} {
                        return -code error \
                        "Non-integer to configuration option: -$var"
                    }
                    # FRINK: nocheck
                    set $var [format %d $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"
                }
                socketcmd {
                    if {$optval eq {}} {
                        return -code error \
                            "Non-command to configuration option: -$var"
                    }

                    set $var $optval
                    set skip 1
                }
                tclchan {
                    #test existence of channel - don't use existence in [chan names] - could be a wrapped channel
                    if {[catch {chan configure $optval} errM]} {
                        return -code error \
                            "Cannot verify existence of Tcl channel supplied to configuration option: -$var"
                    }
                    set $var $optval
                    set skip 1
                }
            }
        }
        if {[info exists skip]} {
            return -code error "Missing value for option: $arg"
        }

        foreach var {port listen local socketcmd tclchan} {
            # 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 ""}

        #experimental e.g fifo2
        #-------------------------
        if {[info exists comm($chan,tclchan)] && $comm($chan,tclchan) ne "" && $comm($chan,listen)} {
            #treat as always connected - call commIncoming imediately.
            punk::icomm::commIncoming $chan $comm($chan,tclchan) "localaddr" "localtclchan"
            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 $comm($chan,socketcmd) -server [list ::punk::icomm::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 ::punk::icomm::comm $chan] &&
                ![string equal [info proc $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 ""
    }

    # ::punk::icomm::Capability --
    #
    #	Internal command. Interogate an interp for
    #	the commands needed to execute regular and
    #	hook scripts.

    proc 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"}]
    }

    # punk::icomm::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 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"
        }

        # experimental
        # -----------------------------------------------------------
        if {[llength $id] == 2 && [lindex $id 0] eq "tclchan"} {
            set fid [lindex $id 1]
            if {[catch {chan configure $fid} errMsg]} {
                error $errMsg $::errorInfo
            }

            # 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)]
            puts $fid [list $comm(offerVers) $fid] ;#all we have to offer is our end of the pipe as an id?
            set comm($chan,vers,$id) $comm(defVers)		;# default proto vers
            flush  $fid
            return $fid
        }
        # -----------------------------------------------------------


        if {[llength $id] > 1} {
            set host [lindex $id 1]
        } else {
            set host $comm(localhost)
        }
        set port [lindex $id 0]
        set fid [$comm($chan,socketcmd) $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
    }

    # ::punk::icomm::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 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
        }

        # Wait for offered version, without blocking the entire system.
        # Bug 3066872. For a Tcl 8.6 implementation consider use of
        # coroutines to hide the CSP and properly handle everything
        # event based.

        fconfigure $fid -blocking 0
        fileevent  $fid readable [list ::punk::icomm::commIncomingOffered $chan $fid $addr $remport]
        return
    }

    proc commIncomingOffered {chan fid addr remport} {
        variable comm

        # Check if we have a complete line.
        if {[gets $fid protoline] < 0} {
            #commDebug {puts stderr "commIncomingOffered: no data"}
            if {[eof $fid]} {
                commDebug {puts stderr "commIncomingOffered: eof on fid=$fid"}
                catch {
                    close $fid
                }
            }
            return
        }

        # Protocol version line has been received, disable event handling
        # again.
        fileevent $fid readable {}
        fconfigure $fid -blocking 1

        # 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 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)]} {
                return
            }
            error "Unknown offered protocols \"$protoline\" from $addr/$remport"
        }

        set chanconf [chan configure $fid]
        if {[dict exists $chanconf -sockname]} {
            # 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]
            }
        } else {
            #tclchan?
            set id $fid

        }

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

    # ::punk::icomm::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 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 ::punk::icomm::commCollect $chan $fid]
    }

    # ::punk::icomm::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 commLostConn {chan fid 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
    }

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

    # 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.

    proc CancelFutures {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
    }

    ###############################################################################

    # ::punk::icomm::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 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.

        # [AK] Actually no. This breaks down if the sender shoves so much
        # data at us so fast that the receiver runs into out of memory
        # before the list is fully well-formed and thus able to be
        # processed.


        while {![catch {
        set cmdrange [Word0 data]
        # word0 is essentially the pre-8.0 'lindex <list> 0', getting
        # the first word of a list, even if the remainder is not fully
        # well-formed. Slight API change, we get the char indices the
        # word is between, and a relative index to the remainder of
        # the list.
        }]} {
            # Unpack the indices, then extract the word.
            #foreach {s e step} $cmdrange break
            lassign $cmdrange s e step

            set cmd [string range $data $s $e]
            commDebug {puts stderr "<$chan> cmd <$data>"}
            if {[string equal "" $cmd]} break
            if {[info complete $cmd]} {
                # The word is a command, step to the remainder of the
                # list, and delete the word we have processed.
                incr e $step
                set data [string range $data $e end]
                after idle \
                    [list ::punk::icomm::commExec $chan $fid $comm($chan,fids,$fid) $cmd]
            }
        }
    }

    # ::punk::icomm::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 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]

        # 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($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
    }

    # ::punk::icomm::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.

    proc commSendReply {chan fid cmd ser err 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
    }

    proc 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 options]
        } else {
            commDebug {puts stderr "<$chan> /main"}
            set code [catch {uplevel 1 $cmd} res options]
        }

        # Perform the return code propagation promised
        # to the hook scripts.
        return -options $options -code $code $res
    }

    # ### ### ### ######### ######### #########
    ## 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.

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

    proc 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.

    proc FutureDone {future chan fid cmd sid rcode 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.

    proc Vwait {varname} {
        variable ::punk::icomm::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 ::punk::icomm::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
    }

    proc Update {args} {
        variable ::punk::icomm::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 ::punk::icomm::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.

    proc InitWrappers {} {
        rename ::vwait       ::punk::icomm::VwaitOrig
        rename ::punk::icomm::Vwait ::vwait

        rename ::update       ::punk::icomm::UpdateOrig
        rename ::punk::icomm::Update ::update

        proc ::punk::icomm::InitWrappers {} {}
        return
    }

    proc Word0 {dv} {
        upvar 1 $dv data

        # data
        #
        # The string we expect to be either a full well-formed list, or a
        # well-formed list until the end of the first word in the list,
        # with non-wellformed data following after, i.e. an incomplete
        # list with a complete first word.

        set re "^\\s*(\{)" ;#\}
        if {[regexp -indices $re $data -> bracerange]} {
            # The word is brace-quoted, starting at index 'lindex
            # bracerange 0'. We now have to find the closing brace,
            # counting inner braces, ignoring quoted braces. We fail if
            # there is no proper closing brace.

            lassign $bracerange s e
            incr s ; # index of the first char after the brace.
            incr e ; # same. but this is our running index.

            set level 1
            set max [string length $data]

            while {$level} {
                # We are looking for the first regular or backslash-quoted
                # opening or closing brace in the string. If none is found
                # then the word is not complete, and we abort our search.

                # \{Bug 2972571: To avoid the bogus detection of
                # backslash-quoted braces we look for double-backslashes
                # as well and skip them. Without this a string like '{puts
                # \\}' will incorrectly find a \} at the end, missing the
                # end of the word.
                set re {((\\\\)|([{}])|(\\[{}]))} ;#split out for dumb editor to fix highlighting
                #       ^^      ^      ^
                #       |\\     regular \quoted
                #       any

                if {![regexp -indices -start $e $re $data -> any dbs regular quoted]} {
                    return -code error "no complete word found/1"
                }
                #
                lassign $dbs ds de
                lassign $quoted qs qe
                lassign $regular rs re

                if {$ds >= 0} {
                    # Skip double-backslashes ...
                    set  e $de
                    incr e
                    continue
                } elseif {$qs >= 0} {
                    # Skip quoted braces ...
                    set  e $qe
                    incr e
                    continue
                } elseif {$rs >= 0} {
                    # Step one nesting level in or out.
                    if {[string index $data $rs] eq "\{" || "boguseditorfix" eq "\}"} {
                        incr level
                    } else {
                        incr level -1
                    }
                    set  e $re
                    incr e
                    #puts @$e
                    continue
                } else {
                    return -code error "internal error"
                }
            }
            #
            incr e -2 ; # index of character just before the brace.
            return [list $s $e 2]

        } elseif {[regexp -indices {^\s*(\S+)\s} $data -> wordrange]} {
            # The word is a simple literal which ends at the next
            # whitespace character. Note that there has to be a whitespace
            # for us to recognize a word, for while there is no whitespace
            # behind it in the buffer the word itself may be incomplete.

            return [linsert $wordrange end 1]
        }

        return -code error "no complete word found/2"
    }

    #*** !doctools
    #[list_end] [comment {--- end definitions namespace punk::icomm ---}]
}

interp alias {} ::punk::icomm::comm_cmd_interps {} ::punk::icomm::comm_cmd_ids




# ### ### ### ######### ######### #########
## API: Future objects.

snit::type punk::icomm::future {
    option -command -default {}

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

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

    method return {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} {
            ::punk::icomm::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.

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

# ### ### ### ######### ######### #########
## Setup
::punk::icomm::InitWrappers

###############################################################################
#
# Finish creating "comm" using the default port for this interp.
#

#don't listen by default
proc ::punk::icomm::initlocal {{tcpport 0}}  {
    if {![info exists ::punk::icomm::comm(comm,port)]} {
        if {[string equal macintosh $::tcl_platform(platform)]} {
            ::punk::icomm::comm new ::punk::icomm::comm -port 0 -local 0 -listen 1
            set ::punk::icomm::comm(localhost) \
                [lindex [fconfigure $::punk::icomm::comm(::punk::icomm::comm,socket) -sockname] 0]
            ::punk::icomm::comm config -local 1
        } else {
            ::punk::icomm::comm new ::punk::icomm::comm -port 0 -local 1 -listen 1
        }
    }
    return [::punk::icomm::comm configure]
}



# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++


# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::icomm::lib {
    tcl::namespace::export {[a-z]*}  ;# Convention: export all lowercase
    tcl::namespace::path [tcl::namespace::parent]
    #*** !doctools
    #[subsection {Namespace punk::icomm::lib}]
    #[para] Secondary functions that are part of the API
    #[list_begin definitions]

    #proc utility1 {p1 args} {
    #    #*** !doctools
    #    #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
    #    #[para]Description of utility1
    #    return 1
    #}



    #*** !doctools
    #[list_end] [comment {--- end definitions namespace punk::icomm::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++



# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::icomm::system {
    #*** !doctools
    #[subsection {Namespace punk::icomm::system}]
    #[para] Internal functions that are not part of the API



#}


# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval punk::icomm {
    tcl::namespace::export {[a-z]*}  ;# Convention: export all lowercase
    variable PUNKARGS
    variable PUNKARGS_aliases

    lappend PUNKARGS [list {
            @id     -id "(package)punk::icomm"
            @package    -name "punk::icomm" -help\
            "taken from tcllib comm package
            todo - describe changes"
        }]

    namespace eval argdoc {
        #namespace for custom argument documentation
        proc package_name {} {
            return punk::icomm
        }
        proc about_topics {} {
            #info commands results are returned in an arbitrary order (like array keys)
            set topic_funs [info commands [namespace current]::get_topic_*]
            set about_topics [list]
            foreach f $topic_funs {
                set tail [namespace tail $f]
                lappend about_topics [string range $tail [string length get_topic_] end]
            }
            #Adjust this function or 'default_topics' if a different order is required
            return [lsort $about_topics]
        }
        proc default_topics {} {return [list Description *]}

        # -------------------------------------------------------------
        # get_topic_ functions add more to auto-include in about topics
        # -------------------------------------------------------------
        proc get_topic_Description {} {
             punk::args::lib::tstr [string trim {
                package punk::icomm
                description to come..
            } \n]
        }
        proc get_topic_License {} {
            return "<unspecified>"
        }
        proc get_topic_Version {} {
            return "$::punk::icomm::version"
        }
        proc get_topic_Contributors {} {
            set authors {<unspecified>}
            set contributors ""
            foreach a $authors {
                append contributors $a \n
            }
            if {[string index $contributors end] eq "\n"} {
                set contributors [string range $contributors 0 end-1]
            }
            return $contributors
        }
        proc get_topic_custom-topic {} {
            punk::args::lib::tstr -return string {
                A custom
                   topic
                      etc
            }
        }
        # -------------------------------------------------------------
    }

    # we re-use the argument definition from punk::args::standard_about and override some items
    set overrides [dict create]
    dict set overrides @id  -id   "::punk::icomm::about"
    dict set overrides @cmd -name "punk::icomm::about"
    dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
                            About punk::icomm
                            }] \n]
    dict set overrides topic -choices           [list {*}[punk::icomm::argdoc::about_topics] *]
    dict set overrides topic -choicerestricted  1
    dict set overrides topic -default [punk::icomm::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict
    set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *]
    lappend PUNKARGS [list $newdef]
    proc about {args} {
        package require punk::args
        #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on
        set argd [punk::args::parse $args withid ::punk::icomm::about]
        lassign [dict values $argd] _leaders opts values _received
        punk::args::package::standard_about -package_about_namespace ::punk::icomm::argdoc {*}$opts {*}[dict get $values topic]
    }
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===


# -----------------------------------------------------------------------------
#    register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked
# -----------------------------------------------------------------------------
#    variable PUNKARGS
#    variable PUNKARGS_aliases
namespace eval ::punk::args::register {
    #use fully qualified so 8.6 doesn't find existing var in global namespace
    lappend ::punk::args::register::NAMESPACES ::punk::icomm
}
# -----------------------------------------------------------------------------

# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
##  Ready
package provide punk::icomm [tcl::namespace::eval punk::icomm {
    variable pkg punk::icomm
    variable version
    set version 999999.0a1.0
}]
return

#*** !doctools
#[manpage_end]