Tcl Source Code

Artifact d88f111d56cd757dcc083cb82397522433929ed0d75f36e67d9f9b3ba3b82b38:

Attachment "memsocktest.tcl" to ticket [18f4a94d03] added by bll 2021-06-12 08:46:09.

---

#!/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
    gets $rch line
    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"
    }
  }
}

proc main { } {
  ::memsock::server AA ::AAhandler
  ::memsock::server BB ::BBhandler

  set rc 1
  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

  exit $rc
}

::main