Fellow monks
A while ago I decided to study something new with Perl, and I pointed to GUIs and threads. I experimented some simple stuff so far, and wanted to try with a more interesting case.
So I decided to try to build a simple chat gui; the client would use http to send and receive information.
So, in about couple of hours I created this:
#!/usr/bin/perl
use strict ;
use warnings ;
use constant DEBUG => 1 ;
use threads ;
use threads::shared ;
use Tk ;
use AppConfig qw(:expand :argcount) ;
use HTTP::Daemon ;
use HTTP::Status ;
use LWP::UserAgent ;
use CGI ;
$| = 1 if DEBUG ;
# Define configuration variables
my $conf = AppConfig->new({CASE => 1, GLOBAL => { ARGCOUNT => ARGCOUNT
+_ONE }}) ;$conf->define('peerhost', { DEFAULT => 'localhost' }) ;
$conf->define('peerport', { DEFAULT => 1080 }) ;
$conf->define('localport', { DEFAULT => 1080 }) ;
$conf->define('mynick', { DEFAULT => $ENV{USER} || $ENV{USERNAME} || "
+Mr.X" }) ;
# Parse command line arguments
$conf->args() ;
my $peerhost = $conf->get("peerhost") ;
my $peerport = $conf->get("peerport") ;
my $localport = $conf->get("localport") ;
my $nick = $conf->get("mynick") ;
# Create a daemon to run in a thread
my $httpd = HTTP::Daemon->new(LocalPort => $localport,
ReuseAddr => 1) ;
die "Cannot create an HTTP daemon" unless defined $httpd ;
# Create an user agent to send messages
my $ua = LWP::UserAgent->new ;
die "Cannot create an User Agent" unless defined $ua ;
# Configure application window
my $mw = MainWindow->new ;
$mw->title("ChatBG - $nick chatting with $peerhost:$peerport") ;
my $etext = "" ;
my $tbox = $mw->Scrolled("Text", -width => 80, -height => 10,) ;
my $ebox = $mw->Entry(-width => 70, -textvariable => \$etext) ;
my $bsend = $mw->Button(-text => 'Send', -command => \&send_text) ;
$tbox->insert('end',"Listening on port $localport\n") ;
$tbox->configure(-state => 'disabled') ;
$tbox->pack(-side => 'top', -expand => 1, -fill => 'x') ;
$ebox->pack(-side => 'left', -expand => 1) ;
$bsend->pack(-side => 'right', -expand => 1, -fill => 'x') ;
my $httpdt = threads->new(\&httpd) ;
$httpdt->detach ;
MainLoop ;
sub send_text {
unless (length $etext > 0) {
print STDERR "Empty text, won't send\n" ;
return ;
}
$ua->post("http://$peerhost:$peerport/message",
{ nick => $nick, message => $etext }) ;
$etext = "" ;
}
sub httpd {
LISTEN: {
my $client = $httpd->accept ;
redo LISTEN unless defined $client ;
my $request = $client->get_request ;
unless ($request->method eq 'POST' and
$request->url->path eq '/message') {
$client->send_error(RC_FORBIDDEN) ;
$client->close ;
redo LISTEN ;
}
my $q = CGI->new($request->content) ;
my ($nick,$message) = map $q->param($_),qw(nick message) ;
print STDERR "Resetting text box state\n" if DEBUG ;
$tbox->configure(-state => 'normal') ;
$tbox->insert('end',qq($nick says: $message\n)) ;
print STDERR "Disabling text box\n" if DEBUG ;
$tbox->configure(-state => 'disabled') ;
$client->send_status_line ;
$client->close ;
redo LISTEN ;
}
}
If I run this without command-line arguments, it simply talks to itself. When I press the "Send" button it displays the message in the text box immediately, but also throws this error:
bronto@marmotta:~/B-Lab/threads$ ./gui.pl
Resetting text box state
Disabling text box
Tk::Error: Not an ARRAY reference at /usr/lib/perl5/Tk/After.pm line 7
+9.
[once,[{},after#9,idle,once,[ConfigChanged,{},{}]]]
("after" script)
Tk::Error: Can't call method "Call" on an undefined value at /usr/lib/
+perl5/Tk/After.pm line 83.
[once,[{},after#10,idle,once,[ConfigChanged,{},{}]]]
("after" script)
Apart of this, it seems to work. Now I fire up another client to talk to this same one that I started first, this way:
bronto@marmotta:~/B-Lab/threads$ ./gui.pl -localport 1081 -peerport 1080 -mynick marco
When I send a message from this new window, nothing happens on the first window for a while, then other errors as the one above come out, and all the messages I sent are finally displayed
Questions are:
- is there anything wrong in the way I am using Tk and threads?
- is there anything wrong in the way I am using threads?
I am using a perl 5.8.4 on a Debian GNU/Linux "sarge" distribution on i686; Tk 800.025
Thanks in advance
Ciao!
--bronto
In theory, there is no difference between theory and practice. In practice, there is.
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.