TMB client: Tcl and Tk

A TMB message bus client in written in TCL


The principles of the Text Message Bus bus are described in the main TMB article. Do read that article first.

This TMB client should work on any platform.

The source code has been split into three files:

  • networking.tcl   — BSD socket code.
  • gui.tcl   — Graphical user interface, using Tk.
  • message-bus-tester.tcl   — TMB message bus logic.

The last file also contains the main program.

Network routines

  • global client   — The socket.
  • proc network_start   — Creates a socket and connects to the server.
  • proc network_write   — Writes a packet to the socket. Appends newline.
  • proc network_read_from_server   — Called by the Tk framework when there are data vailable on the socket

Graphical user interface routines

  • frame .upper   — The canvas for the upper figures, and its six configuration buttons.
  • frame .lower   — And for the lower figure
  • frame .su   — The subscribe and unsubscribe buttons, and the “Send all” button.
  • global upper_colour   — The colour of the upper figure (“red”, “green” or “blue”).
  • global upper_shape   — The colour of the upper figure (“square”, “circle” or “triangle”).
  • global lower_colour   — And so on.
  • global lower_shape   — And so forth.
  • proc draw_figure   — Draws a triangle, square or circle.
  • proc draw_both   — Convenience procedure to draw both the upper and lower figures.
  • proc create_figure_frame   — Creates seven widgets: the figure canvas and its push buttons.
  • proc configure_grid_pair   — Convenience for placing a pair of bttons in the subscription frame.
  • proc create_subscription_button_pair   — Creates a pair of subscribe/unsubscribe buttons.
  • proc create_subscription_frame   — Creates all the subscribe and unsibscribe buttons.
  • proc create_gui   — Creates and populates the applications window.
  • proc send_all   — Callback for the “Send all” button.

Message bus routines, and main program

  • proc mb_send_command_message   — Send a message by calling network_write.
  • proc mb_send_peer_message    — Prepends a colon before calling network_write.
  • proc mb_on_incoming_message   — Called by network_read_from_server for each line read from the socket.
  • proc main   — The main program.

networking.tcl

network_start loops over a range of ports, provided by the main program. When it has connected, it sets up a fileevent to call network_read_from_server when there is data available on the socket. That routine will then call mb_on_incoming_message.

In network_write, not that puts automatically append a newline.

proc network_start { host port1 port2 } {
    global client
    for { set port $port1 } { $port <= $port2 } { incr port } {
        if { [ catch { socket $host $port } client ] } {
            puts "Failed on port $port, trying next port"
        } else {
            puts "Connected on port $port"
            fconfigure $client -blocking 0 -translation lf
            fileevent $client readable "network_read_from_server $client"
            return
        }
    }
    error "Failed to connect"
}

proc network_write { msg } {
    global client
    puts $client "$msg"
    flush $client
    puts "< $msg"
}

proc network_read_from_server { client } {
    if {[eof $client]} {
        exit
    }
    while {[gets $client line] > 0} {
        mb_on_incoming_message [ string trimright $line ]
    }
}

gui.tcl

global upper_colour;   set upper_colour red
global upper_shape;    set upper_shape  square
global lower_colour;   set lower_colour blue
global lower_shape;    set lower_shape  circle

proc send_all { } {
    global upper_colour upper_shape lower_colour lower_shape
    mb_send_peer_message "/upper/colour $upper_colour"
    mb_send_peer_message "/upper/shape  $upper_shape"
    mb_send_peer_message "/lower/colour $lower_colour"
    mb_send_peer_message "/lower/shape  $lower_shape"
}

proc draw_figure { c shape colour } {
    $c delete figure
    if { $shape == "circle" } {
        $c create oval 3m 3m 17m 17m -outline black -fill $colour -tag figure
    }
    if { $shape == "square" } {
        $c create rectangle 3m 3m 17m 17m -outline black -fill $colour -tag figure
    }
    if { $shape == "triangle" } {
        $c create polygon 3m 16m   17m 16m   10m 4m   3m 16m -outline black -fill $colour -tag figure
    }
}

proc draw_both { } {
    global upper_colour upper_shape lower_colour lower_shape
    draw_figure  .upper.image  $upper_shape  $upper_colour
    draw_figure  .lower.image  $lower_shape  $lower_colour
}

proc create_figure_frame { group } {
    frame  .$group
    canvas .$group.image -width 20m -height 20m
    set p  .$group.buttons
    frame  $p

    button $p.red      -text Red      -command " mb_send_peer_message { /$group/colour red    } "
    button $p.green    -text Green    -command " mb_send_peer_message { /$group/colour green  } "
    button $p.blue     -text Blue     -command " mb_send_peer_message { /$group/colour blue   } "
    button $p.circle   -text Circle   -command " mb_send_peer_message { /$group/shape circle  } "
    button $p.square   -text Square   -command " mb_send_peer_message { /$group/shape square  } "
    button $p.triangle -text Triangle -command " mb_send_peer_message { /$group/shape triangle} "
    grid configure $p.red      -row 0 -column 0 -sticky nsew
    grid configure $p.green    -row 0 -column 1 -sticky nsew
    grid configure $p.blue     -row 0 -column 2 -sticky nsew
    grid configure $p.circle   -row 1 -column 0 -sticky nsew
    grid configure $p.square   -row 1 -column 1 -sticky nsew
    grid configure $p.triangle -row 1 -column 2 -sticky nsew
    grid columnconfigure $p { 0 1 2 } -weight 1 -uniform group1

    pack   .$group.image -side left
    pack   .$group.buttons -side left -expand 1 -fill x
}

proc configure_grid_pair { row a b } {
    grid configure $a  -row $row  -column 0  -sticky nsew
    grid configure $b  -row $row  -column 1  -sticky nsew
}    

proc create_subscription_button_pair { row name id match } {
    button .su.${name}sub   -text "subscribe $id $match" -command "mb_send_command_message { subscribe $id $match }"
    button .su.${name}unsub -text "unsubscribe $id"      -command "mb_send_command_message { unsubscribe $id }"
    configure_grid_pair $row .su.${name}sub .su.${name}unsub
    incr row
}

proc create_subscription_frame { } {
    frame .su
    button .su.send_all   -text "Send all"        -command "send_all"
    button .su.unsub_all  -text "unsubscribe *"   -command "mb_send_command_message {unsubscribe *}"
    configure_grid_pair 0 .su.send_all .su.unsub_all
    create_subscription_button_pair 1 sub1 1 "regexp ."
    create_subscription_button_pair 2 sub2 2 "begins-with /upper"
    create_subscription_button_pair 3 sub3 3 "ends-with shape"
    create_subscription_button_pair 4 sub4 4 "contains colour"
    create_subscription_button_pair 5 sub5 5 "is /upper/shape"
    grid columnconfigure .su { 0 1 } -weight 1
}

proc create_gui { } {
    font create default_font -size 10 -family {Source Code Variable}
    option add *font                default_font
    option add *Button.background  #CCC
    option add *Button.relief       raised
    option add *Button.borderWidth  2
    option add *Button.padX         1m

    create_figure_frame upper
    create_figure_frame lower
    create_subscription_frame

    pack .upper .lower .su -expand 1 -fill x
    wm title . "Message bus tester (Tcl + Tk)"

    # Set windows minimum size to its natural size
    update
    regexp {(\d+)x(\d+)} [wm geometry .] all w h
    wm minsize . $w $h
}

message-bus-tester.tcl

One slightly interesting thing is how peer messages are handled in proc on_incoming_message. Stripped of error handling, here is what happens:

regexp {^:/(\S+)/(\S+)\s+(\S+)} $message dummy group key value
set ${group}_$key $value

With an incoming peer message :/lower/colour green the regexp sets group to lower, key to colour and value to red. The next line, after parsing, becomes

set lower_colour red

where lower_colour can be any of the four variables (lower_colour, lower_shape, upper_colour, upper_shape) used when drawing the two figures.

#!/usr/bin/wish

proc mb_send_peer_message    { msg } { network_write ":[string trim $msg]" }

proc mb_send_command_message { msg } { network_write   [string trim $msg] }

proc mb_on_incoming_message { msg } {
    global upper_colour upper_shape lower_colour lower_shape
    set first [ string index $msg 0 ]
    if { ":" == $first } {
        puts "Got message {$msg}"
        set ok [ regexp {^:/(\S+)/(\S+)\s+(\S+)} $msg dummy group key value ]
        if { $ok } {
            set ${group}_$key $value
            puts "ok = $ok, group = $group, key = $key, value = $value"
            draw_both
        }
    } elseif { " " == $first } {
        puts "  > $msg"
    } elseif { "OK: "  == [string range $msg 0 3] } {
        puts "  > $msg"
    } elseif { "ERROR" == [string range $msg 0 4] } {
        puts "  > $msg"
    } else {
        puts "*** Unknown reply {$msg}"
    }
}


proc main { } {
    global upper_colour upper_shape  lower_colour lower_shape
    global argv0

    #-- In case this script is not in the current working directory
    set here [ file dirname $argv0 ]
    source [ file join $here gui.tcl        ]
    source [ file join $here networking.tcl ]

    create_gui
    network_start localhost 4711 4720

    draw_both
}

main

You can reach me by email at “lars dash 7 dot sdu dot se” or by telephone +46 705 189090

View source for the content of this page.