You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2167 lines
71 KiB
2167 lines
71 KiB
# -*- 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] |
|
|
|
|