Perl FCGI Exit Without Dieing - perl

How to end script without using using exit if using Perl FCGI. After searching for days the only solution I found is to jump at label in the main script. below is the code of the main index.fcgi.
$fcgi_requests = 0; # the number of requests this fcgi process handled.
$handling_request = 0;
$exit_requested = 0;
$app_quit_request = 0; # End the application but not the FCGI process
# workaround for known bug in libfcgi
while (($ignore) = each %ENV) { }
$fcgi_request = FCGI::Request();
#$fcgi_request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR, \%ENV, $socket);
sub sig_handler {
my ($callpackage, $callfile, $callline) = caller;
if ($app_quit_request) {
$app_quit_request = 0;
goto ABORTLABEL;
}
$exit_requested = 1;
exit(0) if !$handling_request;
}
$SIG{USR1} = \&sig_handler;
$SIG{TERM} = \&sig_handler;
$SIG{PIPE} = 'IGNORE';
#The goal of fast cgi is to load the program once, and iterate in a loop for every request.
while ($handling_request = ($fcgi_request->Accept() >= 0)) {
process_fcgi_request();
$handling_request = 0;
last if $exit_requested;
#exit if -M $ENV{SCRIPT_FILENAME} < 0; # Autorestart
}
$fcgi_request->Finish();
exit(0);
#=========================================================#
sub process_fcgi_request() {
$fcgi_requests++;
# dispatch current request
my_app();
$fcgi_request->Finish();
}
#=========================================================#
# let it think we are done, used by abort
ABORTLABEL:
$fcgi_request->Finish();
#=========================================================#
The main request is I want to stop the program execution from inside sub insidi modules that may be called by long depth for example inside a login function in a accounts module.
Of course I can not use exit because it will terminate the fcgi process, I tried all error and throw and try modules all use die which also ends the process. Of course I can use the return from each sub but this will require to rewrite the whole program for fcgi.

The normal way to model exceptions in Perl is to call die inside eval BLOCK, which catches the die and so doesn't terminate the process. It'll just terminate the eval and the program continues to run from immediately afterwards. As far as I've seen, the exception-handling modules on CPAN are mostly wrappers around this basic functionality to give it different syntax or make it easier to write catch blocks. Therefore I'm surprised these don't work for you. Did you actually try them or did you just assume die always kills the process? The name is slightly misleading, because it really means 'throw an exception'. Just if you do that outside an eval the interpreter catches it, and its only response is to terminate the process.
eval {
say "Hello world";
die;
say "Not printed";
};
say "Is printed";
You don't want to call exit inside an eval though. Nothing catches that.
I would recommend though rewriting the entire control flow for FCGI. The lifecycle of your code changes significantly, so you have to make a certain amount of modifications to make sure that variable re-use is working properly and you're not leaking memory. Often it's better to do that up front rather than spend days tracking down odd bugs later.

After several questions and deep research, I got this solution. This coding example allows you to return from any nested levels of calls. The module Scope::Upper is XS so it should be fast.
use Scope::Upper qw/unwind CALLER/;
sub level1 {
print "before level 1 \n";
level2();
print "after level 1 \n";
}
sub level2 {
print "before level 2 \n";
level3();
print "after level 2 \n";
}
sub level3 {
print "before level 3 \n";
level4();
print "after level 3 \n";
}
sub level4 {
print "before level 4 \n";
#unwind CALLER 2;
my #frame;
my $i;
#$i++ while #frame = caller($i);# and $frame[0] ne "main";
$i++ while #frame = caller($i);
#print "i=: $i \n";
#unwind CALLER (#frame ? $i : $i - 1);
unwind CALLER $i-1;
print "after level 4 \n";
}
print level1();
If you run this code the output will be:
before level 1
before level 2
before level 3
before level 4
You can return to any up level using:
my intLevel = 2;
unwind CALLER intLevel;

Related

Reading from a file descriptor in a non-blocking way with Perl

Let's say I have this:
pipe(READ,WRITE);
$pid = fork();
if ($pid == 0) {
close(READ);
# do something that may be blocking
print WRITE "done";
close(WRITE);
exit(0);
} else {
close(WRITE);
$resp = <READ>;
close(READ);
# do other stuff
}
In this situation, it's possible for the child to hang indefinitely. Is there a way I can read from READ for a certain amount of time (ie, a timeout) and if I don't get anything, I proceed in the parent with the assumption that the child is hanging?
Typically, in C or Perl, you use select() to test if there is any input available. You can specify a timeout of 0 if you like, though used 1 second in the example below.:
use IO::Select;
pipe(READ,WRITE);
$s = IO::Select->new();
$s->add(\*READ);
$pid = fork();
if ($pid == 0) {
close(READ);
# do something that may be blocking
for $i (0..2) {
print "child - $i\n";
sleep 1;
}
print WRITE "donechild";
close(WRITE);
print "child - end\n";
exit(0);
} else {
print "parent - $pid\n";
close(WRITE);
for $i (0..10) {
print "parent - $i\n";
# 1 second wait (timeout) here. Can be 0.
print "parent - ", (#r=$s->can_read(1))?"yes":"no", "\n";
last if #r;
}
$resp = <READ>;
print "parent - read: $resp\n";
close(READ);
# do other stuff
}
Is there a way I can read from READ for a certain amount of time (ie, a timeout) and if I don't get anything, I proceed in the parent with the assumption that the child is hanging?
When you fork, you are working with two entirely separate processes. You're running two separate copies of your program. Your code cannot switch back and forth between the parent and child in your program. You're program is either the parent or the child.
You can use alarm in the parent to send a SIGALRM to your parent process. If I remember correctly, you set your $SIG{ALRM} subroutine, start your alarm, do your read, and then set alarm back to zero to shut it off. The whole thing needs to be wrapped in an eval.
I did this once a long time ago. For some reason, I remember that the standard system read didn't work. You have to use sysread. See Perl Signal Processing for more help.

Perl, How to break a loop with a signal handler sub

Let's say I have an opened filehandle, or anything I have to fix before to exit the script.
I also have a long loop and I want to break the loop if the processus receives a sigint. What is the cleanest way to do this?
Here is an illustration of the problem ;
use sigtrap 'handler' => \&sigint_handler, 'INT';
sub sigint_handler {
print("\nI see you are trying to escape this evil infinite loop,
but there is nothing that I can do to help you :(\n");
}
my $the_developper_is_unable_to_end_this_mess = 1;
open(my $handle, "< some.important.file");
while($the_developper_is_unable_to_end_this_mess) {
print("And the evil loop rolls again and again...\n");
sleep(3);
}
close($handle);
print("everything went better than expected\n")
Cleanup code that should absolutely be run can be put into an END block:
END {
print "This is run before the program exits\n";
}
print "This is some normal code\n";
Output:
This is some normal code
This is run before the program exits
However, END blocks are not run when the process terminates from a signal, unless when you implement your own signal handler – and if all that it does is calling exit.
So this code won't print END when you terminate it with a SIGINT:
END { print "END\n" }
sleep 4;
But this one will:
END { print "END\n" }
local $SIG{INT} = sub { exit 1 };
sleep 4;
These handlers are dynamically scoped, so you can put one into the loop that isn't in effect on the outside:
my $run = 1;
while ($run) {
local $SIG{INT} = sub { $run = 0 };
print "zzz\n";
sleep 3;
}
print "done!\n";
Of course you can also use sigtrap:
my $run = 1;
while ($run) {
use sigtrap handler => sub { $run = 0 }, 'INT';
print "zzz\n";
sleep 3;
}
print "done!\n";
PS: Filehandles are automatically closed when they fall out of scope / on process exit. If the handle is just reading from a file, there can't be any buffering issues or other processes depending on the handle, so that you can safely forget about close $fh in this case.

Perl - Breaking out of a system/backticks command on keypress if it takes a long time

I have a problem I am hoping someone can help with...
I have a foreach loop that executes a backticks command on each iteration, such as greping a folder in a directory for a string (as shown below, greatly simplified for the purposes of explaining my question).
my #folderList = ("/home/bigfolder", "/home/hugefolder", "/home/massivefolder");
my #wordList = ("hello", "goodbye", "dog", "cat");
foreach my $folder (#folderList) {
foreach my $word (#wordList) {
print "Searching for this $word in this $folder\n";
my #output = `grep -R $word $folder`; #this could take hours so the user needs the option to skip/cancel this iteration and go the next one
print "#output\n";
}
}
The problem I am having:
If the folder the backticks grep command is being run against is particularly large or the array of words to check against is particularly large then the backticks command could take hours to complete (which is fine).
But what i want to be able to do is to break out of the inner loop (i.e when a word is being greped for in a folder) and go to the next iteration if it is taking a long time when the user presses a key on the keyboard or enters the word "next" or "exit" for example.
I know that if i wasnt using backticks I could easily break out of a normal loop using something like the following (but the logic of this obviously does not work when a backticks/system call is involved):
use strict;
use warnings;
use Term::ReadKey;
my $n = 0;
while () {
print '.';
last if ReadKey(-1);
$n++;
}
print $n;
There may be a simple solution that I am overlooking but I have never had the need to do this before, so your help is much appreciated, thanks
The solution is to run the long-running program in a background process (and remember the process id of the new process), and keep your user interaction in the foreground process. When the foreground is signaled to break, kill the background process.
All the parts I mentioned are well-explained in previous posts on Stack Overflow.
You are trying to simultaneously run an external command and process keyboard events, so you need to use some asynchronous framework. Asynchronous frameworks are based on either forks, threads, or event loops, and event loops are not appropriate in this case.
Here's an outline of how you could use a fork:
use POSIX ':sys_wait_h'; # defines WNOHANG
foreach my $folder (#folderList) {
foreach my $word (#wordList) {
print "Searching for this $word in this $folder\n";
my $pid = fork();
if ($pid == 0) { # child process
# we are just printing output from the child process; if you want
# to move data from the child process back to the parent, well,
# that's a whole other can of worms
print `grep -R $word $folder`;
exit;
} else { # parent process
while (waitpid($pid, &WNOHANG) != $pid) {
if (Term::ReadKey(-1)) {
kill 'TERM', $pid; # or maybe kill 'KILL', ...
last;
}
}
}
}
}
I understand what people have said regarding background processes, threads and forking and so on, but the option that suited my arrangement the best (and is probably the easier to implement), although I confess may not be the most efficient, best practice or preferred way of doing it, involved using eval and catching user control-c keypresses.
Very Simple Example:
NEXT:foreach $folder (#folders) { #label on the foreach
eval {
$SIG{INT} = sub { break() }; #catches control-c keypress and calls the break subroutine
$var1 = `grep -r "hello" $folder`;
};
sub break {
print "Breaking out of the backticks command and going to next folder \n";
next NEXT;
}
} #ending bracket of foreach loop

safe to access shared data structure from signal handler

I'm trying to decide wether it's safe to access a common (read: shared between handler-code and rest of the programm) data structure from a signal handler in perl (v5.14.2) built for x86_64-linux-thread-multi, but target platform is solaris11).
perlipc has the following sample code:
use POSIX ":sys_wait_h"; # for nonblocking read
my %children;
$SIG{CHLD} = sub {
# don't change $! and $? outside handler
local ($!, $?);
my $pid = waitpid(-1, WNOHANG);
return if $pid == -1;
return unless defined $children{$pid};
delete $children{$pid};
cleanup_child($pid, $?);
};
while (1) {
my $pid = fork();
die "cannot fork" unless defined $pid;
if ($pid == 0) {
# ...
exit 0;
} else {
$children{$pid}=1;
# ...
system($command);
# ...
}
}
So, %children is accessed from the while-loop and the handler. This seems to be no problem as:
There won't be two processes having the same pid
Access is keyed by pid (I am not sure if $childer{pid}=1 is atomic and interruptible without causing corruption, though.)
Now, i'm trying to do even more in my handler:
my %categoryForPid;
my %childrenPerCategory;
$SIG{CHLD} = sub {
# ... acquire pid like above
my $category = $categoryForPid{$pid};
$childrenPerCategory{$category}--;
delete $categoryForPid{$pid};
}
while (1) {
# ... same as above
} else {
$children{$pid}=1;
my $category = # ... chose some how
$childrenPerCategory{$category}++;
$categoryForPid{$pid} = $category;
# ...
}
}
The idea here is: every child belongs to a certain category (N to 1). I want to keep track of how many children per category exist. That information could be derived from $categoryForPid, but i think that might be problematic also (e.g., when the subroutine doing the computation gets interrupted while summing up).
So my question is:
Do I need to synchronize here somehow?
And on a side note:
Are nested invocations of the signal handler possible in perl 5.12, or are they linearized by the interpreter?
Update
In addition to the problem spotted by #goldilocks and his proposed solution I block signals now while updating the data structures to ensure "atomicity":
my $sigset = POSIX::SigSet->new(SIGCHLD);
sub ublk {
unless (defined sigprocmask(SIG_UNBLOCK, $sigset)) {
die "Could not unblock SIGCHLD\n";
}
}
sub blk {
unless (defined sigprocmask(SIG_BLOCK, $sigset)) {
die "Could not block SIGCHLD\n";
}
}
while (1) {
# ... same as above
} else {
blk;
$children{$pid}=1;
my $category = # ... chose some how
$childrenPerCategory{$category}++;
$categoryForPid{$pid} = $category;
ublk;
# ...
}
}
Seems like a bad idea to me. IPC::Semaphore might solve the problem, if you can get them to work properly in a signal handler -- if control does not return until the handler exits, you're out of luck. However, you could get around that by locking in the parent and having the child wait on the lock until initialization is complete; the handler is not involved with the semaphore. You'd only actually need one lock for that, I think. Anyway:
my #array = (1..10);
my $x = 'x';
$SIG{'USR1'} = sub {
print "SIGUSER1\n";
undef #array;
$x = '!!';
};
print "$$\n";
foreach (#array) {
print "$_:\n";
sleep(2);
print "\t$x\n";
print "\t$array[$_ - 1]\n";
}
Not surprisingly, does this:
2482
1:
x
1
2:
x
2
3:
SIGUSER1
!!
Use of uninitialized value within #array in concatenation (.) or string at ./test.pl line 42.
Implying that if you catch the signal at this point:
my $category = # ... chose some how
$categoryForPid{$pid} will be non-existent in the handler. Etc. Ie, yes you have to synchronize.

just can't get perl working as expected ( conditionals and variable declaring )

EDIT:
I will try a better explication this time, this is the exact code from my script (sorry for all them coments, they are a result of your sugestions, and apear in the video below).
#use warnings;
#use Data::Dumper;
open(my $tmp_file, ">>", "/tmp/some_bad.log") or die "Can not open log file: $!\n";
#if( $id_client != "")
#allowed_locations = ();
#print $tmp_file "Before the if: ". Data::Dumper->Dump([\#allowed_locations, $id_client]) . "";
if( $id_client )
{
# print $tmp_file "Start the if: ". Data::Dumper->Dump([\#allowed_locations, $id_client]) . "";
# my $q = "select distinct id_location from locations inner join address using (id_db5_address) inner join zona_rural_detaliat using (id_city) where id_client=$id_client";
# my $st = &sql_special_transaction($sql_local_host, $sql_local_database, $sql_local_root, $sql_local_root_password, $q);
# print $tmp_file "Before the while loop: ref(st)='". ref($st) . "\n";
# while((my $id)=$st->fetchrow())
# {
# print $tmp_file "Row the while loop: ". Data::Dumper->Dump([$id]) . "";
# my $id = 12121212;
# push(#allowed_locations, $id);
# }
# print $tmp_file "After the while loop: ref(st)='". ref($st) . "\n";
# my($a) = 1;
#} else {
# my($a) = 0;
}
#print $tmp_file "After the if: ". Data::Dumper->Dump([\#allowed_locations, $id_client]) . "";
close($tmp_file) or die "Can not close file: $!\n";
#&html_error(#allowed_locations);
First off all, somebody said that I should try to run it in command line, the script works fine in command line (no warnings, It was uncommented then), but when triyng to load in via apache in the browser it fails, please see this video where I captured the script behavior, what I tried to show in the video:
I have opened 2 tabs the first doesn't define the variable $id_client, the second defines the variable $id_client that is read from GET: ?id_client=36124 => $id_client = 36124; , both of them include the library in the video "locallib.pl"
When running the script with all the
new code commented the page loads
when uncoment the line that defines
the #allowed_locations = (); the
script fails
leave this definition and uncoment
the if block, and the definition of
my $a; in the if block; Now the script works fine when $id_client is
defined, but fails when $id_client
is not defined
Uncoment the else block and the
definition of my $a; in the else
block. Now the script works fine
with or without $id_client
now comment all the my $a;
definisions and comment the else
block, the script fails
but if I'm using open() to open
a file before the IF, and
close() to close it after the if it does't fail even if the IF block
is empty and event if there is no
else block
I have replicated all the steps when running the script in the command line, and the script worked after each step.
I know it sounds like something that cannot be the behavior of the script, but please watch the video (2 minutes), maybe you will notice something that I'm doing wrong there.
Using perl version:
[root#db]# perl -v
This is perl, v5.8.6 built for i386-linux-thread-mult
Somebody asked if I don't have a test server, answer: NO, my company has a production server that has multiple purposes, not only the web interface, and I cannot risk to update the kernel or the perl version, and cannot risk instaling any debuger, as the company owners say: "If it works, leave it alone", and for them the solution with my ($a); is perfect beacause it works, I'm asking here just for me, to learn more about perl, and to understand what is going wrong and what can I do better next time.
Thank you.
P.S. hope this new approach will restore some of my -1 :)
EDIT:
I had success starting the error logging, and found this in the error log after each step that resulted in a failure I got this messages:
[Thu Jul 15 14:29:19 2010] [error] locallib.pl did not return a true value at /var/www/html/rdsdb4/cgi-bin/clients/quicksearch.cgi line 2.
[Thu Jul 15 14:29:19 2010] [error] Premature end of script headers: quicksearch.cgi
What I found is that this code is at the end of the main code in the locallib.pl after this there are sub definitions, and locallib.pl is a library not a program file, so it's last statement must returns true. , a simple 1; statement at the end of the library ensures that (I put it after sub definitions to ensure that noobody writes code in the main after the 1;) and the problem was fixed.
Don't know why in CLI it had no problem ...
Maybe I will get a lot of down votes now ( be gentle :) ) , but what can I do ...and I hope that some newbies will read this and learn something from my mistake.
Thank you all for your help.
You need to explicitly check for definedness.
If you want to enter the loop when $client is defined,
use if ( defined $client ).
If you want to enter the loop when $client is defined and a valid integer,
use if ( defined $client && $client =~ /^-?\d+$/ ).
I assume it's an integer from the context, if it can be a float, the regex needs to be enhanced - there's a standard Perl library containing pre-canned regexes, including ones to match floats. If you require a non-negative int, drop -? from regex's start.
If you want to enter the loop when $client is defined and a non-zero (and assuming it shouldn't ever be an empty string),
use if ( $client ).
If you want to enter the loop when $client is defined and a valid non-zero int,
use if ( $client && $client =~ /^-?\d+$/ ).
Your #ids is "undef" when if condition is false, which may break the code later on if it relies on #ids being an array. Since you didn't actually specify how the script breaks without an else, this is the most likely cause.
Please see if this version works (use whichever "if" condition from above you need, I picked the last one as it appears to match the closest witrh the original code's intent - only enter for non-zero integers):
UPDATED CODE WITH DEBUGGING
use Data::Dumper;
open(my $tmp_file, ">", "/tmp/some_bad.log") or die "Can not open log file: $!\n";
#ids = (); # Do this first so #ids is always an array, even for non-client!
print $tmp_file "Before the if: ". Data::Dumper->Dump([\#ids, $client]) . "\n";
if ( $client && $client =~ /^-?\d+$/ ) # First expression catches undef and zero
{
print $tmp_file "Start the if: ". Data::Dumper->Dump([\#ids, $client]) . "\n";
my $st = &sql_query("select id from table where client=$client");
print $tmp_file "Before the while loop: ref(st)='". ref($st) . "'\n";
while(my $row = $st->fetchrow())
{
print $tmp_file "Row the while loop: ". Data::Dumper->Dump([row]) . "'\n";
push(#ids, $row->[0]);
}
print $tmp_file "After the while loop: ref(st)='". ref($st) . "'\n";
# No need to undef since both variables are lexically in this block only
}
print $tmp_file "After the if\n";
close($tmp_file) or die "Can not close file: $!\n";
when checking against a string, == and != should be respectively 'eq' or 'ne'
if( $client != "" )
should be
if( $client ne "" )
Otherwise you don't get what you're expecting to get.
Always begin your script with :
use warnings;
use strict;
these will give you usefull informations.
Then you could write :
my #ids;
if (defined $client) {
#ids = (); # not necessary if you run this part only once
my $st = sql_query("select id from table where client=$client");
while( my ($id) = $st->fetchrow ) {
push #ids, $id;
}
} else {
warn '$client not defined';
}
if (#ids) { # Your query returned something
# do stuff with #ids
} else {
warn "client '$client' does not exist in database";
}
Note: this answer was deleted because I consider that this is not a real question. I am undeleting it to save other people repeating this.
Instead of
if( $client != "" )
try
if ($client)
Also, Perl debugging is easier if you
use warnings;
use strict;
What I found is that this code is at the end of the main code in the locallib.pl after this there are sub definitions, and locallib.pl is a library not a program file, so it's last statement must returns true, a simple 1; statement at the end of the library ensures that (put it after sub definitions to ensure that noobody writes code in the main after the 1;) and the problem was fixed.
The conclusion:
I have learned that every time you write a library or modify one, ensure that it's last statment returns true;
Oh my... Try this as an example instead...
# Move the logic into a subroutine
# Forward definition so perl knows func exists
sub getClientIds($);
# Call subroutine to find id's - defined later.
my #ids_from_database = &getClientIds("Joe Smith");
# If sub returned an empty list () then variable will be false.
# Otherwise, print each ID we found.
if (#ids_from_database) {
foreach my $i (#ids_from_database) {
print "Found ID $i \n";
}
} else {
print "Found nothing! \n";
}
# This is the end of the "main" code - now we define the logic.
# Here's the real work
sub getClientIds($) {
my $client = shift #_; # assign first parameter to var $client
my #ids = (); # what we will return
# ensure we weren't called with &getClientIds("") or something...
if (not $client) {
print "I really need you to give me a parameter...\n";
return #ids;
}
# I'm assuming the query is string based, so probably need to put it
# inside \"quotes\"
my $st = &sql_query("select id from table where client=\"$client\"");
# Did sql_query() fail?
if (not $st) {
print "Oops someone made a problem in the SQL...\n";
return #ids;
}
my #result;
# Returns a list, so putting it in a list and then pulling the first element
# in two steps instead of one.
while (#result = $st->fetchrow()) {
push #ids, $result[0];
}
# Always a good idea to clean up once you're done.
$st->finish();
return #ids;
}
To your specific questions:
If you want to test if $client is defined, you want "if ( eval { defined $client; } )", but that's almost certainly NOT what you're looking for! It's far easier to ensure $client has some definition early in the program (e.g. $client = "";). Also note Kaklon's answer about the difference between ne and !=
if (X) { stuff } else { } is not valid perl. You could do: if (X) { stuff } else { 1; } but that's kind of begging the question, because the real issue is the test of the variable, not an else clause.
Sorry, no clue on that - I think the problem's elsewhere.
I also echo Kinopiko in recommending you add "use strict;" at the start of your program. That means that any $variable #that %you use has to be pre-defined as "my $varable; my #that; my %you;" It may seem like more work, but it's less work than trying to deal with undefined versus defined variables in code. It's a good habit to get into.
Note that my variables only live within the squiggliez in which they are defined (there's implicit squiggliez around the whole file:
my $x = 1;
if ($x == 1)
{
my $x = 2;
print "$x \n"; # prints 2. This is NOT the same $x as was set to 1 above.
}
print "$x \n"; # prints 1, because the $x in the squiggliez is gone.