I have a subroutine that normally takes 1 second to run. Sometimes, it can run infinitely. I want to move on in the code if the subroutine is taking too long (> 10 seconds) and ignore that run of that subroutine. Here is what I have so far using alarm.
use Win32::OLE;
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm 10; # schedule alarm in 10 seconds
&do_the_subroutine;
alarm 0; # cancel the alarm
};
if ($#) {
$error_string .= $script;
#Do something else if the subroutine took too long.
}
do_the_subroutine{
# use existing instance if Excel is already running
eval {$ex = Win32::OLE->GetActiveObject('Excel.Application')};
die "Excel not installed" if $#;
unless (defined $ex) {
$ex = Win32::OLE->new('Excel.Application', sub {$_[0]->Quit;})
or die "Oops, cannot start Excel";
}
# get a new workbook
$book = $ex->Workbooks->Add;
# write to a particular cell
$sheet = $book->Worksheets(1);
$sheet->Cells(1,1)->{Value} = "foo";
# write a 2 rows by 3 columns range
$sheet->Range("A8:C9")->{Value} = [[ undef, 'Xyzzy', 'Plugh' ],
[ 42, 'Perl', 3.1415 ]];
# print "XyzzyPerl"
$array = $sheet->Range("A8:C9")->{Value};
for (#$array) {
for (#$_) {
print defined($_) ? "$_|" : "<undef>|";
}
print "\n";
}
# save and exit
$book->SaveAs( 'test.xls' );
undef $book;
undef $ex;
}
&do_the_subroutine never returns so I'm not able to move on. I'm also not able to put this block of code inside that subroutine. Any thoughts?
I suspect that what you want to do is simply not natively possible with alarm on Windows.
From perldoc perlport:
alarm Emulated using timers that must be explicitly polled whenever
Perl wants to dispatch "safe signals" and therefore cannot
interrupt blocking system calls. (Win32)
Related
I wrote a simple script to manage the download time ( start and finish ) with wget in Linux-Gnu with Perl. There is no problem and everything works good, except I wish I could read a key from keyboard when the process is running.
I show a simple movement animation on the screen that I do not want to stop it and then read the key.
for example like mplayer or mpv that when you run it on the comman-line, you can press q to exit or s to take a picture from the screen.
A part of the script:
do {
system( "clear" );
($h, $m, $s) = k5mt::second_to_clock( $till_shutdown );
set_screen();
set_screen( 24 );
set_screen();
say "download was started ...";
set_screen();
set_screen( 24 );
set_screen();
printf "till finish: %02d %02d %02d\n", $h, $m, $s;
set_screen();
set_screen( 24 );
set_screen();
say "wget pid: [$wget_pid]";
set_screen();
set_screen( 24 );
set_screen();
$waiting_temp .= $animation[ $counter_animation++ ];
say $waiting_temp;
if( length( $waiting ) == $counter_animation ){
$waiting_temp = "";
$counter_animation = 0;
}
set_screen();
set_screen( 24 );
sleep 1;
$till_shutdown--;
} while( $till_shutdown );
the words waiting till finish..... is shown consecutively ( without interruption ) and I want to read a key like q to exit from the program.
UPDATE
I am looking for a solution with as many option as I want, if I have wanted just for exit from the program I simply tell the user to press Ctrl + C
Is it possible with scripting in Perl? or not? If it is, How?
NOTE: if it is possible without any modules please say the solution
without any module, and if not, okay no problem
However, thank you so much.
Assuming your program has a central loop, or if you can simply fit keyboard checks into the processing, you are better off using Term::ReadKey than trying to fit in fork and handling the necessary inter-process communication
Calling ReadKey(-1) will do a non-blocking read, which will return a single character if a key has been hit, or undef otherwise. (You may supply a second parameter which is the IO channel to be used, but it will default to STDIN.)
I suggest you run this example. I have used sleep 1 as a dummy for your loop processing
use strict;
use warnings 'all';
use feature 'say';
use Term::ReadKey;
my $n;
while () {
my $key = ReadKey(-1);
say "key $key entered" if defined $key;
sleep 1;
say ++$n;
}
This will work for you
use 5.010;
use strict;
use Term::ReadKey;
ReadMode 4; # It will turn off controls keys (eg. Ctrl+c)
my $key;
# It will create a child so from here two processes will run.
# So for parent process fork() will return child process id
# And for child process fork() will return 0 id
my $pid = fork();
# This if block will execute by the child process and not by
# parent because for child $pid is 0
if(not $pid){
while(1){
# Do your main task here
say "hi I'm sub process and contains the main task";
sleep 2;
}
}
# Parent will skip if block and will follow the following code
while (1) {
$key = ReadKey(-1); # ReadKey(-1) will perform a non-blocked read
if($key eq 'q'){ # if key pressed is 'q'
`kill -9 $pid`; # then if will run shell command kill and kill
# the child process
ReadMode 0; # Restore original settings for tty.
exit; # Finally exit from script
} elsif( $key eq 'h' ) {
say "Hey! you pressed $key key for help";
} elsif( $key ne '' ) {
say "Hey! You pressed $key";
}
}
References:
Term::ReadKey
Fork in Perl
If you are not worried about a little delay, you can play with select and alarm to try to handle user input.
Using select you can handle the STDIN and using alarm you can wait for a few seconds or less for user input.
#!/usr/bin/env perl
use common::sense;
use IO::Select;
my $sel = IO::Select->new();
$sel->add( \*STDIN );
$|++;
my $running = 1;
while ($running) {
eval {
local $SIG{ALRM} = sub { die 'Time Out'; };
alarm 0.5;
if ( $sel->can_read(0) ) {
my $input = <STDIN>;
chomp $input;
print "STDIN > $input\n";
$running = 0;
}
};
if ( !$# ) {
select( undef, undef, undef, 0.5 );
print ".";
}
}
print "\nEnd Of Script\n";
I told you to try to use Term::ReadKey :-)
Here we go:
!/usr/bin/env perl
use common::sense;
use Term::ReadKey;
my $running = 1;
my $key;
while ($running) {
ReadMode 4; # Turn off controls keys
while ( not defined( $key = ReadKey(-1) ) ) {
select( undef, undef, undef, 0.5 );
print '.';
}
print "\nSTDIN> $key\n";
ReadMode 0;
}
print "\nEnd Of Script\n";
Now you just have to handle signals like quit or int to exit the loop, but using this you can capture the input and do whatever you want.
I was looking for an example to limit the number of forked processes to run at the same time and I ran across this old code
#!/usr/bin/perl
#total forks, max childs, what to run
#function takes 2 scalars and a reference to code to run
sub mfork ($$&) {
my ($count, $max, $code) = #_;
# total number of processes to spawn
foreach my $c (1 .. $count) {
#what is happening here? why wait vs waitpid?
wait unless $c <= $max;
die "Fork failed: $!\n" unless defined (my $pid = fork);
# i don't undestand the arrow notation here and how it calls a function,
#also unless $pid is saying run function unless you're the parent
exit $code -> ($c) unless $pid;
}
#no idea what's happening here, why are we waiting twice? for the last process?
#why 1 until (-1 == wait)? what's 1 doing here
1 until -1 == wait;
}
#code to run
mfork 10, 3, sub {
print "$$: " . localtime() . ": Starting\n";
select undef, undef, undef, rand 2;
print "$$: " . localtime() . ": Exiting\n";
};
Let's take a look at the code. Code is yours, with most of your comment removed. All other comments are mine.
#!/usr/bin/perl
# total forks, max childs, what to run
# function takes 2 scalars and a reference to code to run
sub mfork ($$&) {
my ($count, $max, $code) = #_;
# total number of processes to spawn
foreach my $c (1 .. $count) {
# wait waits for any child to return,
# waitpid for a specific one
wait unless $c <= $max;
die "Fork failed: $!\n" unless defined (my $pid = fork);
# the arrow is used to call the coderef in $code
# and the argument is $c. It's confusing because it has
# the space. It's a deref arrow, but looks like OOp.
# You're right about the 'unless $pid' part.
# If there is $pid it's in the parent, so it does
# nothing. If it is the child, it will run the
# code and exit.
exit $code -> ($c) unless $pid;
}
# This is reached after the parent is done with the foreach.
# It will wait in the first line of the foreach while there are
# still $count tasks remaining. Once it has spawned all of those
# (some finish and exit and make room for new ones inside the
# loop) it gets here, where it waits for the remaining ones.
# wait will return -1 when there are no more children.
# The '1 until' is just short for having an until loop that
# doesn't have the block. The 1; is not a costly operation.
# When wait == -1 it passes the line, returning from the sub.
1 until -1 == wait;
}
# because of the prototype above there are no () needed here
mfork 10, 3, sub {
print "$$: " . localtime() . ": Starting\n";
select undef, undef, undef, rand 2;
print "$$: " . localtime() . ": Exiting\n";
};
Let's look at stuff in detail.
There is wait and waitpid. wait will wait until any of the children returns. That is useful because the program doesn't care which slot gets freed. As soon as one finishes, a new one can be spawned. waitpid takes an argument of a specific $pid. That's not helpful here.
The $code->($c) syntax runs a coderef. Just like %{ $foo }{bar} will dereference a hashref, &{ $baz }() will dereference (and run, that's the ()) a coderef. An easier to read way is $foo->{bar}. Just the same is true for $baz->(). The arraow derefs it. See perlref and perlreftut.
While this is nice and useful, maybe it would make more sense to use Parallel::Forkmanager, which gives the power of this in a lot less lines of code, and you don't need to worry how it works.
use strict;
use warnings;
use Parallel::ForkManager;
my $pm = Parallel::ForkManager->new(3); # max 3 at the same time
DATA_LOOP:
foreach my $data (1 .. 10) {
# Forks and returns the pid for the child:
my $pid = $pm->start and next DATA_LOOP;
... do some work with $data in the child process ...
print "$$: " . localtime() . ": Starting\n";
select undef, undef, undef, rand 2;
print "$$: " . localtime() . ": Exiting\n";
$pm->finish; # Terminates the child process
}
That's it. Way clearer to read. :)
I have used an Alarm function in my script which is not triggering at the time which it should be :
Here is my code :
$SIG{ALRM} = sub{
print"*****Test Fail*****";
};
eval{
alarm(10);
getTheBootTime();
alarm(0);
};
die $# if $#;
getTheBootTime(); is taking 5 mints to gets execute. Am i doing anything wrong here?
Assuming that getTheBootTime() is a computation and does NOT tackle with alarm and/or sleep itself, the answer is like follows.
print "something"; w/o trailing \n may not output anything, as printed string gets stuck in the buffer until a newline is printed. This is the default behavior (unless $| is set to true or specific file descriptor has autoflush turned on).
Also the specified $SIG{ALRM} does NOT interrupt execution (no die there) which is what eval/alarm combination expects.
So the following may be in $SIG{ALRM}:
$SIG{ALRM} = sub {
print "alarm, no interruption, newline\n";
};
or
$SIG{ALRM} = sub {
die "alarm, interruption";
};
I have this code to timeout a long-running process (sleep in this case):
#!/usr/bin/env perl
use strict;
use warnings;
die "Usage: $0 SLEEP TIMEOUT\n" unless #ARGV == 2;
my ( $sleep, $timeout ) = #ARGV;
$|++;
eval {
local $SIG{ALRM} = sub { die "TIMEOUT\n" };
alarm $timeout;
eval {
# long-running process
print "Going to sleep ... ";
sleep $sleep;
print "DONE\n";
};
alarm 0; # cancel timeout
};
die $# if $#;
When I run it as ./alarm 5 2, I expect it to die saying "TIMEOUT". However it exits with 0 and says nothing. It works as expected when I remove the inner eval block (not the block's content, just the eval) though. Can someone explain why is that? Thanks.
Because you trap the error in the first eval block and the second eval block does not have an exception and clears $#.
eval {
local $SIG{ALRM} = sub { die "TIMEOUT\n" };
alarm $timeout;
eval {
# long-running process
print "Going to sleep ... ";
A: sleep $sleep;
print "DONE\n";
};
B:
alarm 0; # cancel timeout
C:};
die $# if $#;
$sleep > $timeout, so at A: your program throws a SIGALRM. The signal is caught by your local signal handler and calls die "TIMEOUT\n". So Perl sets $# to "TIMEOUT\n" and resumes execution at B:. Your program then makes it to C: without any additional errors. Since your outer eval block completed normally, Perl clears $#, and your final die statement does not execute.
To do what it seems like you want to do, you could either
don't use eval on the outer block
put another die $# if $# call at the end of the outer block
I have this code:
#!/usr/bin/perl
use strict;
use warnings;
my ($timeout, $size, $buffer) = (10, 10, undef);
eval {
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
alarm $timeout;
my $nread = sysread STDIN, $buffer, $size;
# !!!! race condition !!!!!
alarm 0;
print "$nread: $buffer";
};
if ($#) {
warn $#;
}
Is it correct?
May be there is a race condition between 8 and 9 line?
Let's look, what's going on:
my ($timeout, $size, $buffer) = (10, 10, undef);
eval {
#establish ALRM signal handler
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
#send alarm signal to program in 10 second
alarm $timeout;
#try yo read 10 bytes of data into $buffer
my $nread = sysread STDIN, $buffer, $size;
#cancel the previous timer without starting a new one
#if we returned from sysread. Yes, if 10 seconds pass
#before the next function is executed, the script will
#die even though the data was read
alarm 0;
#print number of bytes read (will be 10) and the string,
#read from input
print "$nread: $buffer";
};
$# is set if the string to be eval-ed did not compile, or if Perl code executed during evaluation die()d. In these cases the value of $# is the compile error, or the argument to die:
if ($#) {
warn $#;
}
So, this will print die message "alarm\n" if we didn't return from sysread in 10 second.
In the very unlikely case, when the input will be received just before 10 seconds elapse and we won't be able to run alarm 0;, I suggest to use the following code:
my ($timeout, $size, $buffer) = (10, 10, undef);
#I define $nread before the signal handler as undef, so if it's defined
#it means, that sysread was executed and the value was assigned
my $nread = undef;
eval {
local $SIG{ALRM} = sub {
#if it's not defined - it means, that sysread wasn't executed
unless(defined($nread))
{
die "alarm\n";
}
};
alarm $timeout;
$nread = sysread STDIN, $buffer, $size;
alarm 0;
print "$nread: $buffer";
};
Unfortunately, it doesn't save us from the case, when assignment operator wasn't executed.
Links:
http://perldoc.perl.org/functions/alarm.html
http://perldoc.perl.org/perlvar.html
http://perldoc.perl.org/functions/sysread.html
Your usage of alarm introduces a potential race condition.
The normal solution is to add alarm 0; after your eval block, so if the first alarm 0 isn't executed, you could still close the alarm.
Or you can use Time::Out package on CPAN to wrap up your code, it's better and safer.
What OS are you running this on? What version of perl?
Works fine for me on Mac OS X 10.8.3 with perl 5.12.4.
If you're using perl on Windows, you'll find that signals don't work the same as on POSIX and POSIX-like operating systems, and you might need to use the 4-argument version of select() instead.