''[JMeh] 13 Jul 2017'' - SerWatch (Serial Watcher)

'''SerWatch''' is a little Tcl library for analyzing protocols over a serial line.

I often have to connect serial devices like scales, PD controller or several testing machines and therefore I wrote this library.
You have to make a serial adapter which has to be connected with both communication partners.
Both serial data lines (TxD and RxD) must be connected to each of the RxD line of two additional serial adapters in your PC.
I use USB virtual COM port adapters for my Mac.
Here is a little schematic:

======none
       DB-25(f)                  DB-25(m)
          2 -----*---------------- 2     TxD
          3 -----|----------*----- 3     RxD
          4 -----|----------|----- 4     RTS
          5 -----|----------|----- 5     CTS
          6 -----|----------|----- 6     DSR
          7 -----|--*----*--|----- 7     GND
          8 -----|--|----|--|----- 8     DCD
         20 -----|--|----|--|----- 20    DTR
                 |  |    |  |
                 |  |    |  |
                 |  |    |  |
       DB-9(f)   |  |    |  |   DB-9(f)
          2 -----+  |    |  +----- 2     RxD
          5 --------+    +-------- 5     GND
          7 --\                /-- 7     RTS
          8 --/                \-- 8     CTS
          1 --\                /-- 1     DCD
          4 --+                +-- 4     DTR
          6 --/                \-- 6     DSR
======

Then you can write a little Tcl script to use SerWatch like this:

======tcl
package require Serwatch
Serwatch::Init -tty1 /dev/cu.usbserial-FTGZMSMJ -tty2 /dev/cu.usbserial-FTGZMTOX -hex no \
               -baud 9600,e,8,2 -win . -log impact450.log -tout 5000
======

I think, the parameters are self explained.

This shows in the main window what's going on, if the serial mode parameter is correct :-) and also writes all lines to the given log file.

Here is an example of a typical log:

======none
09:59:02.000 INIT Serwatch
09:59:02.016 tty1 = /dev/ttyUSB0
09:59:02.016 tty2 = /dev/ttyUSB1
09:59:02.016 baud = 9600,e,7,1
09:59:02.031 tty1 OK (file5 = <-) -- reading input
09:59:02.043 tty2 OK (file6 = ->) -- reading input
10:03:30.648 <- ␂ U M ; T I P U 1 5 1 5 3 9 1 ␣ ␣ ␣ ␣ ; ␃ ␊ ␍
10:03:31.669 -> ␂ 0 0 A 0 0 0 1 ␃ ␊ ␍
10:03:31.880 <- ␊ ␍
10:03:36.885 timeout 
10:03:44.262 <- ␂ U M ; B 0 0 0 1 ␣ ␣ ␣ ␣ ␣ ; ␃ ␊ ␍ ␣
10:03:45.298 -> ␂ 0 0 ␃ ␊ ␍
10:03:45.477 <- ␊ ␍
10:03:50.478 timeout 
10:05:15.591 <- ␂ C B ; T I P U 1 5 1 5 3 9 1 ␣ ␣ ␣ ␣ ; ␃ ␊ ␍
10:05:16.628 -> ␂ 0 0 B 0 0 0 1 ␃ ␊ ␍
10:05:16.823 <- ␊ ␍
10:05:21.824 timeout 
10:05:26.214 <- ␂ C B ; B 0 0 0 1 ␣ ␣ ␣ ␣ ␣ ␣ ; ␃ ␊ ␍
10:05:27.234 -> ␂ 0 0 ␃ ␊ ␍
10:05:27.413 <- ␊ ␍
10:05:32.417 timeout 
10:05:41.011 <- ␂ C B ; 2 4 1 1 1 1 1 1 ; ␃ ␊ ␍
10:05:42.032 -> ␂ 0 0 ␃ ␊ ␍
10:05:42.211 <- ␊ ␍
10:05:47.214 timeout 
10:05:54.513 <- ␂ C B ; S E E D ␣ ␣ ␣ ␣ ␣ ␣ ␣ ␣ ␣ ␣ ␣ ␣ ␣ ␣ ␣ ␣ ; ␃
10:05:55.550 -> ␂ 0 0 ␃ ␊ ␍
10:05:55.713 <- ␊ ␍
10:06:00.719 timeout 
10:06:04.143 <- ␂ C B ; B ␣ ␣ ; ␃ ␊ ␍
10:06:05.180 -> ␂ 0 0 ␃ ␊ ␍
10:06:05.343 <- ␊ ␍
10:06:10.344 timeout 
======

The library is tested on macos X, Linux and Windows.

And here is the source:

======tcl
###############################################################################
#
# Serial Watcher (serwatch)
# =========================
#
# Beobachtung zweier serieller Schnittstellen zur Analyse des Datenverkehrs
# zwischen zwei Geräten. Dazu muß ein doppel-T Kabel angefertigt werden:
#
#       DB-25(f)                  DB25(m)
#          2 -----*---------------- 2     TxD
#          3 -----|----------*----- 3     RxD
#          4 -----|----------|----- 4     RTS
#          5 -----|----------|----- 5     CTS
#          6 -----|----------|----- 6     DSR
#          7 -----|--*----*--|----- 7     GND
#          8 -----|--|----|--|----- 8     DCD
#         20 -----|--|----|--|----- 20    DTR
#                 |  |    |  |
#                 |  |    |  |
#                 |  |    |  |
#       DB-9(f)   |  |    |  |   DB-9(f)
#          2 -----+  |    |  +----- 2     RxD
#          5 --------+    +-------- 5     GND
#          7 --\                /-- 7     RTS
#          8 --/                \-- 8     CTS
#          1 --\                /-- 1     DCD
#          4 --+                +-- 4     DTR
#          6 --/                \-- 6     DSR
#
# Die beiden DB-25 sind 1:1 mit einander verbunden. Die beiden DB-9 Buchsen
# sind lediglich mit der Empfangsleitung und Masse mit den DB-25 verbunden.
# Vorsichtshalber sind die Handshake-Leitungen in den DB-9 Buchsen gebrückt
# (7-8 und 1-4-6).
#
###############################################################################


namespace eval Serwatch {
  variable config

  array set config "
    tty1  /dev/ttyS0
    tty2  /dev/ttyS1
    baud  9600,n,8,1
    fd1   {}
    fd2   {}
    key   {}
    win   {}
    txw   {}
    sbw   {}
    timer {}
    time0 {}
    tout  1000
    olen  0
    lcnt  0
    log   {}
    fdlog {}
    hex   0
    uchar yes
    font  Monaco
    fsize 13
    ascnm {NUL SOH STX ETX EOT ENQ ACK BEL BS  TAB LF  VT  FF CR SO SI
           DLE XON DC2 XOF DC4 NAK SYN ETB CAN EM  SUB ESC FS GS RS US}
  "

  namespace export Init
}


proc Serwatch::Hex { c } {
  variable config

  binary scan $c c asc
  if {$config(hex)} {
    return [format %02X [expr {$asc & 0xFF}]]
  } else {
    if {$asc < 32} {
      if {$config(uchar)} {
        return [subst -nocommands -novariables "\\u24[format %02X $asc]"]
      } else {
        return [lindex $config(ascnm) $asc]
      }
    } elseif {$asc == 32} {
      if {$config(uchar)} {
        return "\u2423"
      } else {
        return ._.
      }
    } elseif {$asc > 126} {
      return [format 0x%02X $asc]
    } elseif {$asc == 127} {
      if {$config(uchar)} {
        return "\u2421"
      } else {
        return DEL
      }
    }
  }
  return $c
}


proc Serwatch::Read { fd key } {
  variable config

  after cancel $config(timer)

  if {[eof $config($fd)]} {
    Serwatch::Close
    return
  }

  if {[set c [read $config($fd) 1]] != ""} {
    if {$config(tout) != {}} {
      set config(timer) [after $config(tout) Serwatch::Timeout]
    }
    Message $key [Hex $c]
  }
}


proc Serwatch::Timeout {} {
  Message "timeout"
}


proc Serwatch::Close {} {
  variable config

  catch { close $config(fd1) }
  catch { close $config(fd2) }
  set config(fd1) {}
  set config(fd2) {}
  after 1000 Serwatch::Init
}


proc Serwatch::Init { args } {
  variable config

  if {$args != {}} {
    set argn [llength $args]
    for {set argi 0} {$argi < $argn} {incr argi} {
      set arg [lindex $args $argi]
      switch -- $arg {
        -tty1 - -tty2 - -baud - -win - -tout - -log - -hex {
          set opt [string range $arg 1 end]
          set config($opt) [lindex $args [incr argi]]
        }
        default {
          set opts "-tty1, -tty2, -baud, -win, -tout, -log, or -hex"
          error "bad option \"$arg\": must be $opts"
        }
      }
    }
  }

  if {$config(log) != {}} {
    catch { open $config(log) a } config(fdlog)
  }

  set t0 [clock seconds]
  while 1 {
    set usec [clock clicks -milliseconds]; set sec [clock seconds]
    if {$sec != $t0} {
      set config(time0) [expr {$usec % 1000}]
      break
    }
  }

  Message INIT Serwatch
  Message tty1 "= $config(tty1)"
  Message tty2 "= $config(tty2)"
  Message baud "= $config(baud)"

  set ok 1
  foreach {tty fd key} {tty1 fd1 <-  tty2 fd2 ->} {
    if {$config($tty) != "none"} {
      if {[regexp {^tcp:([\w\.]+):(\w+)$} $config($tty) all host port]} {
        set rc [catch { set config($fd) [socket $host $port] } err]
      } else {
        set rc [catch { set config($fd) [open $config($tty) r+] } err]
        if {$rc == 0} {
          set rc [catch { fconfigure $config($fd) -mode $config(baud) } err]
        }
      }
      if {$rc == 0} {
        fconfigure $config($fd) -buffering none -blocking 1 -translation binary
        Message $tty "OK ($config($fd) = $key) -- reading input"
        fileevent $config($fd) readable [list Serwatch::Read $fd $key]
      } else {
        Message ERROR $err
        set ok 0
      }
    }
  }
  if {!$ok} {
    Serwatch::Close
    return 0
  }
  return 1
}


proc Serwatch::Dlg {} {
  variable config

  if {![winfo exists $config(win)]} {
    toplevel $config(win)
    wm title $config(win) "Serial Watcher"
    wm resizable $config(win) 0 1
  }
  if {$config(win) == "."} {
    set frm .swf
  } else {
    set frm $config(win).swf
  }
  font create AsciiFont -family $config(font) -size $config(fsize) -slant roman -weight bold
  pack [frame $frm] -fill both -expand yes
  pack [scrollbar $frm.sb -command "$frm.txt yview" -takefocus 0] \
          -side right -expand 0 -fill y
  pack [text $frm.txt -font AsciiFont -width 80 -height 25 \
          -state disabled -wrap none -yscrollcommand "$frm.sb set"] \
          -side right -expand 1 -fill both
  set config(txw) $frm.txt
  set config(sbw) $frm.sb
}


proc Serwatch::Message { key {str ""} } {
  variable config

  if {$key != $config(key)} {
    set sec [clock seconds]; set msec [clock clicks -milliseconds]
    set tstr [clock format $sec -format %H:%M:%S]
    append tstr .[format %03u [expr {($msec - $config(time0)) % 1000}]]
    set out "\n$tstr $key $str"
    set config(olen) [string length $out]
    incr config(lcnt)
  } else {
    set out " $str"
    incr config(olen) [string length $out]
    if {$config(olen) >= 75} { set key * }
  }

  if {$config(win) != {}} {
    if {$config(txw) == {}} {
      Serwatch::Dlg
    }
    catch {
      set scrpos [lindex [$config(txw) yview] 1]
      $config(txw) configure -state normal
      $config(txw) insert end $out
      $config(txw) configure -state disabled
      if {$scrpos == 1} { $config(txw) see end }
      if {$config(lcnt) > 2500} {
        $config(txw) configure -state normal
        $config(txw) delete 0.0 9.0
        $config(txw) configure -state disabled
        incr config(lcnt) -10
      }
    }
  } else {
    puts -nonewline stdout $out; flush stdout
  }
  if {$config(fdlog) != {}} {
    puts -nonewline $config(fdlog) $out
    if {$key == "timeout"} { flush $config(fdlog) }
  }

  set config(key) $key
}


package provide Serwatch 1.2
======