File Coverage

blib/lib/Script/Daemonizer.pm
Criterion Covered Total %
statement 108 186 58.0
branch 41 122 33.6
condition 7 21 33.3
subroutine 23 30 76.6
pod 5 5 100.0
total 184 364 50.5


line stmt bran cond sub pod time code
1             package Script::Daemonizer;
2              
3 4     4   89109 use 5.006;
  4         16  
  4         146  
4 4     4   22 use strict;
  4         7  
  4         121  
5 4     4   26 use warnings;
  4         17  
  4         132  
6 4     4   22 use Carp qw/carp croak/;
  4         4  
  4         293  
7 4     4   3525 use POSIX qw(:signal_h);
  4         27356  
  4         23  
8 4     4   6168 use Fcntl qw/:DEFAULT :flock/;
  4         11  
  4         1889  
9 4     4   3604 use FindBin ();
  4         4387  
  4         81  
10 4     4   23 use File::Spec;
  4         7  
  4         62  
11 4     4   18 use File::Basename ();
  4         7  
  4         439  
12              
13             $Script::Daemonizer::VERSION = '1.01.01';
14              
15             # ------------------------------------------------------------------------------
16             # 'Private' vars
17             # ------------------------------------------------------------------------------
18             my @argv_copy;
19             my $devnull = File::Spec->devnull;
20             my @daemon_options = ( qw{
21             chdir
22             do_not_tie_stdhandles
23             drop_privileges
24             output_file
25             pidfile
26             restart_on
27             setsid
28             sigunmask
29             stdout_file
30             stderr_file
31              
32             _DEBUG
33             } );
34             my %id_map = (
35             user => 'uid',
36             group => 'gid',
37             euser => 'euid',
38             egroup => 'egid',
39             );
40             my $global_pidfh;
41             my %defaults = (
42             working_dir => File::Spec->rootdir(),
43             umask => 0,
44             );
45              
46              
47              
48             ################################################################################
49             # SAVING @ARGV for restart()
50             ################################################################################
51             #
52             # restart() needs the exact list of arguments in order to relaunch the script,
53             # if requested.
54             # User is free to shift(@ARGV) and/or modify it in any way, we ensure we always
55             # get the "real" args (unless someone takes some extra effort to modify them
56             # before we get here).
57             # restart() gets an array of args, thoug, so there is no need to tamper with
58             # this:
59              
60             BEGIN {
61 4     4   3616 @argv_copy = @ARGV;
62             }
63              
64             ################################################################################
65             # HANDLING SIGHUP
66             ################################################################################
67             #
68             # When the script restarts itself upon receiving SIGHUP, that signal is masked.
69             # When starting, we unmask the signals so that they do not stop working for us.
70             # We do this regardless of how we were launched.
71             #
72             {
73             my $sigset = POSIX::SigSet->new( SIGHUP ); # Just handle HUP
74             sigprocmask(SIG_UNBLOCK, $sigset);
75             }
76              
77              
78              
79             ################################################################################
80             # HANDLING IMPORT TAGS
81             ################################################################################
82              
83             sub import {
84 4     4   37 my $class = shift;
85 4         4110 for my $opt (@_) {
86 2 100       7 if ($opt eq ':NOCHDIR') {
    50          
87 1         3 delete $defaults{working_dir};
88             } elsif ($opt eq ':NOUMASK') {
89 1         1638 delete $defaults{umask};
90             } else {
91 0         0 croak "Unknown tag: $opt";
92             }
93             }
94             }
95              
96              
97              
98             # ------------------------------------------------------------------------------
99             # 'Private' functions
100             # ------------------------------------------------------------------------------
101              
102             ################
103             # sub _debug() #
104             ################
105              
106             sub _debug {
107 5     5   10 my $self = shift;
108 5 50       17 print @_, "\n"
109             if $self->{_DEBUG};
110             }
111              
112              
113             ##################
114             # sub _set_umask #
115             ##################
116              
117             sub _set_umask {
118 2     2   4 my $self = shift;
119 2 50       38 defined(umask($self->{umask})) or
120             croak qq(Cannot set umask to "), $self->{umask}, qq(": $!);
121             }
122              
123             ###############
124             # sub _fork #
125             ###############
126             # fork() a child
127             sub _fork {
128 0     0   0 my $self = shift;
129              
130 0 0       0 return unless $self->{fork}; # Just in case, but already checked when
131             # _fork() is called
132              
133             # See http://code.activestate.com/recipes/278731/ or the source of
134             # Proc::Daemon for a discussion on ignoring SIGHUP.
135             # Since ignoring it across the fork() should not be harmful, I prefer to set
136             # this to IGNORE anyway.
137 0         0 local $SIG{'HUP'} = 'IGNORE';
138              
139 0 0       0 defined(my $pid = fork())
140             or croak "Cannot fork: $!";
141              
142 0 0       0 exit 0 if $pid; # parent exits here
143              
144 0         0 $self->{fork}--;
145              
146 0         0 $self->_debug("Forked, remaining forks: ", $self->{fork});
147              
148             }
149              
150             ###############
151             # sub _setsid #
152             ###############
153              
154             sub _setsid {
155 1     1   9 my $self = shift;
156             return if
157 1 50 33     23 ( exists $self->{ setsid } && $self->{ setsid } eq 'SKIP' );
158 1 50       49 POSIX::setsid() or
159             croak "Unable to set session id: $!";
160             }
161              
162             #########################
163             # sub _write_pidfile #
164             #########################
165             # Open the pidfile (creating it if necessary), then lock it, then truncate it,
166             # then write pid into it. Then retun filehandle.
167             # If environment variable $_pidfile_fileno is set, then we assume we're product
168             # of an exec() and take that file descriptor as the (already opened) pidfile.
169             sub _write_pidfile {
170 2     2   14 my $self = shift;
171 2         4 my $pidfile = $self->{pidfile};
172 2         6 my $fh;
173              
174             # First we must see if there is a _pidfile_fileno variable in environment;
175             # that means that we were started by an exec() and we must keep the same
176             # pidfile as before
177 2         16 my $pidfd = delete $ENV{_pidfile_fileno};
178 2 50 33     14 if (defined $pidfd && $pidfd =~ /^\d+$/) {
179 0         0 $self->_debug("Reopening pidfile from file descriptor");
180 0 0       0 open($fh, ">&=$pidfd")
181             or croak "can't open fd $pidfd: $!";
182             # Re-set close-on-exec bit for pidfile filehandle
183 0 0       0 fcntl($fh, F_SETFD, 1)
184             or die "Can't set close-on-exec flag on pidfile filehandle: $!\n";
185             } else {
186 2         10 $self->_debug("Opening a new pid file");
187             # Open configured pidfile
188 2 50       276 sysopen($fh, $pidfile, O_RDWR | O_CREAT)
189             or croak "can't open $pidfile: $!";
190             }
191 2 50       24 flock($fh, LOCK_EX|LOCK_NB)
192             or croak "can't lock $pidfile: $! - is another instance running?";
193 2 50       82 truncate($fh, 0)
194             or croak "can't truncate $pidfile: $!";
195              
196 2         18 select((select( $fh ), ++$|)[0]);
197              
198 2         112 print $fh $$;
199              
200             # Save it as a global so that in short init syntax
201             # Script::Daemonizer->new( pidfile => $pfile )->daemonize;
202             # it stays in scope
203 2         26 return $global_pidfh = $self->{pidfh} = $fh;
204             }
205              
206              
207             ##############
208             # sub _chdir #
209             ##############
210              
211             sub _chdir {
212 1     1   3 my $self = shift;
213 1 50       36 chdir($self->{'working_dir'}) or
214             croak "Cannot change directory to ", $self->{'working_dir'}, ": $!";
215             }
216              
217              
218             #################
219             # sub _close #
220             #################
221             # Handle closing of STDOUT/STDERR
222             sub _close {
223 0     0   0 my $self = shift;
224 0         0 my $fh = shift;
225             # Have to lookup handles by name
226 0         0 $self->_debug("Closing $fh");
227 4     4   33 no strict "refs";
  4         11  
  4         612  
228 0 0       0 open *$fh, '>', $devnull
229             or croak "Unable to open $fh on $devnull: $!";
230              
231             }
232              
233             #################
234             # sub _redirect #
235             #################
236              
237             sub _redirect {
238 2     2   14 my ( $self, $fh, $destination ) = @_;
239              
240 2 50       11 $destination = $devnull
241             if $destination eq '/dev/null';
242              
243 2         6 $self->_debug("Redirecting $fh on: $destination ", $destination);
244 4     4   22 no strict "refs";
  4         10  
  4         6153  
245 2 50       138 open *$fh, '>>', $destination
246             or croak "Unable to open $fh on $destination: $!";
247              
248             }
249              
250             ##########################
251             # sub _manage_stdhandles #
252             ##########################
253             sub _manage_stdhandles {
254 1     1   19 my $self = shift;
255              
256 1 50       112 open STDIN, '<', $devnull
257             or croak "Cannot reopen STDIN on $devnull: $!";
258              
259             # If we were requested to redirect output on a file, do it now and return
260 1 50       4 if ($self->{output_file}) {
261 1         6 $self->_debug("Using output file");
262 1         16 $self->_redirect( $_, $self->{output_file}) for (qw{STDOUT STDERR});
263 1         13 return 1;
264             }
265              
266             # Use Tie::Syslog unless both stdout/stderr redirected to file
267 0 0 0     0 unless ($self->{stdout_file} && $self->{stderr_file}) {
268 0         0 $self->_debug("Using Tie::Syslog");
269 0         0 eval {
270 0         0 require Tie::Syslog;
271             };
272              
273 0 0       0 if ($@) {
274 0 0       0 carp "Unable to load Tie::Syslog module. Error is:\n----\n$@----\nI will continue without output"
275             if $self->{_DEBUG};
276 0         0 $self->_close( $_ ) for (qw{STDOUT STDERR});
277 0         0 return 0;
278             }
279              
280 0         0 $Tie::Syslog::ident = $self->{name};
281 0         0 $Tie::Syslog::logopt = 'ndelay,pid';
282             }
283              
284             # STDOUT
285 0 0       0 if ($self->{stdout_file}) {
286 0         0 $self->_redirect( 'STDOUT', $self->{stdout_file} );
287             } else {
288 0         0 $self->_close( 'STDOUT' );
289 0         0 $self->_debug("Tying STDOUT to Tie::Syslog");
290 0         0 tie *STDOUT, 'Tie::Syslog', {
291             facility => 'LOG_DAEMON',
292             priority => 'LOG_INFO',
293             };
294             }
295              
296             # STDERR
297 0 0       0 if ($self->{stderr_file}) {
298 0         0 $self->_redirect( 'STDERR', $self->{stderr_file} );
299             } else {
300 0         0 $self->_close( 'STDERR' );
301 0         0 $self->_debug("Tying STDERR to Tie::Syslog");
302 0         0 tie *STDERR, 'Tie::Syslog', {
303             facility => 'LOG_DAEMON',
304             priority => 'LOG_ERR',
305             };
306             }
307              
308             }
309              
310             ########################
311             # sub _get_signal_list #
312             ########################
313             sub _get_signal_list {
314 0     0   0 my $self = shift;
315              
316             }
317              
318             # ------------------------------------------------------------------------------
319             # 'Public' functions
320             # ------------------------------------------------------------------------------
321              
322             sub drop_privileges {
323              
324 6     6 1 32 my $self = shift;
325              
326             # Check parameters:
327 6 50       20 croak "Odd number of arguments in drop_privileges() call!"
328             if @_ % 2;
329              
330             # Get parameters
331 6 100       20 my %ids = @_ ? @_ : %{ $self->{drop_privileges} };
  4         20  
332              
333             # Resolve user name to user id if given
334 6         16 for (qw{ user euser }) {
335 12 100       42 defined( my $us = delete $ids{ $_ } )
336             or next;
337 4 50       290 defined ( $ids{ $id_map{ $_ } } = getpwnam( $us ) )
338             or croak "No such user: $us";
339             }
340              
341             # Resolve group name to group id if given
342 6         12 for (qw{ group egroup }) {
343 12 100       36 defined( my $gr = delete $ids{ $_ } )
344             or next;
345 4 50       214 defined ( $ids{ $id_map{ $_ } } = getgrnam( $gr ) )
346             or croak "No such group: $gr";
347             }
348              
349             # Get ids
350 6         18 my ($euid, $egid, $uid, $gid) = @ids{qw(euid egid uid gid)};
351              
352             # Drop GROUP ID
353 6 50       24 if (defined $gid) {
    0          
354 6 50       78 POSIX::setgid((split " ", $gid)[0])
355             or croak "POSIX::setgid() failed: $!";
356             } elsif (defined $egid) {
357             # $egid might be a list
358 0         0 $) = $egid;
359 0 0       0 croak "Cannot drop effective group id to $egid: $!"
360             if $!;
361             }
362              
363             # Drop USER ID
364 6 50       16 if (defined $uid) {
    0          
365 6 50       48 POSIX::setuid($uid)
366             or croak "POSIX::setuid() failed: $!";
367             } elsif (defined $euid) {
368             # Drop EUID too, unless explicitly forced to something else
369 0         0 $> = $euid;
370 0 0       0 croak "Cannot drop effective user id to $uid: $!"
371             if $!;
372             }
373              
374 6         80 return 1;
375              
376             }
377              
378             sub new {
379              
380 15     15 1 12992 my $pkg = shift;
381              
382 15 50       52 croak ("This is a class method!")
383             if ref($pkg);
384              
385 15 100       211 croak "Odd number of arguments in configuration!"
386             if @_ %2;
387              
388 14         83 my $self = {
389             %defaults,
390             };
391              
392             # Get the configuration
393 14         50 my %params = @_;
394              
395             # Set useful defaults
396 14   66     365 $self->{name} = delete $params{name} || (File::Spec->splitpath($0))[-1];
397 14 50 33     81 $self->{fork} = (exists $params{fork} && $params{fork} =~ /^[012]$/)
398             ? delete $params{fork}
399             : 2;
400              
401 14 50       32 $self->{working_dir} = delete $params{working_dir} if $params{working_dir};
402              
403 14 50       85 if (exists $params{umask}) {
404 0 0       0 croak "Invalid umask specified: ", $params{umask}
405             unless $params{umask} =~ /^[0-7]{1,3}$/;
406 0         0 $self->{umask} = delete $params{umask};
407             }
408              
409             # Get other options as they are:
410 14         42 for (@daemon_options) {
411 154 100       353 $self->{ $_ } = delete $params{ $_ }
412             if exists $params{ $_ };
413             }
414              
415 14         35 my @extra_args = keys %params;
416             {
417 14         18 local $" = ", ";
  14         25  
418 14 100       158 croak sprintf "Invalid argument(s) passed: @extra_args"
419             if @extra_args;
420             }
421              
422 13         28 bless $self, $pkg;
423              
424             # Set up signal handlers
425 13 50 33     49 if ($self->{restart_on} && ref $self->{restart_on} eq 'ARRAY') {
426 0         0 my @sigs = @{ $self->{restart_on} };
  0         0  
427 0         0 for (@sigs) {
428             $SIG{ $_ } = sub {
429 0     0   0 $self->restart();
430 0         0 };
431             }
432 0         0 $self->sigunmask( @sigs );
433             }
434              
435             # Unmask signals if requested
436 13 50 33     34 if ($self->{sigunmask} && ref $self->{sigunmask} eq 'ARRAY') {
437 0         0 $self->sigunmask(@{ $self->{sigunmask} });
  0         0  
438             }
439              
440 13         293 return $self;
441              
442             }
443              
444             sub daemonize {
445 0     0 1   my $self = shift;
446              
447             # Step 0.0 - OPTIONAL: drop privileges
448 0 0         $self->drop_privileges
449             if $self->{drop_privileges};
450              
451             # Step 1.
452 0 0         $self->_set_umask
453             if exists $self->{umask};
454              
455             # Step 2.
456 0 0         $self->_fork()
457             if $self->{fork};
458              
459             # Step 3.
460 0           $self->_setsid();
461              
462             # Step 4.
463 0 0         $self->_fork()
464             if $self->{fork};
465              
466             # Step 4.5 - OPTIONAL: take a lock on pidfile
467             # (and write pid into it)
468 0 0         $self->_write_pidfile()
469             if $self->{pidfile};
470              
471             # Step 5.
472 0 0         $self->_chdir()
473             if $self->{working_dir};
474              
475              
476             # Step 6.
477             # REMOVED!
478              
479              
480             # Step 7.
481 0           $self->_manage_stdhandles();
482              
483 0           return 1;
484              
485             }
486              
487             sub restart {
488              
489 0     0 1   my $self = shift;
490              
491 0 0         my @args = @_ ? @_ : @argv_copy;
492              
493             # See perlipc
494             # make the daemon cross-platform, so exec always calls the script
495             # itself with the right path, no matter how the script was invoked.
496 0           my $script = File::Basename::basename($0);
497 0           my $SELF = File::Spec->catfile($FindBin::Bin, $script);
498              
499             # $pidf must be kept open across exec() if we don't want race conditions:
500 0 0         if (my $pidfh = $self->{pidfh}) {
501 0           $self->_debug("Keeping current pidfile open");
502             # Clear close-on-exec bit for pidfile filehandle
503 0 0         fcntl($pidfh, F_SETFD, 0)
504             or die "Can't clear close-on-exec flag on pidfile filehandle: $!\n";
505             # Now we must notify ourseves that pidfile is already open
506 0           $ENV{_pidfile_fileno} = fileno( $pidfh );
507             }
508              
509 0 0         exec($SELF, @args)
510             or croak "$0: couldn't restart: $!";
511              
512             }
513              
514             # Bye default, we unmask SIGHUP but, if other signals must be unmasked too,
515             # then use this and pass in a list of signals to be unmasked.
516             sub sigunmask {
517 0     0 1   my $self = shift;
518 0 0         croak "sigunmask called without arguments"
519             unless @_;
520 4     4   24 no strict "refs";
  4         8  
  4         619  
521             # Have to convert manually signal names into numbers. I remove the prefix
522             # POSIX::[SIG] from signal name and add it back again, this allows user to
523             # refer to signals in any way, for example:
524             # QUIT
525             # SIGQUIT
526             # POSIX::QUIT
527             # POSIX::SIGQUIT
528 0           my @sigs = map {
529 0           ( my $signal = $_ ) =~ s/^POSIX:://;
530 0           $signal =~ s/^SIG//;
531 0           $signal = "POSIX::SIG".$signal;
532 0           &$signal
533             } @_;
534 0           my $sigset = POSIX::SigSet->new( @sigs ); # Handle all given signals
535 0           sigprocmask(SIG_UNBLOCK, $sigset);
536             }
537              
538              
539             'End of Script::Daemonizer'
540              
541             __END__