Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?

controlling threads with Tk: while loop vs. signals

by zentara (Archbishop)
on Feb 14, 2012 at 18:16 UTC ( #953739=CUFP: print w/replies, xml ) Need Help??

A few people have asked recently about how to deal with the problem that threads must be started early in Tk programs, and are often running before the Tk gui gets going. Here are 2 methods. One uses a while loop and shared variables, the other Thread::Semaphore and signals.

The while loop one runs well, but it has the drawback of needing to frequently check the status of shared variables. The signals method will break a while loop running, but has the drawback of letting the thread run a bit, until the signal handlers get setup. If you can see a way to prevent the Signals thread from printing 1 or 2 lines before responding to the suspend request, please show us how.

The code is pretty much self documenting, and I purposely left the variables simple and straight forward to avoid obscurring what is happening.

#!/usr/bin/perl use warnings; use strict; use threads 'exit' => 'threads_only'; use threads::shared; use IO::Pipe; use Thread::Semaphore; # uses a reusable thread concept # shows 2 ways to control the thread # 1 -- thru a while loop # 2 -- thru signals, suspend resume #create threads before any tk code is called my $go_control:shared = 0; # controls for while loop method my $die_control:shared = 0; # create pipes and threads my $pipe1 = IO::Pipe->new(); my $thr1 = threads->new(\&execute1, $pipe1); # Create a semaphore for signaling and pass it to thread 2 my $sema = Thread::Semaphore->new(); my $pipe2 = IO::Pipe->new(); my $thr2 = threads->new(\&execute2, $pipe2, $sema ); # after thread initiation is complete, get Tk going use Tk; my $mw = MainWindow->new(); $mw->geometry('800x500'); # catch window close button to clean up threads $mw->protocol('WM_DELETE_WINDOW' => sub { &clean_exit }); $mw->fontCreate('big',-weight=>'bold', -size=> 14 ); # setup pipes for Tk's fileevent $pipe1->reader(); # make Tk's end a reader $pipe2->reader(); # add fileevents( similar to select) on pipes $mw->fileevent($pipe1 ,'readable', \&write_t1); $mw->fileevent($pipe2 ,'readable', \&write_t2); # control button frame my $topframe = $mw->Frame(-bg => 'brown')->pack(-fill=>'x', -expand=> +0); my $control1 = $topframe->Button(-text => 'Start 1', -font => 'big', -bg => 'lightyellow', -command => \&start1 )->pack(-side =>'left',-padx=>20); my $lab1 = $topframe->Label(-text => 'while loop control', -font => 'big', -bg => 'lightyellow', )->pack(-side =>'left',-padx=>20); my $control2 = $topframe->Button(-text => 'Start 2', -font => 'big', -bg => 'black', -fg => 'lightyellow', -command => \&start2 )->pack(-side =>'right', -padx=>20); my $lab2 = $topframe->Label(-text => 'signal control', -font => 'big', -bg => 'black', -fg => 'lightyellow', )->pack(-side =>'right',-padx=>20); # make a frame to lock in the scrolled text my $frame = $mw->Frame()->pack(-fill=>'both', -expand=> 1); my $text1 = $frame->Scrolled('Text', -background=>'white', -foreground=>'black', -font => 'big', -height => 550, # how many lines are shown -width => 20, # how many characters per line )->pack(-side=>'left', -fill=>'both', -expand=>1); $text1-> insert('end', "Thread 1 output\n"); my $text2 = $frame->Scrolled('Text', -background=>'black', -foreground=>'white', -font => 'big', -height => 550, # how many lines are shown -width => 20, # how many characters per line )->pack(-side=>'right',-fill=>'both', -expand=>1); $text2-> insert('end', "Thread 2 output\n"); # this is delayed, and I don't know a workaround # so it prints once before suspending # suspend thread 2 $sema->down(); $thr2->kill('STOP'); MainLoop; sub clean_exit{ # harvest thread 1 $die_control = 1; $thr1->join; print " thread1 joined\n"; # harvest thread 2 # a problem exists in that you need to detect # if the $sema is down or up, to see if thread 2 is running or su +spended # when you want to exit # The "down_nb" method attempts to decrease the semaphore's count + # by the specified number (which must be an integer >= 1), or # by one if no number is specified. # If the semaphore's count would drop below zero, this method wil +l return false, # and the semaphore's count remains unchanged. # Otherwise, the semaphore's count is decremented and this method + returns true. # turn on suspended thread if needed .. a bit tricky logic wise if(! $sema->down_nb() ){ $sema->up(); print " sema up\n"; } $thr2->kill('KILL'); $thr2->join; print " thread2 joined\n"; exit; } sub start1{ my $text = $control1->cget(-text); if ($text eq 'Start 1'){ $go_control = 1; $control1->configure(-text=>'Stop 1'); }else{ $go_control = 0; $control1->configure(-text=>'Start 1'); } } sub write_t1{ my $buf = <$pipe1>; $text1->insert('end',"$buf"); $text1->see('end'); } sub execute1{ # thread code my $pipe = shift; my $wh = $pipe->writer(); $wh->autoflush(1); while(1){ if($die_control){ return }; #wait for $go_control if($go_control){ print $wh time." continuing\n"; if($die_control){ return }; #do your stuff here while(1){ if($die_control){ return }; last if ! $go_control; print "1"; print $wh time."\n"; select(undef,undef,undef,.5); # sleep until aw +akened for next command } #done, so turn thread back to sleep print $wh time." suspending\n"; $go_control = 0; }else{ select(undef,undef,undef,.25); # sleep until awakened for next +command } } return; } sub start2{ my $text = $control2->cget(-text); if ($text eq 'Start 2'){ $sema->up(); $thr2->kill('CONT'); $control2->configure(-text=>'Stop 2'); }else{ $sema->down(); $thr2->kill('STOP'); $control2->configure(-text=>'Start 2'); } } sub write_t2{ my $buf = <$pipe2>; $text2->insert('end',"$buf"); $text2->see('end'); } sub execute2{ my ($pipe,$sema) = @_; my $wh = $pipe->writer(); $wh->autoflush(1); my $myobject = threads->self; my $mytid= $myobject->tid; #setup signal handlers $SIG{'KILL'} = sub { print "2 killed\n"; threads->exit; }; # Thread 'suspend/resume' signal handler $SIG{'STOP'} = sub { print $wh time.' suspended'."\n"; $sema->down(); }; # Thread suspended $SIG{'CONT'} = sub { $sema->up(); # Thread resumes print $wh time.' continuing'."\n"; }; while(1){ print "2"; print $wh time."\n"; select(undef,undef,undef,.5); # sleep until awakened for next + command } }

I'm not really a human, but I play one on earth.
Old Perl Programmer Haiku ................... flash japh

Replies are listed 'Best First'.
Re: controlling threads with Tk: while loop vs. signals
by BrowserUk (Pope) on Feb 14, 2012 at 21:41 UTC

    Pairing the clumsy Thread::Semaphore with the should-never-have-been-invented "threads signalling" is an extremely convoluted way of controlling a producer thread.

    This does what I think you were trying to achieve -- start the thread 'suspended' and allow it to be resumed and suspended -- with rather less fuss and complication:

    #! perl -slw use strict; use threads; use threads::shared; use Thread::Queue; use Tk; my $sem :shared = 0; sub thread { my( $Q, $file ) = @_; open my $fh, '<', $file or die $!; while( <$fh> ) { lock $sem; cond_wait( $sem ); $Q->enqueue( $_ ); } } my $Q = new Thread::Queue; my $t = async( \&thread, $Q, $ARGV[0] )->detach; my $mw = MainWindow->new; $mw->geometry( "1024x768" ); my $b1; $b1 = $mw->Label->pack( -anchor => 'nw' )->Button( -width => 10, -text => 'start', -command => sub{ if( $sem ) { $b1->configure( -text => 'resume' ); lock $sem; cond_signal( $sem ); $sem = 0; } else{ $b1->configure( -text => 'suspend' ); lock $sem; cond_signal( $sem ); $sem = 1; } } )->pack( -side => 'left' ); my $lb = $mw->Scrolled( 'Listbox', -height => 55, -scrollbars => 'e' )->pack( -anchor => 's', -fill => 'both' )->Subwidget('scrolled'); my $repeat = $mw->repeat( 1 => sub { while( $Q->pending ) { $lb->insert( 'end', $Q->dequeue ); $lb->see( 'end' ); $mw->update; lock $sem; $sem and cond_signal( $sem ); } }); $mw->MainLoop;

    Update: Simplified the code a little.

    With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority".
    In the absence of evidence, opinion is indistinguishable from prejudice.

    The start of some sanity?

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://953739]
Approved by Corion
Front-paged by Corion
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 10:25 GMT
Find Nodes?
    Voting Booth?
    What does the "s" stand for in "perls"? (Whence perls)

    Results (102 votes). Check out past polls.