Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

Tk-with-worker-threads

by zentara (Cardinal)
on Oct 23, 2004 at 12:47 UTC ( [id://401819]=CUFP: print w/replies, xml ) Need Help??

UPDATED Oct 25/2004

I added code to exit the threads correctly without warning, and a non-leakin text progressbar. To exit a thread without warning, the thread must reach the end of it's code block and be joined. I used a goto, but the idea is simple. I add a 'die' shared variable, which I call when the Exit bitton is pressed.

Everyone has been looking for some way which can run concurrent processes from Tk, in a non-blocking manner, with data exchange. Fork-and-exec works nice, but it's a PITA to exchange data. Here is a proof-of-concept using threads. The sharing of data is easier than I thought. You can pass a $data to the worker thread to be eval'ed. It dosn't leak memory at all, and remains steady after 2 full cycles.

In this example, the worker thread opens an xterm, and when the xterm is closed will start a count to 100, then turn itself off. A progressBar is commented out, because it leaks, but ActivityBar dosn't.

Eventually I want to be able to read filehandles from the thread through the shared hash. 

#!/usr/bin/perl
use warnings;
use strict;
use lib ',';
use threads;
use threads::shared;
use Tk;
use Tk::ActivityBar;
use Tk::Dialog;
#use MeM;
                   
my $data = shift || 'xterm -e bash';
                   
my %shash;         
#share(%shash); #will work only for first level keys 
my %hash;
my %workers;
my $numworkers = 3;
    
foreach my $dthread(1..$numworkers){
 share ($shash{$dthread}{'go'});
 share ($shash{$dthread}{'progress'});
 share ($shash{$dthread}{'timekey'});  #actual instance of the thread 
 share ($shash{$dthread}{'frame_open'}); #open or close the frame 
 share ($shash{$dthread}{'handle'});
 share ($shash{$dthread}{'data'});
 share ($shash{$dthread}{'pid'});
 share ($shash{$dthread}{'die'});
                
 $shash{$dthread}{'go'} = 0;
 $shash{$dthread}{'progress'} = 0;
 $shash{$dthread}{'timekey'} = 0;
 $shash{$dthread}{'frame_open'} = 0;
 $shash{$dthread}{'handle'} = 0;
 $shash{$dthread}{'data'} = $data;
 $shash{$dthread}{'pid'} = -1;

 $shash{$dthread}{'die'} = 0;
 $hash{$dthread}{'thread'} = threads->new( \&work,$dthread );
}
        
my $mw = MainWindow->new(-background => 'gray50');
              
my $lframe = $mw->Frame( -background => 'gray50',-borderwidth=>10 )
                  ->pack(-side =>'left' ,-fill=>'y');
my $rframe = $mw->Frame( -background => 'gray50',-borderwidth=>10 )
                  ->pack(-side =>'right',-fill =>'both' );
        
my %actives = (); #hash to hold reusable numbered widgets used for dow
+nloads 
my @ready = ();   #array to hold markers indicating activity is needed
+ 
my $activity = $lframe->ActivityBar()->pack(-side => 'top',-anchor => 
+'n');
      
#make 3 reusable downloader widget sets------------------------- 
foreach(1..$numworkers){
   push @ready, $_;
#frames to hold indicator 
$actives{$_}{'frame'} = $rframe->Frame( -background => 'gray50' );
                 
$actives{$_}{'stopbut'} = $actives{$_}{'frame'}->Button(
        -text       => "Stop Worker $_",
        -background => 'lightyellow',
        -command    => sub {  } )->pack( -side => 'left', -padx => 10 
+);

$actives{$_}{'label1'} = $actives{$_}{'frame'} ->Label(
         -width       => 3,
         -background => 'black',
         -foreground => 'lightgreen',
         -textvariable => \$shash{$_}{'progress'},
    )->pack( -side => 'left' );
        
$actives{$_}{'label2'} = $actives{$_}{'frame'} ->Label(
         -width       => 1,
         -text        => '%',
         -background  => 'black',
         -foreground  => 'lightgreen',
    )->pack( -side => 'left' );
 
$actives{$_}{'pb'} = $actives{$_}{'frame'}->Label(
        -width => 15,
        -bg    => 'grey45',
        -fg    => 'hotpink',
        -anchor => 'w',
        )->pack( -side => 'left');
        
$actives{$_}{'label3'} = $actives{$_}{'frame'} ->Label(
          -text        => '',
         -background  => 'black',
         -foreground  => 'skyblue',
    )->pack( -side => 'left',-padx =>10 );
 
}
#-------------------------------------------------- 
my $button = $lframe->Button(
    -text       => 'Get a worker',
    -background => 'lightgreen',
    -command    => sub { &get_a_worker(time) }
           )->pack( -side => 'top',
              -anchor => 'n', -fill=>'x', -pady => 20 );
     
my $text = $rframe->Scrolled("Text",
                   -scrollbars => 'ose',
                   -background => 'black',
                   -foreground => 'lightskyblue',
                   )->pack(-side =>'top', -anchor =>'n');

my $repeat;
my $startbut;
my $repeaton = 0;
$startbut = $lframe->Button(
    -text       => 'Start Test Count',
    -background => 'hotpink',
    -command    => sub {
        my $count = 0;
        $startbut->configure( -state => 'disabled' );
        $repeat = $mw->repeat(
            100,
            sub {
                $count++;
                $text->insert( 'end', "$count\n" );
                $text->see('end');
            }
        );
        $repeaton = 1;
    })->pack( -side => 'top',  -fill=>'x', -pady => 20);

my $stoptbut = $lframe->Button(
    -text    => 'Stop Count',
    -command => sub {
        $repeat->cancel;
        $repeaton = 0;
        $startbut->configure( -state => 'normal' );
    })->pack( -side => 'top',-anchor => 'n',
              -fill=>'x', -pady => 20 );

my $exitbut = $lframe->Button(
    -text    => 'Exit',
    -command => sub {
        if ($repeaton) { $repeat->cancel }
        #foreach ( keys %downloads ) { 
        #    #$downloads{$_}{'repeater'}->cancel; 
        #} 
      foreach my $dthread(keys %hash){
          $shash{$dthread}{'die'} = 1;
          $hash{$dthread}{'thread'}->join
         }
      exit;
      })->pack( -side => 'top',-anchor => 'n',
                 -fill=>'x', -pady => 20 );

#dialog to get file url--------------------- 
    my $dialog = $mw->Dialog(
        -background => 'lightyellow',
        -title      => 'Get File',
        -buttons    => [ "OK", "Cancel" ]
    );

    my $hostl = $dialog->add(
        'Label',
        -text       => 'Enter File Url',
        -background => 'lightyellow'
    )->pack();

    my $hostd = $dialog->add(
        'Entry',
        -width        => 100,
        -textvariable => '',
        -background   => 'white'
    )->pack();

$dialog->bind( '<Any-Enter>' => sub { $hostd->Tk::focus } );

   my $message = $mw->Dialog(
        -background => 'lightyellow',
        -title      => 'ERROR',
        -buttons    => [ "OK" ]
    );

  my $messagel = $message->add(
               'Label',
        -text       => '       ',
        -background => 'hotpink'
    )->pack();
$mw->repeat(10, sub{
       if(scalar @ready == $numworkers){return}

       foreach my $set(1..$numworkers){
         $actives{$set}{'label1'}->
               configure(-text =>\$shash{$set}{'progress'});
           my $str = '|' x int($shash{$set}{'progress'}/4);
           $actives{$set}{'pb'}->configure(-text => $str );

             if(($shash{$set}{'go'} == 0) and
                ($shash{$set}{'frame_open'} == 1))
                {
                  my $timekey = $shash{$set}{'timekey'};

                  $workers{ $timekey }{'frame'}->packForget;
                  $shash{$set}{'frame_open'} = 0;

                  $actives{$set}{'pb'}->configure(-text => '' );

                  push @ready, $workers{$timekey}{'setnum'};
                     if((scalar @ready) == 3)
                          { $activity->configure(-value => 0) }
                   $workers{$timekey} = ();
                   delete $workers{$timekey};

                 }
        }
    });

$mw->MainLoop;
################################################################### 

sub get_a_worker {

   my $timekey = shift;

  $hostd->configure( -textvariable => \$data);
  if ( $dialog->Show() eq 'Cancel' ) { return }

#---------------------------------------------- 
#get an available frameset 
my $setnum;
  if($setnum = shift @ready){print "setnum->$setnum\n"}
    else{ print "no setnum available\n"; return}

$workers{$timekey}{'setnum'} = $setnum;
$shash{$setnum}{'timekey'} = $timekey;

$workers{$timekey}{'frame'} = $actives{$setnum}{'frame'};
$workers{$timekey}{'frame'}->pack(-side =>'bottom', -fill => 'both' );

$workers{$timekey}{'stopbut'} = $actives{$setnum}{'stopbut'};
$workers{$timekey}{'stopbut'}->configure(
         -command => sub {
                 $workers{$timekey}{'frame'}->packForget;
                 $shash{ $workers{$timekey}{'setnum'} }{'go'} = 0;
                 $shash{ $workers{$timekey}{'setnum'} }{'frame_open'} 
+= 0;
                 push @ready, $workers{$timekey}{'setnum'};
                     if((scalar @ready) == $numworkers)
                          { $activity->configure(-value => 0) }
                         $workers{$timekey} = ();
                         delete $workers{$timekey};
                    });

$workers{$timekey}{'label1'} = $actives{$setnum}{'label1'};
$workers{$timekey}{'label1'}->configure(
              -textvariable => \$shash{$setnum}{'progress'},
               );

$workers{$timekey}{'label2'} = $actives{$setnum}{'label2'};

$workers{$timekey}{'pb'} = $actives{$setnum}{'pb'};
#$workers{$timekey}{'pb'}->configure( 
#              -text => \$workers{$timekey}{'progress'}, 
#              ); 

$workers{$timekey}{'label3'} = $actives{$setnum}{'label3'};
$workers{$timekey}{'label3'}->configure(-text => $timekey);

$activity->startActivity();

$shash{$setnum}{'go'} = 1;
$shash{$setnum}{'frame_open'} = 1;
#--------end of get_file sub-------------------------- 
}
################################################################## 
sub work{
  my $dthread = shift;
    $|++;
    while(1){
       if($shash{$dthread}{'die'} == 1){ goto END };
       if ( $shash{$dthread}{'go'} == 1 )       {

    eval( system( $shash{$dthread}{'data'} )    );

   foreach my $num (1..100){
          $shash{$dthread}{'progress'} = $num;
       print "\t" x $dthread,"$dthread->$num\n";
       select(undef,undef,undef, .5);
       if($shash{$dthread}{'go'} == 0){last}
       if($shash{$dthread}{'die'} == 1){ goto END };
       }

    $shash{$dthread}{'go'} = 0; #turn off self before returning       
       }else
         { sleep 1 }
    }
END:
}
#####################################################################

[download]

Replies are listed 'Best First'.
Re: Tk-with-worker-threads
by Anonymous Monk on Sep 01, 2006 at 04:28 UTC
    Thats great to know its possible. The author had asked if we need a simpler chopped of example.Can I request one .THat will be greatly useful to many of them.
[reply]
      Hi, here is about as simple an example as you can get. It uses a thread to watch a filehandle(like tail), push the results into a shared array, then display the results in a Tk::Text box. It dosn't get much simpler than this. Basically the shared array is a buffer between the thread and main Tk code. NOT thorougly tested for buffer problems. 
      #!/usr/bin/perl
use warnings;
use strict;
use threads;
use threads::shared;

# must setup thread code before any Tk code is used
# to avoid Tk thread-safety problems

my @logdata : shared;
my $thread_die : shared;
@logdata = ();
$thread_die = 0;

my $thread = threads->new( \&work );
############################################

use Tk;

my $mw = MainWindow->new(-background => 'gray50');

my $tframe = $mw->Frame( -background => 'gray50',-borderwidth=>10 )
                  ->pack(-side =>'top' ,-fill=>'y');
my $bframe = $mw->Frame( -background => 'gray50',-borderwidth=>10 )
                  ->pack(-side =>'bottom',-fill =>'both' );


my $text = $tframe->Scrolled("Text",
                   -scrollbars => 'ose',
                   -background => 'black',
                   -foreground => 'lightskyblue',
                   )->pack(-side =>'top', -anchor =>'n');

my $exit_button = $mw->Button(-text => 'Exit',
                    -command => sub{
                     $thread_die = 1; #kill thread
             $thread->join;
             exit;                          
            })->pack();


my $timer = $mw->repeat(1000, sub{
                lock( @logdata );  #locks within scope
                my @in = @logdata; #copy it 
        @logdata = ();  #clear out old log lines
            $text->insert('end', "@in");
        $text->see('end');
              });


MainLoop;

########################################
sub work{

   $|++;
   open(FH,"< z.log") or die "$!\n";

 while(1){
    while(<FH>){
         push @logdata, $_;
    if( $thread_die == 1 ){return} #kill thread
     }
  }

}
############################################

      [download]
      I'm not really a human, but I play one on earth. Cogito ergo sum a bum
[reply]
[d/l]

Back to Cool Uses for Perl

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: CUFP [id://401819]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others drinking their drinks and smoking their pipes about the Monastery: (2)
As of 2024-12-07 17:43 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Which IDE have you been most impressed by?













    Results (50 votes). Check out past polls.