(Before running the below script replace /home/porton/t/MOVE with a path to a file you have the right to create or erase.)
When I start this script from the command line and during 10 secs start the same script from command line again, it prints what I expect:
Flock: 1
and
Flock: 0
correspondingly.
But when I run it twice (with interval between the time of the requests less than 10 secs) as CGI that is as http://test.localhost/cgi-bin/test2.pl it prints
Flock: 1
for both two CGI requests.
What is the error? Why it behaves in a different unexpected way when run from CGI?
#!/usr/bin/perl
use strict;
use warnings;
use Fcntl qw(:flock);
print "Content-Type: text/plain\n\n";
open(my $lock_fh, '>', "/home/porton/t/MOVE");
print "Flock: " . flock($lock_fh, LOCK_EX|LOCK_NB) . "\n";
sleep 10;
Are you sure the two requests are running in parallel? They might be handled sequentially, i.e. the second request could be processed after the first one is completed, and after the lock has been released.
Related
Consider this scenario:
We have three scripts:
script.pl
use strict;
use warnings;
print "\nStarting a blocking process";
print "\nRedirect the output of the blocking process to execution.log";
my $cmd = "perl d:\\blocking_script.pl >d:\\execution.log";
my $exitCode = system ($cmd);
print "\nAfter the execution of the blocking process";
print "\nNow I try to rename the log";
rename "d:\\execution.log", "d:\\execution.err" or print "\nCouldn't rename because : $!";
blocking_script.pl
use strict;
use warnings;
print "\nFrom the blocking_process I run a non-blocking process";
my $cmd = "start perl d:\\non_blocking_script.pl";
my $exitCode = system ($cmd);
print "\nAfter I started the non-blocking process";
non_blocking_script.pl
use strict;
use warnings;
print "\nI am an independent non-blocking process";
sleep 5;
print "\nStill here";
sleep 2;
print "\nYou can't rename the log because you didn't wait for me";
sleep 3;
print "\n.";
sleep 1;
What will result from this?
Couldn't rename because : Permission denied
While another command promopt will be hanging ironically :
I am an independent non-blocking process
Still here
You can't rename the log because you didn't wait for me
.
In my situation from perl I run an external application in a blocking way, but that application was starting some non-blocking process which were holding my log.
How can I overcome this situation?
Here is the documentation for start (which you should also be able to read by using start /? on the command line. I do not have access to a Windows system right now, so I can't verify.
/b
Starts an application without opening a new Command Prompt window. CTRL+C handling is ignored unless the application enables CTRL+C processing. Use CTRL+BREAK to interrupt the application.
blocking_script.pl is waiting for the cmd window which start opened to run non_blocking_script.pl.
In the short run, using start /b might help.
Or, you could try
my #cmd = start => qw(perl d:\\non_blocking_script.pl);
my $exitCode = system #cmd;
However, you should change your design.
I start two instances of this Perl CGI script approximately simultaneously:
#!/usr/bin/perl
use strict;
use warnings;
print "Content-Type: text/plain\n\n";
print "Started at: " . time;
sleep 10;
Comparing the start time of the two scripts (which it outputs to the browser), I get that the difference is 10 sec, what is exactly the run time of the first script. This experiment shows that two instances of the same Perl script cannot run simultaneously.
Now I ask why, and whether this can be corrected (to allow two instances of the same Perl script to run simultaneously)?
We use a combination of Apache 2 and Nginx with CGI Perl scripts (not mod_perl).
I'm trying to test a piece of code ($code) that should make sure that only one instance of the program is running at a time:
#!/usr/bin/perl
# test_lock
use strict;
use warnings;
( my $code = <<'CODE') =~ s/^\s+//gm;
#!/usr/bin/perl
use strict;
use warnings;
use Fcntl qw(:flock);
# Make sure only one instance of the program is running at a time.
open our $Lock, '<', $0 or die "Can't lock myself $0: $!";
flock $Lock, LOCK_EX | LOCK_NB
or die "Another instance of $0 is already running. Exiting ...\n";
sleep(2);
CODE
my $progfile = '/tmp/x';
open my $fh, '>', $progfile or die $!;
print $fh $code;
close $fh;
$|++;
my $ex1 = system("perl $progfile &");
print "First system(): $ex1\n";
my $ex2 = system("perl $progfile");
print "Second system(): $ex2\n";
I expected that the second call to system() would return a non-zero value ($ex2) as it can't get the lock and dies. However I get:
$ perl test_lock
First system(): 0
Another instance of /tmp/x is already running. Exiting ...
Second system(): 0
What is wrong with my assumption? (Is there a better way to test the $code?)
I think it likely because you have a race condition. How do you know that error is actually coming from your second process?
Because if you for example, run:
perl /tmp/x & perl /tmp/x ; echo $?
You may get a zero return, because the 'winner' of the race may well be the latter process (which return code you're catching). (Try it a few times, and you'll see different results)
You also do have slight difference is what the shell is doing between the two commands - from the docs:
If there is only one scalar argument, the argument is checked for shell metacharacters, and if there are any, the entire argument is passed to the system's command shell for parsing (this is /bin/sh -c on Unix platforms, but varies on other platforms). If there are no shell metacharacters in the argument, it is split into words and passed directly to execvp , which is more efficient.
So actually you should see invocation of sh before perl in your first, which means it's actually more likely to take longer to get to the lock point.
That means your command is more like:
sh -c "perl /tmp/x"& perl /tmp/x; echo $?
Run that a few times and see how many times you get non-zero error codes. It's not often, because usually the 'delay' of the shell start up is enough to ensure that the second instance wins the race most of the time!
If you've linux - try strace -fTt yourscript which will trace the execution flow. Or you can make judicious use of $$ to report the process-pid when running.
In both cases, you are obtaining the exit code of the shell you launch. Roughly speaking, the shell returns the exit code of the last program it ran.
Since the shell created by system("perl $progfile &") doesn't wait for the child to end, it will virtually always return 0 since launching perl in the background is unlikely to result in an error.
So if the second instance of perl managed to obtain the lock first, you'll get the outcome you got. This race condition can be seem more clearly if you identify the source of the exception.
#!/usr/bin/perl
# test_lock
use strict;
use warnings;
( my $code = <<'CODE') =~ s/^\s+//gm;
#!/usr/bin/perl
use strict;
use warnings;
use Fcntl qw(:flock);
# Make sure only one instance of the program is running at a time.
open our $Lock, '<', $0 or die "Can't lock myself $0: $!";
flock $Lock, LOCK_EX | LOCK_NB
or die "$ARGV[0]: Another instance of $0 is already running. Exiting ...\n";
sleep(2);
CODE
my $progfile = 'b.pl';
open my $fh, '>', $progfile or die $!;
print $fh $code;
close $fh;
$|++;
my $ex1 = system("perl $progfile 1 &");
print "First system(): $ex1\n";
my $ex2 = system("perl $progfile 2");
print "Second system(): $ex2\n";
Output:
$ perl a.pl
First system(): 0
1: Another instance of b.pl is already running. Exiting ...
Second system(): 0
$ perl a.pl
First system(): 0
2: Another instance of b.pl is already running. Exiting ...
Second system(): 2816
I'm trying to get a perl script to loop very quickly (in Solaris).
I have something like this:
#! /bin/perl
while ('true')
{
use strict;
use warnings;
use Time::HiRes;
system("sh", "shell script.sh");
Time::HiRes::usleep(10);
}
I want the perl script to execute a shell script every 10 microseconds. The script doesn't fail but no matter how much I change the precision of usleep within the script, the script is still only being executed approx 10 times per second. I need it to loop much faster than that.
Am I missing something fundamental here? I've never used perl before but I can't get the sleep speed I want in Solaris so I've opted for perl.
TIA
Huskie.
EDIT:
Revised script idea thanks to user comments - I'm now trying to do it all within perl and failing miserably!
Basically I'm trying to run the PS command to capture processes - if the process exists I want to capture the line and output to a text file.
#! /bin/perl
while ('true')
{
use strict;
use warnings;
use Time::HiRes;
open(PS,"ps -ef | grep <program> |egrep -v 'shl|grep' >> grep_out.txt");
Time::HiRes::usleep(10);
}
This returns the following error:
Name "main::PS" used only once: possible typo at ./ps_test_loop.pl line 9.
This is a pure perl program (not launching any external process) that looks for processes running some particular executable:
#!/usr/bin/perl
use strict;
use warnings;
my $cmd = 'lxc-start';
my $cmd_re = qr|/\Q$cmd\E$|;
$| = 1;
while (1) {
opendir PROC, "/proc" or die $!;
while (defined(my $pid = readdir PROC)) {
next unless $pid =~ /^\d+$/;
if (defined(my $exe = readlink "/proc/$pid/exe")) {
if ($exe =~ $cmd_re) {
print "pid: $pid\n";
}
}
}
closedir PROC;
# sleep 1;
}
On my computer this runs at 250 times/second.
The bottleneck is the creation of processes, pipes, and opening the output file. You should be doing that at most once, instead of doing it in each iteration. That's why you need to do everything in Perl if you want to make this faster. Which means: don't call the ps command, or any other command. Instead, read from /proc or use Proc::ProcessTable, as the comments suggest.
Incidentally: the use statement is executed only once (it is essentially a shorthand for a require statement wrapped in a BEGIN { } clause), so you might as well put that at the top of the file for clarity.
I currently have a Perl script that runs an external command on the system, gathers the output, and performs some action based on what was returned. Right now, here is how I run this (where $cmd is a string with the command setup):
#output = `$cmd`;
I'd like to change this so if the command hangs and does not return a value after so much time then I kill the command. How would I go about running this asynchronously?
There's a LOT of ways to do this:
You can do this with a fork (perldoc -f fork)
or using threads (perldoc threads). Both of these make passing the returned information back to the main program difficult.
On systems that support it, you can set an alarm (perldoc -f alarm) and then clean up in the signal handler.
You can use an event loop like POE or Coro.
Instead of the backticks, you can use open() or respectively open2 or open3 (cf. IPC::Open2, IPC::Open3) to start a program while getting its STDOUT/STDERR via a file handle. Run non-blocking read operations on it. (perldoc -f select and probably google "perl nonblocking read")
As a more powerful variant of the openX()'s, check out IPC::Run/IPC::Cmd.
Probably tons I can't think of in the middle of the night.
If you really just need to put a timeout on a given system call that is a much simpler problem than asynchronous programming.
All you need is alarm() inside of an eval() block.
Here is a sample code block that puts these into a subroutine that you could drop into your code. The example calls sleep so isn't exciting for output, but does show you the timeout functionality you were interested in.
Output of running it is:
/bin/sleep 2 failure: timeout at
./time-out line 15.
$ cat time-out
#!/usr/bin/perl
use warnings;
use strict;
my $timeout = 1;
my #cmd = qw(/bin/sleep 2);
my $response = timeout_command($timeout, #cmd);
print "$response\n" if (defined $response);
sub timeout_command {
my $timeout = (shift);
my #command = #_;
undef $#;
my $return = eval {
local($SIG{ALRM}) = sub {die "timeout";};
alarm($timeout);
my $response;
open(CMD, '-|', #command) || die "couldn't run #command: $!\n";
while(<CMD>) {
$response .= $_;
}
close(CMD) || die "Couldn't close execution of #command: $!\n";
$response;
};
alarm(0);
if ($#) {
warn "#cmd failure: $#\n";
}
return $return;
}
If your external program doesn't take any input, look for the following words in the perlipc manpage:
Here's a safe backtick or pipe open for read:
Use the example code and guard it with an alarm (which is also explained in perlipc).
I coded below to run rsync on 20 directories simultaneously (in parallel instead of sequentially requiring me to wait hours for it to complete):
use threads;
for my $user ( keys %users ) {
my $host = $users{$user};
async {
system <<~ "SHELL";
ssh $host \\
rsync_user $user
SHELL
}
}
$ pgrep -lf rsync | wc -l
20
Not sure if it's best or even a good solution, but I was glad that it worked for my use case.
With this you get a mixed output on screen (what I ignored anyway), but it does its job successfully.
threads pragma exports the (very useful) async function by default.
rsync_user is my Perl script that wraps rsync command with options, and source and target directories set.
Ran on FreeBSD 13.1 with Perl 5.32.1