Category: Perl

This is the Perl and Tk implementation of the message bus program. The principles of the message bus are described in the main message bus article. Do read that article first.

This example uses tkinter, Perl’s interface to the Tk GUI toolkit. Tk has support for events on files and sockets, so socket handling is integrated into the GUI’s event loop.

Tk is used by several implementations: Perl, Python and Tcl.

The source code

#!/usr/bin/perl

require Tk::Menu;
use Tk;
use IO::Socket;
use strict;

my $current_colour = 1002;

#---------------------------------------------------------------------------------------- Server
my @workers;
my $server;

sub create_server($) {
    my ($root) = @_;
    $server = new IO::Socket::INET(LocalPort => 4711,
                                   type      => SOCK_STREAM,
                                   Reuse     =>  1,
                                   Listen    => 10);
    if ($server) {
        $root->fileevent($server, "readable", sub { accept_connection($root); } );
    }
}

sub accept_connection($) {
    my ($root) = @_;
    my $worker = $server->accept();
    push @workers, $worker;
    $root->fileevent($worker, "readable", sub { read_from_client($worker); });
    write_to_client($worker, sprintf("%d\n", $current_colour));
}

#---------------------------------------------------------------------------------------- Worker
sub read_from_client($) {
    my ($worker) = @_;
    if ($worker->eof()) {
        $worker->close();
        exit();
    } else {
        my ($line) = <$worker>;
        map { write_to_client($_, $line) } @workers;
    }
}

sub write_to_client($$) {
    my ($worker, $line) = @_;
    $worker->send($line);
}
#---------------------------------------------------------------------------------------- Client
my $client;

sub create_client($) {
    my ($root) = @_;
    $client = new IO::Socket::INET(PeerAddr => 'localhost',
                                   PeerPort => 4711,
                                   Proto    => 'tcp');

    $root->fileevent($client, "readable", \&read_from_server);
}

sub notify_server($) {
    my ($colour) = @_;
    $client->send(sprintf("%d\n", $colour));
}

sub read_from_server {
    if ($client->eof()) { exit(0); }
    my $line = <$client>;
    on_incoming_message($line);
}

#---------------------------------------------------------------------------------------- Gui
my ($red, $green, $blue);
my $x      = 2 * 2.54 / 72.27;  #--- Conversion factor from points to "something"

sub create_gui() {
    my $root   = MainWindow->new();
    $root->title("Perl and Tk");
    $red   = btn("Red",    1001, $root);
    $green = btn("Green",  1002, $root);
    $blue  = btn("Blue",   1003, $root);

    $red  ->grid(-in => $root, -column => '1', -row => '1');
    $green->grid(-in => $root, -column => '2', -row => '1');
    $blue ->grid(-in => $root, -column => '3', -row => '1');
    return $root;
}

sub on_clicked($) {
    my ($colour) = @_;
    printf("on_clicked(%d)\n", $colour);
    notify_server($colour);
}

sub update_btn($$$) {
    my ($button, $cond, $colour_spec) = @_;
    my $c = ($cond ? $colour_spec : 'white');
    $button->configure(-background       => $c,
                       -activebackground => $c);
}

sub on_incoming_message($) {
    my ($line) = @_;
    $current_colour = int($line);

#    printf("New colour is %d\n", $current_colour);

    update_btn($red,   1001 == $current_colour, '#F77'  );
    update_btn($green, 1002 == $current_colour, '#7F7');
    update_btn($blue,  1003 == $current_colour, '#77F' );
}

sub btn($$) {
    my ($text, $colour, $root) = @_;
    return $root->Button(-text     => $text,
                         -command  => sub { on_clicked($colour) },
                         -width    => 100 * $x,
                         -height   =>  20 * $x
                     );
}

#---------------------------------------------------------------------------------------- Gui

sub main {
    my $root = create_gui();
    create_server($root);
    create_client($root);
}

main();
Tk::MainLoop;

# Local Variables:
#     coding:  us-ascii-unix
# End:

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.