1# -*- perl -*-
2#
3#  Net::Server::Daemonize - Daemonization utilities.
4#
5#  Copyright (C) 2001-2017
6#
7#    Jeremy Howard
8#    j+daemonize@howard.fm
9#
10#    Paul Seamons <paul@seamons.com>
11#
12#  This package may be distributed under the terms of either the
13#  GNU General Public License
14#    or the
15#  Perl Artistic License
16#
17#  All rights reserved.
18#
19################################################################
20
21package Net::Server::Daemonize;
22
23use strict;
24use base qw(Exporter);
25use POSIX qw(SIGINT SIG_BLOCK SIG_UNBLOCK);
26
27our $VERSION = "0.06";
28
29our @EXPORT_OK = qw(check_pid_file    create_pid_file   unlink_pid_file
30                    is_root_user      get_uid get_gid   set_uid set_gid
31                    set_user          safe_fork         daemonize);
32
33###----------------------------------------------------------------###
34
35### check for existence of pid_file
36### if the file exists, check for a running process
37sub check_pid_file ($) {
38    my $pid_file = shift;
39    return 1 if ! -e $pid_file or ! -s $pid_file && -M _ > 0.01;
40
41    open my $fh, '<', $pid_file or die "$pid_file: Couldn't open existent pid_file [$!]\n";
42    my $current_pid = <$fh> || "";
43    close $fh;
44    $current_pid = ($current_pid =~ /^(\d{1,10})/) ? $1 : die "$pid_file: Couldn't find pid in existent pid_file";
45
46    my $exists;
47    if ($$ == $current_pid) {
48        warn "Pid_file created by this same process. Doing nothing.\n";
49        return 1;
50    } elsif (-d "/proc/$$") { # try a proc file system
51        $exists = -e "/proc/$current_pid";
52    } elsif (kill 0, $current_pid) {
53        $exists = 1;
54    }
55    die "Pid_file already exists for running process ($current_pid)... aborting\n"
56        if $exists;
57
58    # remove the pid_file
59    warn "Pid_file \"$pid_file\" already exists.  Overwriting!\n";
60    unlink $pid_file || die "Couldn't remove pid_file \"$pid_file\" [$!]\n";
61    return 1;
62}
63
64### actually create the pid_file, calls check_pid_file
65### before proceeding
66sub create_pid_file ($) {
67    my $pid_file = shift;
68
69    check_pid_file($pid_file);
70
71    open my $fh, '>', $pid_file or die "Couldn't open pid file \"$pid_file\" [$!].\n";
72    print $fh "$$\n";
73    close $fh;
74
75    die "Pid_file \"$pid_file\" not created.\n" if ! -e $pid_file;
76    return 1;
77}
78
79### Allow for safe removal of the pid_file.
80### Make sure this process owns it.
81sub unlink_pid_file ($) {
82    my $pid_file = shift;
83    return 1 if ! -e $pid_file; # no pid_file = return success
84
85    open my $fh, '<', $pid_file or die "$pid_file: Couldn't open existent pid_file [$!]\n"; # slight race
86    my $current_pid = <$fh>;
87    close $fh;
88    chomp $current_pid;
89
90    die "Process $$ doesn't own pid_file \"$pid_file\". Can't remove it.\n"
91        if $current_pid ne $$;
92
93    unlink($pid_file) || die "$pid_file: Couldn't unlink pid_file [$!]\n";
94    return 1;
95}
96
97###----------------------------------------------------------------###
98
99sub is_root_user () {
100    my $id = get_uid('root');
101    return ! defined($id) || $< == $id || $> == $id;
102}
103
104### get the uid for the passed user
105sub get_uid ($) {
106    my $user = shift;
107    my $uid  = ($user =~ /^(\d+)$/) ? $1 : getpwnam($user);
108    die "No such user \"$user\"\n" unless defined $uid;
109    return $uid;
110}
111
112### get all of the gids that this group is (space delimited)
113sub get_gid {
114    my @gid;
115
116    foreach my $group ( split( /[, ]+/, join(" ",@_) ) ){
117        if( $group =~ /^\d+$/ ){
118            push @gid, $group;
119        }else{
120            my $id = getgrnam($group);
121            die "No such group \"$group\"\n" unless defined $id;
122            push @gid, $id;
123        }
124    }
125
126    die "No group found in arguments.\n" unless @gid;
127    return join(" ",$gid[0],@gid);
128}
129
130### change the process to run as this uid
131sub set_uid {
132    my $uid = get_uid(shift());
133
134    POSIX::setuid($uid);
135    if ($< != $uid || $> != $uid) { # check $> also (rt #21262)
136        $< = $> = $uid; # try again - needed by some 5.8.0 linux systems (rt #13450)
137        if ($< != $uid) {
138            die "Couldn't become uid \"$uid\": $!\n";
139        }
140    }
141
142    return 1;
143}
144
145### change the process to run as this gid(s)
146### multiple groups must be space or comma delimited
147sub set_gid {
148    my $gids = get_gid(@_);
149    my $gid  = (split /\s+/, $gids)[0];
150    eval { $) = $gids }; # store all the gids - this is really sort of optional
151
152    POSIX::setgid($gid);
153    if (! grep {$gid == $_} split /\s+/, $() { # look for any valid id in the list
154        die "Couldn't become gid \"$gid\": $!\n";
155    }
156
157    return 1;
158}
159
160### backward compatibility sub
161sub set_user {
162    my ($user, @group) = @_;
163    set_gid(@group) || return undef;
164    set_uid($user)  || return undef;
165    return 1;
166}
167
168###----------------------------------------------------------------###
169
170### routine to protect process during fork
171sub safe_fork () {
172
173    # block signal for fork
174    my $sigset = POSIX::SigSet->new(SIGINT);
175    POSIX::sigprocmask(SIG_BLOCK, $sigset) or die "Can't block SIGINT for fork: [$!]\n";
176
177    my $pid = fork;
178    die "Couldn't fork: [$!]" if ! defined $pid;
179
180    $SIG{'INT'} = 'DEFAULT'; # make SIGINT kill us as it did before
181
182    POSIX::sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock SIGINT for fork: [$!]\n";
183
184    return $pid;
185}
186
187###----------------------------------------------------------------###
188
189### routine to completely dissociate from terminal process.
190sub daemonize ($$$) {
191    my ($user, $group, $pid_file) = @_;
192
193    check_pid_file($pid_file) if defined $pid_file;
194
195    my $uid = get_uid($user);
196    my $gid = get_gid($group); # returns list of groups
197    $gid = (split /\s+/, $gid)[0];
198
199    my $pid = safe_fork();
200
201    exit(0) if $pid; # exit parent
202
203    # child
204    create_pid_file($pid_file) if defined $pid_file;
205    chown($uid, $gid, $pid_file) if defined $pid_file;
206
207    set_user($uid, $gid);
208
209    open STDIN,  '<', '/dev/null' or die "Can't open STDIN from /dev/null: [$!]\n";
210    open STDOUT, '>', '/dev/null' or die "Can't open STDOUT to /dev/null: [$!]\n";
211    open STDERR, '>&STDOUT'       or die "Can't open STDERR to STDOUT: [$!]\n";
212
213    ### does this mean to be chroot ?
214    chdir '/' or die "Can't chdir to \"/\": [$!]";
215
216    POSIX::setsid(); # Turn process into session leader, and ensure no controlling terminal
217
218    ### install a signal handler to make sure SIGINT's remove our pid_file
219    $SIG{'INT'}  = sub { HUNTSMAN($pid_file) } if defined $pid_file;
220    return 1;
221}
222
223### SIGINT routine that will remove the pid_file
224sub HUNTSMAN {
225    my $path = shift;
226    unlink $path;
227
228    eval {
229        require Unix::Syslog;
230        Unix::Syslog::syslog(Unix::Syslog::LOG_ERR(), "Exiting on INT signal.");
231    };
232
233    exit;
234}
235
236
2371;
238
239__END__
240
241=head1 NAME
242
243Net::Server::Daemonize - Safe fork and daemonization utilities
244
245=head1 SYNOPSIS
246
247    use Net::Server::Daemonize qw(daemonize);
248
249    daemonize(
250      'nobody',                 # User
251      'nobody',                 # Group
252      '/var/state/mydaemon.pid' # Path to PID file - optional
253    );
254
255=head1 DESCRIPTION
256
257This module is intended to let you simply and safely daemonize your
258server on systems supporting the POSIX module. This means that your
259Perl script runs in the background, and it's process ID is stored in a
260file so you can easily stop it later.
261
262=head1 EXPORTED FUNCTIONS
263
264=over 4
265
266=item daemonize
267
268Main routine.  Arguments are user (or userid), group (or group id or
269space delimited list of groups), and pid_file (path to file).  This
270routine will check on the pid file, safely fork, create the pid file
271(storing the pid in the file), become another user and group, close
272STDIN, STDOUT and STDERR, separate from the process group (become
273session leader), and install $SIG{INT} to remove the pid file.  In
274otherwords - daemonize.  All errors result in a die.  As of version
2750.89 the pid_file is optional.
276
277=item safe_fork
278
279Block SIGINT during fork.  No arguments.  Returns pid of forked child.
280All errors result in a die.
281
282=item set_user
283
284Become another user and group.  Arguments are user (or userid) and
285group (or group id or space delimited list of groups).
286
287=item set_uid
288
289Become another user.  Argument is user (or userid).  All errors die.
290
291=item set_gid
292
293Become another group.  Arguments are groups (or group ids or space
294delimited list of groups or group ids).  All errors die.
295
296=item get_uid
297
298Find the uid.  Argument is user (userid returns userid).  Returns
299userid.  All errors die.
300
301=item get_gid
302
303Find the gids.  Arguments are groups or space delimited list of
304groups.  All errors die.
305
306=item is_root_user
307
308Determine if the process is running as root.  Returns 1 or undef.
309
310=item check_pid_file
311
312Arguments are pid_file (full path to pid_file).  Checks for existence
313of pid_file.  If file exists, open it and determine if the process
314that created it is still running.  This is done first by checking for
315a /proc file system and second using a "ps" command (BSD syntax).  (If
316neither of these options exist it assumed that the process has ended)
317If the process is still running, it aborts.  Otherwise, returns true.
318All errors die.
319
320=item create_pid_file.
321
322Arguments are pid_file (full path to pid_file).  Calls check_pid_file.
323If it is successful (no pid_file exists), creates a pid file and
324stores $$ in the file.
325
326=item unlink_pid_file
327
328Does just that.
329
330=back
331
332=head1 SEE ALSO
333
334L<Net::Server>.
335L<Net::Daemon>, The Perl Cookbook Recipe 17.15.
336
337=head1 AUTHORS
338
339Jeremy Howard <j+daemonize@howard.fm>
340
341Program flow, concepts and initial work.
342
343Paul Seamons <paul@seamons.com>
344
345Code rework and componentization.
346Ongoing maintainer.
347
348=head1 LICENSE
349
350  This package may be distributed under the terms of either the
351  GNU General Public License
352    or the
353  Perl Artistic License
354
355  All rights reserved.
356
357=cut
358