package Script::Daemonizer;
use 5.006;
use strict;
use warnings;
use Carp qw/carp croak/;
use POSIX qw(:signal_h);
use Fcntl qw/:DEFAULT :flock/;
use FindBin ();
use File::Spec;
use File::Basename ();
$Script::Daemonizer::VERSION = '0.93.04';
# ------------------------------------------------------------------------------
# 'Private' vars
# ------------------------------------------------------------------------------
my @argv_copy;
my $devnull = File::Spec->devnull;
my @daemon_options = ( qw{
chdir
do_not_tie_stdhandles
drop_privileges
output_file
pidfile
restart_on
setsid
sigunmask
stdout_file
stderr_file
_DEBUG
} );
my $global_pidfh;
my %defaults = (
working_dir => File::Spec->rootdir(),
umask => 0,
);
################################################################################
# SAVING @ARGV for restart()
################################################################################
#
# restart() needs the exact list of arguments in order to relaunch the script,
# if requested.
# User is free to shift(@ARGV) and/or modify it in any way, we ensure we always
# get the "real" args (unless someone takes some extra effort to modify them
# before we get here).
# restart() gets an array of args, thoug, so there is no need to tamper with
# this:
BEGIN {
@argv_copy = @ARGV;
}
################################################################################
# HANDLING SIGHUP
################################################################################
#
# When the script restarts itself upon receiving SIGHUP, that signal is masked.
# When starting, we unmask the signals so that they do not stop working for us.
# We do this regardless of how we were launched.
#
{
my $sigset = POSIX::SigSet->new( SIGHUP ); # Just handle HUP
sigprocmask(SIG_UNBLOCK, $sigset);
}
################################################################################
# HANDLING IMPORT TAGS
################################################################################
sub import {
my $class = shift;
for my $opt (@_) {
if ($opt eq ':NOCHDIR') {
delete $defaults{working_dir};
} elsif ($opt eq ':NOUMASK') {
delete $defaults{umask};
} else {
croak "Unknown tag: $opt";
}
}
}
# ------------------------------------------------------------------------------
# 'Private' functions
# ------------------------------------------------------------------------------
################
# sub _debug() #
################
sub _debug {
my $self = shift;
print @_, "\n"
if $self->{_DEBUG};
}
##################
# sub _set_umask #
##################
sub _set_umask {
my $self = shift;
defined(umask($self->{umask})) or
croak qq(Cannot set umask to "), $self->{umask}, qq(": $!);
}
###############
# sub _fork #
###############
# fork() a child
sub _fork {
my $self = shift;
return unless $self->{fork}; # Just in case, but already checked when
# _fork() is called
# See http://code.activestate.com/recipes/278731/ or the source of
# Proc::Daemon for a discussion on ignoring SIGHUP.
# Since ignoring it across the fork() should not be harmful, I prefer to set
# this to IGNORE anyway.
local $SIG{'HUP'} = 'IGNORE';
defined(my $pid = fork())
or croak "Cannot fork: $!";
exit 0 if $pid; # parent exits here
$self->{fork}--;
$self->_debug("Forked, remaining forks: ", $self->{fork});
}
###############
# sub _setsid #
###############
sub _setsid {
POSIX::setsid() or
croak "Unable to set session id: $!";
}
#########################
# sub _write_pidfile #
#########################
# Open the pidfile (creating it if necessary), then lock it, then truncate it,
# then write pid into it. Then retun filehandle.
# If environment variable $_pidfile_fileno is set, then we assume we're product
# of an exec() and take that file descriptor as the (already opened) pidfile.
sub _write_pidfile {
my $self = shift;
my $pidfile = $self->{pidfile};
my $fh;
# First we must see if there is a _pidfile_fileno variable in environment;
# that means that we were started by an exec() and we must keep the same
# pidfile as before
my $pidfd = delete $ENV{_pidfile_fileno};
if (defined $pidfd && $pidfd =~ /^\d+$/) {
$self->_debug("Reopening pidfile from file descriptor");
open($fh, ">&=$pidfd")
or croak "can't open fd $pidfd: $!";
# Re-set close-on-exec bit for pidfile filehandle
fcntl($fh, F_SETFD, 1)
or die "Can't set close-on-exec flag on pidfile filehandle: $!\n";
} else {
$self->_debug("Opening a new pid file");
# Open configured pidfile
sysopen($fh, $pidfile, O_RDWR | O_CREAT)
or croak "can't open $pidfile: $!";
}
flock($fh, LOCK_EX|LOCK_NB)
or croak "can't lock $pidfile: $! - is another instance running?";
truncate($fh, 0)
or croak "can't truncate $pidfile: $!";
my $prev = select $fh;
++$|;
select $prev;
# Save it as a global so that in short init syntax
# Script::Daemonizer->new( pidfile => $pfile )->daemonize;
# it stays in scope
return $global_pidfh = $self->{pidfh} = $fh;
}
##############
# sub _chdir #
##############
sub _chdir {
my $self = shift;
chdir($self->{'working_dir'}) or
croak "Cannot change directory to ", $self->{'working_dir'}, ": $!";
}
#################
# sub _close #
#################
# Handle closing of STDOUT/STDERR
sub _close {
my $self = shift;
my $fh = shift;
# Have to lookup handles by name
$self->_debug("Closing $fh");
no strict "refs";
open *$fh, '>', $devnull
or croak "Unable to open $fh on $devnull: $!";
}
#################
# sub _redirect #
#################
sub _redirect {
my ( $self, $fh, $destination ) = @_;
$destination = $devnull
if $destination eq '/dev/null';
$self->_debug("Redirecting $fh on: $destination ", $destination);
no strict "refs";
open *$fh, '>>', $destination
or croak "Unable to open $fh on $destination: $!";
}
##########################
# sub _manage_stdhandles #
##########################
sub _manage_stdhandles {
my $self = shift;
open STDIN, '<', $devnull
or croak "Cannot reopen STDIN on $devnull: $!";
# If we were requested to redirect output on a file, do it now and return
if ($self->{output_file}) {
$self->_debug("Using output file");
$self->_redirect( $_, $self->{output_file}) for (qw{STDOUT STDERR});
return 1;
}
# Use Tie::Syslog unless both stdout/stderr redirected to file
unless ($self->{stdout_file} && $self->{stderr_file}) {
$self->_debug("Using Tie::Syslog");
eval {
require Tie::Syslog;
};
if ($@) {
my $msg = sprintf ("Unable to load Tie::Syslog module.%s",
$self->{_DEBUG}
? " Error is:\n----\n$@----\nI will continue without output"
: ""
);
carp $msg;
$self->_close( $_ ) for (qw{STDOUT STDERR});
return 0;
}
$Tie::Syslog::ident = $self->{name};
$Tie::Syslog::logopt = 'ndelay,pid';
}
# STDOUT
if ($self->{stdout_file}) {
$self->_redirect( 'STDOUT', $self->{stdout_file} );
} else {
$self->_close( 'STDOUT' );
$self->_debug("Tying STDOUT to Tie::Syslog");
tie *STDOUT, 'Tie::Syslog', {
facility => 'LOG_DAEMON',
priority => 'LOG_INFO',
};
}
# STDERR
if ($self->{stderr_file}) {
$self->_redirect( 'STDERR', $self->{stderr_file} );
} else {
$self->_close( 'STDERR' );
$self->_debug("Tying STDERR to Tie::Syslog");
tie *STDERR, 'Tie::Syslog', {
facility => 'LOG_DAEMON',
priority => 'LOG_ERR',
};
}
}
########################
# sub _get_signal_list #
########################
sub _get_signal_list {
my $self = shift;
}
# ------------------------------------------------------------------------------
# 'Public' functions
# ------------------------------------------------------------------------------
sub drop_privileges {
my $self = shift;
# Check parameters:
croak "Odd number of arguments in drop_privileges() call!"
if @_ % 2;
my %ids = @_ ? @_ : %{ $self->{drop_privileges} };
my ($euid, $egid, $uid, $gid) = @ids{qw(euid egid uid gid)};
# Drop GROUP ID
if (defined $gid) {
POSIX::setgid((split " ", $gid)[0])
or croak "POSIX::setgid() failed: $!";
} elsif (defined $egid) {
# $egid might be a list
$) = $egid;
croak "Cannot drop effective group id to $egid: $!"
if $!;
}
if (defined $uid) {
POSIX::setuid($uid)
or croak "POSIX::setuid() failed: $!";
} elsif (defined $euid) {
# Drop EUID too, unless explicitly forced to something else
$> = $euid;
croak "Cannot drop effective user id to $uid: $!"
if $!;
}
return 1;
}
sub new {
my $pkg = shift;
croak ("This is a class method!")
if ref($pkg);
croak "Odd number of arguments in configuration!"
if @_ %2;
my $self = {
%defaults,
};
# Get the configuration
my %params = @_;
# Set useful defaults
$self->{name} = delete $params{name} || (File::Spec->splitpath($0))[-1];
$self->{fork} = (exists $params{fork} && $params{fork} =~ /^[012]$/)
? delete $params{fork}
: 2;
$self->{working_dir} = delete $params{working_dir} if $params{working_dir};
if (exists $params{umask}) {
croak "Invalid umask specified: ", $params{umask}
unless $params{umask} =~ /^[0-7]{1,3}$/;
$self->{umask} = delete $params{umask};
}
# Get other options as they are:
for (@daemon_options) {
$self->{ $_ } = delete $params{ $_ };
}
my @extra_args = keys %params;
{
local $" = ", ";
croak sprintf "Invalid argument(s) passed: @extra_args"
if @extra_args;
}
bless $self, $pkg;
# Set up signal handlers
if ($self->{restart_on} && ref $self->{restart_on} eq 'ARRAY') {
my @sigs = @{ $self->{restart_on} };
for (@sigs) {
$SIG{ $_ } = sub {
$self->restart();
};
}
$self->sigunmask( @sigs );
}
# Unmask signals if requested
if ($self->{sigunmask} && ref $self->{sigunmask} eq 'ARRAY') {
$self->sigunmask(@{ $self->{sigunmask} });
}
return $self;
}
sub daemonize {
my $self = shift;
# Step 0.0 - OPTIONAL: drop privileges
$self->drop_privileges
if $self->{drop_privileges};
# Step 0.1 - OPTIONAL: take a lock on pidfile
$self->_write_pidfile()
if $self->{pidfile};
# Step 1.
$self->_set_umask
if exists $self->{umask};
# Step 2.
$self->_fork()
if $self->{fork};
# Step 3.
$self->_setsid();
# Step 4.
$self->_fork()
if $self->{fork};
#
# Step 4.5 - OPTIONAL: if pidfile is in use, now it's the moment to dump our
# pid into it.
#
### NEW from 0.92.00 - try to lock pidfile again: on some platforms* the
# lock is not preserved across fork(), so we must ensure again that no one
# is holding the lock. This allows a tiny race condition between the first
# and the second lock attempt, however nothing harmful is done between these
# two operations - steps 1 to 4 can be done safely even if another instance
# is running. The only reason I didn't remove the first flock() attempt is
# that if we need to fail and we have the chance to do it sooner, then it's
# preferable, since at step 0.1 we're still attached to our controlling
# process (and to the terminal, if launched by user) and the failure is more
# noticeable (maybe).
#
# * Failing platforms (from CPANTesters): FreeBSD, Mac OS X, OpenBSD, Solaris;
# Linux and NetBSD seem to be unaffected.
#
if ($self->{pidfh}) {
my $pidfh = $self->{pidfh};
flock($pidfh, LOCK_EX|LOCK_NB)
or croak "can't lock ", $self->{pidfile}, ": $! - is another instance running?";
print $pidfh $$;
}
# Step 5.
$self->_chdir()
if $self->{working_dir};
# Step 6.
# REMOVED!
# Step 7.
$self->_manage_stdhandles();
return 1;
}
sub restart {
my $self = shift;
my @args = @_ ? @_ : @argv_copy;
# See perlipc
# make the daemon cross-platform, so exec always calls the script
# itself with the right path, no matter how the script was invoked.
my $script = File::Basename::basename($0);
my $SELF = File::Spec->catfile($FindBin::Bin, $script);
# $pidf must be kept open across exec() if we don't want race conditions:
if (my $pidfh = $self->{pidfh}) {
$self->_debug("Keeping current pidfile open");
# Clear close-on-exec bit for pidfile filehandle
fcntl($pidfh, F_SETFD, 0)
or die "Can't clear close-on-exec flag on pidfile filehandle: $!\n";
# Now we must notify ourseves that pidfile is already open
$ENV{_pidfile_fileno} = fileno( $pidfh );
}
exec($SELF, @args)
or croak "$0: couldn't restart: $!";
}
# Bye default, we unmask SIGHUP but, if other signals must be unmasked too,
# then use this and pass in a list of signals to be unmasked.
sub sigunmask {
my $self = shift;
croak "sigunmask called without arguments"
unless @_;
no strict "refs";
# Have to convert manually signal names into numbers. I remove the prefix
# POSIX::[SIG] from signal name and add it back again, this allows user to
# refer to signals in any way, for example:
# QUIT
# SIGQUIT
# POSIX::QUIT
# POSIX::SIGQUIT
my @sigs = map {
( my $signal = $_ ) =~ s/^POSIX:://;
$signal =~ s/^SIG//;
$signal = "POSIX::SIG".$signal;
&$signal
} @_;
my $sigset = POSIX::SigSet->new( @sigs ); # Handle all given signals
sigprocmask(SIG_UNBLOCK, $sigset);
}
'End of Script::Daemonizer'
__END__