in reply to Re^2: Tk + threads
in thread Tk + threads

I just knocked up something to demonstrate the technique, I didn't do any debugging. For your purposes you need to handle multiple queues simultaneously, so you would need to use dequeue_nb() (non-blocking) in the while loop. You also need to coordinate the queues with their associated windows, so the logic required is slightly more complex.

This version, equally minimally tested, will run multiple concurrent commands as shown at the __END__. I've used Win32::Sleep to allow the updates to happen quickly whilst not running away with the cpu. You could use select, or Time::HiRes or yield() (though the latter tends to thrash the cpu!). 

#! perl -slw
use strict;
use threads;
use Thread::Queue;
use IO::Pipe;

sub runNGather {
    my( $Q, $cmd ) = @_;
    my $pipe = IO::Pipe->new();
    $pipe->reader( "$cmd 2>&1" );
    $Q->enqueue( $_ ) while <$pipe>;
    $Q->enqueue( '!!!EOF!!!' );
    return;
}

my @Qs;
for( @ARGV ) {
    push @Qs, [ new Thread::Queue ];
    threads->create( \&runNGather, $Qs[-1][0], $_ )->detach;
}

require Tk;
require Tk::ROText;

my $mw = MainWindow->new;
for my $Q ( @Qs ) {
    my $top = $mw->Toplevel();

    my $label = $top -> Label(
        -text=>"STDOUT from script", -relief=>"groove"
    )->pack();

    my $ro = $top->Scrolled(
        'ROText', -width => 60, -height=>20, -scrollbars=>"e"
    )->pack();

    # add close button
    my $close = $top->Button(
        -text => "Close window",
        -command => sub{ destroy $top; }
    )->pack();

    push @{ $Q }, $ro;
}


# continuously display output
while( 1 ) {
    last unless @Qs;
    for my $n ( 0 .. $#Qs ) {
        my $text = $Qs[ $n ][0]->dequeue_nb;
        next unless defined $text;
        if( $text =~ m[^!!!EOF!!!$] ) {
            my $Q = splice( @Qs, $n, 1 );
            undef $Q->[0];
            last;
        }
        my $ro = $Qs[ $n ][1];
        $ro->insert("end", "$text");
        $ro->update();
    }
    $mw->update;
    Win32::Sleep .1;
}

$mw->MainLoop;

__END__
P:\test>522177 "ping www.perlmonks.org" "ping www.bbc.co.uk" "dir /s \
+*.pl"

[download]
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
Lingua non convalesco, consenesco et abolesco. -- Rule 1 has a caveat! -- Who broke the cabal?
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.

Replies are listed 'Best First'.
Re^4: Tk + threads
by knirirr (Scribe) on Jan 10, 2006 at 17:18 UTC

    Thanks again! I'll take a look at that. Meanwhile, further work with your original suggestion has produced something like this (not complete): 

    my $Q = new Thread::Queue;
my $mw = MainWindow->new();

my $run_button = $mw -> Button(-text => "Run Programs",
-command=> sub { threads->create(\&runprogs, $Q)->detach(); &view_out;
+ });

sub runprogs
{
  # run the main script 
  my $pipe = IO::Pipe->new();
  $pipe->reader("$script $args 2>&1");
  $Q->enqueue( $_ ) while <$pipe>;
  $Q->enqueue ( undef );
  sleep;
}

sub view_out
{
  # create display window
  my $top = $mw-> Toplevel();
  my $label = $top -> Label(-text=>"Script output",-relief=>"groove")-
+>pack();
  my $ro = $top->Scrolled('ROText', -width => 60, -height=>20, -scroll
+bars=>"e")->pack();
  # continuously display output
  while (my $thingy = $Q->dequeue_nb())
  {
    last unless (defined $thingy);
    $ro->insert("end", "$thingy");
    $ro->update();
    sleep 1;
  }
  # add close button
  my $close = $top -> Button(-text=>"Close window", -command => sub { 
+destroy $top; })->pack();
}

    [download]

    This works, but if I omit the "sleep" from &runprogs, or have a return in there then all manner of horrible things happen. Presumably this is because I have misunderstood how this all works and cocked up the queueing somehow.

[reply]
[d/l]
      but if I omit the "sleep" from &runprogs, or have a return in there then all manner of horrible things happen

      You're gonna have to be a little more specific that "all manner of horrible things" :)

      sleep without an argument means sleep forever, (I just discovered), or until the process receives a signal. So basically you are saying that if you allow the thread to terminate something breaks somehow.

      One problem is that your while loop is going to terminate pretty much straight away. dequeue_nb returns undef if there is nothing currently in the queue. So, if there is a delay whilst waiting for the output from the command, the dequeuing loop will terminate early. Queueing undef to terminate the dequeue loop works fine when using dequeue, but not for dequeue_nb_ hence the change to a sentinel value in my updated version.

      Another thing I notice with your code. You are creating your $Q before the declaration of runprogs(), and whilst you pass $Q as an argument to the thread, you are not using that argument, but rather picking it up by closure. That's messy, but works okay whilst you only have one command and queue, but once you start having multiple, it won't work at all.

      You really need to be creating a new queue for each command thread you start. That implies that you should be creating the Q inside the command callback sub. It also implies that you would either

      • loop inside that callback once for each program you which to run. Creating a new queue and starting a thread.
      • Or, you have a separate button for each command.
      • Or, you have one button which determines which command to start according to some selection made by the user on the GUI.

      All these are possible, but which makes sense depends upon the architecture of the rest of your application.

      I seriously suggest that you play with the code of the second version I posted and understand how the bits work together. Doing this in a separate stand alone app will allow you get to grips with things more easily than in the context of a more elaborate, complex app.

      You should also take a good look at the code zentara posted. It tackles the problem from a different direction, but you may find it a simpler starting point. I'm not quite sure how it scales for running multiple concurrent processes, but starting simple is good.

      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      Lingua non convalesco, consenesco et abolesco. -- Rule 1 has a caveat! -- Who broke the cabal?
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
[d/l]
[select]
        OK - I'll take a look at both of those options (your second script and zentara's). Thanks again for the suggestions.
[reply]

In Section Seekers of Perl Wisdom