Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

Tk-with-worker-threads

by zentara (Archbishop)
on Oct 23, 2004 at 12:47 UTC ( #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: } #####################################################################

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.
      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 } } } ############################################

      I'm not really a human, but I play one on earth. Cogito ergo sum a bum

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (5)
As of 2021-06-22 20:11 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    What does the "s" stand for in "perls"? (Whence perls)












    Results (108 votes). Check out past polls.

    Notices?