-textvariable-Optionen sind übrigens nur im Tk-Thread sichtbar. Eine geteilte Variable an ein Widget zu binden funktioniert also nicht.Nachfolgendes Beispiel zeigt ein Tk-Programm, bei dem die ganze Zeit ein zweiter Thread mitläuft. Dieser generiert Daten, die im Tk-Thread dargestellt werden.
#!/usr/bin/perl -w
# source: http://www.perlmonks.org/?node_id=585533
# 2014-08-26
# Always use 'strict' and 'warnings'
use strict;
use warnings;
# Libraries
use threads;
use threads::shared;
use Thread::Queue;
use Tk;
use Tk::ROText;
# Globals
my $rotext = 0; # The Read-only text widget
my $n_lines_waiting: shared = 0; # Message passing between threads
my $p_queue = Thread::Queue->new(); # Construct message 'Queue'
####################
### Main program ###
####################
# Startup worker thread
my $gui_thr = threads->create( \&worker_thread);
# Only *now* is it safe to construct the GUI, from the parent thread
gui();
###################
### Subroutines ###
###################
# This subroutine is ONLY called from the parent thread
sub gui {
my $mw = MainWindow->new();
my $top = $mw->Frame()->pack(-expand => 1, -fill => 'both');
my $bt = $top->Button(-bg => 'skyblue', -text => "Exit");
$bt->configure(-command => sub { $mw->destroy() });
$rotext = $top->ROText(-bg => 'white');
$rotext->pack();
$bt->pack();
$mw->repeat(1000 => \&main_loop);
MainLoop;
}
sub main_loop {
if ($n_lines_waiting) {
fetch_worker_data();
}
}
sub fetch_worker_data {
for (my $i = 0; $i < $n_lines_waiting; $i++) {
my $line = $p_queue->dequeue();
$rotext->insert("end", "$line\n");
}
$rotext->insert("end", "--- End of $n_lines_waiting line(s) ---\n");
$rotext->see("end");
my $mw = $rotext->toplevel();
$mw->update();
$n_lines_waiting = 0;
}
# This subroutine is ONLY called in the worker thread
sub worker_thread {
while (1) {
sleep 3;
worker_simulate_data();
}
}
sub worker_simulate_data {
my $nlines = int(rand(10));
($nlines > 0) or return;
my $timestamp = localtime(time);
for (my $i = 0; $i < $nlines; $i++) {
my $idx = $i + 1;
my $line = "[$timestamp] Random line of text #$idx";
$p_queue->enqueue($line);
}
$n_lines_waiting = $nlines;
}Das zuvor aufgeführte Beispiel kann man auch in Verbindung mit Moose verwenden:
#!perl
# based on: http://www.perlmonks.org/?node_id=585533
# 2014-08-26
package My::Test;
use Moose;
# Libraries
use threads;
use threads::shared;
use Thread::Queue;
use Tk;
use Tk::ROText;
# Globals
has 'rotext' => (is => 'rw', isa => 'Tk::ROText');
has 'n_lines_waiting' => (is => 'rw', isa => 'ScalarRef[Int]', default => sub{
# Message passing between threads
my $n_lines_waiting: shared = 0;
return \$n_lines_waiting;
});
has 'p_queue' => (is => 'ro', isa => 'Thread::Queue', default => sub{ return Thread::Queue->new(); });
####################
### Main program ###
####################
sub run {
my $self = shift;
# Startup worker thread
my $gui_thr = threads->create(sub{ $self->worker_thread(); });
# Only *now* is it safe to construct the GUI, from the parent thread
$self->gui();
} # /run
###################
### Subroutines ###
###################
# This subroutine is ONLY called from the parent thread
sub gui {
my $self = shift;
my $mw = MainWindow->new();
my $top = $mw->Frame()->pack(-expand => 1, -fill => 'both');
my $bt = $top->Button(-bg => 'skyblue', -text => "Exit");
$bt->configure(-command => sub { $mw->destroy() });
$self->rotext( $top->ROText(-bg => 'white') );
$self->rotext->pack();
$bt->pack();
$mw->repeat(1000 => sub{ $self->main_loop(); });
$mw->MainLoop;
}
sub main_loop {
my $self = shift;
print "n_lines_waiting in GUI thread is now: " . ${$self->n_lines_waiting} . "\n";
if (${$self->n_lines_waiting}) {
$self->fetch_worker_data();
}
}
sub fetch_worker_data {
my $self = shift;
my $rotext = $self->rotext;
for (my $i = 0; $i < ${$self->n_lines_waiting}; $i++) {
my $line = $self->p_queue->dequeue();
$rotext->insert("end", "$line\n");
}
$rotext->insert("end", "--- End of ".${$self->n_lines_waiting}." line(s) ---\n");
$rotext->see("end");
my $mw = $rotext->toplevel();
$mw->update();
${$self->n_lines_waiting} = 0;
}
# This subroutine is ONLY called in the worker thread
sub worker_thread {
my $self = shift;
while (1) {
sleep 3;
print "now worker_simulate_data()\n";
$self->worker_simulate_data();
print "n_lines_waiting in worker thread is now: " . ${$self->n_lines_waiting} . "\n";
}
}
sub worker_simulate_data {
my $self = shift;
my $nlines = int(rand(10));
($nlines > 0) or return;
my $timestamp = localtime(time);
for (my $i = 0; $i < $nlines; $i++) {
my $idx = $i + 1;
my $line = "[$timestamp] Random line of text #$idx";
$self->p_queue->enqueue($line);
}
${$self->n_lines_waiting} = $nlines;
}
1; # /My::Test
use strict;
use warnings;
my $app = My::Test->new;
$app->run;
exit(0);Eventuell möchte man bei einem Klick auf einen Button einfach eine Aktion starten, die dann losläuft und irgendwann sagt, dass sie fertig ist. Das kann beispielsweise erreicht werden, indem der Arbeiter seine Aufgabe nur verrichtet, wenn er das entsprechende Signal dazu bekommt - über eine geteilte Variable. Über eine solche geteilte Variable kann an den Tk-Thread dann auch gemeldet werden, wenn die Aufgabe abgeschlossen wurde.
#!perl
use strict;
use warnings;
use threads;
use threads::shared;
use Tk;
use Tk::After;
use Tk::ProgressBar;
# based on: http://gojooz.blogspot.de/2010/05/perl-tkx-thread-request-demo.html
# 2014-08-28
# Create shared variables
my $child_finished_flag : shared = 0;
my $child_request_flag : shared = 0;
# Create child thread
my $ChildThread = threads->create( \&child_thread );
$ChildThread->detach();
# Create Tk mainwindow
my $mw = MainWindow->new();
my $frame2 = $mw->Frame( -borderwidth => 2 );
$frame2->pack( -anchor => 'nw', -padx => '10', -pady => '10' );
# create progressbar and button widgets
my $progressbar = $frame2->ProgressBar(
-length => 200,
-from => 0,
-to => 10,
-blocks => 10,
-colors => [0, 'yellow', 9, 'green'],
);
my $button = $frame2->Button(
-text => "Process Request",
-state => 'normal',
-width => '15',
-command => sub{
# only start once
return if $child_request_flag;
process_request();
},
);
$button->grid(
-row => 1,
-column => 1,
-columnspan => 2,
-padx => 10,
-pady => 5
);
$progressbar->grid(
-row => 2,
-column => 1,
-columnspan => 2,
-padx => 10,
-pady => 5
);
# Initiate Tk Listener
$mw->MainLoop();
sub process_request {
$progressbar->value(0);
$child_request_flag = 1;
&check_status_1;
}
sub check_status_1 {
$mw->after(
500,
sub {
if ( $child_finished_flag == 1 ) {
$progressbar->value(100);
# Reset flags
$child_finished_flag = 0;
$child_request_flag = 0;
print "child_request finished\n";
} else {
my $current_val = $progressbar->value();
print "$current_val\n";
$current_val = ($current_val >= 9 ? 0 : ++$current_val);
$progressbar->value($current_val);
&check_status_2;
print "child_request processing\n";
}
}
);
}
sub check_status_2 {
$mw->after(
500,
sub {
&check_status_1;
}
);
}
sub child_thread {
while (1) {
sleep 2;
if ( $child_request_flag == 1 ) {
print "begin child_request\n";
# long running task here
for( 1 .. 10 ) {
print "long running task $_...\n";
sleep(2);
}
$child_finished_flag = 1;
} else {
print "waiting for child_request\n";
}
}
}