0.0.2 2012-18-12 SymKat <symkat@symkat.com>

* Default fork mode changed to double.
    * Added show_warnings command instead of alerting
      about DWIM actions.
    * Fatal warnings changed from warn+exit to die (exits non-zero)
    * _fork handles undef/cannot fork.
    * $self->redirect_filehandles added
    * redirect_before_fork added (default 1)
    * With a code ref, $self is passed (can $control->redriect_filehandles)

changelog

@@ -1,2 +1,14 @@
-0.1.0 2012-02-12 SymKat <symkat@symkat.com>
+0.0.2 2012-18-12 SymKat <symkat@symkat.com>
+    * Default fork mode changed to double.
+    * Added show_warnings command instead of alerting
+      about DWIM actions.
+    * Fatal warnings changed from warn+exit to die (exits non-zero)
+    * _fork handles undef/cannot fork.
+    * $self->redirect_filehandles added
+    * redirect_before_fork added (default 1)
+    * With a code ref, $self is passed (can $control->redriect_filehandles)
+
+
+
+0.0.1 2012-02-12 SymKat <symkat@symkat.com>
     * Inital Commit

lib/Daemon/Control.pm

@@ -10,11 +10,16 @@ $VERSION = eval $VERSION;
 
 my @accessors = qw| pid color_map name code program program_args 
     uid path gid scan_name stdout_file stderr_file pid_file fork data 
-    lsb_start lsb_stop lsb_sdesc lsb_desc |;
+    lsb_start lsb_stop lsb_sdesc lsb_desc redirect_before_fork        |;
 
 sub new {
     my ( $class, $args ) = @_;
-    my $self = bless { _color_map => { red => 31, green => 32 } }, $class;
+    
+    # Create the object with defaults.
+    my $self = bless { 
+        _color_map => { red => 31, green => 32 }, 
+        _redirect_before_fork => 1,
+    }, $class;
 
     for my $accessor ( @accessors ) {
         if ( exists $args->{$accessor} ) {
@@ -27,6 +32,21 @@ sub new {
     return $self;
 }
 
+sub redirect_filehandles {
+    my ( $self ) = @_;
+
+    if ( $self->stdout_file ) {
+        my $file = $self->stdout_file;
+        open STDOUT, ">>", ( $file eq '/dev/null' ? File::Spec->devnull : $file )
+            or die "Failed to open STDOUT to " . $self->stdout_file , ": $!";
+    }
+    if ( $self->stderr_file ) {
+        my $file = $self->stderr_file;
+        open STDERR, ">>", ( $file eq '/dev/null' ? File::Spec->devnull : $file )
+            or die "Failed to open STDERR to " . $self->stderr_file . ": $!";
+    }
+}
+
 sub _double_fork {
     my ( $self ) = @_;
     my $pid = fork();
@@ -38,18 +58,14 @@ sub _double_fork {
             setgid( $self->gid ) if $self->gid;
             setuid( $self->uid ) if $self->uid;
             open( STDIN, "<", File::Spec->devnull );
-            if ( $self->stdout_file ) {
-                open STDOUT, ">>", $self->stdout_file
-                    or die "Failed to open STDOUT to " . $self->stdout_file , ": $!";
-            }
-            if ( $self->stderr_file ) {
-                open STDOUT, ">>", $self->stderr_file
-                    or die "Failed to open STDERR to " . $self->stderr_file . ": $!";
+
+            if ( $self->redirect_before_fork ) {
+                $self->redirect_filehandles;
             }
 
             # New Program Stuff.
             if ( ref $self->program eq 'CODE' ) {
-                $self->program->( @{$self->program_args || []} );
+                $self->program->( $self, @{$self->program_args || []} );
             } else {
                 exec ( $self->program, @{$self->program_args || [ ]} )
                     or die "Failed to exec " . $self->program . " " 
@@ -83,6 +99,8 @@ sub _fork {
                     . join( " ", @{$self->program_args} ) . ": $!";
         }
         _exit 0;
+    } elsif ( not defined $pid ) {
+        print STDERR "Cannot fork.\n";
     } else { # In the parent, $pid = child's PID, return it.
         $self->pid( $pid );
         $self->write_pid;
@@ -156,16 +174,29 @@ sub do_start {
         exit 1;
     }
 
-    if ( ! $self->fork ) {
-        warn "Defaulting to fork ( set fork => 1, or fork => 2 )";
-        $self->_fork;
-    } else {
-        $self->_double_fork if $self->fork == 2;
-        $self->_fork if $self->fork == 1;
-    }
+    $self->fork( 2 ) unless $self->fork;
+    $self->_double_fork if $self->fork == 2;
+    $self->_fork if $self->fork == 1;
     $self->pretty_print( "Started" );
 }
 
+sub do_show_warnings {
+    my ( $self ) = @_;
+    
+    if ( ! $self->fork ) {
+        print STDERR "Fork undefined.  Defaulting to fork => 2.";
+    }
+
+    if ( ! $self->stdout_file ) {
+        print STDERR "stdout_file undefined.  Will not redirect file handle.";    
+    }
+    
+    if ( ! $self->stderr_file ) {
+        print STDERR "stderr_file undefined.  Will not redirect file handle.";    
+    }
+    
+}
+
 sub do_stop {
     my ( $self ) = @_;
 
@@ -272,18 +303,13 @@ sub run {
    
     # Error Checking.
     if ( ( ! $self->code ) && ( ! $self->program ) ) {
-        warn "Error: code or program MUST be defined.";
-        exit 1;
+        die "Error: program must be defined.";
     }
     if ( ! $self->pid_file ) {
-        warn "Error: pid_file MUST be defined.";
-        exit 1;
-    }
-    if ( ( ! $self->stdout_file ) || ( ! $self->stderr_file ) ) {
-        warn "Warning: stdout_file and stderr_file not set.  Will not reopen to new files.";
+        die "Error: pid_file must be defined.";
     }
     if ( ! $self->name ) {
-        warn "Error: name MUST be defined.";
+        die "Error: name must be defined.";
     }
 
     my $called_with = shift @ARGV if @ARGV;
@@ -292,11 +318,9 @@ sub run {
     if ( $self->can($action) ) {
         $self->$action;
     } elsif ( ! $called_with  ) {
-        warn "Must be called with an action [start|stop|restart|status]";
-        exit 1;
+        die "Must be called with an action [start|stop|restart|status|show_warnings]";
     } else {
-        warn "Error: I don't know how to $called_with.";
-        exit 1;
+        die "Error: undefined action $called_with";
     }
     exit 0;
 }

t/03_perl_gets_control.t

@@ -0,0 +1,34 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use Test::More;
+
+my ( $file, $ilib );
+
+# Let's make it so people can test in t/ or in the dist directory.
+if ( -f 't/bin/03_perl_gets_control.pl' ) { # Dist Directory.
+    $file = "t/bin/03_perl_gets_control.pl";
+    $ilib = "lib";
+} elsif ( -f 'bin/03_perl_gets_control.pl' ) {
+    $file = "bin/03_perl_gets_control.pl";
+    $ilib = "../lib";
+} else {
+    die "Tests should be run in the dist directory or t/";
+}
+
+
+sub get_command_output {
+    my ( @command ) = @_;
+    open my $lf, "-|", @command
+        or die "Couldn't get pipe to '@command': $!";
+    my $content = do { local $/; <$lf> };
+    close $lf;
+    return $content;
+}
+
+my $out;
+
+ok $out = get_command_output( "perl -I$ilib $file start" ), "Started perl daemon";
+ok $out !~ /FAILED/, "Code ref gets Daemon::Control instance.";
+
+done_testing;

t/bin/02_sleep_perl.pl

@@ -11,7 +11,7 @@ Daemon::Control->new({
     lsb_desc    => 'My Daemon controls the My Daemon daemon.',
     path        => '/usr/sbin/mydaemon/init.pl',
 
-    program     => sub { sleep shift },
+    program     => sub { sleep $_[1] },
     program_args => [ 10 ],
 
     pid_file    => '/dev/null', # I don't want to leave tmp files for testing.

t/bin/03_perl_gets_control.pl

@@ -0,0 +1,28 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use Daemon::Control;
+
+Daemon::Control->new({
+    name        => "My Daemon",
+    lsb_start   => '$syslog $remote_fs',
+    lsb_stop    => '$syslog',
+    lsb_sdesc   => 'My Daemon Short',
+    lsb_desc    => 'My Daemon controls the My Daemon daemon.',
+    path        => '/usr/sbin/mydaemon/init.pl',
+
+    program     => sub { 
+        if ( ref $_[0] ne 'Daemon::Control' ) {
+            print "FAILED\n";
+        }
+    },
+    program_args => [ ],
+
+    redirect_before_fork => 0,
+    pid_file    => '/dev/null', # I don't want to leave tmp files for testing.
+    stderr_file => '/dev/null',
+    stdout_file => '/dev/null',
+
+    fork        => 2,
+
+})->run;