I'm using some idioms from Lincoln Stein's fine Network Programming With Perl book to write a server. I seem to be getting weird behaviors for a variable that is declared prior to a fork and referenced afterwards.
Here is a complete program illustrating the problem. (I apologize for its not being more stripped-down; when I stripped out all the stuff I thought was irrelevant, the problem went away.) If you look for ##### MYSTERY ##### you'll see two versions of the declaration my $pid. One version works, while the other doesn't. Following the call to become_daemon(), which assigns the child PID to $pid, I attempt to write it to a PID file, and then verify that this worked. Depending on which method of declaring it I used, it either succeeds or it fails. I don't get it!
#!/usr/bin/perl
#
# Prototype contactd master server
use warnings;
use strict;
use Carp;
use Getopt::Std;
use File::Basename;
use IO::Socket;
use IO::File;
use Net::hostent; # for OO version of gethostbyaddr
use POSIX qw{WNOHANG setsid};
use Data::Dumper;
#use 5.010;
sub say { print "#_\n"; }
my $program = basename $0;
my $default_config = "$program.config";
$| = 1; # flush STDOUT buffer regularly
my %opts;
my $config_file = $opts{c} || $default_config;
# Process the config file to obtain default settings
#
# Note: for now we'll hard code config values into the config hash.
#
my %config;
$config{PORT} = 2000;
$config{DAEMONIZE} = 0;
$config{VERBOSE} = 0;
$config{LOGDIR} = "/mxhome/charrison/private/wdi/logs";
$config{PIDFILE} = "/var/tmp/$program.pid";
# Process command line args to override default settings
#
my $server_port = $opts{p} || $config{PORT};
my $log_dir = $opts{l} || $config{LOGDIR};
my $verbose = !!( exists $opts{v} || $config{VERBOSE} );
my $daemonize = !!( exists $opts{d} || $config{DAEMONIZE} );
my $pid_file = $opts{P} || $config{PIDFILE};
################################################################################
# Set up signal handlers
#
# Caution: these call the logging manager servlog(), which has not yet been
# spawned.
################################################################################
# Set up a child-reaping subroutine for SIGCHLD
#
$SIG{CHLD} = sub {
local ( $!, $^E, $# );
while ( ( my $kid = waitpid( -1, WNOHANG ) ) > 0 ) {
}
};
# Set up a signal handler for interrupts
#
my $quit = 0;
$SIG{INT} = sub {
$quit++;
};
# Set up signal handler for pipe errors
#
$SIG{PIPE} = sub {
local ( $!, $^E, $# );
};
################################################################################
# DAEMONIZATION OCCURS HERE
################################################################################
my $pid_fh = open_pid_file($pid_file);
##### MYSTERY #####
my $pid; # this makes it work
# my $pid = $$; # this breaks it!
$daemonize = 1; # inserted here for demo
if ($daemonize) {
say "Becoming a daemon and detaching from your terminal. Bye!";
$pid = become_daemon(); # update w/new pid
}
say "Here is pid: $pid. Going to write it to $pid_file and close.";
# If we daemonized, then we are now executing with a different PID
#
# And in that case, the following fails silently!!
#
print $pid_fh $pid; # store our PID in known location in filesystem
close $pid_fh;
say "Boo boo" if !-e $pid_file;
say qx{cat $pid_file};
##### END OF DEMO #####
# open_pid_file()
#
# Courtesy of Network Programming with Perl, by Lincoln D. Stein
#
sub open_pid_file {
my $file = shift;
if ( -e $file ) { # PID file already exists
my $fh = IO::File->new($file) || return;
my $pid = <$fh>; # so read it and probe for the process
croak "Server already running with PID $pid\n" # die ...
if kill 0 => $pid; # if it responds
warn "Removing PID file for defunct server process $pid.";
croak "Can't unlink PID file $file" # die ...
unless -w $file && unlink $file; # if can't unlink
}
return IO::File->new( $file, O_WRONLY | O_CREAT | O_EXCL, 0644 )
or die "Can't create PID file $file: $!\n";
}
# become_daemon()
#
# Courtesy of Network Programming with Perl, by Lincoln D. Stein
#
sub become_daemon {
die "Can't fork" unless defined( my $child = fork );
exit 0 if $child != 0; # die here if parent
# --- PARENT PROCESS DIES
# --- CHILD PROCESS STARTS
setsid(); # Become session leader
open( STDIN, "</dev/null" );
# servlog() writes to STDOUT which is being piped to log manager
#
#open( STDOUT, ">/dev/null" );
open( STDERR, ">&STDOUT" );
chdir '/'; # go to root directory
umask(0); # ??
$ENV{PATH} = '/bin:/sbin:/use/bin:/usr/sbin';
return $$;
}
END {
unlink $pid_file if $pid == $$; # only the daemon unlinks pid file
}
At the end of your code, you have:
END {
unlink $pid_file if $pid == $$; # only the daemon unlinks pid file
}
This works fine if $pid is undefined in the parent process. But if you initialize it to the parent process's ID, then the parent will unlink the PID file as soon as become_daemon calls exit.
(It seems to me that there's a race here between the child writing the PID file and the parent unlinking it, so the outcome might not always be the same.)
Edit: Actually, there is no race, since the PID file is opened before the fork. So the parent process opens the file, forks the child, unlinks the file and exits. The child still has a handle on the file and it can still write to it, but the file is no longer linked from anywhere in the filesystem, and it will disappear as soon as the child process exits.
Related
I run a while(1) loop in perl to pull out email addresses and each one's configuration values from PostgreSQL tables.
Right now, I write a temporary file and use neomutt -nF the_temp_file with system.
Then I unlink the file. Neomutt quits.
Then the loop gives me the list of email addresses to start neomutt again with any one of those addresses I select.
I haven't asked this question yet on the neomutt mailing list, but I will.
I would like to know in general if there is a way to imitate the temporary file without writing one into the file system.
To be more clear:
Get the config values, like:
set beep = 0
set beep_new = 0
set bounce = ask-yes
set check_mbox_size = 1
set check_new = 1
and send that directly to the spot neomutt expects a file at neomutt -F config_file
Is this possible?
Thanks
It still involves a temporary file, but if you're using an OS like Linux that has a /dev/fd filesystem, you can open a temporary file, immediately delete it to keep things tidy, and pass /dev/fd/N as the filename to neomutt, where N is the underlying file descriptor number of the perl file handle. If you use the core File::Temp module to create the temporary file, it can be done securely without potential race conditions or having to manually delete the file.
There is a bit of drudgery in stopping the descriptor from being closed before system executes the child program, though.
Example:
#!/usr/bin/env perl
use strict;
use warnings;
use File::Temp qw/tempfile/;
use Fcntl qw/:DEFAULT/;
# Get a handle to an anonymous temporary file
my $fh = tempfile;
print $fh <<EOF;
set beep = 0
set beep_new = 0
set bounce = ask-yes
set check_mbox_size = 1
set check_new = 1
EOF
flush $fh;
# Clear the CLOEXEC bit so the descriptor is available to the program run
# by system
my $flags = fcntl $fh, F_GETFD, 0
or die "Unable to get descriptor flags: $!";
fcntl $fh, F_SETFD, $flags & ~FD_CLOEXEC
or die "Unable to set descriptor flags: $!";
my $fd = fileno $fh;
system("cat", "/dev/fd/$fd");
An alternative that completely avoids temporary files (but is a bit more complicated) is to open up a pipe, and fork off a child that writes the data to it, and again using the /dev/fd/N interface with neomutt:
#!/usr/bin/env perl
use strict;
use warnings;
use Fcntl qw/:DEFAULT/;
pipe my $reader, my $writer or die "Unable to pipe: $!\n";
my $pid = fork;
die "Unable to fork" unless defined $pid;
if ($pid == 0) { # Child process
close $reader;
print $writer <<EOF;
set beep = 0
set beep_new = 0
set bounce = ask-yes
set check_mbox_size = 1
set check_new = 1
EOF
close $writer;
exit;
} else { # Parent process
close $writer;
# Clear the CLOEXEC bit so the descriptor is available to the program run
# by system
my $flags = fcntl $reader, F_GETFD, 0;
fcntl $reader, F_SETFD, $flags & ~FD_CLOEXEC;
my $fd = fileno $reader;
system("cat", "/dev/fd/$fd");
close $reader;
waitpid $pid, 0; # Reap the child process
}
I need to run my perl tests in parallel and capture STDOUT and STDERR in a separate file for each test file. I'm having no success even in capturing in one file. I've been all over SO and have had no luck. Here is where I started (I'll spare you all the variations). Any help is greatly appreciated. Thanks!
foreach my $file ( #files) {
next unless $file =~ /\.t$/;
print "\$file = $file\n";
$file =~ /^(\w+)\.\w+/;
my $file_pfx = $1;
my $this_test_file_name = $file_pfx . '.txt';
system("perl $test_dir\\$file > results\\$test_file_name.txt &") && die "cmd failed: $!\n";
}
Here is a simple example using Parallel::ForkManager to spawn separate processes.
In each process the STDOUT and STDERR streams are redirected, in two ways for a demo: STDOUT to a variable, that can then be passed around as desired (here dumped into a file), and STDERR directly to a file. Or use a library, with an example in a separate code snippet.
The numbers 1..6 represent batches of data that each child will pick from to process. Only three processes are started right away and then as one finishes another one is started in its place.† (Here they exit nearly immediately, the "jobs" being trivial.)
use warnings;
use strict;
use feature 'say';
use Carp qw(carp)
use Path::Tiny qw(path);
use Parallel::ForkManager;
my $pm = Parallel::ForkManager->new(3);
foreach my $data (1..6) {
$pm->start and next; # start a child process
proc_in_child($data); # code that runs in the child process
$pm->finish; # exit it
}
$pm->wait_all_children; # reap all child processes
say "\nParent $$ done\n";
sub proc_in_child {
my ($data) = #_;
say "Process $$ with data $data"; # still shows on terminal
# Will dump all that was printed to streams to these files
my (outfile, $errfile) =
map { "proc_data-${data}_" . $_ . ".$$.out" } qw(stdout stderr);
# Redirect streams
# One way to do it, redirect to a variable (for STDOUT)...
open my $fh_stdout, ">", \my $so or carp "Can't open handle to variable: $!";
my $fh_STDOUT = select $fh_stdout;
# ...another way to do it, directly to a file (for any stream)
# (first 'dup' it so it can be restored if needed)
open my $SAVEERR, ">&STDERR" or carp "Can't dup STDERR: $!";
open *STDERR, ">", $errfile or carp "Can't redirect STDERR to $errfile: $!";
# Prints wind up in a variable (for STDOUT) and a file (for STDERR)
say "STDOUT: Child process with pid $$, processing data #$data";
warn "STDERR: Child process with pid $$, processing data #$data";
close $fh_stdout;
# If needed to restore (not in this example which exits right away)
select $fh_STDOUT;
open STDERR, '>&', $SAVEERR or carp "Can't reopen STDERR: $!";
# Dump all collected STDOUT to a file (or pass it around, it's a variable)
path( $outfile )->spew($so);
return 1
}
While STDOUT is redirected to a variable, STDERR cannot be redirected that way and here it goes directly to a file. See open. However there are ways to capture it in a variable as well.
Then you can use the module's ability to return from child processes to the parent, which can then handle those variables. See for example this post and this post and this post. (There's way more, these are merely the ones I know.) Or indeed just dump them to files, as done here.
Another way is to use modules that can run code and redirect output, like Capture::Tiny
use Capture::Tiny qw(capture);
sub proc_in_child {
my ($data) = #_;
say "Process $$ with data $data"; # on terminal
# Run code and capture all output
my ($stdout, $stderr, #results) = capture {
say "STDOUT: Child process $$, processing data #$data";
warn "STDERR: Child process $$, processing data #$data";
# return results perhaps...
1 .. 4;
}
# Do as needed with variables with collected STDOUT and STDERR
# Return to parent, or dump to file:
my ($outfile, $errfile) =
map { "proc_data-${data}_" . $_ . ".$$.out" } qw(stdout stderr);
path($outfile) -> spew( $stdout );
path($errfile) -> spew( $stderr );
return 1
}
† This keeps the same number of processes running. Or, one can set it up to wait for the whole batch to finish and then start another batch. For some details of operation see this post
I think, the easiest way is to use shell redirects in your 'system' command. BTW, spawning uncontrolled subprocesses from it with '&' makes me frown.
Here is a simple example of with shell redirects and fork.
#!/usr/bin/perl
use strict;
for my $i (0..2) {
my $stdoutName = "stdout$i.txt";
my $stderrName = "stderr$i.txt";
my $pid = fork();
if($pid == 0) {
system("perl mytest.pl 1>$stdoutName 2>$stderrName"); #redirects are here 1> (stdout) and 2> (stderr)
exit $?;
}
}
I have two code
1.
use File::Temp qw(tempfile);
$tmp = new File::Temp( UNLINK => 0 );
system("tv_grab_au | tv_sort >> $file");
system("cp $file $HOME/.xmltv/listings.xml");
unlink($file);
2.
while (-e $file) {
sleep 2;
system("tvtime-command DISPLAY_MESSAGE \'Updating TV Guide. Please wait this might take a several minutes...\'");
}
I would like to combine this 2 code to run tv_grab_au xmltv grabber (update TV Guide), and simultaneously, send command to tvtime for display message 'Updating TV Guide. Please wait this might take a several minutes...', every two seconds, until $file exist.
I try this one:
use strict;
use warnings;
use File::Temp qw(tempfile);
my $file = new File::Temp( UNLINK => 0 );
use POSIX qw(:sys_wait_h);
$|++;
defined(my $pid = fork) or die "Couldn't fork: $!";
if (!$pid) {
system("tv_grab_huro | tv_sort >> $file");
unlink($file);
}
else {
while (! waitpid($pid, WNOHANG)) {
system("tvtime-command DISPLAY_MESSAGE \'Updating TV Guide. Please wait this might take a several minutes...\'");
sleep 2;
}
}
Thanks.
The builtin fork function creates a copy of your current program in a new background process. The original process and the "child" process will then run at the same time. So you can do something like:
use File::Temp qw(tempfile);
my $file = new File::Temp( UNLINK => 0 );
my $new_pid = fork();
die "fork failed $!" unless defined $new_pid; # this is uncommon
# Task 1 - in the background
if ($new_pid == 0) {
system("tv_grab_au | tv_sort >> $file");
system("cp $file $HOME/.xmltv/listings.xml");
unlink($file);
exit; # don't forget this part!
}
# Task 2 - in the foreground
while (-e $file) {
print "...";
sleep 2;
}
Using $file as an indicator of when the first task has finished has some drawbacks. What if the child code has some runtime error? What if the child process gets interrupted? The child process could exit before it gets a chance to delete $file. Then your while loop in the parent process would never end.
The builtin waitpid command can check if a child process is still running, and can handle the case where the child terminates abnormally.
# Task 2
use POSIX ':sys_wait_h';
while (! waitpid $new_pid, &WNOHANG) { # WNOHANG => non-blocking wait
print "...";
sleep 2;
}
Use fork(). I've added extra sleep() calls so you can see that the processes both run and work. In practice, the crontab update will probably run fast enough that the monitor loop doesn't run at all, or only runs once. I used "unless(...)" because it seems to me to make the code clearer; the thing to remember is that fork() returns the pid to the parent, and zero to the child. The process that doesn't see the pid is therefore a subprocess. (As has been pointed out, if the fork fails, the fork will return undef, and the code will be executing in the original process. In our case, that will simply mean that the monitoring starts up after the writing finishes, so the only thing we lose is the monitoring.)
my $file = "/tmp/.$$.crontab.txt";
my $crontab = <<EOS;
# Crontab lines here. Inserted at #{[scalar localtime()]}
EOS
my ($writer_pid, $monitor_pid);
$|++;
# Open file BEFORE launching processes. The monitor depends on the file's
# presence or absence, so if we opened it in the writer process, there'd be a
# chance the monitor process would check before we created it, and exit without
# monitoring.
die "Cannot open temp file\n" unless open(WRITE, ">" . $file);
# Crontab file handle gets passed to the forked process, so we can just use it.
# Altered so we can see the process do its thing.
unless ($writer_pid = fork()) {
print WRITE $crontab."\n";
close WRITE;
print("crontab -l |grep -v backup >> $file");
sleep 20;
print("crontab $file");
sleep 10;
unlink($file);
print "done!\n";
exit;
}
# Either file will exist, or the previous process will
# have completed. If it exists, we monitor. If not,
# we exit immediately.
unless ($monitor_pid = fork()) {
# Child: monitor the writer.
my $waitcount = 1;
while ( -e $file ) {
sleep 2;
print "($waitcount) installing crontab...";
$waitcount++;
}
print "installed\n";
exit;
}
waitpid($monitor_pid, 0);
waitpid($writer_pid,0);
print "both processes done\n";
So when I run this code it seems to fork bomb the system can you guys help me out? All I want to do is start a thread for each one of the appWatch domains and enviroments.
#!/usr/bin/perl
#
#
# Starts the mass processes to watch each directory & enviroment.
#
#
#
###################################################################################
use strict;
use warnings;
use POSIX 'setsid';
setsid();
my #domains = (qw(austin batman luke heman drevil joker skeltor drevil goodguy badguy));
my #envs = (qw(qa dev));
foreach my $env (#envs){
foreach my $guy (#domains){
unless(my $pid = fork()){
system("echo $env.$guy");
system("sleep 10 ");
#system("./appWatch -d $guy -e $env");
open PID, ">>pid.lock";
print PID $$ . "\n";
print "$$ is Parent, $pid is child";
}
}
}
wait();
Your code should only create three children. If you are seeing a bunch of children being created then you are running different code (or the culprit is appWatch not your code). On a slightly unrelated note, there are a couple things you should probably be doing differently:
fork has three possible return values, not two
you must reap your children or set the system up to reap them for you
you should use exec instead of system if you don't want to return to the code
you should use the multiple argument version of system and exec instead of the one argument version if you don't want the shell to do stuff with the arguments.
Here is my version of your code:
$SIG{CHLD} = "IGNORE"; #auto-reap the children
my #domains = qw(domains);
my #envs = qw(enviromentA enviromentB);
for my $env (#envs){
for my $guy (#domains){
die "could not fork: $!" unless defined(my $pid = fork);
next if $pid;
exec "./appWatch", "-d", $guy, "-e", $env;
die "exec must have failed";
}
}
You updated version of the code shows what happened. Your child does not exit. Here is how I would write your code:
#!/usr/bin/perl
# Starts the mass processes to watch each directory & enviroment.
use strict;
use warnings;
use POSIX 'setsid';
setsid();
my #domains = qw(
austin batman luke heman
drevil joker skeltor drevil
goodguy badguy
);
my #envs = qw(qa dev);
my #pids;
for my $env (#envs){
for my $guy (#domains){
die "could not fork: $!" unless defined(my $pid = fork);
if ($pid) {
push #pids, $pid;
next;
}
print "$env.$guy\n";
sleep 10; #FIXME: I don't know if you really need this
#exec will replace the child process with appWatch
exec "./appWatch", "-d", $guy, "-e", $env;
die "exec failed for some reason";
}
}
for my $pid (#pids) {
waitpid $pid, 0;
}
With
$ cat appWatch
#! /usr/bin/perl -l
print "[", join("][" => #ARGV), "]";
running on
$ uname -a
Linux mybox 2.6.32-24-generic #39-Ubuntu SMP Wed Jul 28 05:14:15 UTC 2010 x86_64 GNU/Linux
I get no fork bomb, just an unexciting Cartesian product:
$ ./prog.pl
[-d][domains][-e][enviromentA]
[-d][domains][-e][enviromentB]
I am running the below code snippet on Windows. The server starts listening continuously after reading from client. I want to terminate this command after a time period.
If I use alarm() function call within main.pl, then it terminates the whole Perl program (here main.pl), so I called this system command by placing it in a separate Perl file
and calling this Perl file (alarm.pl) in the original Perl File using the system command.
But in this way I was unable to take the output of this system() call neither in the original Perl File nor in called one Perl File.
Could anybody please let me know the way to terminate a system() call or take the output in that way I used above?
main.pl
my #output = system("alarm.pl");
print"one iperf completed\n";
open FILE, ">display.txt" or die $!;
print FILE #output_1;
close FILE;
alarm.pl
alarm 30;
my #output_1 = readpipe("adb shell cd /data/app; ./iperf -u -s -p 5001");
open FILE, ">display.txt" or die $!;
print FILE #output_1;
close FILE;
In both ways display.txt is always empty.
There are a few separate issues here.
First, to keep the alarm from killing your script, you need to handle the ALRM signal. See the alarm documentation. You shouldn't need two scripts for this.
Second, system doesn't capture output. You need one of the backtick variants or a pipe if you want to do that. There are answers for that on Stackoverflow already.
Third, if alarm.pl puts anything in display.txt, you discard it in main.pl when you re-open the file in write mode. You only need to create the file in one place. When you get rid of the extra script, you won't have this problem.
I recently had some problems with alarm and system, but switching to IPC::System::Simple fixed that.
Good luck, :)
What the hell was I thinking? You don't need a background process for this task. You just need to follow the example in the perldoc -f alarm function and wrap your time-sensitive code in an eval block.
my $command = "adb shell cd /data/app; ./iperf -u -s -p 5001";
my #output;
eval {
local $SIG{ALRM} = sub { die "Timeout\n" };
alarm 30;
#output = `$command`;
alarm 0;
};
if ($#) {
warn "$command timed out.\n";
} else {
print "$command successful. Output was:\n", #output;
}
Inside the eval block, you can capture your output the regular way (with backticks or qx() or readpipe). Though if the call times out, there won't be any output.
If you don't need the output (or don't mind hacking some interprocess communication together), an almost idiot-proof alternative is to set the alarm and run the system call in a child process.
$command = "adb shell cd /data/app; ./iperf -u -s -p 5001";
if (($pid = fork()) == 0) {
# child process
$SIG{ALRM} = sub { die "Timeout\n" }; # handling SIGALRM in child is optional
alarm 30;
my $c = system($command);
alarm 0;
exit $c >> 8; # if you want to capture the exit status
}
# parent
waitpid $pid, 0;
waitpid will return when either the child's system command is finished, or when the child's alarm goes off and kills the child. $? will hold the exit code of the system call, or something else (142 on my system) for an unhandled SIGALRM or 255 if your SIGALRM handler calls die.
I run into a similar problem that requires:
run a system command and get its output
time out the system command after x seconds
kill the system command process and all child processes
After much reading about Perl IPC and manual fork & exec, I came out with this solution. It is implemented as a simulated 'backtick' subroutine.
use Error qw(:try);
$SIG{ALRM} = sub {
my $sig_name = shift;
die "Timeout by signal [$sig_name]\n";
};
# example
my $command = "vmstat 1 1000000";
my $output = backtick(
command => $command,
timeout => 60,
verbose => 0
);
sub backtick {
my %arg = (
command => undef,
timeout => 900,
verbose => 1,
#_,
);
my #output;
defined( my $pid = open( KID, "-|" ) )
or die "Can't fork: $!\n";
if ($pid) {
# parent
# print "parent: child pid [$pid]\n" if $arg{verbose};
try {
alarm( $arg{timeout} );
while (<KID>) {
chomp;
push #output, $_;
}
alarm(0);
}
catch Error with {
my $err = shift;
print $err->{-text} . "\n";
print "Killing child process [$pid] ...\n" if $arg{verbose};
kill -9, $pid;
print "Killed\n" if $arg{verbose};
alarm(0);
}
finally {};
}
else {
# child
# set the child process to be a group leader, so that
# kill -9 will kill it and all its descendents
setpgrp( 0, 0 );
# print "child: pid [$pid]\n" if $arg{verbose};
exec $arg{command};
exit;
}
wantarray ? #output : join( "\n", #output );
}
Might use "timeout -n " for wrapping your commands if thats already common on your system.