Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

Problems with forking

by mraspberry (Initiate)
on Apr 02, 2011 at 01:16 UTC ( [id://897037] : perlquestion . print w/replies, xml ) Need Help??

mraspberry has asked for the wisdom of the Perl Monks concerning the following question:

Hello monks, any help with a vexing issue I am having would be appreciated. I'm trying to write a program that will basically act as a daemon (no networking component, just run continuously disconnected from a shell). I'm not too familiar with forking though nor have I ever written anything like this in any other language. So I decided to write a short program to work out this issues I've been having with it but I can't get that to do what I want either. I'm using perl 5.10.1. The logic I am using to create the daemon is as follows: !) Fork 2) close the parent 3) fork the child 4) close the child and run your code in the grandchild Here is the code I'm having trouble with:

#!/usr/bin/env perl use strict; my $pid = fork(); if ($pid == 0){ # child print "Testing daemon\n"; my $child = fork(); if ($child == 0) { # grandchild open TEST, ">", "$ENV{HOME}/daemon.test" or exit 2; my $i = 0; while ($i < 10){ print TEST "Alive\n"; sleep 5; } close TEST; exit 0; } print "Exiting child\n"; print "Grandchild PID is $child\n"; exit 0; } # parent print "Parent process is $$: Child is $pid\n"; print "Exiting Parent\n"; exit 0;

So everything runs fine until it gets to the grandchild. For some reason it doesn't seem to be doing anything after opening the filehandle (I'm used to checking for filehandle open errors with die but I wasn't sure what would happen if a message from a grandchild process no longer connected to a parent or grandparent got printed to STDERR. Anyway, the message never gets printed to the daemon.test file nor does the grandchild ever exit. What am I missing?

Replies are listed 'Best First'.
Re: Problems with forking
by Argel (Prior) on Apr 02, 2011 at 01:35 UTC
    Update: You do realize you are never incrementing $i in the while loop, making it an infinite while loop? And maybe the writes to the file are being buffered so you do not see anything right away. How long have you left it running?

    Here is a short subroutine I like to use that is based on what Stein (CGI.pm) recommends in "Network Programming with Perl". As you can see, there are several additional things you should be doing for your script to be a proper daemon. I have seen forking multiple times before, but I do not think that is actually necessary. It's probably a more expensive, less elegant way to e.g. help disassociate from the shell. Though if you want to you could also call daemonize() more than once.

    use IO::Socket; use POSIX qw(WNOHANG setsid); sub daemonize { $SIG{CHLD} = 'IGNORE'; # Configure to autoreap zombies die "Can't fork" unless defined ( my $child = fork ); # FORK +<<<<<<<<<<<< CORE::exit(0) if $child; # Parent exits setsid(); # Become session leader open( STDIN, "</dev/null" ); # Detach STDIN from shell open( STDOUT, ">/dev/null" ); # Detach STDOUT from shell open( STDERR, ">&STDOUT" ); # Detach STDERR from shell chdir '/tmp'; # Change working directory umask(0); # Reset umask $ENV{PATH} = '/bin:/sbin:/usr/sbin'; # Reset PATH }
    See also Re: Persistent perl.

    Elda Taluta; Sarks Sark; Ark Arks

      Thanks, wow I'm dumb, I wrote that test very fast and apparently was more tired than I thought I was. Can't believe I missed the fact that I wasn't incrementing that counter. I like the suggestion on the proper way to daemonize. Thanks for the help.

Re: Problems with forking
by afoken (Chancellor) on Apr 02, 2011 at 08:51 UTC

    Since I discovered daemontools, I no longer write code to do all that typical daemonize stuff. All I write is an ordinary "foreground" program. The daemontools take care of the rest: Logging, starting, stopping, restarting, "backgrounding". With daemontools, a simple-and-stupid daemon needs less than 10 lines shell code, including logging, start-stop-restart, and everything. (See also my various daemontools postings listed in afoken)

    Alexander

    --
    Today I will gladly share my knowledge and experience, for there are no sweeter words than "I told you so". ;-)

      Didn't know that one. Thanks.

      Personally, i use the ActiveState development kit. Especially on windows, it takes out a lot of hassle when writing services and tray applets.

      For my Maplat project, i wrote my own service start/stop/watchdog thingy. This is still only in my DarkPAN repository.

      ...what the hell. i'm just gonna release it right here (i just copy it from my repo, you may/will have to tweak it to your needs). One caution, though: You need a running memcached as well as the Maplat Framework installed.

      Here's the main program:

      #!/usr/bin/perl -w # MAPLAT (C) 2008-2009 Rene Schickbauer # Developed under Artistic license # for Magna Powertrain Ilz use 5.010; use strict; use warnings; BEGIN { unshift @INC, "/home/cavac/src/maplat_prodit/server"; unshift @INC, "/home/cavac/src/maplat_prodit/lib"; unshift @INC, "/home/cavac/src/maplat_logging/lib"; unshift @INC, "/home/cavac/src/maplat_framework/lib"; } use MaplatSVCLinux; use XML::Simple; use Maplat::Helpers::Logo; our $APPNAME = "Maplat SVC"; our $VERSION = 0.995; MaplatLogo($APPNAME, $VERSION); our $isCompiled = 0; if(defined($PerlApp::VERSION)) { $isCompiled = 1; } our $cycleStartTime = 0; # ------------------------------------------ # MAPLAT - Service/Daemon for Linux # ------------------------------------------ my $action = shift @ARGV; if(($action ne "start" && $action ne "stop" && $action ne "reset")) { print "ARGV: " . $#ARGV . "\n"; print("Usage:\n\tmaplat_svc_linux.pl [start|stop|reset] config.xml +\n"); exit(1); } my $configfile = shift @ARGV; print "Loading config file $configfile\n"; my $config = XMLin($configfile, ForceArray => ['module', 'run'],); if(defined($config->{basedir})) { print "Changing dir to " . $config->{basedir} . "\n"; chdir $config->{basedir}; } my @modlist = @{$config->{module}}; my $svcserver = new MaplatSVCLinux(0, $config->{basedir}, $config->{memhserver}, $config->{memhnamespace}, $APPNAME, $VERSION, $isCompiled, ); if($action eq "stop") { my $status = $svcserver->getServerStatus(); if($status eq "stopping") { print "STOP already requested\n"; exit(0); } elsif($status eq "stopped") { print "Service not running\n"; exit(0); } $svcserver->requestStop(); print "STOP requested\n"; while(1) { $status = $svcserver->getServerStatus(); last if($status eq "stopped"); print "Waiting for service to stop...\n"; sleep(1); } print "Service shut down.\n"; exit(0); } if($action eq "reset") { print "'Manually' resetting service status fields...\n"; #$svcserver->requestStop(); $svcserver->setServerStatus("stopped"); sleep(5); my $status = $svcserver->getServerStatus(); if($status eq "stopped") { print "Reset seems to have worked.\n"; } else { print "Failed: Got back status '$status'\n"; } exit(0); } # Configure run-once scripts $svcserver->setServerStatus("starting"); if(defined($config->{startup}->{run})) { foreach my $script (@{$config->{startup}->{run}}) { $svcserver->configure_startup($script); } } if(defined($config->{shutdown}->{run})) { foreach my $script (@{$config->{shutdown}->{run}}) { $svcserver->configure_shutdown($script); } } foreach my $module (@modlist) { $svcserver->configure_module($module); } $svcserver->endconfig(); $svcserver->setServerStatus("running"); my $loopcount = 0; while (!$svcserver->shouldStop()) { my $workCount = $svcserver->work(); sleep(1); # Just in case - set our status to running as long as the main loo +p # runs. This helps prevent some troubles $svcserver->setServerStatus("running"); $loopcount++; if($loopcount == 100) { print "...ping...\n"; $loopcount = 0; } } $svcserver->setServerStatus("stopping"); $svcserver->shutdown; $svcserver->setServerStatus("stopped");

      And the package that does the actual work:

      package MaplatSVCLinux; use strict; use warnings; use Maplat::Helpers::Cache::Memcached; use Maplat::Helpers::BuildNum; use Unix::PID; sub new { my ($class, $isService, $basePath, $memhserver, $memhnamespace, $APPNAME, $VERSION, $isCompiled) = @_; my $self = bless {}, $class; $self->{isService} = $isService; $basePath =~ s/\//\\/g; # Convert to Win32 Path $self->{basePath} = $basePath; if($memhserver ne "none") { my $memd; my $memd_loaded = 0; # Decide which Memcached module we want to use # First, we try the festest one, then the standard # one and if everything fails we use our own if(eval('require Cache::Memcached::Fast')) { print " Cache::Memcached::Fast available.\n"; $memd = new Cache::Memcached::Fast { servers => [ $memhserver ], namespace => $memhnamespace . "::", connect_timeout => 0, }; $memd_loaded = 1; } elsif(eval('require Cache::Memcached')) { print " No Cache::Memcached::Fast ... falling back to C +ache::Memcached\n"; $memd = new Cache::Memcached { servers => [ $memhserver ], namespace => $memhnamespace . "::", connect_timeout => 0, }; $memd_loaded = 1; } else { print " No Cache::Memcached* available ... will try to +use MaplatHelpers::Cache::Memcached\n"; } # Check if the selected Memcached lib is working correctly my $key = "test_" . int(rand(10000)) . "_" . int(rand(10000)); my $val = "test_" . int(rand(10000)) . "_" . int(rand(10000)); my $newval; if($memd_loaded) { $memd->set($key, $val); $newval = $memd->get($key); } if(!defined($newval) || $newval ne $val) { if($memd_loaded) { print " Selected Memcached client lib is broken - f +alling back to MaplatHelpers::Cache::Memcached\n"; } $memd = new MaplatHelpers::Cache::Memcached { servers => [ $memhserver ], namespace => $memhnamespace . "::", connect_timeout => 0, }; $memd->set($key, $val); $newval = $memd->get($key); if(!defined($newval) || $newval ne $val) { die("Maplat Memcached client lib is also broken - givi +ng up!"); } else { $memd->delete($key); } } else { $memd->delete($key); } print " Selected Memcached library seems to be working. Goo +d!\n"; $self->{memd} = $memd; $self->memhset("VERSION::" . $APPNAME, $VERSION); $self->memhset("BUILD::" . $APPNAME, readBuildNum(undef, $isCo +mpiled)); $self->memhdelete("StopSVC"); $self->{is_configured} = 0; } return $self; } sub requestStop { my ($self) = @_; my $tmp = 1; $self->memhset("StopSVC", $tmp); } sub shouldStop { my ($self) = @_; my $stop = $self->memhget("StopSVC"); if(!defined($stop) || $stop != 1){ return 0; } else { return 1; } } sub setServerStatus { my ($self, $status) = @_; $self->memhset("SVCRunningStatus", $status); } sub getServerStatus { my ($self) = @_; my $status = $self->memhget("SVCRunningStatus"); if(!defined($status)){ return "stopped"; } else { return $status; } } sub startconfig { my ($self) = @_; $self->{apps} = (); $self->{startup_scripts} = (); $self->{shutdown_scripts} = (); } sub configure_module { my ($self, $module) = @_; print "Configuring module " . $module->{description} . "...\n"; $module->{handle} = undef; my $fullapp = $module->{app}; $module->{app} = $fullapp; my $fullconf = $module->{conf}; $module->{conf} = $fullconf; push @{$self->{apps}}, $module; } sub configure_startup { my ($self, $command) = @_; $command =~ s/\//\\/g; push @{$self->{startup_scripts}}, $command; } sub configure_shutdown { my ($self, $command) = @_; $command =~ s/\//\\/g; push @{$self->{shutdown_scripts}}, $command; } sub endconfig { my ($self) = @_; # "Don't fear the Reaper" $SIG{CHLD} = 'IGNORE'; foreach my $script (@{$self->{startup_scripts}}) { $self->run_script($script); } print "Startup scripts complete\n"; foreach my $app (@{$self->{apps}}) { $self->start_app($app); } print "Initial apps startup complete\n"; $self->{shutdown_complete} = 0; $self->{is_configured} = 1; } sub work { my ($self) = @_; my $workCount = 0; foreach my $app (@{$self->{apps}}) { if(!$self->check_app($app)) { print "*** App " . $app->{description} . " FAILED! ***\n" } $workCount++; } return $workCount; } sub shutdown { my ($self) = @_; if($self->{is_configured} == 1) { print "Shutdown started.\n"; foreach my $app (@{$self->{apps}}) { $self->stop_app($app); } print "Apps shut down.\n"; foreach my $script (@{$self->{shutdown_scripts}}) { $self->run_script($script); } print "Shutdown scripts complete\n"; } $self->{shutdown_complete} = 1; return; } sub DESTROY { my ($self) = @_; if(!$self->{shutdown_complete}) { $self->shutdown(); } } sub check_app { my ($self, $app) = @_; if(!defined($app->{handle})) { return $self->start_app($app); } my $checker = Unix::PID->new(); # First, check if the process exited if(!$checker->is_pid_running($app->{handle})) { # Process exited, so, restart print "Process exit detected: " . $app->{description} . "!n"; return $self->start_app($app); } if(!defined($app->{lifetick}) || $app->{lifetick} == 0) { return 1; } else { # Process itself is still running, so check its lifetick # to see if it hangs my $pid = $app->{handle}; my $apptick = $self->memhget("LIFETICK::" . $pid); if(defined(!$apptick)) { #print "Apptick not set for " . $app->{description} . "!\n +"; return 1; } elsif($apptick == 0) { # Client requested a temporary suspension of lifetick hand +ling return 1; } my $tickage = time - $apptick; if($tickage > $app->{lifetick}) { # Stale lifetick print "Stale Lifetick detected: " . $app->{description} . +"!\n"; $self->stop_app($app); return $self->start_app($app); } else { return 1; } } } sub start_app { my ($self, $app) = @_; my $pid = fork(); if($pid) { #parent print "Forked " . $app->{app} . " has PID $pid\n"; $app->{handle} = $pid; my $stime = time; $self->memhset("LIFETICK::" . $pid, $stime); } else { # Child exec($app->{app} . " " . $app->{conf}) or die("Can't exec"); print "Child done\n"; exit(0); } } sub stop_app { my ($self, $app) = @_; if(defined($app->{handle}) && $app->{handle}) { my $pid = $app->{handle}; print "Killing app " . $app->{description} . " with PID $pid.. +.\n"; kill 15, $pid; # SIGTERM sleep(2); kill 9, $pid; #SIGKILL $app->{handle} = undef; print "...killed.\n"; $self->memhdelete("LIFETICK::" . $pid); } else { print "App " . $app->{description} . " already killed\n"; } } sub run_script { my ($self, $command) = @_; print "Running command '$command':\n"; my @lines = `$command`; foreach my $line (@lines) { chomp $line; print ":: $line\n"; } return 1; } sub memhget { my ($self, $key) = @_; return if(!defined($self->{memd})); $key = $self->memhsanitize_key($key); return $self->{memd}->get($key); } sub memhset { my ($self, $key, $data) = @_; return if(!defined($self->{memd})); $key = $self->memhsanitize_key($key); return $self->{memd}->set($key, $data); } sub memhdelete { my ($self, $key) = @_; return if(!defined($self->{memd})); $key = $self->memhsanitize_key($key); return $self->{memd}->delete($key); } sub memhsanitize_key { my ($self, $key) = @_; # Certain chars are not allowed in keys for whatever reason. # This *should* be handled by the Cache::Memcached module, but isn +'t # We handle this by substituting them with a tripple underline $key =~ s/\ /___/go; return $key; } 1;

      All configuration is done in a simple XML file (which is why i use XML::Simple... harhar):

      <maplatsvc> <basedir>/home/cavac/src/maplat_prodit/server</basedir> <memhserver>127.0.0.1:11211</memhserver> <memhnamespace>RBSMem</memhnamespace> <!-- <startup> <run>start.sh</run> </startup> <shutdown> <run>shut.sh</run> <run>shut.sh</run> </shutdown> --> <module> <description>WebGui</description> <app>perl webgui_cmd.pl</app> <conf>configs/rbswebgui.xml</conf> <lifetick>0</lifetick> </module> <module> <description>WebGuiSSL</description> <app>perl webgui_cmd.pl</app> <conf>configs/rbswebgui_ssl.xml</conf> <lifetick>0</lifetick> </module> <module> <description>RBS Worker</description> <app>perl worker_cmd.pl</app> <conf>configs/rbsworker.xml</conf> <lifetick>120</lifetick> </module> <module> <description>Uncritical Worker</description> <app>perl worker_cmd.pl</app> <conf>configs/uncriticalworker.xml</conf> <lifetick>600</lifetick> </module> <module> <description>TimeServer</description> <app>perl timeserver_cmd.pl</app> <conf></conf> <lifetick>60</lifetick> </module> </maplatsvc>

      The svc program does not detach itself from the command line, here's a sample script to start all services. Most of it's work is to set the correct path for my perl interpreter.

      #!/bin/bash # ActiveState Perl export PATH=/home/cavac/bin/ActivePerl-5.12/site/bin:/home/cavac/bin/A +ctivePerl-5.12/bin:$PATH export MANPATH=/home/cavac/bin/ActivePerl-5.12/site/man:/home/cavac/bi +n/ActivePerl-5.12/man:$MANPATH # ActiveState PDK export PATH=/home/cavac/bin/PDK/bin:$PATH export MANPATH=/home/cavac/bin/PDK/share/man:$MANPATH # ActiveState Komodo export PATH=/home/cavac/bin/Komodo-5/bin:$PATH cd /home/cavac/src/maplat_prodit/server perl maplat_svc_linux.pl start configs/rbssvc.xml &>/dev/null & echo MAPLAT Background startup initiated...

      When you don't want to background (like in this example, when we stop all services), just neither redirect nor use '&':

      #!/bin/bash # ActiveState Perl export PATH=/home/cavac/bin/ActivePerl-5.12/site/bin:/home/cavac/bin/A +ctivePerl-5.12/bin:$PATH export MANPATH=/home/cavac/bin/ActivePerl-5.12/site/man:/home/cavac/bi +n/ActivePerl-5.12/man:$MANPATH # ActiveState PDK export PATH=/home/cavac/bin/PDK/bin:$PATH export MANPATH=/home/cavac/bin/PDK/share/man:$MANPATH # ActiveState Komodo export PATH=/home/cavac/bin/Komodo-5/bin:$PATH cd /home/cavac/src/maplat_prodit/server perl maplat_svc_linux.pl stop configs/rbssvc.xml

      Sorry, this scripts are currently not really documented. If there is a problem, just contact me here on PerlMonks. But so far, the code worked over 2 years without a hitch.

        use lib "/home/cavac/src/maplat_prodit/server" , "/home/cavac/src/maplat_prodit/lib" , "/home/cavac/src/maplat_logging/lib" , "/home/cavac/src/maplat_framework/lib" ;
        See lib