Re: Tk: Call subroutine when MainWindow is realized?

From: zentara (zentara_at_highstream.net)
Date: 01/14/05 

Date: Fri, 14 Jan 2005 11:57:12 -0500

On Thu, 13 Jan 2005 13:50:06 +0000 (UTC), Steve Lidie
<lusol@Dragonfly.cc.lehigh.edu> wrote:

>Now, back to threads. You can't use them,

It may be presumptuous of me to argue with the "teacher",
but I have been able to use threads with Tk, with 2 caveats.
1. No passing objects around, only simple text and scalars.
2. Threads must be created before Tk is init'ed.

In this example, I start 3 threads before Tk is started, and put them
to sleep. I control them with shared vars. It look more complicated
than it actually is, because I add an activity bar, and have 3 worker
threads, intead of one, with the associated hash complexities. This
concept can easily be used to start a worker thread to communicate with
the card. The thread can report back it's findings to Tk thru shared
variables, and you could manipulate you window accordingly.

#!/usr/bin/perl
use warnings;
use strict;
use threads;
use threads::shared;
use Tk;
use Tk::ActivityBar;
use Tk::Dialog;

my $data = shift || ' '; #sample code to pass to thread

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
downloads
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{$_}{'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 {
        
        foreach my $dthread(keys %hash){
          $shash{$dthread}{'die'} = 1;
          $hash{$dthread}{'thread'}->join
         }
        
         if ($repeaton) { $repeat->cancel }
           #foreach ( keys %downloads ) {
           # #$downloads{$_}{'repeater'}->cancel;
           #}
      # $mw->destroy;
       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'});
       
         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;
           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}{'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:
}
######################################################
__END__ 

-- 
I'm not really a human, but I play one on earth.
http://zentara.net/japh.html

Relevant Pages

  • Re: polling TCP server on Win32 (with Tk)
    ... The problem is Win32 (Unix works). ... foreach my $count{ ... this is an example of a threaded tk gui. ... #Example - one worker subroutine for one worker thread ...
    (comp.lang.perl.misc)
  • Re: Threading a ShowDialog? - progress form.
    ... However in practice I am sure you will find the BackgroundWorker component to be significantly easier. ... Sub A calls B calls C ... WorkerForm is a base form that has the common routines along with the progress bar & background worker. ... I would like to show a Progress Bar / form in modal/ShowDialog format when this runs and slowely update the progress bar as each sub runs. ...
    (microsoft.public.dotnet.languages.vb)
  • CSV dB script help
    ... # It uses the order of those keys for the order it displays them. ... # printpagesub and prepares the date for the writeupdate# ... # We need the array, ... foreach $num ...
    (comp.lang.perl.misc)
  • Re: CSV dB script help
    ... > # It uses the order of those keys for the order it displays them. ... > # printpagesub and prepares the date for the writeupdate# ... > # We need the array, ... > foreach $num ...
    (comp.lang.perl.misc)
  • local and my in subroutines
    ... The second sub in this script works using: ... # Create extenions for log files as the older ones have a bz2 extension. ... foreach my $end ...
    (perl.beginners)