File Coverage

blib/lib/Net/Server/Daemonize.pm

Criterion	Covered	Total	%
statement	12	110	10.9
branch	0	70	0.0
condition	0	17	0.0
subroutine	4	17	23.5
pod	10	12	83.3
total	26	226	11.5

# -*- perl -*-
#
#  Net::Server::Daemonize - Daemonization utilities.
#
#  Copyright (C) 2001-2022
#
#    Jeremy Howard
#    [e-mail]
#
#    Paul Seamons
#
#  This package may be distributed under the terms of either the
#  GNU General Public License
#    or the
#  Perl Artistic License
#
#  All rights reserved.
#
################################################################

package Net::Server::Daemonize;

use strict;
use base qw(Exporter);
use Carp qw(croak);
use POSIX qw(SIGINT SIG_BLOCK SIG_UNBLOCK);

our $VERSION = "0.06";

our @EXPORT_OK = qw(check_pid_file    create_pid_file   unlink_pid_file
                    is_root_user      get_uid get_gid   set_uid set_gid
                    set_user          safe_fork         daemonize);

###----------------------------------------------------------------###

### check for existence of pid_file
### if the file exists, check for a running process
sub check_pid_file ($) {
    my $pid_file = shift;
    return 1 if ! -e $pid_file or ! -s $pid_file && -M _ > 0.01;

    open my $fh, '<', $pid_file or croak "$pid_file: Couldn't open existent pid_file [$!]";
    my $current_pid = <$fh> || "";
    close $fh;
    $current_pid = ($current_pid =~ /^(\d{1,10})/) ? $1 : croak "$pid_file: Couldn't find pid in existent pid_file";

    my $exists;
    if ($$ == $current_pid) {
        warn "Pid_file created by this same process. Doing nothing.\n";
        return 1;
    } elsif (-d "/proc/$$") { # try a proc file system
        $exists = -e "/proc/$current_pid";
    } elsif (kill 0, $current_pid) {
        $exists = 1;
    }
    croak "Pid_file already exists for running process ($current_pid)... aborting"
        if $exists;

    # remove the pid_file
    warn "Pid_file \"$pid_file\" already exists.  Overwriting!\n";
    unlink $pid_file || croak "Couldn't remove pid_file \"$pid_file\" [$!]";
    return 1;
}

### actually create the pid_file, calls check_pid_file
### before proceeding
sub create_pid_file ($) {
    my $pid_file = shift;

    check_pid_file($pid_file);

    open my $fh, '>', $pid_file or croak "Couldn't open pid file \"$pid_file\" [$!]";
    print $fh "$$\n";
    close $fh;

    die "Pid_file \"$pid_file\" not created.\n" if ! -e $pid_file;
    return 1;
}

### Allow for safe removal of the pid_file.
### Make sure this process owns it.
sub unlink_pid_file ($) {
    my $pid_file = shift;
    return 1 if ! -e $pid_file; # no pid_file = return success

    open my $fh, '<', $pid_file or croak "$pid_file: Couldn't open existent pid_file [$!]"; # slight race
    my $current_pid = <$fh>;
    close $fh;
    chomp $current_pid;

    croak "Process $$ doesn't own pid_file \"$pid_file\" so can't remove it"
        if $current_pid ne $$;

    unlink($pid_file) || die "$pid_file: Couldn't unlink pid_file [$!]\n";
    return 1;
}

###----------------------------------------------------------------###

sub is_root_user () {
    my $id = get_uid('root');
    return ! defined($id) || $< == $id || $> == $id;
}

### get the uid for the passed user
sub get_uid ($) {
    my $user = shift;
    my $uid  = ($user =~ /^(\d+)$/) ? $1 : getpwnam($user);
    croak "No such user \"$user\"" unless defined $uid;
    return $uid;
}

### get all of the gids that this group is (space delimited)
sub get_gid {
    my @gid;

    foreach my $group ( split( /[, ]+/, join(" ",@_) ) ){
        if( $group =~ /^\d+$/ ){
            push @gid, $group;
        }else{
            my $id = getgrnam($group);
            croak "No such group \"$group\"" unless defined $id;
            push @gid, $id;
        }
    }

    croak "No group found in arguments" unless @gid;
    return join(" ", $gid[0], @gid);
}

### change the process to run as this uid
sub set_uid {
    my $uid = get_uid(shift());

    POSIX::setuid($uid);
    if ($< != $uid || $> != $uid) { # check $> also (rt #21262)
        $< = $> = $uid; # try again - needed by some 5.8.0 linux systems (rt #13450)
        if ($< != $uid) {
            die "Couldn't become uid \"$uid\": $!\n";
        }
    }

    return 1;
}

### change the process to run as this gid(s)
### multiple groups must be space or comma delimited
sub set_gid {
    my $gids = get_gid(@_);
    my $gid  = (split /\s+/, $gids)[0];
    eval { $) = $gids }; # store all the gids - this is really sort of optional

    POSIX::setgid($gid);
    if (! grep {$gid == $_} split /\s+/, $() { # look for any valid id in the list
        die "Couldn't become gid \"$gid\": $!\n";
    }

    return 1;
}

### backward compatibility sub
sub set_user {
    my ($user, @group) = @_;
    set_gid(@group) || return undef;
    set_uid($user)  || return undef;
    return 1;
}

###----------------------------------------------------------------###

### routine to protect process during fork
sub safe_fork () {

    # block signal for fork
    my $sigset = POSIX::SigSet->new(SIGINT);
    POSIX::sigprocmask(SIG_BLOCK, $sigset) or croak "Can't block SIGINT for fork: [$!]";

    my $pid = fork;
    die "Couldn't fork: [$!]" if ! defined $pid;

    $SIG{'INT'} = 'DEFAULT'; # make SIGINT kill us as it did before

    POSIX::sigprocmask(SIG_UNBLOCK, $sigset) or croak "Can't unblock SIGINT for fork: [$!]";

    return $pid;
}

###----------------------------------------------------------------###

### routine to completely dissociate from terminal process.
sub daemonize ($$$) {
    my ($user, $group, $pid_file) = @_;

    check_pid_file($pid_file) if defined $pid_file;

    my $uid = get_uid($user);
    my $gid = get_gid($group); # returns list of groups
    $gid = (split /[\s,]+/, $gid)[0];

    my $pid = safe_fork();

    exit(0) if $pid; # exit parent

    # child
    create_pid_file($pid_file) if defined $pid_file;
    chown($uid, $gid, $pid_file) if defined $pid_file;

    set_user($uid, $gid);

    open STDIN,  '<', '/dev/null' or die "Can't open STDIN from /dev/null: [$!]\n";
    open STDOUT, '>', '/dev/null' or die "Can't open STDOUT to /dev/null: [$!]\n";
    open STDERR, '>&STDOUT'       or die "Can't open STDERR to STDOUT: [$!]\n";

    ### does this mean to be chroot ?
    chdir '/' or croak "Can't chdir to \"/\": [$!]";

    POSIX::setsid(); # Turn process into session leader, and ensure no controlling terminal

    ### install a signal handler to make sure SIGINT's remove our pid_file
    $SIG{'INT'}  = sub { HUNTSMAN($pid_file) } if defined $pid_file;
    return 1;
}

### SIGINT routine that will remove the pid_file
sub HUNTSMAN {
    my $path = shift;
    unlink $path;

    eval {
        require Unix::Syslog;
        Unix::Syslog::syslog(Unix::Syslog::LOG_ERR(), "Exiting on INT signal.");
    };

    exit;
}


1;

__END__