#!/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 
     }

}
[download]