File Coverage

blib/lib/Daemon/Control.pm

Criterion	Covered	Total	%
statement	78	336	23.2
branch	33	216	15.2
condition	3	38	7.8
subroutine	20	43	46.5
pod	18	26	69.2
total	152	659	23.0

package Daemon::Control;

use strict;
use warnings;
use POSIX qw(_exit setsid setuid setgid getuid getgid);
use File::Spec;
use File::Path qw( make_path );
use Cwd 'abs_path';
require 5.008001; # Supporting 5.8.1+

our $VERSION = '0.001009'; # 0.1.9
$VERSION = eval $VERSION;

my @accessors = qw(
    pid color_map name program program_args directory quiet
    path scan_name stdout_file stderr_file pid_file fork data
    lsb_start lsb_stop lsb_sdesc lsb_desc redirect_before_fork init_config
    kill_timeout umask resource_dir help init_code
    prereq_no_process foreground reload_signal stop_signals
);

my $cmd_opt = "[start|stop|restart|reload|status|foreground|show_warnings|get_init_file|help]";

# Accessor building

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

# As a result of not using a real object system for
# this, I don't get after user => sub { } style things,
# so I'm making my own triggers for user and group.

sub user {
    my $self = shift;

    if ( @_ ) {
        $self->{user} = shift;
        delete $self->{uid};
    }

    return $self->{user};
}

sub group {
    my $self = shift;

    if ( @_ ) {
        $self->{group} = shift;
        delete $self->{gid};
    }

    return $self->{group};
}

sub uid {
    my $self = shift;

    return $self->{uid} = shift if @_;

    $self->_set_uid_from_name unless exists $self->{uid};

    return $self->{uid}
}

sub gid {
    my $self = shift;

    return $self->{gid} = shift if @_;

    $self->_set_gid_from_name unless exists $self->{gid};

    return $self->{gid}
}

sub new {
    my ( $class, @in ) = @_;

    my $args = ref $in[0] eq 'HASH' ? $in[0] : { @in };

    # Create the object with defaults.
    my $self = bless {
        color_map               => { red => 31, green => 32 },
        redirect_before_fork    => 1,
        kill_timeout            => 1,
        quiet                   => 0,
        umask                   => 0,
        foreground              => 0,
        reload_signal           => 'HUP',
        stop_signals            => [ qw(TERM TERM INT KILL) ],
    }, $class;

    for my $accessor ( @accessors, qw(uid gid user group) ) {
        if ( exists $args->{$accessor} ) {
            $self->{$accessor} = delete $args->{$accessor};
        }
    }

    # Shortcut caused by setting foreground or using the ENV to do it.
    if ( ( $self->foreground == 1 ) || ( $ENV{DC_FOREGROUND} ) ) {
        $self->fork( 0 );
        $self->quiet( 1 );
    }

    die "Unknown arguments to the constructor: " . join( " ", keys %$args )
        if keys( %$args );

    return $self;
}

sub with_plugins {
    my ( $class, @in ) = @_;

    # ->with_plugins()->new is just ->new...
    return $class unless @in;

    # Make sure we have Role::Tiny installed.
    local $@;
    eval "require Role::Tiny";
    if ( $@ ) {
        die "Error: Role::Tiny is required for with_plugins to function.\n";
    }

    # Take an array or arrayref as an argument
    # and mutate it into a list like this:
    #   'Module'  -> Becomes -> 'Root::Module'
    #   '+Module' ->  Becomes -> 'Module'
    my @plugins = map {
        substr( $_, 0, 1 ) eq '+'
            ? substr( $_, 1 )
            : "Daemon::Control::Plugin::$_"
    } ref $in[0] eq 'ARRAY' ? @{ $in[0] } : @in;


    # Compose the plugins into our class, and return for the user
    # to call ->new().
    return Role::Tiny->create_class_with_roles( $class, @plugins );
}

# Set the uid, triggered from getting the uid if the user has changed.
sub _set_uid_from_name {
    my ( $self ) = @_;
    return unless defined $self->user;

    my $uid = getpwnam( $self->user );
    die "Error: Couldn't get uid for non-existent user " . $self->user
        unless defined $uid;
    $self->trace( "Set UID => $uid" );
    $self->uid( $uid );
}

# Set the uid, triggered from getting the gid if the group has changed.
sub _set_gid_from_name {
    my ( $self ) = @_;

    # Grab the GID if we have a UID but no GID.
    if ( !defined $self->group && defined $self->uid ) {
        my ( $gid ) = ( (getpwuid( $self->uid ))[3] );
        $self->gid( $gid );
        $self->trace( "Implicit GID => $gid" );
        return $gid;
    }

    return unless defined $self->group;

    my $gid = getgrnam( $self->group );
    die "Error: Couldn't get gid for non-existent group " . $self->group
        unless defined $gid;
    $self->trace( "Set GID => $gid" );
    $self->gid( $gid );

}

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

    if ( $self->stdout_file ) {
        my $file = $self->stdout_file;
        $file = $file eq '/dev/null' ? File::Spec->devnull : $file;

        if ( ref $file eq 'ARRAY' ) {
            my $mode = shift @$file;
            open STDOUT, $mode, @$file ? @$file : ()
                or die "Failed to open STDOUT with args $mode @$file: $!";

            $self->trace("STDOUT redirected to open(STDOUT $mode @$file)");
        }
        else {
            open STDOUT, ">>", $file
                or die "Failed to open STDOUT to $file: $!";
            $self->trace( "STDOUT redirected to $file" );
        }
    }
    if ( $self->stderr_file ) {
        my $file = $self->stderr_file;
        $file = $file eq '/dev/null' ? File::Spec->devnull : $file;

        if ( ref $file eq 'ARRAY' ) {
            my $mode = shift @$file;
            open STDERR, $mode, @$file ? @$file : ()
                or die "Failed to open STDERR with args $mode @$file: $!";

            $self->trace("STDERR redirected to open(STDERR $mode @$file)");
        }
        else {
            open STDERR, ">>", $file
                or die "Failed to open STDERR to $file: $!";
            $self->trace("STDERR redirected to $file");
        }
    }
}

sub _create_resource_dir {
    my ( $self ) = @_;
    $self->_create_dir($self->resource_dir);
}

sub _create_dir {
    my ( $self, $dir ) = @_;

    return 0 unless defined $dir;
    return 1 unless length($dir);

    if ( -d $dir ) {
        $self->trace( "Dir exists (" . $dir . ") - no need to create" );
        return 1;
    }

    my ( $created ) = make_path(
        $dir,
        {
            uid => $self->uid,
            group => $self->gid,
            error => \my $errors,
        }
    );

    if ( @$errors ) {
        for my $error ( @$errors ) {
            my ( $file, $msg ) = %$error;
            die "Error creating $file: $msg";
        }
    }

    if ( $created eq $dir ) {
        $self->trace( "Created dir (" . $dir . ")" );
        return 1;
    }

    $self->trace( "_create_dir() for $dir failed and I don't know why" );
    return 0;
}

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

    $self->trace( "_double_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.

            if ( $self->gid ) {
                setgid( $self->gid );
                $self->trace( "setgid(" . $self->gid . ")" );
            }

            if ( $self->uid ) {
                setuid( $self->uid );

                $ENV{USER} = $self->user || getpwuid($self->uid);
                $ENV{HOME} = ((getpwuid($self->uid))[7]);

                $self->trace( "setuid(" . $self->uid . ")" );
                $self->trace( "\$ENV{USER} => " . $ENV{USER} );
                $self->trace( "\$ENV{HOME} => " . $ENV{HOME} );
            }

            if ( $self->umask ) {
                umask( $self->umask);
                $self->trace( "umask(" . $self->umask . ")" );
            }

            open( STDIN, "<", File::Spec->devnull );

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

            $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 );
    }
    return $self;
}

sub _foreground { shift->_launch_program }

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

    $self->trace( "_fork()" );
    if ( $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" );
        $self->write_pid;
    }
    return $self;
}

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

    if ( $self->directory ) {
        chdir( $self->directory );
        $self->trace( "chdir(" . $self->directory . ")" );
    }

    my @args = @{$self->program_args || [ ]};

    if ( ref $self->program eq 'CODE' ) {
        $self->program->( $self, @args );
    } else {
        exec ( $self->program, @args )
            or die "Failed to exec " . $self->program . " "
                . join( " ", @args ) . ": $!";
    }
    return 0;
}

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

    # Create the PID file as the user we currently are,
    # and change the permissions to our target UID/GID.

    $self->_write_pid;

    if ( $self->uid && $self->gid ) {
        chown $self->uid, $self->gid, $self->pid_file;
        $self->trace("PID => chown(" . $self->uid . ", " . $self->gid .")");
    }
}

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

    my ($volume, $dir, $file) = File::Spec->splitpath($self->pid_file);
    return 0 if not $self->_create_dir($dir);

    open my $sf, ">", $self->pid_file
        or die "Failed to write " . $self->pid_file . ": $!";
    print $sf $self->pid;
    close $sf;
    $self->trace( "Wrote pid (" . $self->pid . ") to pid file (" . $self->pid_file . ")" );
    return $self;
}

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

    # If we don't have a PID file, we're going to set it
    # to 0 -- this will prevent killing normal processes,
    # and make is_running return false.
    if ( ! -f $self->pid_file ) {
        $self->pid( 0 );
        return 0;
    }

    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, $pid ) = @_;

    $pid ||= $self->read_pid;

    return 0 unless $self->pid >= 1;
    return 0 unless kill 0, $self->pid;

    if ( $self->scan_name ) {
        open my $lf, "-|", "ps", "-w", "-w", "-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 process_running {
    my ( $self, $pattern ) = @_;

    my $psopt = $^O =~ m/bsd$/ ? '-ax' : '-u ' . $self->user;
    my $ps = `LC_ALL=C command ps $psopt -o pid,args`;
    $ps =~ s/^\s+//mg;
    my @pids;
    for my $line (split /\n/, $ps)
    {
        next if $line =~ m/^\D/;
        my ($pid, $command, $args) = split /\s+/, $line, 3;

        next if $pid eq $$;
        push @pids, $pid
          if $command =~ $pattern
              or defined $args and $args =~ $pattern;
    }
    return @pids;
}

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

    return if $self->quiet;

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

# Callable Functions

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

    # Short cut to...
    $self->fork( 0 );
    $self->quiet( 1 );
    return $self->do_start;
}

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

    # Optionally check if a process is already running with the same name
    if ($self->prereq_no_process)
    {
        my $program = $self->program;
        my $pattern = $self->prereq_no_process eq '1'
            ? qr/\b${program}\b/
            : $self->prereq_no_process;
        my @pids = $self->process_running($pattern);
        if (@pids)
        {
            $self->pretty_print( 'Duplicate Running? (pid ' . join(', ', @pids) . ')', "red" );
            return  1;
        }
    }

    # Make sure the PID file exists.
    if ( ! -f $self->pid_file ) {
        $self->pid( 0 ); # Make PID invalid.
        $self->write_pid();
    }

    # Duplicate Check
    $self->read_pid;
    if ( $self->pid && $self->pid_running ) {
        $self->pretty_print( "Duplicate Running", "red" );
        return 1;
    }

    $self->_create_resource_dir;

    $self->fork( 2 ) unless defined $self->fork;
    $self->_double_fork if $self->fork == 2;
    $self->_fork if $self->fork == 1;
    $self->_foreground if $self->fork == 0;
    $self->pretty_print( "Started" );
    return 0;
}

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

    if ( ! $self->fork ) {
        warn "Fork undefined.  Defaulting to fork => 2.\n";
    }

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

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

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

    $self->read_pid;
    my $start_pid = $self->pid;

    # Probably don't want to send anything to init(1).
    return 1 unless $start_pid > 1;

    if ( $self->pid_running($start_pid) ) {
        SIGNAL:
        foreach my $signal (@{ $self->stop_signals }) {
            $self->trace( "Sending $signal signal to pid $start_pid..." );
            kill $signal => $start_pid;

            for (1..$self->kill_timeout)
            {
                # abort early if the process is now stopped
                $self->trace("checking if pid $start_pid is still running...");
                last if not $self->pid_running($start_pid);
                sleep 1;
            }
            last unless $self->pid_running($start_pid);
        }
        if ( $self->pid_running($start_pid) ) {
            $self->pretty_print( "Failed to Stop", "red" );
            return 1;
        }
        $self->pretty_print( "Stopped" );
    } else {
        $self->pretty_print( "Not Running", "red" );
    }

    # Clean up the PID file on stop, unless the pid
    # doesn't match $start_pid (perhaps a standby
    # worker stepped in to take over from the one
    # that was just terminated).

    if ( $self->pid_file ) {
      unlink($self->pid_file) if $self->read_pid == $start_pid;
    }
    return 0;
}

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

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

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

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

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

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

sub do_get_init_file {
    shift->dump_init_script;
    return 0;
}

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

    print "Syntax: $0 $cmd_opt\n\n";
    print $self->help if $self->help;
    return 0;
}

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

    # So, instead of expanding run_template to use a real DSL
    # or making TT a dependancy, I'm just going to fake template
    # IF logic.
    my $init_source_file = $self->init_config
        ? $self->run_template(
            '[ -r [% FILE %] ] && . [% FILE %]',
            { FILE => $self->init_config } )
        : "";

    $self->data( $self->run_template(
        $self->data,
        {
            HEADER            => 'Generated at ' . scalar(localtime)
                . ' with Daemon::Control ' . ($self->VERSION || 'DEV'),
            NAME              => $self->name      ? $self->name      : "",
            REQUIRED_START    => $self->lsb_start ? $self->lsb_start : "",
            REQUIRED_STOP     => $self->lsb_stop  ? $self->lsb_stop  : "",
            SHORT_DESCRIPTION => $self->lsb_sdesc ? $self->lsb_sdesc : "",
            DESCRIPTION       => $self->lsb_desc  ? $self->lsb_desc  : "",
            SCRIPT            => $self->path      ? $self->path      : abs_path($0),
            INIT_SOURCE_FILE  => $init_source_file,
            INIT_CODE_BLOCK   => $self->init_code ? $self->init_code : "",
        }
    ));
    print $self->data;
}

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

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

    return $content;
}



sub run_command {
    my ( $self, $arg ) = @_;

    # Error Checking.
    if ( ! $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 = $arg || "help";
    $called_with =~ s/^[-]+//g; # Allow people to do --command too.

    my $action = "do_" . ($called_with ? $called_with : "" );

    my $allowed_actions = "Must be called with an action: $cmd_opt";

    if ( $self->can($action) ) {
        return $self->$action;
    } elsif ( ! $called_with  ) {
        die $allowed_actions
    } else {
        die "Error: undefined action $called_with.  $allowed_actions";
    }

}

# Application Code.
sub run {
    exit shift->run_command( @ARGV );
}

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

    return unless $ENV{DC_TRACE};

    print "[TRACE] $message\n" if $ENV{DC_TRACE} == 1;
    print STDERR "[TRACE] $message\n" if $ENV{DC_TRACE} == 2;
}

1;

__DATA__