From a3468980d925a2f3fd8fc15e65b8db3cb92caa0e Mon Sep 17 00:00:00 2001
From: Slaven Rezic <slaven.rezic@idealo.de>
Date: Thu, 27 Feb 2014 15:08:41 +0100
Subject: [PATCH] Correct check for failed forks

Swapped the checks after a fork() call, so now
the check for defined() is done first, so a failed
fork() is trapped correctly.

Additionally, a failed fork() now causes a die() instead
of a warn() --- in this situation nothing works correctly,
so the do_start() call should fail.

This change has also a new test file, which simulates a
failed fork().
---
 lib/Daemon/Control.pm | 18 +++++++++---------
 t/05_fork_fail.t      | 40 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 49 insertions(+), 9 deletions(-)
 create mode 100644 t/05_fork_fail.t

diff --git a/lib/Daemon/Control.pm b/lib/Daemon/Control.pm
index 3723dea..4c105c0 100644
--- a/lib/Daemon/Control.pm
+++ b/lib/Daemon/Control.pm
@@ -188,10 +188,14 @@ sub _double_fork {
     my $pid = fork();
 
     $self->trace( "_double_fork()" );
-    if ( $pid == 0 ) { # Child, launch the process here.
+    if ( not defined $pid ) { # We couldn't fork.  =(
+        die "Cannot fork: $!";
+    } elsif ( $pid == 0 ) { # Child, launch the process here.
         setsid(); # Become the process leader.
         my $new_pid = fork();
-        if ( $new_pid == 0 ) { # Our double fork.
+        if ( not defined $new_pid ) {
+            die "Cannot fork: $!";
+        } elsif ( $new_pid == 0 ) { # Our double fork.
 
             if ( $self->gid ) {
                 setgid( $self->gid );
@@ -221,16 +225,12 @@ sub _double_fork {
             }
 
             $self->_launch_program;
-        } elsif ( not defined $new_pid ) {
-            warn "Cannot fork: $!";
         } else {
             $self->pid( $new_pid );
             $self->trace("Set PID => $new_pid" );
             $self->write_pid;
             _exit 0;
         }
-    } elsif ( not defined $pid ) { # We couldn't fork.  =(
-        warn "Cannot fork: $!";
     } else { # In the parent, $pid = child's PID, return it.
         waitpid( $pid, 0 );
     }
@@ -244,10 +244,10 @@ sub _fork {
     my $pid = fork();
 
     $self->trace( "_fork()" );
-    if ( $pid == 0 ) { # Child, launch the process here.
+    if ( not defined $pid ) {
+        die "Cannot fork: $!";
+    } elsif ( $pid == 0 ) { # Child, launch the process here.
         $self->_launch_program;
-    } elsif ( not defined $pid ) {
-        warn "Cannot fork: $!";
     } else { # In the parent, $pid = child's PID, return it.
         $self->pid( $pid );
         $self->trace("Set PID => $pid" );
diff --git a/t/05_fork_fail.t b/t/05_fork_fail.t
new file mode 100644
index 0000000..28fd418
--- /dev/null
+++ b/t/05_fork_fail.t
@@ -0,0 +1,40 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+
+use Errno qw(EAGAIN);
+use File::Temp qw(tempfile);
+use Test::More;
+
+# Simulate failing forks in the Daemon::Control package only
+BEGIN {
+    *CORE::GLOBAL::fork = sub {
+	if ((caller)[0] eq 'Daemon::Control') {
+	    $! = EAGAIN;
+	    undef;
+	} else {
+	    CORE::fork;
+	}
+    };
+}
+
+my(undef,$pidfile) = tempfile(SUFFIX => '_Daemon_Control.pid', UNLINK => 1);
+my(undef,$outfile) = tempfile(SUFFIX => '_Daemon_Control.txt', UNLINK => 1);
+unlink $outfile;
+
+use_ok 'Daemon::Control';
+
+eval {
+    Daemon::Control->new(
+        name => "failing_fork_test",
+        program => "/bin/sh",
+        program_args => ['-c', "echo this should not happen > $outfile"],
+        pid_file => $pidfile,
+        fork => 1,
+    )->run_command('start');
+};
+like $@, qr{Cannot fork};
+
+ok !-e $outfile, 'daemon was not called';
+
+done_testing;
-- 
1.8.3.4