File Coverage

blib/lib/Net/Server/Daemonize.pm
Criterion Covered Total %
statement 9 107 8.4
branch 0 70 0.0
condition 0 8 0.0
subroutine 3 16 18.7
pod 10 12 83.3
total 22 213 10.3


line stmt bran cond sub pod time code
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
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              
21             package Net::Server::Daemonize;
22              
23 28     28   165 use strict;
  28         89  
  28         917  
24 28     28   153 use base qw(Exporter);
  28         54  
  28         2808  
25 28     28   173 use POSIX qw(SIGINT SIG_BLOCK SIG_UNBLOCK);
  28         58  
  28         148  
26              
27             our $VERSION = "0.06";
28              
29             our @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 existance of pid_file
36             ### if the file exists, check for a running process
37             sub check_pid_file ($) {
38 0     0 1   my $pid_file = shift;
39 0 0         return 1 if ! -e $pid_file;
40              
41 0 0         open my $fh, '<', $pid_file or die "Couldn't open existant pid_file \"$pid_file\" [$!]\n";
42 0           my $current_pid = <$fh>;
43 0           close $fh;
44 0 0         $current_pid = ($current_pid =~ /^(\d{1,10})/) ? $1 : die "Couldn't find pid in existing pid_file";
45              
46 0           my $exists;
47 0 0         if ($$ == $current_pid) {
    0          
    0          
48 0           warn "Pid_file created by this same process. Doing nothing.\n";
49 0           return 1;
50             } elsif (-d "/proc/$$") { # try a proc file system
51 0           $exists = -e "/proc/$current_pid";
52             } elsif (kill 0, $current_pid) {
53 0           $exists = 1;
54             }
55 0 0         die "Pid_file already exists for running process ($current_pid)... aborting\n"
56             if $exists;
57              
58             # remove the pid_file
59 0           warn "Pid_file \"$pid_file\" already exists. Overwriting!\n";
60 0   0       unlink $pid_file || die "Couldn't remove pid_file \"$pid_file\" [$!]\n";
61 0           return 1;
62             }
63              
64             ### actually create the pid_file, calls check_pid_file
65             ### before proceeding
66             sub create_pid_file ($) {
67 0     0 0   my $pid_file = shift;
68              
69 0           check_pid_file($pid_file);
70              
71 0 0         open my $fh, '>', $pid_file or die "Couldn't open pid file \"$pid_file\" [$!].\n";
72 0           print $fh "$$\n";
73 0           close $fh;
74              
75 0 0         die "Pid_file \"$pid_file\" not created.\n" if ! -e $pid_file;
76 0           return 1;
77             }
78              
79             ### Allow for safe removal of the pid_file.
80             ### Make sure this process owns it.
81             sub unlink_pid_file ($) {
82 0     0 1   my $pid_file = shift;
83 0 0         return 1 if ! -e $pid_file; # no pid_file = return success
84              
85 0 0         open my $fh, '<', $pid_file or die "Couldn't open existant pid_file \"$pid_file\" [$!]\n"; # slight race
86 0           my $current_pid = <$fh>;
87 0           close $fh;
88 0           chomp $current_pid;
89              
90 0 0         die "Process $$ doesn't own pid_file \"$pid_file\". Can't remove it.\n"
91             if $current_pid ne $$;
92              
93 0 0         unlink($pid_file) || die "Couldn't unlink pid_file \"$pid_file\" [$!]\n";
94 0           return 1;
95             }
96              
97             ###----------------------------------------------------------------###
98              
99             sub is_root_user () {
100 0     0 1   my $id = get_uid('root');
101 0   0       return ! defined($id) || $< == $id || $> == $id;
102             }
103              
104             ### get the uid for the passed user
105             sub get_uid ($) {
106 0     0 1   my $user = shift;
107 0 0         my $uid = ($user =~ /^(\d+)$/) ? $1 : getpwnam($user);
108 0 0         die "No such user \"$user\"\n" unless defined $uid;
109 0           return $uid;
110             }
111              
112             ### get all of the gids that this group is (space delimited)
113             sub get_gid {
114 0     0 1   my @gid;
115              
116 0           foreach my $group ( split( /[, ]+/, join(" ",@_) ) ){
117 0 0         if( $group =~ /^\d+$/ ){
118 0           push @gid, $group;
119             }else{
120 0           my $id = getgrnam($group);
121 0 0         die "No such group \"$group\"\n" unless defined $id;
122 0           push @gid, $id;
123             }
124             }
125              
126 0 0         die "No group found in arguments.\n" unless @gid;
127 0           return join(" ",$gid[0],@gid);
128             }
129              
130             ### change the process to run as this uid
131             sub set_uid {
132 0     0 1   my $uid = get_uid(shift());
133              
134 0           POSIX::setuid($uid);
135 0 0 0       if ($< != $uid || $> != $uid) { # check $> also (rt #21262)
136 0           $< = $> = $uid; # try again - needed by some 5.8.0 linux systems (rt #13450)
137 0 0         if ($< != $uid) {
138 0           die "Couldn't become uid \"$uid\": $!\n";
139             }
140             }
141              
142 0           return 1;
143             }
144              
145             ### change the process to run as this gid(s)
146             ### multiple groups must be space or comma delimited
147             sub set_gid {
148 0     0 1   my $gids = get_gid(@_);
149 0           my $gid = (split /\s+/, $gids)[0];
150 0           eval { $) = $gids }; # store all the gids - this is really sort of optional
  0            
151              
152 0           POSIX::setgid($gid);
153 0 0         if (! grep {$gid == $_} split /\s+/, $() { # look for any valid id in the list
  0            
154 0           die "Couldn't become gid \"$gid\": $!\n";
155             }
156              
157 0           return 1;
158             }
159              
160             ### backward compatibility sub
161             sub set_user {
162 0     0 1   my ($user, @group) = @_;
163 0 0         set_gid(@group) || return undef;
164 0 0         set_uid($user) || return undef;
165 0           return 1;
166             }
167              
168             ###----------------------------------------------------------------###
169              
170             ### routine to protect process during fork
171             sub safe_fork () {
172              
173             # block signal for fork
174 0     0 1   my $sigset = POSIX::SigSet->new(SIGINT);
175 0 0         POSIX::sigprocmask(SIG_BLOCK, $sigset) or die "Can't block SIGINT for fork: [$!]\n";
176              
177 0           my $pid = fork;
178 0 0         die "Couldn't fork: [$!]" if ! defined $pid;
179              
180 0           $SIG{'INT'} = 'DEFAULT'; # make SIGINT kill us as it did before
181              
182 0 0         POSIX::sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock SIGINT for fork: [$!]\n";
183              
184 0           return $pid;
185             }
186              
187             ###----------------------------------------------------------------###
188              
189             ### routine to completely dissociate from terminal process.
190             sub daemonize ($$$) {
191 0     0 1   my ($user, $group, $pid_file) = @_;
192              
193 0 0         check_pid_file($pid_file) if defined $pid_file;
194              
195 0           my $uid = get_uid($user);
196 0           my $gid = get_gid($group); # returns list of groups
197 0           $gid = (split /\s+/, $gid)[0];
198              
199 0           my $pid = safe_fork();
200              
201 0 0         exit(0) if $pid; # exit parent
202              
203             # child
204 0 0         create_pid_file($pid_file) if defined $pid_file;
205 0 0         chown($uid, $gid, $pid_file) if defined $pid_file;
206              
207 0           set_user($uid, $gid);
208              
209 0 0         open STDIN, '<', '/dev/null' or die "Can't open STDIN from /dev/null: [$!]\n";
210 0 0         open STDOUT, '>', '/dev/null' or die "Can't open STDOUT to /dev/null: [$!]\n";
211 0 0         open STDERR, '>&STDOUT' or die "Can't open STDERR to STDOUT: [$!]\n";
212              
213             ### does this mean to be chroot ?
214 0 0         chdir '/' or die "Can't chdir to \"/\": [$!]";
215              
216 0           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 0 0   0     $SIG{'INT'} = sub { HUNTSMAN($pid_file) } if defined $pid_file;
  0            
220 0           return 1;
221             }
222              
223             ### SIGINT routine that will remove the pid_file
224             sub HUNTSMAN {
225 0     0 0   my $path = shift;
226 0           unlink $path;
227              
228 0           eval {
229 0           require Unix::Syslog;
230 0           Unix::Syslog::syslog(Unix::Syslog::LOG_ERR(), "Exiting on INT signal.");
231             };
232              
233 0           exit;
234             }
235              
236              
237             1;
238              
239             __END__