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