learning tk and threads: what do these errors mean?

[bronto]

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

[BrowserUk]

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.

[Courage]

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

[zentara]

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.

[BrowserUk]

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.

[bronto]

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