File Coverage

lib/Proc/DaemonLite.pm
Criterion Covered Total %
statement 37 150 24.6
branch 1 54 1.8
condition 1 18 5.5
subroutine 13 32 40.6
pod 9 11 81.8
total 61 265 23.0


line stmt bran cond sub pod time code
1             ############################################################
2             #
3             # $Id: DaemonLite.pm 946 2007-02-11 15:14:13Z nicolaw $
4             # Proc::DaemonLite - Simple server daemonisation module
5             #
6             # Copyright 2006,2007 Nicola Worthington
7             #
8             # Licensed under the Apache License, Version 2.0 (the "License");
9             # you may not use this file except in compliance with the License.
10             # You may obtain a copy of the License at
11             #
12             # http://www.apache.org/licenses/LICENSE-2.0
13             #
14             # Unless required by applicable law or agreed to in writing, software
15             # distributed under the License is distributed on an "AS IS" BASIS,
16             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
17             # See the License for the specific language governing permissions and
18             # limitations under the License.
19             #
20             ############################################################
21              
22             package Proc::DaemonLite;
23             # vim:ts=4:sw=4:tw=78
24              
25 2     2   21006 use strict;
  2         89  
  2         100  
26 2     2   13 use Exporter;
  2         5  
  2         114  
27 2     2   20 use Carp qw(croak cluck carp);
  2         4  
  2         246  
28 2     2   3107 use POSIX qw(:signal_h setsid WNOHANG);
  2         18122  
  2         15  
29 2     2   3142 use File::Basename qw(basename);
  2         4  
  2         131  
30 2     2   1918 use IO::File;
  2         32390  
  2         518  
31 2     2   23 use Cwd qw(getcwd);
  2         4  
  2         105  
32 2     2   7401 use Sys::Syslog qw(:DEFAULT setlogsock);
  2         32788  
  2         450  
33              
34 2 50 33 2   23 use constant PIDPATH => -d '/var/run' && -w _ ? '/var/run' : '/var/tmp';
  2         6  
  2         222  
35 2     2   10 use constant FACILITY => 'local0';
  2         4  
  2         90  
36              
37 2         264 use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS @ISA
38 2     2   11 $DEBUG %CHILDREN $SCRIPT);
  2         4  
39              
40 2     2   10 BEGIN { use vars qw($SCRIPT); $SCRIPT = $0; }
  2     2   4  
  2         66  
  2         6569  
41              
42             $VERSION = '0.01' || sprintf('%d', q$Revision: 946 $ =~ /(\d+)/g);
43             $DEBUG = $ENV{DEBUG} ? 1 : 0;
44              
45             @ISA = qw(Exporter);
46             @EXPORT_OK = qw(&init_server &kill_children &launch_child &do_relaunch
47             &log_debug &log_notice &log_warn &log_die &log_info %CHILDREN);
48             @EXPORT = qw(&init_server);
49             %EXPORT_TAGS = (all => \@EXPORT_OK);
50              
51             # These are private
52             my ($pid, $pidfile, $saved_dir, $CWD);
53              
54             sub init_server {
55 0     0 1   TRACE('init_server()');
56 0           my ($user, $group);
57 0           ($pidfile, $user, $group) = @_;
58 0   0       $pidfile ||= _getpidfilename();
59 0           my $fh = _open_pid_file($pidfile);
60 0           _become_daemon();
61 0           print $fh $$;
62 0           close $fh;
63 0           _init_log();
64 0 0 0       _change_privileges($user, $group) if defined $user && defined $group;
65 0           return $pid = $$;
66             }
67              
68             sub _become_daemon {
69 0     0     TRACE('_become_daemon()');
70 0 0         croak "Can't fork" unless defined(my $child = fork);
71 0 0         exit(0) if $child; # parent dies;
72 0           POSIX::setsid(); # become session leader
73 0           open(STDIN, "
74 0           open(STDOUT, ">/dev/null");
75 0           open(STDERR, ">&STDOUT");
76 0           $CWD = Cwd::getcwd; # remember working directory
77 0           chdir('/'); # change working directory
78 0           umask(0); # forget file mode creation mask
79 0           $ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin';
80 0           delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
81 0           $SIG{CHLD} = \&_reap_child;
82             }
83              
84             sub _change_privileges {
85 0     0     TRACE('_change_privileges()');
86 0           my ($user, $group) = @_;
87 0 0         my $uid = getpwnam($user) or die "Can't get uid for $user\n";
88 0 0         my $gid = getgrnam($group) or die "Can't get gid for $group\n";
89 0           $) = "$gid $gid";
90 0           $( = $gid;
91 0           $> = $uid; # change the effective UID (but not the real UID)
92             }
93              
94             sub launch_child {
95 0     0 1   TRACE('launch_child()');
96 0           my $callback = shift;
97 0           my $home = shift;
98              
99 0           my $signals = POSIX::SigSet->new(SIGINT, SIGCHLD, SIGTERM, SIGHUP);
100 0           sigprocmask(SIG_BLOCK, $signals); # block inconvenient signals
101 0 0         log_die("Can't fork: $!") unless defined(my $child = fork());
102              
103 0 0         if ($child) {
104 0   0       $CHILDREN{$child} = $callback || 1;
105             } else {
106 0           $SIG{HUP} = $SIG{INT} = $SIG{CHLD} = $SIG{TERM} = 'DEFAULT';
107 0           _prepare_child($home);
108             }
109 0           sigprocmask(SIG_UNBLOCK, $signals); # unblock signals
110              
111 0           return $child;
112             }
113              
114             sub _prepare_child {
115 0     0     TRACE('_prepare_child()');
116 0           my $home = shift;
117 0 0         if ($home) {
118 0           local ($>, $<) = ($<, $>); # become root again (briefly)
119 0 0         chdir($home) || croak "chdir(): $!";
120 0 0         chroot($home) || croak "chroot(): $!";
121             }
122 0           $< = $>; # set real UID to effective UID
123             }
124              
125             sub _reap_child {
126 0     0     TRACE('_reap_child()');
127 0           while ((my $child = waitpid(-1, WNOHANG)) > 0) {
128 0 0         $CHILDREN{$child}->($child) if ref $CHILDREN{$child} eq 'CODE';
129 0           delete $CHILDREN{$child};
130             }
131             }
132              
133             sub kill_children {
134 0     0 1   TRACE('kill_children()');
135 0           DUMP('%CHILDREN',\%CHILDREN);
136 0           kill TERM => keys %CHILDREN;
137              
138             # wait until all the children die
139 0           sleep while %CHILDREN;
140             }
141              
142             sub do_relaunch {
143 0     0 1   TRACE('do_relaunch()');
144 0           $> = $<; # regain privileges
145 0 0         chdir $1 if $CWD =~ m!([./a-zA-z0-9_-]+)!;
146 0 0         croak "bad program name" unless $SCRIPT =~ m!([./a-zA-z0-9_-]+)!;
147 0           my $program = $1;
148 0           unlink($pidfile);
149              
150 0           my @perl = ($^X);
151 0 0         push @perl, '-T' if ${^TAINT} eq 1;
152 0 0         push @perl, '-t' if ${^TAINT} eq -1;
153 0 0         push @perl, '-w' if $^W;
154              
155 0 0         exec(@perl, $program, @ARGV) or croak "Couldn't exec: $!";
156             }
157              
158             sub _init_log {
159 0     0     TRACE('_init_log()');
160 0           Sys::Syslog::setlogsock('unix');
161 0           my $basename = File::Basename::basename($SCRIPT);
162 0           openlog($basename, 'pid', FACILITY);
163 0           $SIG{__WARN__} = \&log_warn;
164 0           $SIG{__DIE__} = \&log_die;
165             }
166              
167 0     0 1   sub log_debug { TRACE('log_debug()'); syslog('debug', _msg(@_)) }
  0            
168 0     0 1   sub log_notice { TRACE('log_notice()'); syslog('notice', _msg(@_)) }
  0            
169 0     0 1   sub log_warn { TRACE('log_warn()'); syslog('warning', _msg(@_)) }
  0            
170 0     0 1   sub log_info { TRACE('log_info()'); syslog('info', _msg(@_)) }
  0            
171              
172             sub log_die {
173 0     0 1   TRACE('log_die()');
174 0 0         Sys::Syslog::syslog('crit', _msg(@_)) unless $^S;
175 0           die @_;
176             }
177              
178             sub _msg {
179 0     0     TRACE('_msg()');
180 0   0       my $msg = join('', @_) || "Something's wrong";
181 0           my ($pack, $filename, $line) = caller(1);
182 0 0         $msg .= " at $filename line $line\n" unless $msg =~ /\n$/;
183 0           $msg;
184             }
185              
186             sub _getpidfilename {
187 0     0     TRACE('_getpidfilename()');
188 0           my $basename = File::Basename::basename($SCRIPT, '.pl');
189 0           return PIDPATH . "/$basename.pid";
190             }
191              
192             sub _open_pid_file {
193 0     0     TRACE('_open_pid_file()');
194 0           my $file = shift;
195              
196 0 0         if (-e $file) { # oops. pid file already exists
197 0   0       my $fh = IO::File->new($file) || return;
198 0           my $pid = <$fh>;
199 0 0         croak "Invalid PID file" unless $pid =~ /^(\d+)$/;
200 0 0         croak "Server already running with PID $1" if kill 0 => $1;
201 0           cluck "Removing PID file for defunct server process $pid.\n";
202 0 0 0       croak "Can't unlink PID file $file" unless -w $file && unlink $file;
203             }
204              
205 0 0         return IO::File->new($file, O_WRONLY | O_CREAT | O_EXCL, 0644)
206             or die "Can't create $file: $!\n";
207             }
208              
209             END {
210             $> = $<; # regain privileges
211             unlink $pidfile if defined $pid and $$ == $pid;
212             }
213              
214             sub TRACE {
215 0 0   0 0   return unless $DEBUG;
216 0           log_debug($_[0]);
217 0           warn(shift());
218             }
219              
220             sub DUMP {
221 0 0   0 0   return unless $DEBUG;
222 0           eval {
223 0           require Data::Dumper;
224 0           my $msg = shift().': '.Data::Dumper::Dumper(shift());
225 0           log_debug($msg);
226 0           warn($msg);
227             }
228             }
229              
230             1;
231              
232             =pod
233              
234             =head1 NAME
235              
236             Proc::DaemonLite - Simple server daemonisation module
237              
238             =head1 SYNOPSIS
239              
240             use strict;
241             use Proc::DaemonLite qw(:all);
242            
243             my $pid = init_server();
244             log_warn("Forked in to background PID $pid");
245            
246             $SIG{__WARN__} = \&log_warn;
247             $SIG{__DIE__} = \&log_die;
248            
249             for my $cid (1..4) {
250             my $child = launch_child();
251             if ($child == 0) {
252             log_warn("I am child PID $$") while sleep 2;
253             exit;
254             } else {
255             log_warn("Spawned child number $cid, PID $child");
256             }
257             }
258            
259             sleep 20;
260             kill_children();
261              
262             =head1 DESCRIPTION
263              
264             Proc::DaemonLite is a basic server daemonisation module that trys
265             to cater for most basic Perl daemon requirements.
266              
267             The POD for this module is incomplete, as is some of the tidying
268             of the code. It is however fully functional. This is a pre-release
269             in order to reserve the namespace before it becomes unavailable.
270              
271             =head1 EXPORTS
272              
273             By default only I is exported. The export tag I will export
274             the following: I, I,
275             I, I, I, I,
276             I, I, I and I<%CHILDREN>.
277              
278             =head2 init_server()
279              
280             my $pid = init_server($pidfile, $user, $group);
281              
282             =head2 launch_child()
283              
284             my $child_pid = launch_child($callback, $home);
285              
286             =head2 kill_children()
287              
288             kill_children();
289              
290             Terminate all children with a I signal.
291              
292             =head2 do_relaunch()
293              
294             do_relaunch()
295              
296             Attempt to start a new incovation of the current script.
297              
298             =head2 log_debug()
299              
300             log_debug(@messages);
301              
302             =head2 log_info()
303              
304             log_info(@messages);
305              
306             =head2 log_notice()
307              
308             log_notice(@messages);
309              
310             =head2 log_warn()
311              
312             log_warn(@messages);
313              
314             =head2 log_die()
315              
316             log_die(@messages);
317              
318             =head2 %CHILDREN
319              
320             I<%CHILDREN> is a hash of all child processes keyed by PID. Children
321             with registered callbacks will contain a reference to their callback
322             in this hash.
323              
324             =head1 SEE ALSO
325              
326             L, L, L,
327             L, L, L,
328             L, L,
329             L
330              
331             =head1 VERSION
332              
333             $Id: DaemonLite.pm 946 2007-02-11 15:14:13Z nicolaw $
334              
335             =head1 AUTHOR
336              
337             Nicola Worthington
338              
339             L
340              
341             If you like this software, why not show your appreciation by sending the
342             author something nice from her
343             L?
344             ( http://www.amazon.co.uk/gp/registry/1VZXC59ESWYK0?sort=priority )
345              
346             Original code written by Lincoln D. Stein, featured in "Network Programming
347             with Perl". L
348              
349             Released with permission of Lincoln D. Stein.
350              
351             =head1 COPYRIGHT
352              
353             Copyright 2006,2007 Nicola Worthington.
354              
355             This software is licensed under The Apache Software License, Version 2.0.
356              
357             L
358              
359             =cut
360              
361              
362             __END__