Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight
 
PerlMonks  

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

by BrowserUk (Pope)
on Jan 08, 2005 at 18:22 UTC ( #420561=note: print w/replies, xml ) Need Help??


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

By way of demonstration that it is perfectly possible and easy to use threads and Tk in the same app, here's a somewhat tested version of your program that does so.

#! perl -slw use strict; use Carp qw[ cluck croak ]; use threads; use threads::shared; use Thread::Queue; our $NICK ||= 'Me'; our $PEERHOST ||= 'localhost'; our $PEERPORT ||= '1080'; our $LOCALPORT ||= '1081'; our $DEBUG ||= 0; { no warnings; our $cluck; *cluck = sub () {} unless $DEBUG; } ## Allow the daemon thread to communicate with the interface thread. my $Q = new Thread::Queue; my $running : shared = 0; ## Start the daemon my $deamon = threads->new( \&httpd, $Q, \$running ); ## Start the UI my $UI = threads->new( \&ui, $Q, \$running ); ## Sleep until they are done sleep 1 until $running; sleep 1 while $running; exit; sub httpd { my( $Q, $runningRef ) = @_; { lock $$runningRef; $$runningRef++ } ## Setup daemon require CGI; require HTTP::Daemon; require HTTP::Status; my $httpd = HTTP::Daemon->new( LocalPort => $LOCALPORT, ReuseAddr => 1, ) or die "Cannot create an HTTP daemon"; $httpd->timeout( 2 ); ## Make sure the UI is running; sleep 1 until $$runningRef == 2; ## And do our thing until the UI goes away. while( $$runningRef == 2 ) { my $client = $httpd->accept or next; cluck "$NICK: Accepted"; my $request = $client->get_request; unless ( $request->method eq 'POST' and $request->url->path eq '/message' ) { cluck "$NICK: Rejected"; $client->send_error( RC_FORBIDDEN() ); $client->close; next; } my $q = CGI->new($request->content); my( $nick, $message ) = map{$q->param( $_ ) } qw[ nick message + ]; cluck "$NICK: Queued '$nick:'$message'"; $Q->enqueue( "$nick says: $message\n" ); $client->send_status_line; $client->close; } { lock $$runningRef; $$runningRef-- } } sub ui { my( $Q, $runningRef ) = @_; { lock $$runningRef; $$runningRef++ } ## require LWP; my $ua = LWP::UserAgent->new or die "Cannot create an User Agent"; ## Build the UI require Tk; my $mw = MainWindow->new; $mw->title("ChatBG - $NICK chatting with $PEERHOST:$PEERPORT"); my $tbox = $mw->Scrolled( "Text", -width => 80, -height => 10,); $tbox->insert( 'end', "Listening on port $LOCALPORT\n" ); $tbox->configure( -state => 'disabled' ); $tbox->pack( -side => 'top', -expand => 1, -fill => 'x' ); my $etext = ""; my $ebox = $mw->Entry( -width => 70, -textvariable => \$etext ); $ebox->pack(-side => 'left', -expand => 1); my $bsend = $mw->Button( -text => 'Send', -command => sub { return unless length $etext; cluck "$NICK: Sending '$etext' to '$PEERHOST:$PEERPORT'"; $ua->post( "http://$PEERHOST:$PEERPORT/message", { nick => $NICK, message => $etext } ) or die "$!"; $etext = ''; } ); $bsend->pack( -side => 'right', -expand => 1, -fill => 'x' ); ## Make sure the deamon is running; sleep 1 until $$runningRef == 2; ## Arrange for the interface to be updated $mw->repeat( 100, sub { while( $Q->pending ) { $tbox->configure( -state => 'normal' ); $tbox->insert( 'end', $Q->dequeue ); $tbox->configure( -state => 'disabled' ); } } ); ## Run the insterface $mw->MainLoop; cluck "$NICK: MainLoop ended"; { lock $$runningRef; $$runningRef-- } }

If anyone who runs a threaded perl, has Tk and HTTP::Daemon; LWP; CGI etc installed fancies helping me try this out across the net, /msg me.


Examine what is said, not who speaks.
Silence betokens consent.
Love the truth but pardon error.

Replies are listed 'Best First'.
Re^2: learning tk and threads: what do these errors mean?
by bronto (Priest) on Jan 08, 2005 at 20:32 UTC

    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.

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (2)
As of 2018-10-21 03:22 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    When I need money for a bigger acquisition, I usually ...














    Results (119 votes). Check out past polls.

    Notices?