Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

learning tk and threads: what do these errors mean?

by bronto (Priest)
on Jan 07, 2005 at 23:27 UTC ( #420430=perlquestion: print w/ replies, xml ) Need Help??
bronto has asked for the wisdom of the Perl Monks concerning the following question:

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.

Comment on learning tk and threads: what do these errors mean?
Select or Download Code
Re: learning tk and threads: what do these errors mean?
by BrowserUk (Pope) on Jan 07, 2005 at 23:50 UTC

    You are using an object $tbox from across threads. This does not work.

    You can use threads and Tk in the same app, but you must confine all your interaction with Tk to your main thread.

    If you want to use information collected or generated in your other thread(s), to be displayed in your Tk widgets, your must communicate that information from the other threads to the Tk thread through shared variables--scalars, arrays or hashes; not objects.

    A good way to communicate strings that you want to display in your textbox woud be to have your comms thread enqueue them to a Thread::Queue, and have your -after routine dequeue them in your main thread and update the display.

    Do a supersearch for "threads" & "Tk", with my name as the author and you should find one or to examples plus some explaination kicking around.


    Examine what is said, not who speaks.
    Silence betokens consent.
    Love the truth but pardon error.
Re: learning tk and threads: what do these errors mean?
by Courage (Parson) on Jan 07, 2005 at 23:54 UTC
    No luck with threading with perl+Tk, it was confirmed many times by author of perlTk ni-s

    Much more chances with perl+Tcl::Tk, available at http://search.cpan.org/~vkon/Tcl-Tk/ but I have no information about threading with it at the moment however.

    It is because perl threads are somewhat special, and different compared to ones in Tk, and Tcl/Tk has another threading model, but perlTk avoids threading at all, so you'll get less chances with it.

    Please excuse my bad English, its time to go to sleep for me

    Best regards,
    Courage, the Cowardly Dog

Re: learning tk and threads: what do these errors mean?
by zentara (Archbishop) on Jan 08, 2005 at 13:27 UTC
    After alot of trial and error, the only way to get threads and Tk to work together, is to make your threads before you declare your mainwindow. You can make a thread, and put it to sleep, then start Tk, and awaken and use the thread for simple purposes, but don't try to pass or use Tk object's from or to it. You can pass data around through shared variables however.

    I'm not really a human, but I play one on earth. flash japh
Re: learning tk and threads: what do these errors mean?
by BrowserUk (Pope) on Jan 08, 2005 at 18:22 UTC

    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.

      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: perlquestion [id://420430]
Approved by BrowserUk
Front-paged by Courage
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (12)
As of 2014-09-02 20:39 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite cookbook is:










    Results (29 votes), past polls