Perl procedural return two stack call levels - perl

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.

Related

How can I force exiting a perl subroutine/closure via last/next to fail the program automatically?

Given the following fully functional perl script and module:
tx_exec.pl:
#!/usr/bin/perl
use strict; # make sure $PWD is in your PERL5LIB
# no warnings!
use tx_exec qw(tx_exec);
tx_exec ("normal", sub { return "foobar"; });
tx_exec ("die", sub { die "barbaz\n"; });
tx_exec ("last", sub { last; });
tx_exec ("next", sub { next; });
tx_exec.pm:
package tx_exec;
use strict;
use warnings;
require Exporter;
our #ISA = qw(Exporter);
our #EXPORT_OK = qw(tx_exec);
my $MAX_TRIES = 3;
sub tx_exec {
my ($desc, $sub, $args) = #_;
print "\ntx_exec($desc):\n";
my $try = 0;
while (1) {
$try++;
my $sub_ret;
my $ok = eval {
# start transaction
$sub_ret = $sub->($args);
# commit transaction
1;
};
unless ($ok) {
print "failed with error: $#";
# rollback transaction
if ($try >= $MAX_TRIES) {
print "failed after $try tries\n";
return (undef, undef);
}
print "try #$try failed, retrying...\n";
next;
}
# some cleanup
print "returning (1, ".($sub_ret//'<undef>').")\n";
return (1, $sub_ret);
}
}
I get the following output:
$ ./tx_exec.pl
tx_exec(normal):
returning (1, foobar)
tx_exec(die):
failed with error: barbaz
try #1 failed, retrying...
failed with error: barbaz
try #2 failed, retrying...
failed with error: barbaz
failed after 3 tries
tx_exec(last):
tx_exec(next):
# infinite loop
I understand what is happening, and I'm getting a warning about it if I turn on warnings in the script defining the closures. However, can I force the program to fail/die automatically/idiomatically, when next/last would exit a closure-subroutine like here, under the following strict circumstances:
The $sub being passed is a closure and not a simple function (a simple function dies on bare next/last anyway, which is trivial to handle)
The library code (tx_exec) and the client code (invoking it) are in separate compilation units and the client does not use warnings.
Using perl 5.16.2 (without possibility of upgrading).
Here is a github gist documenting all the approaches so far:
use warnings FATAL => qw(exiting) doesn't make a difference in library code
local $SIG handler doesn't work if the call site doesn't have FATAL => qw(exiting) warning enabled
manual detection works, but is somewhat cumbersome and all over the place (nonlocalized)
ysth's approach with a bare block works best, as it catches the last/next, fully localizing manual detection and guaranteeing that nothing can go wrong (except next/last with labels, which is easier to avoid).
Short Using next/last in the sub (that caller passes as coderef) triggers an exception, if not within a "loop block." This affords an easy handling of such use, with a small change of tx_exec().
The wrong use of last/next raised in the question is a little nuanced. First, from last
last cannot be used to exit a block that returns a value such as eval {}, sub {}, or do {}, and should not be used to exit a grep or map operation.
and for doing this in a sub or eval we get a warning
Exiting subroutine via last at ...
(and for "eval"), and similarly for next. These are classified as W in perldiag and can be controlled by using/not the warnings pragma.† This fact foils attempts to make such use fatal by FATAL => 'exiting' warning or by $SIG{__WARN__} hook.
However, if such use of next or last (in a sub or eval) has no "loop block" in any enclosing scope (or call stack) then it also raises an exception.‡ The message is
Can't "last" outside a loop block...
and similarly for next. It is found in perldiag (search for outside a loop), classified as F.
Then one solution for the posed problem is to run the coderef passed by caller outside of loop blocks, and we get the interpreter to check for and alert us to (raise exception) the offending use. As the while (1) loop is there only to be able to try multiple times this can be implemented.
The coderef can be run and tested against this exception in a utility routine
sub run_coderef {
my ($sub, #args) = #_;
my $sub_ret;
my $ok = eval { $sub_ret = $sub->(#args); 1 };
if (not $ok) {
if ($# =~ /^Can't "(?:next|last)"/) { #'
die $#; # disallow such use
}
else { return } # other error, perhaps retry
}
else { return $sub_ret }
}
which can be used like
sub tx_exec {
my ($sub, #args) = #_;
my $sub_ret = run_coderef($sub, #args);
my $run_again = (defined $sub_ret) ? 0 : 1;
if ($run_again) {
my $MAX_TRIES = 3;
my $try = 0;
while (1) {
++$try;
$sub_ret = run_coderef($sub, #args);
if ( not defined $sub_ret ) { # "other error", run again
if ($try >= $MAX_TRIES) {
print "failed after $try tries\n";
return (undef, undef);
}
print "try #$try failed, retrying...\n";
next;
}
...
}
}
}
This approach makes perfect sense design wise: it allows an exception to be raised for the disallowed use, and it localizes the handling in its own sub.
The disallowed behavior is checked for really only on the first run, since after that run_coderef is called out of a loop, in which case (this) exception isn't thrown. This is fine since the repeated runs (for "allowed" failures) are executed with that same sub so it is enough to check the first use.
On the other hand, it also means that we can
run eval { $sub_ret = $sub->(#args) ... } directly in the while (1), since we have checked for bad use of last/next on the first run
Can add further cases to check for in run_coderef, making it a more rounded checker/enforcer. The first example is the Exiting warnings, which we can make fatal and check for them as well. This will be useful if warnings in the caller are enabled
This approach can be foiled but the caller would have to go out of their way toward that end.
Tested with v5.16.3 and v5.26.2.
† Btw, you can't fight a caller's decision to turn off warnings. Let them be. It's their code.
‡ This can be checked with
perl -wE'sub tt { last }; do { tt() }; say "done"'
where we get
Exiting subroutine via last at -e line 1.
Can't "last" outside a loop block at -e line
while if there is a "loopy" block
perl -wE'sub tt { last }; { do { tt() } }; say "done"'
we get to see the end of the program, no exception
Exiting subroutine via last at -e line 1.
done
The extra block { ... } "semantically identical to a loop that executes once" (next).
This can be checked for eval by printing its message in $#.
The original post, based on the expectation that only warnings are emitted
The warnings pragma is lexical, so adding per ysth comment
use warnings FATAL => 'exiting';
in the sub itself (or in eval to scope it more tightly) should work under the restrictions
sub tx_exec {
use warnings FATAL => "exiting";
my ($sub, $args) = #_;
$sub->($args);
};
since the warning fires inside the tx_exec scope. In my test the call to this with a coderef not doing last/next first runs fine, and it dies only for a later call with them.
Or, can implement it using $SIG{__WARN__} "signal" (hook)
sub tx_exec {
local $SIG{__WARN__} = sub {
die #_ if $_[0] =~ /^Exiting subroutine via (?:last|next)/;
warn #_
};
my ($sub, $args) = #_;
...
}
This is the manual approach I was mentioning in the question. So far this was the only approach that helped me cleanly handle misbehaving client code, without any assumptions or expectations.
I'd prefer, and will gladly consider, a more idiomatic approach, like the local $SIG or use warnings FATAL => 'exiting', if they work without any expectation from client code (specifically that it has warnings enabled in any form).
tx_exec.pl:
#!/usr/bin/perl
use strict;
# no warnings!
use tx_exec qw(tx_exec);
tx_exec ("normal", sub { return "foobar"; });
tx_exec ("die", sub { die "barbaz\n"; });
tx_exec ("last", sub { last; });
tx_exec ("next", sub { next; });
tx_exec.pm:
package tx_exec;
use strict;
use warnings;
require Exporter;
our #ISA = qw(Exporter);
our #EXPORT_OK = qw(tx_exec);
my $MAX_TRIES = 3;
sub tx_exec {
my ($desc, $sub, $args) = #_;
print "\ntx_exec($desc):\n";
my $try = 0;
my $running = 0;
while (1) {
$try++;
my $sub_ret;
my $ok = eval {
# start transaction
die "Usage of `next` disallowed in closure passed to tx_exec\n" if $running;
$running = 1;
$sub_ret = $sub->($args);
print "sub returned properly\n";
# commit transaction
1;
};
$running = 0;
unless ($ok) {
if ($# =~ /^Usage of `next`/) {
print $#;
return (undef, undef); # don't retry
}
print "failed with error: $#";
# rollback transaction
if ($try >= $MAX_TRIES) {
print "failed after $try tries\n";
return (undef, undef);
}
print "try #$try failed, retrying...\n";
next;
}
# some cleanup
print "returning (1, ".($sub_ret//'<undef>').")\n";
return (1, $sub_ret);
}
print "Usage of `last` disallowed in closure passed to tx_exec\n";
return (undef, undef);
}
output:
tx_exec(normal):
sub returned properly
returning (1, foobar)
tx_exec(die):
failed with error: barbaz
try #1 failed, retrying...
failed with error: barbaz
try #2 failed, retrying...
failed with error: barbaz
failed after 3 tries
tx_exec(last):
Usage of `last` disallowed in closure passed to tx_exec
tx_exec(next):
Usage of `next` disallowed in closure passed to tx_exec
For lack of #ysth's involvement in writing an answer, I'm writing the best solution I found so far, inspired by his first attempt from the comments to the question. (I will re-accept ysth's answer if he posts it later).
The eval calling the coderef needs to look like this:
my $ok = eval {
# start transaction
my $proper_return = 0;
{
$sub_ret = $sub->($args);
$proper_return = 1;
}
die "Usage of `next` or `last` disallowed in coderef passed to tx_exec\n" unless $proper_return;
# commit transaction
1;
};
The bare block is acting as a loop which will immediately exit on either next or last, so whether we land after the bare block, or within it, from calling the coderef, we can deduce whether the coderef executed next/last and act appropriately.
More on bare block semantics and their interaction with next/last can be found here.
It is left as an exercise for the reader to handle the rarely seen redo in the code above.

Is it ok to use Attribute::Handlers for implementing retry logic

Is it ok to use Attribute::Handlers for implementing retry logic
I have almost 50+ subroutine like verifyXXXX. I need to implement the retry logic for all these subs. I want to write this retry logic where the sub is actually implemented. If the return value of sub is false/undef then it will retry again.
subs will be called in regular way, so that the caller will not know about the retry logic, something like.
verify_am_i_doing_good()
or die('sorry you are not doing as expected.');
verify_am_i_fine()
or die ('sorry you are not find.');
:
:
the actual implementation of these functions is something like this in the package.
use Attribute::Handlers;
use constant RETRY_LIMIT => 4;
use constant RETRY_DELAY => 2;
sub verify_am_i_doing_good : __retry
{
return 1 if ($x == $y);
return;
}
sub __retry : ATTR(CODE) {
my ($pkg, $sym, $code) = #_;
my $name = *{ $sym }{NAME};
no warnings 'redefine';
*{ $sym } = sub
{
my $self = $_[0];
my $result;
logMsg (INFO, "Executing subroutine $name with retry limit " . RETRY_LIMIT);
for (my $retryCount = 1; $retryCount <= RETRY_LIMIT; $retryCount++)
{
logMsg (INFO, "Executing subroutine $name with retry count $retryCount");
my $result = $code->( #_ );
if ($result)
{
logMsg (INFO, "Expected result observed in retry count $retryCount");
return wantarray ? #$result : $result;
}
else
{
logMsg (INFO, "Expected result is NOT observed in retry count $retryCount");
logMsg (INFO, "Retrying again by updating uixml");
sleep RETRY_DELAY;
$self->updateState();
}
}
logMsg (WARN, "Failed to verify expected result for subroutine $name with retry limit " . RETRY_LIMIT);
return;
};
}
The reason to use Attribute::Handlers, inplace of Attribute::Attempts is that in the case of failure, I need to call another subroutine updateState() before retrying (re-executing) the subroutine.
I got this idea of writing the retry logic from following post http://www.perl.com/pub/2007/04/12/lightning-four.html
My main concern is that since I am using this __retry attribute for almost 50+ subs. Is it a good practice to do in this way or is there anything simple I can do?
You help will be highly appreciated.
You don't need attributes to do a sub wrapper. There was Memoize long before there was Memoize::Attrs (or Attribute::Memoize for that matter). You can just take a look at how Memoize handles it.
Quite recently, I was writing some Perl for functions called in another interface. All the arguments passed to the Perl function from this interface would be passed in a funky-but-universal format used by my division. Rather than deal with this everywhere, I wrote a logic wrapper like so
sub external (#) {
my ( $subname, $code ) = #_;
...
my $wrapped
= sub {
my $count = 5;
while ( --$count and not my #results = &$code ) {
adjust_stuff();
}
return #results;
};
{ no strict 'refs'; # my special "no-block"
*$subname = $wrapped;
}
return;
}
And used it like this (some people don't like this use of the "fat comma")
external something_I_want_to_do => sub {
my #regular_old_perl_args = #_;
...
};
The prototype (#) helps a sub act as an operator and need not always be called with parenthesis.
But by all means if you like method attributes and it works and you can get it not to bite you, use them. But you don't have to. You should probably read up on the caveats though.

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.

Perl Multithreaded GTK+ applet

I'd like to write a Perl GTK+ application which will:
0.1) Press button A
0.2) Disable A
0.3) start threads 1 and 2
0.4) start thread 3
Thread 3 does the following:
3.1) join thread 1
3.2) join thread 2
3.3) Enable A
On completion of thread 3, the button A should be enabled again.
Now, this kind of approach is perfectly valid in C/C++ under Win32, Linux using native GUI libraries and/or GTK+, KDE. Problem with GTK+ and Perl is that you can't share the button variable within threads (eg. point 3.3 can't be performed by thread 3).
The problem is that threads::shared works only on base types, not on references like Gtk2::Button.
I tried to bless the Gtk2::Button object again (as shown in the docs), but I got an error:
my $thread_button = shared_clone(Gtk2::Button->new('_Threads'));
bless $thread_button => 'Gtk2::Button';
$hbox->pack_start($thread_button, FALSE, FALSE, 0);
my ($jobA, $jobB);
$thread_button->signal_connect( clicked => sub {
$thread_button->set_sensitive(0);
if (defined($jobA)) {
$jobA->join();
}
if (defined($jobB)) {
$jobB->join();
}
# spawn jobs
$jobA = threads->create(\&async_func, 10);
$jobB = threads->create(\&async_func, 10);
threads->create(sub {
$jobA->join();
$jobB->join();
bless $thread_button => 'Gtk2::Button';
$thread_button->set_sensitive(1);
});
});
Is my code ok?
I'm asking because when it runs the GUI won't display the Thread button and report the following error:
Gtk-CRITICAL **: gtk_box_pack: assertion `GTK_IS_WIDGET (child)' failed at vbox.pl line 48. (Where I use pack_start)
GLib-GObject-WARNING **: invalid (NULL) pointer instance at vbox.pl line 67.
GLib-GObject-CRITICAL **: g_signal_connect_closure: assertion `G_TYPE_CHECK_INSTANCE (instance)' failed at vbox.pl line 67. (the signal_connect doesn't work)
Apparently this doesn't work with complex objects.
I've tried another fix, polling for the running threads inside a callback function invoked in the main (GTK) thread:
my $thread_button = Gtk2::Button->new('_Threads');
$hbox->pack_start($thread_button, FALSE, FALSE, 0);
my ($jobA, $jobB);
$thread_button->signal_connect( clicked => sub {
$thread_button->set_sensitive(0);
# spawn jobs
$jobA = threads->create(\&async_func, 10);
$jobB = threads->create(\&async_func, 10);
Glib::Timeout->add(3000, sub {
print "TIMER\n";
if (defined($jobA)) {
if (! $jobA->is_running()) {
print "jobA is not running!\n";
$jobA->join();
undef $jobA;
}
}
if (defined($jobB)) {
if (! $jobB->is_running()) {
print "jobB is not running!\n";
#$jobB->join();
undef $jobB;
}
}
if (!defined($jobA) && !defined($jobB)) {
print "Both jobs have terminated!\n";
$thread_button->set_sensitive(1);
return 0;
}
return 1;
});
});
Please note the following things:
1) I have to comment the join on the second thread
#$jobB->join();
Otherwise the applet will crash.
2) Apparently it works, but when I click on the re-enabled button for the second time, the thread creation crahses the application
This is a lot unstable. I thought Perl was more C based, but this huge instability is totally absent in C/C++. I'm a bit disappointed.
Does anyone have more suggestions?
Is the multithread API such unnstable in Perl?
Latest update.
This code works:
my $thread_button = Gtk2::Button->new('_Threads');
$hbox->pack_start($thread_button, FALSE, FALSE, 0);
my ($jobA, $jobB);
$thread_button->signal_connect( clicked => sub {
$thread_button->set_sensitive(0);
# spawn jobs
$jobA = threads->create(\&async_func, 10);
$jobB = threads->create(\&async_func, 10);
Glib::Timeout->add(100, sub {
if (!$jobA->is_running() && !$jobB->is_running()) {
print "Both jobs have terminated!\n";
$thread_button->set_sensitive(1);
return 0;
}
return 1;
});
});
But:
1) I have to poll for threads (not very resources intensive on modern CPUs but NOT elegant ... one should rely only on OS sync primitives)
2) I can't join threads otherwise the applet crashes
3) Given (2) there are huge memory leaks every time I push the button
Honestly the more I see this the more I'm convinced that for proper app dev you can't rely on Perl...but even from a prototype-wise point of view it kinda sucks.
I hope I'm doing something wrong...in this case, could anyone please help me?
Cheers,
As explained in the threads::shared docs, you need to re-bless shared objects.
Update: Try the following variation
#!/usr/bin/perl
package Button;
use strict; use warnings;
# Trivial class because I do not have GTK2
sub new { bless \ my $self => $_[0] }
sub enable { ${ $_[0] } = 1; return }
sub disable { ${ $_[0] } = 0; return }
sub is_enabled { ${ $_[0] } ? 1 : 0 }
package main;
use strict; use warnings;
use threads; use threads::shared;
my $buttonA = shared_clone( Button->new );
my $button_class = ref $buttonA;
$buttonA->disable;
my #thr = map { threads->create(
sub {
print "thread $_ started\n";
sleep rand 3;
print "thread $_ finished\n";
return; }
) } (1, 2);
my $thr3 = threads->create( sub {
$_->join for #_ ;
bless $buttonA => $button_class;
$buttonA->enable;
}, #thr,
);
$thr3->join;
printf "buttonA is %s\n", $buttonA->is_enabled ? 'enabled' : 'disabled';
Another alternative is to pass a callback to $thr3:
my $buttonA = Button->new;
share($buttonA);
$buttonA->disable;
# start the other threads
my $thr3 = threads->create( sub {
my $callback = shift;
$_->join for #_ ;
$callback->();
}, sub { $buttonA->enable }, #thr,
);
Both versions of the code produce the output:
thread 1 started
thread 2 started
thread 1 finished
thread 2 finished
buttonA is enabled
I've read a couple of examples about threads and GTK in perl, but all of them initialize worker threads and then they'll switch their status to run/halt...
Very bad example of concurrent development.
Any more suggestions?
Cheers,

Retrying an operation after an exception: Please criticize my code

My Perl application uses resources that become temporarily unavailable at times, causing exceptions using die. Most notably, it accesses SQLite databases that are shared by multiple threads and with other applications using through DBIx::Class. Whenever such an exception occurs, the operation should be retried until a timeout has been reached.
I prefer concise code, therefore I quickly got fed up with repeatedly
typing 7 extra lines for each such operation:
use Time::HiRes 'sleep';
use Carp;
# [...]
for (0..150) {
sleep 0.1 if $_;
eval {
# database access
};
next if $# =~ /database is locked/;
}
croak $# if $#;
... so I put them into a (DB access-specific) function:
sub _retry {
my ( $timeout, $func ) = #_;
for (0..$timeout*10) {
sleep 0.1 if $_;
eval { $func->(); };
next if $# =~ /database is locked/;
}
croak $# if $#;
}
which I call like this:
my #thingies;
_retry 15, sub {
$schema->txn_do(
sub {
#thingies = $thingie_rs->search(
{ state => 0, job_id => $job->job_id },
{ rows => $self->{batchsize} } );
if (#thingies) {
for my $thingie (#thingies) {
$thingie->update( { state => 1 } );
}
}
} );
};
Is there a better way to implement this? Am I re-inventing the wheel? Is
there code on CPAN that I should use?
I'd probably be inclined to write retry like this:
sub _retry {
my ( $retrys, $func ) = #_;
attempt: {
my $result;
# if it works, return the result
return $result if eval { $result = $func->(); 1 };
# nah, it failed, if failure reason is not a lock, croak
croak $# unless $# =~ /database is locked/;
# if we have 0 remaining retrys, stop trying.
last attempt if $retrys < 1;
# sleep for 0.1 seconds, and then try again.
sleep 0.1;
$retrys--;
redo attempt;
}
croak "Attempts Exceeded $#";
}
It doesn't work identically to your existing code, but has a few advantages.
I got rid of the *10 thing, like another poster, I couldn't discern its purpose.
this function is able to return the value of whatever $func() does to its caller.
Semantically, the code is more akin to what it is you are doing, at least to my deluded mind.
_retry 0, sub { }; will still execute once, but never retry, unlike your present version, that will never execute the sub.
More suggested ( but slightly less rational ) abstractions:
sub do_update {
my %params = #_;
my #result;
$params{schema}->txn_do( sub {
#result = $params{rs}->search( #{ $params{search} } );
return unless (#result);
for my $result_item (#result) {
$result_item->update( #{ $params{update} } );
}
} );
return \#result;
}
my $data = _retry 15, sub {
do_update(
schema => $schema,
rs => $thingy_rs,
search => [ { state => 0, job_id => $job->job_id }, { rows => $self->{batchsize} } ],
update => [ { state => 1 } ],
);
};
These might also be handy additions to your code. ( Untested )
The only real problem I see is the lack of a last statement. This is how I would write it:
sub _retry {
my ($timeout, $func) = #_;
for my $try (0 .. $timeout*10) {
sleep 0.1 if $try;
eval { $func->(); 1 } or do {
next if $# =~ /database is locked/; #ignore this error
croak $#; #but raise any other error
};
last;
}
}
I might use 'return' instead of 'last' (in the code as amended by Chas Owens), but the net effect is the same. I am also not clear why you multiply the first parameter of your retry function by 10.
IMNSHO, it is far better to (re)factor common skeletal code into a function as you have done than to continually write the same code fragment over and over. There's too much danger that:
You have to change the logic - in far too many places
You forget to edit the logic correctly at some point
These are standard arguments in favour of using functions or equivalent abstractions over inline code.
In other words - good job on creating the function. And it is useful that Perl allows you to create the functions on the fly (thanks, Larry)!
Attempt by Mark Fowler seems to be pretty close to what I described above. Now, it would be handy if one could specify some sort of exception filter.