Change the text of a Tk label asynchronously - perl

I need graphical output from a Perl program. The window has a label status field and should show what programming code decides.
How do I change the text of a label field after the window has been created without any buttons?
I have the following:
use Tk;
$mw = Tk::MainWindow->new(-title => 'Status Window',-bg=>"white");
$mw->geometry ("400x200+0+0");
$lala = $mw->Label(-text => "Current Status")->grid(-row=>0,-column=>0);
$mw->bind( 'all' => '<Key-Escape>' => sub {exit;} );
MainLoop;
How do I incorporate the following subroutine so that it is run automatically
after the window is created? Label-Widget does not have
a -command field. It should start immediately and
not wait for a event to happen
sub calculate() {
for ( $i = 0; $i < 10; $i++ ) {
sleep 2s;
$lala->configure(-text=>"Current Status : $i");
}
}

The following seems to work. I used after() to run code after 100 ms then used update() to redraw window:
use feature qw(say);
use strict;
use warnings;
use Tk;
my $mw = Tk::MainWindow->new(-title => 'Status Window',-bg=>"white");
$mw->geometry ("400x200+0+0");
my $lala = $mw->Label(-text => "Current Status")->grid(-row=>0,-column=>0);
$mw->bind('all'=> '<Key-Escape>' => sub {exit;});
$lala->after(100, \&calculate );
MainLoop;
sub calculate() {
for(my $i=0; $i<10; $i++){
sleep 1;
$lala->configure(-text=>"Current Status : $i");
$mw->update();
}
}
Edit:
The above code blocks during the sleep 1 call, so any input for the Tk event loop will will be delayed. In particular, pressing Esc to quit the application will not work immediately. It will be blocked until sleep returns. To solve this, one can use Tk's repeat() instead of sleep and Tk's after(), and cancel the repeat if necessary:
my $repeat_count = 10;
my $timer_id = $lala->repeat(1000, \&calculate );
MainLoop;
sub calculate() {
$lala->configure(-text=>"Current Status : $repeat_count");
if ( --$repeat_count == 0) {
$timer_id->cancel;
}
}

Related

Perl procedural return two stack call levels

My question is similar to:
Is it possible for a Perl subroutine to force its caller to return?
but I need procedural method.
I want to program some message procedure with return, example essential code:
sub PrintMessage {
#this function can print to the screen and both to logfile
print "Script message: $_[0]\n";
}
sub ReturnMessage {
PrintMessage($_[0]);
return $_[2]; # <-- we thinking about *this* return
}
sub WorkingProc {
PrintMessage("Job is started now");
#some code
PrintMessage("processed 5 items");
# this should return from WorkingProc with given exitcode
ReturnMessage("too many items!",5) if $items>100;
#another code
ReturnMessage("time exceded!",6) if $timespent>3600;
PrintMessage("All processed succesfully");
return 0;
}
my $ExitCode=WorkingProc();
#finish something
exit $ExitCode
Idea is, how to use return inside ReturnMessage function to exit with specified code from WorkingProc function? Notice, ReturnMessage function is called from many places.
This isn't possible. However, you can explicitly return:
sub WorkingProc {
PrintMessage("Job is started now");
...
PrintMessage("processed 5 items");
# this returns from WorkingProc with given exitcode
return ReturnMessage("to much items!", 5) if $items > 100;
...
return ReturnMessage("time exceded!", 6) if $timespent > 3600;
PrintMessage("All processed succesfully");
return 0;
}
A sub can have any number of return statements, so this isn't an issue.
Such a solution is preferable to hacking through the call stack, because the control flow is more obvious to the reader. What you were dreaming of was a kind of GOTO, which most people not writing C or BASIC etc. have given up 45 years ago.
Your code relies on exit codes to determine errors in subroutines. *Sigh*. Perl has an exception system which is fairly backwards, but still more advanced than that.
Throw a fatal error with die "Reason", or use Carp and croak "Reason". Catch errors with the Try::Tiny or TryCatch modules.
sub WorkingProc {
PrintMessage("Job is started now");
...
PrintMessage("processed 5 items");
# this should return from WorkingProc with given exitcode
die "Too much items!" if $items > 100;
...
die "Time exceeded" if $timespent > 3600;
PrintMessage("All processed succesfully");
return 0;
}
WorkingProc();
If an error is thrown, this will exit with a non-zero status.
The approach that springs to mind for non-local return is to throw an exception (die) from the innermost function.
You'll then need to have some wrapping code to handle it at the top level. You could devise a set of utility routines to automatically set that up.
Using Log::Any and Log::Any::Adapter in conjunction with Exception::Class allow you to put all the pieces together with minimum fuss and maximum flexibility:
#!/usr/bin/env perl
package My::Worker;
use strict; use warnings;
use Const::Fast;
use Log::Any qw($log);
use Exception::Class (
JobException => { fields => [qw( exit_code )] },
TooManyItemsException => {
isa => 'JobException',
description => 'The worker was given too many items to process',
},
TimeExceededException => {
isa => 'JobException',
description => 'The worker spent too much time processing items',
},
);
sub work {
my $jobid = shift;
my $items = shift;
const my $ITEM_LIMIT => 100;
const my $TIME_LIMIT => 10;
$log->infof('Job %s started', $jobid);
shift #$items for 1 .. 5;
$log->info('Processed 5 items');
if (0.25 > rand) {
# throw this one with 25% probability
if (#$items > $ITEM_LIMIT) {
TooManyItemsException->throw(
error => sprintf(
'%d items remain. Limit is %d.',
scalar #$items, $ITEM_LIMIT,
),
exit_code => 5,
);
}
}
{ # simulate some work that might take more than 10 seconds
local $| = 1;
for (1 .. 40) {
sleep 1 if 0.3 > rand;
print '.';
}
print "\n";
}
my $time_spent = time - $^T;
($time_spent > $TIME_LIMIT) and
TimeExceededException->throw(
error => sprintf (
'Spent %d seconds. Limit is %d.',
$time_spent, $TIME_LIMIT,
),
exit_code => 6);
$log->info('All processed succesfully');
return;
}
package main;
use strict; use warnings;
use Log::Any qw( $log );
use Log::Any::Adapter ('Stderr');
eval { My::Worker::work(exceptional_job => [1 .. 200]) };
if (my $x = JobException->caught) {
$log->error($x->description);
$log->error($x->error);
exit $x->exit_code;
}
Sample output:
Job exceptional_job started
Processed 5 items
........................................
The worker spent too much time processing items
Spent 12 seconds. Limit is 10.
or
Job exceptional_job started
Processed 5 items
The worker was given too many items to process
195 items remain. Limit is 100.

Limiting processes with Parallel::ForkManager

I am trying to use Parallel::ForkManager to control some child processes. I would like to limit the number of processes running concurrently to 10. In total I need to run 20.
I know I could set the process limit at 10 in the first line at the object declaration, but I am also using the $pm object to run child processes that do something different (the current function is much more memory intensive so needs to be limited).
The code I have currently does not work, the run on finish call is never made, so the remaining 10 children never get forked. I don't understand why this is the case- I'd have thought the child would still call the finish code on exit,and decrement the count, but the "if" statement seems to stop this. Could someone explain why this is the case?
Thanks for any help!
# Parallel declarations
my $pm = Parallel::ForkManager->new(30);
$pm->run_on_finish(sub {
my ($pid, $exit_code, $ident, $exit_signal, $core_dump, $data_str_ref) = #_;
--$active_jobs;
})
my $total_jobs = 0;
my $active_jobs = 0;
while( $total_jobs < 20) {
sleep 300 and next if $active_jobs > 10;
my $pid = $pm->start and ++$active_p1_jobs and ++$total_p1_jobs and next;
my $return = module::function(%args);
$pm->finish(0, { index => $total_jobs, return => $return });
}
print STDERR "Submitted all jobs, now waiting for children to exit.\n";
$pm->wait_all_children();
I'm going to call "type 2" the jobs that are limited to 10.
This is how I'd do it with P::FM:
use strict;
use warnings;
use List::Util qw( shuffle );
use Parallel::ForkManager qw( );
use POSIX qw( WNOHANG );
use Time::HiRes qw( sleep );
use constant MAX_WORKERS => 30;
use constant MAX_TYPE2_WORKERS => 10;
sub is_type2_job { $_[0]{type} == 2 }
my #jobs = shuffle(
( map { { type => 1, data => $_ } } 0..19 ),
( map { { type => 2, data => $_ } } 0..19 ),
);
my $pm = Parallel::ForkManager->new(MAX_WORKERS);
my $type2_count = 0;
$pm->run_on_finish(sub {
my ($pid, $exit_code, $ident, $exit_signal, $core_dump, $job) = #_;
--$type2_count if is_type2_job($job);
print "Finished: $pid, $job->{type}, $job->{data}, $job->{result}\n";
});
my #postponed_jobs;
while (#postponed_jobs || #jobs) {
my $job;
if (#postponed_jobs && $type2_count < MAX_TYPE2_WORKERS) {
$job = shift(#postponed_jobs);
}
elsif (#jobs) {
$job = shift(#jobs);
if ($type2_count >= MAX_TYPE2_WORKERS && is_type2_job($job)) {
push #postponed_jobs, $job;
redo;
}
}
# elsif (#postponed_jobs) {
# # Already max type 2 jobs being processed,
# # but there are idle workers.
# $job = shift(#postponed_jobs);
# }
else {
local $SIG{CHLD} = sub { };
select(undef, undef, undef, 0.300);
$pm->wait_one_child(WNOHANG);
redo;
}
++$type2_count if is_type2_job($job);
my $pid = $pm->start and next;
$job->{result} = $job->{data} + 100; # Or whatever.
$pm->finish(0, $job);
}
$pm->wait_all_children();
But this is broken. The code that picks the next job should be done in the middle of start (i.e. after it waits for children to finish, but before it forks), not before start. This could cause jobs to be run out of order. This isn't the first time I've wished P::FM has a pre-fork callback. Maybe you could ask the maintainer for one.

Perl AnyEvent callback on latency sub, how run it async?

I start to learn AnyEvent and have some trobles with it.
I totally misunderstood how its possible to get asynchronous profit, fe :
#!/usr/bin/env perl
package LatencySub;
use strict;
use warnings;
use AnyEvent;
# sub for emulate latency - is it right way?
sub do_delay{
my ($name, $delay) = (#_);
my $cv = AE::cv;
my $timer = AE::timer $delay, 0, sub { $cv->send() };
$cv->recv;
return $name.' proceed, delay is '.$delay;
};
package main;
use 5.12.0;
use warnings;
use Smart::Comments;
use AnyEvent;
my #list = (
{ name => 'first', delay => 1 },
{ name => 'second', delay => 1 },
{ name => 'third', delay => 2 }
);
sub process_cb {
my ( $name, $delay, $cb ) = #_;
my $result = LatencySub::do_delay( $name, $delay );
$cb->($result);
}
my %result;
my $cv = AE::cv;
# outer loop
$cv->begin (sub { shift->send (\%result) });
my $before_time = AE::time;
### foreach start...
foreach my $entity (#list) {
$cv->begin;
process_cb (
$entity->{'name'},
$entity->{'delay'},
sub {
$result{$entity->{'name'}} = shift;
$cv->end;
}
);
}
### foreach end...
$cv->end;
my $time_all = AE::time - $before_time;
### $time_all
### %result
At output I got:
### foreach start...
### foreach end...
### $time_all: '4.02105116844177'
### %result: {
### first => 'first proceed, delay is 1',
### second => 'second proceed, delay is 1',
### third => 'third proceed, delay is 2'
### }
All delay sum (1+1+2) eq $time_all - 4 seconds.
So, no profit at all.
Why is it and how I can (and is it possible?) create "right" callback?
Don't use condvars except to block your top-level program while waiting for events to complete. Using condvars makes it very difficult to reuse code; any function that has a condvar internally can never be safely used in a program that has another function that has a condvar in it. (This is not true if you never call recv and only use cb. But still... it's dangerous and not for those that don't know what they're doing.)
My rule: if the filename ends .pm, no condvars!
If you want to run multiple things in parallel and run some more code once all the results are available, try Event::Join:
sub delay($$) {
AnyEvent->timer( after => $_[0], cb => $_[1] );
}
my $join = Event::Join->new(
on_completion => sub { say "Everything is done" }
events => [qw/t1 t2 t3/],
);
delay 1, $join->event_sender_for('t1');
delay 2, $join->event_sender_for('t2');
delay 3, $join->event_sender_for('t3');
Then, after 3 seconds, you'll see "everything is done". Event::Join is like begin and end on condvars, but can never block your program. So it's easy to reuse code that uses it. Also, events are named, so you can collect results as a hash instead of just calling a callback when other callbacks are called.
The call $cv->recv will block until ->send is called, so do_delay() takes $delay secs to return.
Here is an example of spawning three threads and waiting for all of them to complete:
use strict;
use warnings;
use AnyEvent;
sub make_delay {
my ($name, $delay, $cv) = (#_);
$cv->begin;
return AE::timer $delay, 0, sub { warn "done with $name\n"; $cv->end };
}
my $cv = AE::cv;
my #timers = (make_delay("t1", 3, $cv),
make_delay("t2", 5, $cv),
make_delay("t3", 4, $cv)
);
$cv->recv;

AnyEvent timer question

How could I make "visible" the timer? This example returns (intependent from the sleep-time always) 2 (I expected something similar to the sleep-time).
#!/usr/local/bin/perl
use warnings;
use 5.014;
use AnyEvent;
my $c = 0;
my $cv = AnyEvent->condvar;
my $once_per_second = AnyEvent->timer (
after => 0,
interval => 1,
cb => sub {
$c++;
$cv->send;
},
);
sleep 5;
$cv->recv;
say $c;
There are at least two problems:
sleep 5 doesn't run the event loop.
Your callback triggers the cond. variable. If, for instance, you removed the sleep 5 statement, $c would only be 1.
Is this what you want?
my $c = 0;
my $cv = AnyEvent->condvar;
my $once_per_second = AnyEvent->timer(after => 0, interval => 1, cb => sub { $c++ });
my $five_seconds = AnyEvent->timer(after => 5, cb => sub { $cv->send });
$cv->recv;
say $c;
The event loop is not running (well nothing is running) while sleep is "active". So no event registered with AnyEvent can be triggered.
The rule: If you use AnyEvent (or any other ansynchronous framework), never use sleep.
See user5402's answer for the correct solution.

What else can i do 'sleep' when the sleep() can't work well with alarm?

There are many documents say "you should avoid using sleep with alarm, since many systems use alarm for the sleep implementation". And actually, I'm suffering with this problem.
So does anyone can help me that what else i can do 'sleep' when the sleep() can't work well with alarm? I have already tried 'usleep' of the Time::HiRes module, and select() function. But they didn't work either.
Seeing as you're being interrupted by alarms, and so can't reliably use sleep() or select(), I suggest using Time::HiRes::gettimeofday in combination with select().
Here's some code that I've not tested. It should resist being interrupted by signals, and will sleep for the desired number of seconds plus up to 0.1 seconds. If you're willing to burn more CPU cycles doing nothing productive, you can make the resolution much better:
...
alarm_resistant_sleep(5); # sleep for 5 seconds, no matter what
...
use Time::HiRes;
sub alarm_resistant_sleep {
my $end = Time::HiRes::time() + shift();
for (;;) {
my $delta = $end - Time::HiRes::time();
last if $delta <= 0;
select(undef, undef, undef, $delta);
}
}
You can try AnyEvent:
use AnyEvent;
my $cv = AnyEvent->condvar;
my $wait_one_and_a_half_seconds = AnyEvent->timer(
after => 1.5,
cb => sub { $cv->send }
);
# now wait till our time has come
$cv->recv;
You can sleep on a new process via system:
system ( "sleep", 5 );
Or did I misunderstand the question?
When using (from MySQL forum)
use Sys::SigAction qw( set_sig_handler );
eval {
my $hsig = set_sig_handler( 'ALRM', sub { my $canceled = 1; die; }, { mask=>[ qw( INT ALRM ) ] ,safe => 0 } );
alarm($timeout);
...
alarm(0);
}
I noticed that any subsequent calls made to sleep($delay) with $timeout shorter than $delay would end up with the script execution being terminated, and the print of "Alarm clock".
The workaround I've found is to call alarm() again but with an improbably large value (3600), and cancel that alarm right after.
eval {
alarm(3600);
print " .... Meeeep ...."; # Some trace
alarm(0);
};
Then I can use sleep() with no interference anymore.
Example below (live code snippet):
sub unmesswithsleep {
eval {
alarm(3600);
&tracing (8, " .... Meeeep ....");
alarm(0);
};
}
sub lockDBTables {
return (0) unless ($isdbMySQLconnect);
my $stm = qq {
LOCK TABLES
myBIGtable WRITE
};
my $timeout = 60; # This is the timer set to protect against deadlocks. Bail out then.
eval {
my $h = set_sig_handler( 'ALRM', sub { my $canceled = 1; die; }, { mask=>[ qw( INT ALRM ) ] ,safe => 0 } );
alarm($timeout);
my $res = $dbmyh->do($stm) + 0;
alarm(0); # Reset alarm
};
if ( $# =~ m/Die/i ) {
$isdbTabledlocked = 0;
&tracerr (0, "FATAL: Lock on Tables has NOT been acquired within ${timeout}s. Lock is set to <$isdbTabledlocked>.");
&unmesswithsleep(); # MUST be called each time alarm() is used
return (0);
} else {
$isdbTabledlocked = 1;
&tracing (2, " Good: Lock on Tables has been acquired in time. Lock is set to <$isdbTabledlocked>.");
&unmesswithsleep(); # MUST be called each time alarm() is used
return (1);
}
# Can use sleep() now.
}
try
print "Start\n";
select undef, undef, undef, 1;
print "End\n";
This will sleep for 1 second.
It sounds like your code that sleeps is being interrupted by some code that sets an alarm. This is by design so you're seeing the expected behavior. In other words an alarm *should always interrupt a sleep call.
If you're looking for a pure perl way to sleep without being interrupted by an alarm you can do this by installing your own alarm signal handler. This way when your code gets an alarm it won't interrupt your processing.
However, an important caveat is that this will delay any alarm that was set by other code. The other code will receive the alarm late; after your code completes. This means that if you want to play well with others you're better off using one of the other solutions.
Here is an example:
#!/usr/bin/perl
use POSIX;
use strict;
use warnings;
# set an alarm
print "Setting alarm\n";
alarm 1;
my $old_alarm;
my $snoozed;
{
# store the previous alarm handler (if any)
$old_alarm = $SIG{ALRM};
# override the alarm handler so that we don't
# get interrupted
local $SIG{ALRM} = sub {
print "got alarm; snoozing\n";
# record the fact that we caught an alarm so that
# we can propagate it when we're done
$snoozed++;
};
# sleep for a while.
for (1 .. 3) {
print "z" x $_ ,"\n";
sleep 1;
}
}
# replace the old sleep handler;
$SIG{ALRM} = $old_alarm
if $old_alarm;
# if we had to snooze fire an immediate alarm;
if ($snoozed) {
POSIX::raise(POSIX::SIGALRM);
}
The documentation you reference hints at but does not describe a different symptom. The main thing you need to worry about when sleep is implemented via alarm is having your alarm reset when someone calls sleep.
*Apparently there are some versions of perl (e.g.: old Win32) where an alarm doesn't interrupt sleep.