--- /dev/null
+
+# Copyright (C) 2006, David Muir Sharnoff <perl@dave.sharnoff.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.71;
+
+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_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 "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') {
+ 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') {
+ $self->gd_other_cmd($do, $locked);
+ }
+
+ unless ($self->{gd_foreground}) {
+ $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};
+ my $logname = $self->gd_logname;
+ my $p = $self->{gd_logpriority} ? "-p $self->{gd_logpriority}" : "";
+ open(STDERR, "|logger $p -t '$logname'") or (print "could not open stderr: $!" && exit(1));
+ close(STDOUT);
+ open(STDOUT, ">&STDERR") or die "redirect STDOUT -> STDERR: $!";
+ close(STDIN);
+}
+
+sub gd_daemonize
+{
+ my $self = shift;
+ print "Starting $self->{gd_progname} server\n";
+ $self->gd_redirect_output();
+ my $pid;
+ POSIX::_exit(0) if $pid = fork;
+ die "Could not fork: $!" unless defined $pid;
+ POSIX::_exit(0) if $pid = fork;
+ die "Could not fork: $!" unless defined $pid;
+
+ POSIX::setsid();
+ select(STDERR);
+ $| = 1;
+ print "Sucessfully daemonized\n";
+}
+
+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}",
+ )
+}
+
+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;
+ $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;
projects / kivitendo-erp.git / blobdiff