Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

Re^2: learning tk and threads: what do these errors mean?

by bronto (Priest)
on Jan 08, 2005 at 20:32 UTC ( #420587=note: print w/ replies, xml ) Need Help??


in reply to Re: learning tk and threads: what do these errors mean?
in thread learning tk and threads: what do these errors mean?

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.


Comment on Re^2: learning tk and threads: what do these errors mean?
Download Code

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://420587]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (9)
As of 2014-09-18 21:48 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (124 votes), past polls