Attachment "memsock_vwait.test" to
ticket [18f4a94d03]
added by
pooryorick
2021-06-16 12:07:34.
#!/usr/bin/tclsh
namespace eval ::memsock {
variable vars
proc server { port handler } {
variable vars
if { ! [info exists vars($port)] } {
set memsock [_memchan new]
set vars($port) [dict create]
dict set vars($port) memchan $memsock
dict set vars($port) memsock \
[chan create [list read write] $memsock]
set ch [dict get $vars($port) memsock]
chan configure $ch -encoding utf-8
chan configure $ch -buffering line
chan configure $ch -blocking false
# need an out-of-band fifo for sendget messages
set memsock [_memchan new]
dict set vars($port) memchanoob $memsock
dict set vars($port) memsockoob \
[chan create [list read write] $memsock]
set ch [dict get $vars($port) memsockoob]
chan configure $ch -encoding utf-8
chan configure $ch -buffering line
chan configure $ch -blocking true
}
dict set vars($port) type server
set ch [dict get $vars($port) memsock]
fileevent $ch readable [list ::memsock::readhandler $ch $port $handler]
}
# this helps to emulate the socket message handler
proc readhandler { ch port handler } {
variable vars
while { [gets $ch line] >= 0 } {
if { $handler ne {} } {
# if the channel is closed by the handler while called
# from this routine, then the program will crash, as
# the channel no longer exists and it cannot be flushed.
# for this reason, the 'exit' commands for various modules
# that will close their server sockets are detached with
# an 'after 100' when started by the called handler.
# ( FlushChannel: damaged channel list )
# ( alloc: invalid block )
{*}$handler $line $port
}
}
}
proc check { port } {
variable vars
if { ! [info exists vars($port)] ||
[dict get $vars($port) type] ne "server" } {
return false
}
return true
}
proc serverClose { port } {
variable vars
if { ! [info exists vars($port)] ||
[dict get $vars($port) type] ne "server" } {
return
}
set ch [dict get $vars($port) memsock]
fileevent $ch readable {}
chan close $ch
set ch [dict get $vars($port) memsockoob]
chan close $ch
unset vars($port)
}
proc sendoob { port msg } {
variable vars
if { ! [info exists vars($port)] } {
return
}
set ch [dict get $vars($port) memsockoob]
try {
puts $ch $msg
} on error {err res} {
puts "sendoob error: $res"
}
}
proc send { port msg } {
variable vars
if { ! [info exists vars($port)] } {
return
}
set ch [dict get $vars($port) memsock]
try {
puts $ch $msg
} on error {err res} {
puts "send error: $res"
}
}
proc sendget { rport sport msg } {
variable vars
if { ! [info exists vars($sport)] } {
return {}
}
set sch [dict get $vars($sport) memsock]
# in order for this to work, the receiver must also have
# a server-side memory channel open
if { ! [info exists vars($rport)] ||
[dict get $vars($rport) type] ne "server" } {
return {}
}
# use the out-of-band channel that is not normally used for receipt
set rch [dict get $vars($rport) memsockoob]
puts $sch $msg
chan event $rch readable [list [info coroutine]]
yield
gets $rch line
chan event $rch readable {}
return $line
}
}
oo::class create ::_memchan {
constructor { } {
my variable vars
}
method _initchan { } {
my variable vars
set vars(chandata) [list]
set vars(watch.read) 0
set vars(watch.write) 0
}
method initialize {ch args} {
my variable vars
my _initchan
return [list initialize finalize watch read write]
}
method finalize { ch args } {
my variable vars
set vars(watch.read) 0
set vars(watch.write) 0
my destroy
}
method read {ch count args} {
my variable vars
set resp {}
if { [llength $vars(chandata)] > 0 } {
set resp [lindex $vars(chandata) 0]
# this is not efficient, but there will rarely be any
# large amount of data in the memory socket.
# if this changes, the queueing should be changed.
set vars(chandata) [lrange $vars(chandata) 1 end]
}
return $resp
}
method write {ch data args} {
my variable vars
lappend vars(chandata) $data
# inform the app that there's something to read
if { $vars(watch.read) } {
chan postevent $ch read
}
return [string length $data]
}
method watch {ch events} {
my variable vars
# Channel no longer interested in events that are not in $events
foreach event {read write} {
set vars(watch.$event) 0
}
foreach event $events {
set vars(watch.$event) 1
}
}
}
package provide memsock 1.0
proc AAhandler { cmd sock } {
set fcmd [lindex $cmd 0]
switch -exact -- $fcmd {
testAA {
set rport [lindex $cmd 1]
::memsock::sendoob $rport testAAreturn
}
default {
puts "AA:unknown $cmd"
}
}
}
proc BBhandler { cmd sock } {
switch -exact -- $cmd {
default {
puts "BB:unknown $cmd"
}
}
}
after 0 [list coroutine main apply [list { } {
variable copts
variable cres
variable rc
set rc [catch {
::memsock::server AA ::AAhandler
::memsock::server BB ::BBhandler
set chk [::memsock::check AA]
if { $chk } {
set ret [::memsock::sendget BB AA [list testAA BB]]
#puts "got return /$ret/"
if { $ret eq "testAAreturn" } {
set rc 0
puts "OK"
} else {
puts "FAIL"
}
} else {
puts "socket not open"
}
::memsock::serverClose AA
::memsock::serverClose BB
} cres copts]
if {$rc} {
if {} {
}
}
return
} [namespace current]]]
vwait [namespace current]::rc
if {[dict exists $copts -errorinfo]} {
puts stderr [dict get $copts -errorinfo]
}
exit $rc
