File Coverage

blib/lib/JIP/Daemon.pm

Criterion	Covered	Total	%
statement	102	102	100.0
branch	66	70	94.2
condition	25	27	92.5
subroutine	14	14	100.0
pod	4	4	100.0
total	211	217	97.2

package JIP::Daemon;

use 5.006;
use strict;
use warnings;
use JIP::ClassField;
use POSIX ();
use Carp qw(carp croak);
use English qw(-no_match_vars);

our $VERSION = '0.03';

my $maybe_set_subname = sub { $ARG[1]; };

# Will be shipping with Perl 5.22
eval {
    require Sub::Util;

    if (my $set_subname = Sub::Util->can('set_subname')) {
        $maybe_set_subname = $set_subname;
    }
};

my $default_log_callback = sub {
    my ($self, @params) = @ARG;

    if (defined(my $logger = $self->logger)) {
        my $msg;

        if (@params == 1) {
            $msg = shift @params;
        }
        elsif (@params) {
            my $format = shift @params;
            $msg = sprintf $format, @params;
        }

        $logger->info($msg) if defined $msg;
    }
};

has $_ => (get => q{+}, set => q{-}) for qw(
    pid
    uid
    gid
    cwd
    umask
    logger
    dry_run
    is_detached
    log_callback
    on_fork_callback
);

sub new {
    my ($class, %param) = @ARG;

    # Perform a trial run with no changes made (foreground if dry_run)
    my $dry_run = (exists $param{'dry_run'} and $param{'dry_run'}) ? 1 : 0;

    my $uid;
    if (exists $param{'uid'}) {
        $uid = $param{'uid'};

        croak q{Bad argument "uid"}
            unless defined $uid and $uid =~ m{^\d+$}x;
    }

    my $gid;
    if (exists $param{'gid'}) {
        $gid = $param{'gid'};

        croak q{Bad argument "gid"}
            unless defined $gid and $gid =~ m{^\d+$}x;
    }

    my $cwd;
    if (exists $param{'cwd'}) {
        $cwd = $param{'cwd'};

        croak q{Bad argument "cwd"}
            unless defined $cwd and length $cwd;
    }

    my $umask;
    if (exists $param{'umask'}) {
        $umask = $param{'umask'};

        croak q{Bad argument "umask"}
            unless defined $umask and length $umask;
    }

    my $logger;
    if (exists $param{'logger'}) {
        $logger = $param{'logger'};

        croak q{Bad argument "logger"}
            unless defined $logger and ref $logger and $logger->can('info');
    }

    my $log_callback;
    if (exists $param{'log_callback'}) {
        $log_callback = $param{'log_callback'};

        croak q{Bad argument "log_callback"}
            unless defined $log_callback and ref($log_callback) eq 'CODE';

        $log_callback = $maybe_set_subname->('custom_log_callback', $log_callback);
    }
    else {
        $log_callback = $maybe_set_subname->('default_log_callback', $default_log_callback);
    }

    my $on_fork_callback;
    if (exists $param{'on_fork_callback'}) {
        $on_fork_callback = $param{'on_fork_callback'};

        croak q{Bad argument "on_fork_callback"}
            unless defined $on_fork_callback and ref($on_fork_callback) eq 'CODE';

        $on_fork_callback = $maybe_set_subname->('on_fork_callback', $on_fork_callback);
    }

    return bless({}, $class)
        ->_set_dry_run($dry_run)
        ->_set_uid($uid)
        ->_set_gid($gid)
        ->_set_cwd($cwd)
        ->_set_umask($umask)
        ->_set_logger($logger)
        ->_set_log_callback($log_callback)
        ->_set_on_fork_callback($on_fork_callback)
        ->_set_pid($PROCESS_ID)
        ->_set_is_detached(0);
}

sub daemonize {
    my $self = shift;

    return $self if $self->is_detached;

    # Fork and kill parent
    if (not $self->dry_run) {
        $self->_log('Daemonizing the process');

        my $pid = POSIX::fork(); # returns child pid to the parent and 0 to the child

        croak q{Can't fork} if not defined $pid;

        # fork returned 0, so this branch is the child
        if ($pid == 0) {
            POSIX::setsid()
                or croak(sprintf q{Can't start a new session: %s}, $OS_ERROR);

            $self->reopen_std;

            $self->_set_pid(POSIX::getpid())->_set_is_detached(1);
        }

        # this branch is the parent
        else {
            $self->_log('Spawned process pid=%d. Parent exiting', $pid);
            $self->_set_pid($pid)->_set_is_detached(1);

            if (defined(my $cb = $self->on_fork_callback)) {
                $cb->($self);
            }

            POSIX::exit(0);
        }
    }
    else {
        $self->_set_pid($PROCESS_ID);
    }

    return $self->drop_privileges;
}

sub reopen_std {
    my $self = shift;

    open STDIN,  '
        or croak(sprintf q{Can't reopen STDIN: %s},  $OS_ERROR);
    open STDOUT, '>/dev/null'
        or croak(sprintf q{Can't reopen STDOUT: %s}, $OS_ERROR);
    open STDERR, '>/dev/null'
        or croak(sprintf q{Can't reopen STDERR: %s}, $OS_ERROR);

    return $self;
}

sub drop_privileges {
    my $self = shift;

    if (defined(my $uid = $self->uid)) {
        $self->_log('Set uid=%d', $uid);
        POSIX::setuid($uid)
            or croak(sprintf q{Can't set uid "%s": %s}, $uid, $OS_ERROR);
    }

    if (defined(my $gid = $self->gid)) {
        $self->_log('Set gid=%d', $gid);
        POSIX::setgid($gid)
            or croak(sprintf q{Can't set gid "%s": %s}, $gid, $OS_ERROR);
    }

    if (defined(my $umask = $self->umask)) {
        $self->_log('Set umask=%s', $umask);
        POSIX::umask($umask)
            or croak(sprintf q{Can't set umask "%s": %s}, $umask, $OS_ERROR);
    }

    if (defined(my $cwd = $self->cwd)) {
        $self->_log('Set cwd=%s', $cwd);
        POSIX::chdir($cwd)
            or croak(sprintf q{Can't chdir to "%s": %s}, $cwd, $OS_ERROR);
    }

    return $self;
}

sub try_kill {
    my ($self, $signal) = @ARG;

    if (defined(my $pid = $self->pid)) {
        # parameter order in POSIX.pm
        # CORE::kill($signal, $pid);
        # POSIX::kill($pid, $signal);
        return POSIX::kill($pid, defined $signal ? $signal : q{0});
    }
    else {
        carp q{No subprocess running};
        return;
    }
}

sub status {
    my $self = shift;
    my $pid  = $self->pid;

    return $pid, POSIX::kill($pid, 0) ? 1 : 0, $self->is_detached;
}

# private methods
sub _log {
    my $self = shift;

    $self->log_callback->($self, @ARG);

    return $self;
}

1;

__END__