package Daemon::Control;

use strict;
use warnings;
use POSIX qw(_exit setsid setuid setgid getuid getgid);
use File::Spec;

our $VERSION = '0.001000'; # 0.1.0
$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 redirect_before_fork        |;

sub new {
    my ( $class, $args ) = @_;
    
    # 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} ) {
            $self->{"_$accessor"} = delete $args->{$accessor};
        }
    }
    die "Unknown arguments to the constructure: " . join( " ", keys %$args )
        if keys( %$args );

    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();

    if ( $pid == 0 ) { # Child, launch the process here.
        setsid(); # Become the process leader.
        my $new_pid = fork();
        if ( $new_pid == 0 ) { # Our double fork.
            setgid( $self->gid ) if $self->gid;
            setuid( $self->uid ) if $self->uid;
            open( STDIN, "<", File::Spec->devnull );

            if ( $self->redirect_before_fork ) {
                $self->redirect_filehandles;
            }

            # New Program Stuff.
            if ( ref $self->program eq 'CODE' ) {
                $self->program->( $self, @{$self->program_args || []} );
            } else {
                exec ( $self->program, @{$self->program_args || [ ]} )
                    or die "Failed to exec " . $self->program . " " 
                        . join( " ", @{$self->program_args} ) . ": $!";
            }
        } elsif ( not defined $new_pid ) {
            print STDERR "Cannot fork.\n";
        } else {
            $self->pid( $new_pid );
            $self->write_pid;
            _exit 0;
        }
    } elsif ( not defined $pid ) { # We couldn't fork.  =(
        print STDERR "Cannot fork.\n";
    } else { # In the parent, $pid = child's PID, return it.
        waitpid( $pid, 0 );
    }
    return $self;
}

sub _fork {
    my ( $self ) = @_;
    my $pid = fork();

    if ( $pid == 0 ) { # Child, launch the process here.
        if ( ref $self->program eq 'CODE' ) {
            $self->program->( @{$self->program_args || []} );
        } else {
            exec ( $self->program, @{$self->program_args || [ ]} )
                or die "Failed to exec " . $self->program . " " 
                    . 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;
        #waitpid( $pid, 0 );
    }
    return $self;
}

sub write_pid {
    my ( $self ) = @_;
    open my $sf, ">", $self->pid_file
        or die "Failed to write " . $self->pid_file . ": $!";
    print $sf $self->pid;
    close $sf;
    return $self;
}

sub read_pid {
    my ( $self ) = @_;
    open my $lf, "<", $self->pid_file 
        or die "Failed to read " . $self->pid_file . ": $!";
    my $pid = do { local $/; <$lf> };
    close $lf;
    $self->pid( $pid );
    return $pid;
}

sub pid_running {
    my ( $self ) = @_;

    $self->read_pid;

    return 0 unless kill 0, $self->pid;
    #return kill 0, shift->pid;

    if ( $self->scan_name ) {
        open my $lf, "-|", "ps", "-p", $self->pid, "-o", "command="
            or die "Failed to get pipe to ps for scan_name.";
        while ( my $line = <$lf> ) {
            return 1 if $line =~ $self->scan_name;
        }
        return 0;
    }
    # Scan name wasn't used, testing normal PID.
    return kill 0, $self->pid;
}

sub pretty_print {
    my ( $self, $message, $color ) = @_;

    $color ||= "green"; # Green is no color.
    my $code = $self->color_map->{$color} ||= "32"; # Green is invalid.
    printf( "%-49s %30s\n", $self->name, "\033[$code" ."m[$message]\033[0m" );
}

# Callable Functions

sub do_start {
    my ( $self ) = @_;

    # Make sure the PID file exists.
    if ( ! -f $self->pid_file ) {
        $self->pid( "_" ); # Make PID invalid.
        $self->write_pid();
    }
    
    # Duplicate Check
    $self->read_pid;
    if ( $self->pid && $self->pid_running ) {
        $self->pretty_print( "Duplicate Running", "red" );
        exit 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.\n";
    }

    if ( ! $self->stdout_file ) {
        print STDERR "stdout_file undefined.  Will not redirect file handle.\n";    
    }
    
    if ( ! $self->stderr_file ) {
        print STDERR "stderr_file undefined.  Will not redirect file handle.\n";    
    }
    
}

sub do_stop {
    my ( $self ) = @_;

    $self->read_pid;
    if ( $self->pid && $self->pid_running ) {
        my $tried = 0;
        while ( $self->pid_running ) {
            kill INT => $self->pid if $tried == 0;
            kill TERM => $self->pid if $tried == 1 or $tried == 2;
            kill KILL => $self->pid if $tried == 3;
            $tried++;
            sleep 1;
        }
        if ( $self->pid_running ) {
            $self->pretty_print( "Failed to Stop", "red" );
            exit 1;
        }
        $self->pretty_print( "Stopped" );
        exit 0;
    } else {
        $self->pretty_print( "Not Running", "red" );
        exit 0;
    }
}

sub do_restart {
    my ( $self ) = @_;
    $self->read_pid;

    if ( $self->pid_running ) {
        $self->do_stop;
    }
    $self->do_start;
}

sub do_status {
    my ( $self ) = @_;
    $self->read_pid;

    if ( $self->pid && $self->pid_running ) {
        $self->pretty_print( "Running" );
        exit 0;
    } else {
        $self->pretty_print( "Not Running", "red" );
        exit 1;
    }
}

sub do_get_init_file {
    shift->dump_init_script;
}

# Magically create the accessors.

for my $method ( @accessors ) {
    my $accessor = sub {
        my $self = shift;
        $self->{"_$method"} = shift if @_;
        return $self->{"_$method"};
    };
    {
        no strict 'refs';
        no warnings 'redefine';
        *$method = $accessor;
    }
}

sub dump_init_script {
    my ( $self ) = @_;
    if ( ! $self->data ) {
        my $data;
        while ( my $line = <DATA> ) {
            last if $line =~ /^__END__$/;
            $data .= $line;
        }
        $self->data( $data );
    }

    $self->data( $self->run_template(
        $self->data,
        {
            NAME                => $self->name,
            REQUIRED_START      => $self->lsb_start,
            REQUIRED_STOP       => $self->lsb_stop,
            SHORT_DESCRIPTION   => $self->lsb_sdesc,
            DESCRIPTION         => $self->lsb_desc,
            SCRIPT              => $self->path ? $self->path : $0,
        }
    ));
    print $self->data;
}

sub run_template {
    my ( $self, $content, $config ) = @_;

    $content =~ s/\[% (.*?) %\]/$config->{$1}/g;

    return $content;
}

# Application Code.
sub run {
    my ( $self ) = @_;
   
    # Error Checking.
    if ( ( ! $self->code ) && ( ! $self->program ) ) {
        die "Error: program must be defined.";
    }
    if ( ! $self->pid_file ) {
        die "Error: pid_file must be defined.";
    }
    if ( ! $self->name ) {
        die "Error: name must be defined.";
    }

    my $called_with = shift @ARGV if @ARGV;
    my $action = "do_" . ($called_with ? $called_with : "" );

    if ( $self->can($action) ) {
        $self->$action;
    } elsif ( ! $called_with  ) {
        die "Must be called with an action [start|stop|restart|status|show_warnings]";
    } else {
        die "Error: undefined action $called_with";
    }
    exit 0;
}

1;

__DATA__
#!/bin/sh

### BEGIN INIT INFO
# Provides:          [% NAME %]
# Required-Start:    [% REQUIRED_START %]
# Required-Stop:     [% REQUIRED_STOP %]
# Default-Start:     2 3 4 5
# Default-Stop:      0 1 6
# Short-Description: [% SHORT_DESCRIPTION %]
# Description:       [% DESCRIPTION %]
### END INIT INFO`


if [ -x [% SCRIPT %] ];
then
    [% SCRIPT %] $1
else
    echo "Requred program [% SCRIPT %] not found!"
    exit 1;
fi
__END__

=head1 NAME

Daemon::Control - Create init scripts in Perl

=head1 DESCRIPTION

Daemon::Control provides a library for creating init scripts in perl.
Your perl script just needs to set the accessors for what and how you
want something to run and the library takes care of the rest.

You can launch programs through the shell (/usr/sbin/my_program) or
launch Perl code itself into a daemon mode.  Single and double fork
methods are supported and in double-fork mode all the things you would
expect like reopening STDOUT/STDERR, switching UID/GID are supported.

=head1 SYNOPSIS

Write a program that describes the daemon:

    #!/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        => '/home/symkat/etc/init.d/program',

        program     => '/home/symkat/bin/program',
        program_args => [ '-a', 'orange', '--verbose' ],

        pid_file    => '/tmp/mydaemon.pid',
        stderr_file => '/tmp/mydaemon.out',
        stdout_file => '/tmp/mydaemon.out',

        fork        => 2,

    })->run;

You can then call the program:

    /home/symkat/etc/init.d/program start

You can also make an LSB compatable init script:

    /home/symkat/etc/init.d/program get_init_file > /etc/init.d/program

=head1 CONSTRUCTURE

The constucture takes the following arguments.

=head2 name

The name of the program the daemon is controlling.  This will be used in
status messages "name [Started]" and the name for the LSB init script
that is generated.

=head2 program

This can be a coderef or the path to a shell program that is to be run.

$daemon->program( sub { ... } );

$daemon->program( "/usr/sbin/http" );

=head2 program_args

This is an array ref of the arguments for the program.  In the context
of a coderef being executed this will be given to the coderef as @_,
the Daemon::Control instance that called the coderef will be passed
as the first arguments.  Your arguments start at $_[1].

In the context of a shell program, it will be given as arguments to
be executed.

$daemon->program_args( [ 'foo', 'bar' ] );

$daemon->program_args( [ '--switch', 'argument' ] );

=head2 uid

If provided, the UID that the program will drop to when forked.  This is
ONLY supported in double-fork mode and will only work if you are running
as root.  This takes the numerical UID (grep user /etc/passwd )

$daemon->uid( 1001 );

=head2 gid

If provided, the GID that the program will drop to when forked.  This is
ONLY supported in double-fork mode and will only work if you are running
as root.  This takes the numerical GID ( grep group /etc/groups )

$daemon->gid( 1001 );

=head2 path

The path of the script you are using Daemon::Control in.  This will be used in 
the LSB file genration to point it to the location of the script.  If this is
not provided $0 will be used, which is likely to work only if you use the full
path to execute it when asking for the init script.

=head2 redirect_before_fork

By default this is set true.  STDOUT will be redirected to stdout_file,
STDERR will be redirected to stderr_file.  Setting this to 0 will disable
redriecting before a double fork.  This is useful when you are using a code
ref and would like to leave the file handles alone until you're in control.

Call ->redirect_filehandles on the Daemon::Control instance your coderef is
passed to redirect the filehandles.

=head2 stdout_file

If provided stdout will be redirected to the given file.  This is only supported
in double fork more.

$daemon->stdout_file( "/tmp/mydaemon.stdout" );

=head2 stderr_file

If provided stderr will be redirected to the given file.  This is only supported
in double fork more.

$daemon->stderr_file( "/tmp/mydaemon.stderr" );

=head2 pid_file

The location of the PID file to use.  Warning: if using single-fork mode, it is
recommended to set this to the file which the daemon launching in single-fork
mode will put it's PID.  Failure to follow this will most likely result in status,
stop, and restart not working.

$daemon->pid_file( "/tmp/mydaemon.pid" );

=head2 fork

The mode to use for fork.  By default a double-fork will be used.

In double-fork, uid, gid, std*_file, and a number of other things are
supported.  A traditional double-fork is used and setsid is called.

In single-fork none of the above are called, and it is the responsiblity
of whatever you're forking to reopen files, associate with the init process
and do all that fun stuff.  This mode is recommended when the program you want
to control has it's own daemonizing code.  It is importand to note that the PID
file should be set to whatever PID file is used by the daemon.

$daemon->fork( 1 );

$daemon->fork( 2 ); # Default

=head2 scan_name

This provides an extra check to see if the program is running.  Normally
we only check that the PID listed in the PID file is running.  When given
a regular expression, we will also match the name of the program as shown
in ps.

$daemon->scan_name( qr|mydaemon| );

=head2 lsb_start

The value of this string is used for the 'Required-Start' value of
the generated LSB init script.  See L<http://wiki.debian.org/LSBInitScripts>
for more information.

$daemon->lsb_start( '$remote_fs $syslog' );

=head2 lsb_stop

The value of this string is used for the 'Required-Stop' value of
the generated LSB init script.  See L<http://wiki.debian.org/LSBInitScripts>
for more information.

$daemon->lsb_stop( '$remote_fs $syslog' );

=head2 lsb_sdesc

The value of this string is used for the 'Short-Description' value of
the generated LSB init script.  See L<http://wiki.debian.org/LSBInitScripts>
for more information.

$daemon->lsb_sdesc( 'Mah program...' );


=head2 lsb_desc

The value of this string is used for the 'Description' value of
the generated LSB init script.  See L<http://wiki.debian.org/LSBInitScripts>
for more information.

$daemon->lsb_desc( 'My program controls a thing that does a thing.' );

=head1 METHODS

=head2 run

This will make your program act as an init file, accepting input from
the command line.  Run will exit either 1 or 0, following LSB files on
exiting.  As such no code should be used after ->run is called.  Any code
in your file should be before this.

=head2 do_start

Is called when start is given as an argument.  Starts the forking, and
exits.

/usr/bin/my_program_launcher.pl start

=head2 do_stop

Is called when stop is given as an argument.  Stops the running program
if it can.

/usr/bin/my_program_launcher.pl stop

=head2 do_restart

Is called when restart is given as an argument.  Calls do_stop and do_start.

/usr/bin/my_program_launcher.pl restart

=head2 do_status

Is called when status is given as an argument.  Displays the status of the
program, basic on the PID file.

/usr/bin/my_program_launcher.pl status

=head2 do_get_init_file

Is called when get_init_file is given as an argument.  Dumps an LSB
compatable init file, for use in /etc/init.d/

/usr/bin/my_program_launcher.pl get_init_file

=head2 pretty_print

This is used to display status to the user.  It accepts a message, and a color.
It will default to green text, if no color is explictly given.  Only supports
red and green.

$daemon->pretty_print( "My Status", "red" );

=head2 write_pid

This will write the PID to the file in pid_file.

=head2 read_pid

This will read the PID from the file in pid_file and set it in pid.

=head2 pid

An accessor for the PID.  Set by read_pid, or when the program is started.

=head2 dump_init_script

A function to dump the LSB compatable init script.  Used by do_get_init_file.

=head1 AUTHOR

SymKat I<E<lt>symkat@symkat.comE<gt>> ( Blog: L<http://symkat.com/> )

=head2 CONTRIBUTORS

Matt S. Trout (mst) I<E<lt>mst@mst@shadowcat.co.ukE<gt>>

=head1 COPYRIGHT

Copyright (c) 2012 the Daemon::Control L</AUTHOR> and L</CONTRIBUTORS> as listed above.

=head1 LICENSE 

This library is free software and may be distributed under the same terms as perl itself.

=head2 AVAILABILITY

The most current version of Daemon::Control can be found at L<https://github.com/symkat/Daemon-Control>