First of all, thanks a lot for your help. Starting from your suggestions about Thread::Queue, I modified my program and made it finally work, left apart that when I closed the window the httpd thread was abruptedly stopped
Just after a couple of minutes I finished making my script work, I read yours, and I subscribe to the point that threads and Tk can play nicely together. I then took the time to examine your code and see how I could stop the httpd thread more gently. After collecting some advice from you via /msg, here is the result.
#!/usr/bin/perl
use strict ;
use warnings ;
use constant DEBUG => 0 ;
use threads ;
use threads::shared ;
use Tk ;
use AppConfig qw(:expand :argcount) ;
use HTTP::Daemon ;
use HTTP::Status ;
use LWP::UserAgent ;
use CGI ;
use Thread::Queue ;
use Time::HiRes qw(sleep) ;
$| = 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") ;
# This will do the trick of updating the text window
my $queue : shared = Thread::Queue->new ;
my $keep_running : shared = 1 ;
my $httpd_timeout : shared = 10 ;
my $httpdt = threads->new(\&httpd) ;
$httpdt->detach ;
# Create an user agent to send messages
print STDERR "Creating an HTTP user agent\n" if DEBUG ;
my $ua = LWP::UserAgent->new ;
die "Cannot create an User Agent" unless defined $ua ;
# Configure application window
print STDERR "Building the main window\n" if DEBUG ;
my $mw = MainWindow->new ;
$mw->title("ChatBG - $nick chatting with $peerhost:$peerport") ;
my $etext = "" ;
print STDERR "Creating chat window\n" if DEBUG ;
my $tbox = $mw->Scrolled("Text", -width => 80, -height => 10,) ;
print STDERR "Creating text entry field\n" if DEBUG ;
my $ebox = $mw->Entry(-width => 70, -textvariable => \$etext) ;
print STDERR "Configuring send button\n" if DEBUG ;
my $bsend = $mw->Button(-text => 'Send', -command => \&send_text) ;
print STDERR "Filling server information in chat window\n" if DEBUG ;
$tbox->insert('end',"Listening on port $localport\n") ;
$tbox->configure(-state => 'disabled') ;
print STDERR "packing...\n" if DEBUG ;
$tbox->pack(-side => 'top', -expand => 1, -fill => 'x') ;
$ebox->pack(-side => 'left', -expand => 1) ;
$bsend->pack(-side => 'right', -expand => 1, -fill => 'x') ;
print STDERR "Waiting for incoming messages\n" if DEBUG ;
$tbox->repeat(300,\&update_chat_window) ;
MainLoop ;
print STDERR "GUI is being destroyed!\n" if DEBUG ;
{
lock $keep_running ;
$keep_running-- ;
}
print STDERR "Giving httpd a chance to terminate" ;
for (my $i = $httpd_timeout ; $i >= 0 ; $i--) {
if ($keep_running == 0) {
print STDERR ".\n" ;
exit 0 ;
}
print STDERR "...$i" ;
sleep(1) ;
}
print STDERR "\nExit forced!" ;
exit 1 ;
exit ;
sub send_text {
unless (length $etext > 0) {
print STDERR "Empty text, won't send\n" ;
return ;
}
print STDERR "Sending message...\n" if DEBUG ;
$queue->enqueue(qq(you say: $etext\n)) ;
$ua->post("http://$peerhost:$peerport/message",
{
nick => $nick, message => $etext }) ;
$etext = "" ;
}
sub update_chat_window {
my $message = $queue->dequeue_nb ;
return if not defined $message ;
post_to_chat_window($message) ;
}
sub post_to_chat_window {
my $message = shift ;
return unless length $message ;
$tbox->configure(-state => 'normal') ;
$tbox->insert('end',$message) ;
print STDERR "Disabling text box\n" if DEBUG ;
$tbox->configure(-state => 'disabled') ;
}
sub httpd {
# Create a daemon to run in a thread
print STDERR "Creating an HTTP daemon\n" if DEBUG ;
my $httpd = HTTP::Daemon->new(LocalPort => $localport,
Timeout => $httpd_timeout,
ReuseAddr => 1) ;
die "Cannot create an HTTP daemon" unless defined $httpd ;
{
lock $keep_running ;
$keep_running ++ ;
}
print STDERR "HTTP daemon listening on port $localport\n" if DEBUG ;
LISTEN: {
my $client = $httpd->accept ;
if (not defined $client) {
redo LISTEN if $keep_running == 2 ;
# $keep_running is now 1
$httpd->close ;
{
lock $keep_running ;
$keep_running-- ;
}
return ;
}
print STDERR "httpd got an incoming message\n" if DEBUG ;
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) ;
$queue->enqueue(qq($nick says: $message\n)) ;
print STDERR "httpd enqueued message" if DEBUG ;
$client->send_status_line ;
$client->close ;
redo LISTEN ;
}
print STDERR "httpd is being destroyed!\n" if DEBUG ;
}
I hope that this work will help other people that start playing with threads and/or is trying to make threads and Tk play together
Ciao and thanks!
--bronto
In theory, there is no difference between theory and practice. In practice, there is.