lib/Daemon/Generic.pm - metacpan.org


package Daemon::Generic;

use strict;
use warnings;
require Exporter;
require POSIX;
use Getopt::Long;
use File::Slurp;
use File::Flock;
our @ISA = qw(Exporter);
our @EXPORT = qw(newdaemon);

our $VERSION = 0.82;

our $force_quit_delay = 15;
our $package = __PACKAGE__;
our $caller;

sub newdaemon
{
	my (%args) = @_;
	my $pkg = $caller || caller() || 'main';

	my $foo = bless {}, $pkg;

	unless ($foo->isa($package)) {
		no strict qw(refs);
		my $isa = \@{"${pkg}::ISA"};
		unshift(@$isa, $package);
	}

	bless $foo, 'This::Package::Does::Not::Exist';
	undef $foo;

	new($pkg, %args);
}

sub new
{
	my ($pkg, %args) = @_;

	if ($pkg eq __PACKAGE__) {
		$pkg = caller() || 'main';
	}

	srand(time ^ ($$ << 5))
		unless $args{no_srand};

	my $av0 = $0;
	$av0 =~ s!/!/.!g;

	my $self = {
		gd_av0		=> $av0,
		gd_args		=> \%args,
		gd_pidfile	=> $args{pidfile},
		gd_logpriority	=> $args{logpriority},
		gd_progname	=> $args{progname}
					? $args{progname}
					: $0,
		gd_pidbase	=> $args{pidbase}
					? $args{pidbase}
					: ($args{progname} 
						? "/var/run/$args{progname}"
						: "/var/run/$av0"),
		gd_foreground	=> $args{foreground} || 0,
		configfile	=> $args{configfile}
					? $args{configfile}
					: ($args{progname}
						? "/etc/$args{progname}.conf"
						: "/etc/$av0"),
		debug		=> $args{debug} || 0,
	};
	bless $self, $pkg;

	$self->gd_getopt;
	$self->gd_parse_argv;

	my $do = $self->{do} = $ARGV[0];

	$self->gd_help		if $do eq 'help';
	$self->gd_version	if $do eq 'version';
	$self->gd_install	if $do eq 'install';
	$self->gd_uninstall	if $do eq 'uninstall';

	$self->gd_pidfile unless $self->{gd_pidfile};

	my %newconfig = $self->gd_preconfig;

	$self->{gd_pidfile} = $newconfig{pidfile} if $newconfig{pidfile};

	print "PIDFILE=$self->{gd_pidfile}\n" if $self->{debug};

	print "Configuration looks okay\n" if $do eq 'check';

	my $pidfile = $self->{gd_pidfile};
	my $killed = 0;
	my $locked = 0;
	if (-e $pidfile) {
		if ($locked = lock($pidfile, undef, 'nonblocking')) {
			# old process is dead
			if ($do eq 'status') {
			    print "$0 dead\n";
			    exit 1;
			}
		} else {
			sleep(2) if -M $pidfile < 2/86400;
			my $oldpid = read_file($pidfile);
			chomp($oldpid);
			if ($oldpid) {
				if ($do eq 'stop' or $do eq 'restart') {
					$killed = $self->gd_kill($oldpid);
					$locked = lock($pidfile);
					if ($do eq 'stop') {
						unlink($pidfile);
						exit;
					}
				} elsif ($do eq 'reload') {
					if (kill(1,$oldpid)) {
						print "Requested reconfiguration\n";
						exit;
					} else {
						print "Kill failed: $!\n";
					}
				} elsif ($do eq 'status') {
					if (kill(0,$oldpid)) {
						print "$0 running - pid $oldpid\n";
						$self->gd_check($pidfile, $oldpid);
						exit 0;
					} else {
						print "$0 dead\n";
						exit 1;
					}
				} elsif ($do eq 'check') {
					if (kill(0,$oldpid)) {
						print "$0 running - pid $oldpid\n";
						$self->gd_check($pidfile, $oldpid);
						exit;
					} 
				} elsif ($do eq 'start' || $do eq 'debug') {
					print "\u$self->{gd_progname} is already running (pid $oldpid)\n";
					exit; # according to LSB, this is no error
				}
			} else {
				$self->gd_error("Pid file $pidfile is invalid but locked, exiting\n");
			}
		}
	} else {
		$locked = lock($pidfile, undef, 'nonblocking') 
			or die "Could not lock pid file $pidfile: $!";
	}

	if ($do eq 'reload' || $do eq 'stop' || $do eq 'check' || ($do eq 'restart' && ! $killed)) {
		print "No $0 running\n";
	}

	if ($do eq 'stop') {
		unlink($pidfile);
		exit;
	}

	if ($do eq 'status') {
		print "Unused\n";
		exit 3;
	}

	if ($do eq 'check') {
		$self->gd_check($pidfile);
		exit 
	}

	unless ($do eq 'reload' || $do eq 'restart' || $do eq 'start' || $do eq 'debug') {
		$self->gd_other_cmd($do, $locked);
	}

	unless ($self->{gd_foreground} || $do eq 'debug') {
		$self->gd_daemonize;
	}

	$locked or lock($pidfile, undef, 'nonblocking') 
		or die "Could not lock PID file $pidfile: $!";

	write_file($pidfile, "$$\n");

	print STDERR "Starting up...\n";

	$self->gd_postconfig(%newconfig);

	$self->gd_setup_signals;

	$self->gd_run;

	unlink($pidfile);
	exit(0);
}

sub gd_check {}

sub gd_more_opt { return() }

sub gd_getopt
{
	my $self = shift;
	Getopt::Long::Configure("auto_version");
	GetOptions(
		'configfile=s'	=> \$self->{configfile},
		'foreground!'	=> \$self->{gd_foreground},
		'debug!'	=> \$self->{debug},
		$self->{gd_args}{options}
			? %{$self->{gd_args}{options}}
			: (),
		$self->gd_more_opt(),
	) or exit($self->gd_usage());

	if (@ARGV < ($self->{gd_args}{minimum_args} || 1)) {
		exit($self->gd_usage());
	}
	if (@ARGV > ($self->{gd_args}{maximum_args} || 1)) {
		exit($self->gd_usage());
	}
}

sub gd_parse_argv { }

sub gd_help
{
	my $self = shift;
	exit($self->gd_usage($self->{gd_args}));
}

sub gd_version
{
	my $self = shift;
	no strict qw(refs);
	my $v = $self->{gd_args}{version} 
		|| ${ref($self)."::VERSION"} 
		|| $::VERSION 
		|| $main::VERSION 
		|| "?";
	print "$self->{gd_progname} - version $v\n";;
	exit;
} 

sub gd_pidfile
{
	my $self = shift;
	my $x = $self->{configfile};
	$x =~ s!/!.!g;
	$self->{gd_pidfile} = "$self->{gd_pidbase}$x.pid";
}

sub gd_other_cmd
{
	my $self = shift;
	$self->gd_usage;
	exit(1);
}

sub gd_redirect_output
{
	my $self = shift;
	return if $self->{gd_foreground};
	open(STDOUT, ">/dev/null") or die("open >/dev/null: $!");
	open(STDIN, "</dev/null") or die("open </dev/null: $!");
	open(STDERR, ">&STDOUT") or tmpdie("dup stdout > stderr: $!");
}

sub gd_daemonize
{
	my $self = shift;
	my $logname = $self->gd_logname;

	open(TMPERR, ">&STDERR") or die "dup STDERR > TMPERR: $!";

	print "Starting $self->{gd_progname} server\n";
	$self->gd_redirect_output();
	my $pid;
	POSIX::_exit(0) if $pid = fork;
	tmpdie("Could not fork: $!") 
		unless defined $pid;

	POSIX::setsid();

	my $p = $self->{gd_logpriority} ? "-p $self->{gd_logpriority}" : "";
	open(STDERR, "|logger $p -t '$logname'") or tmpdie("open |logger $p -t $logname: $!");
	open(STDOUT, ">&STDERR") or tmpdie("dup stderr > stdout: $!");
	select(STDERR);
	$| = 1;
	select(STDOUT);
	$| = 1;
	print "Sucessfully daemonized\n" 
		or tmpdie("write to |logger: $!");

	close(TMPERR);
}

sub tmpdie
{
	my $msg = "@_";
	$msg .= sprintf(" at %s line %d\n", (caller())[1,2]) unless $msg =~ /\n$/;
	print TMPERR $msg;
	exit 1;
}

sub gd_logname
{
	my $self = shift;
	return $self->{gd_progname}."[$$]";
}

sub gd_reconfig_event
{
	my $self = shift;
	print STDERR "Reconfiguration requested\n";
	$self->gd_postconfig($self->gd_preconfig());
}

sub gd_quit_event
{
	my $self = shift;
	print STDERR "Quitting...\n";
	exit(0);
}

sub gd_setup_signals
{
	my $self = shift;
	$SIG{INT} = sub { $self->gd_quit_event() };
	$SIG{HUP} = sub { $self->gd_reconfig_event() };
}

sub gd_run { die "must defined gd_run()" }

sub gd_error
{
	my $self = shift;
	my $e = shift;
	my $do = $self->{do};
	if ($do && $do eq 'stop') {
		warn $e;
	} else {
		die $e;
	}
}

sub gd_flags_more { return () }

sub gd_flags
{
	my $self = shift;
	return (
		'-c file'	=> "Specify configuration file (instead of $self->{configfile})",
		'-f'		=> "Run in the foreground (don't detach)",
		$self->gd_flags_more
	);
}

sub gd_commands_more { return () }

sub gd_commands
{
	my $self = shift;
	return (
		start		=> "Starts a new $self->{gd_progname} if there isn't one running already",
		stop		=> "Stops a running $self->{gd_progname}",
		reload		=> "Causes a running $self->{gd_progname} to reload it's config file.  Starts a new one if none is running.",
		restart		=> "Stops a running $self->{gd_progname} if one is running.  Starts a new one.",
		$self->gd_commands_more(),
		($self->gd_can_install()
			? ('install' => "Setup $self->{gd_progname} to run automatically after reboot")
			: ()),
		($self->gd_can_uninstall()
			? ('uninstall' => "Do not run $self->{gd_progname} after reboots")
			: ()),
		check		=> "Check the configuration file and report the daemon state",
		help		=> "Display this usage info",
		version		=> "Display the version of $self->{gd_progname}",
		debug		=> "Starts a new $self->{gd_progname} in the foreground",
	)
}

sub gd_positional_more { return() }

sub gd_alts
{
	my $offset = shift;
	my @results;
	for (my $i = $offset; $i <= $#_; $i += 2) {
		push(@results, $_[$i]);
	}
	return @results;
}

sub gd_usage
{
	my $self = shift;

	require Text::Wrap;
	import Text::Wrap;

	my $col = 15;

	my @flags = $self->gd_flags;
	my @commands = $self->gd_commands;
	my @positional = $self->gd_positional_more;

	my $summary = "Usage: $self->{gd_progname} ";
	my $details = '';
	for my $i (gd_alts(0, @flags)) {
		$summary .= "[ $i ] ";
	}
	$summary .= "{ ";
	$summary .= join(" | ", gd_alts(0, @commands));
	$summary .= " } ";
	$summary .= join(" ", gd_alts(0, @positional));

	my (@all) = (@flags, @commands, @positional);
	while (@all) {
		my ($key, $desc) = splice(@all, 0, 2);
		local($Text::Wrap::columns) = 79;
		local($Text::Wrap::unexpand) = 0;
		$details .= wrap(
			sprintf(" %-${col}s ", $key),
			" " x ($col + 2),
			$desc);
		$details .= "\n";
	}

	print "$summary\n$details";
	return 0;
}

sub gd_install_pre {}
sub gd_install_post {}

sub gd_can_install
{
	my $self = shift;
	require File::Basename;
	my $basename = File::Basename::basename($0);
	if (
		-x "/usr/sbin/update-rc.d"
		&& 
		-x $0
		&& 
		$0 !~ m{^(?:/usr|/var)?/tmp/}
		&&
		eval { symlink("",""); 1 }
		&& 
		-d "/etc/init.d"
		&&
		! -e "/etc/init.d/$basename"
	) {
		return sub {
			$self->gd_install_pre("update-rc.d");
			require Cwd;
			my $abs_path = Cwd::abs_path($0);
			symlink($abs_path, "/etc/init.d/$basename")
				or die "Install failed: symlink /etc/init.d/$basename -> $abs_path: $!\n";
			print "+ /usr/sbin/update-rc.d $basename defaults\n";
			system("/usr/sbin/update-rc.d", $basename, "defaults");
			my $exit = $? >> 8;
			$self->gd_install_post("update-rc.d");
			exit($exit) if $exit;
		};
	}

	return 0;
}

sub gd_install
{
	my $self = shift;
	my $ifunc = $self->gd_can_install();
	die "Install command not supported\n" unless $ifunc;
	&$ifunc($self);
	exit(0);
}

sub gd_uninstall_pre {}
sub gd_uninstall_post {}

sub gd_can_uninstall
{
	my $self = shift;
	require File::Basename;
	my $basename = File::Basename::basename($0);
	require Cwd;
	my $abs_path = Cwd::abs_path($0) || 'no abs path';
	my $link = readlink("/etc/init.d/$basename") || 'no link';
	if (
		$link eq $abs_path
		&& 
		-x "/usr/sbin/update-rc.d"
	) {
		return sub {
			$self->gd_uninstall_pre("update-rc.d");
			unlink("/etc/init.d/$basename");
			print "+ /usr/sbin/update-rc.d $basename remove\n";
			system("/usr/sbin/update-rc.d", $basename, "remove");
			my $exit = $? >> 8;
			$self->gd_uninstall_post("update-rc.d");
			exit($exit) if $exit;
		}
	}
	return 0;
}

sub gd_uninstall
{
	my $self = shift;
	my $ufunc = $self->gd_can_uninstall();
	die "Cannot uninstall\n" unless $ufunc;
	&$ufunc($self);
	exit(0);
}

sub gd_kill
{
	my ($self, $pid) = @_;

	my $talkmore = 0;
	my $killed = 0;
	if (kill(0, $pid)) {
		$killed = 1;
		kill(2,$pid);
		print "Killing $pid\n";
		my $t = time;
		sleep(1) if kill(0, $pid);
		if ($force_quit_delay && kill(0, $pid)) {
			print "Waiting for $pid to die...\n";
			$talkmore = 1;
			while(kill(0, $pid) && time - $t < $force_quit_delay) {
				sleep(1);
			}
		}
		if (kill(15, $pid)) {
			print "Killing $pid with -TERM...\n";
			if ($force_quit_delay) {
				while(kill(0, $pid) && time - $t < $force_quit_delay * 2) {
					sleep(1);
				}
			} else {
				sleep(1) if kill(0, $pid);
			}
		}
		if (kill(9, $pid)) {
			print "Killing $pid with -KILL...\n";
			my $k9 = time;
			my $max = $force_quit_delay * 4;
			$max = 60 if $max < 60;
			while(kill(0, $pid)) {
				if (time - $k9 > $max) {
					print "Giving up on $pid ever dying.\n";
					exit(1);
				}
				print "Waiting for $pid to die...\n";
				sleep(1);
			}
		}
		print "Process $pid is gone\n" if $talkmore;
	} else {
		print "Process $pid no longer running\n";
	}
	return $killed;
}

sub gd_preconfig { die "gd_preconfig() must be redefined"; }

sub gd_postconfig { }


1;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)