Revision 23d89499
Von Moritz Bunkus vor etwa 14 Jahren hinzugefügt
| modules/fallback/Daemon/Generic.pm | ||
|---|---|---|
|
|
||
|
# 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;
|
||
| modules/fallback/Daemon/Generic/Event.pm | ||
|---|---|---|
|
|
||
|
# Copyright (C) 2006, David Muir Sharnoff <muir@idiom.com>
|
||
|
|
||
|
package Daemon::Generic::Event;
|
||
|
|
||
|
use strict;
|
||
|
use warnings;
|
||
|
require Daemon::Generic;
|
||
|
require Event;
|
||
|
require Exporter;
|
||
|
|
||
|
our @ISA = qw(Daemon::Generic Exporter);
|
||
|
our @EXPORT = @Daemon::Generic::EXPORT;
|
||
|
our $VERSION = 0.3;
|
||
|
|
||
|
sub newdaemon
|
||
|
{
|
||
|
local($Daemon::Generic::caller) = caller() || 'main';
|
||
|
local($Daemon::Generic::package) = __PACKAGE__;
|
||
|
Daemon::Generic::newdaemon(@_);
|
||
|
}
|
||
|
|
||
|
sub gd_setup_signals
|
||
|
{
|
||
|
my $self = shift;
|
||
|
my $reload_event = Event->signal(
|
||
|
signal => 'HUP',
|
||
|
desc => 'reload on SIGHUP',
|
||
|
prio => 6,
|
||
|
cb => sub {
|
||
|
$self->gd_reconfig_event;
|
||
|
$self->{gd_timer}->cancel()
|
||
|
if $self->{gd_timer};
|
||
|
$self->gd_setup_timer();
|
||
|
},
|
||
|
);
|
||
|
my $quit_event = Event->signal(
|
||
|
signal => 'INT',
|
||
|
cb => sub { $self->gd_quit_event; },
|
||
|
);
|
||
|
}
|
||
|
|
||
|
sub gd_setup_timer
|
||
|
{
|
||
|
my $self = shift;
|
||
|
if ($self->can('gd_run_body')) {
|
||
|
my $interval = ($self->can('gd_interval') && $self->gd_interval()) || 1;
|
||
|
$self->{gd_timer} = Event->timer(
|
||
|
cb => [ $self, 'gd_run_body' ],
|
||
|
interval => $interval,
|
||
|
hard => 0,
|
||
|
);
|
||
|
}
|
||
|
}
|
||
|
|
||
|
sub gd_run
|
||
|
{
|
||
|
my $self = shift;
|
||
|
$self->gd_setup_timer();
|
||
|
Event::loop();
|
||
|
}
|
||
|
|
||
|
sub gd_quit_event
|
||
|
{
|
||
|
my $self = shift;
|
||
|
print STDERR "Quitting...\n";
|
||
|
Event::unloop_all();
|
||
|
}
|
||
|
|
||
|
1;
|
||
|
|
||
|
=head1 NAME
|
||
|
|
||
|
Daemon::Generic::Event - Generic daemon framework with Event.pm
|
||
|
|
||
|
=head1 SYNOPSIS
|
||
|
|
||
|
use Daemon::Generic::Event;
|
||
|
|
||
|
@ISA = qw(Daemon::Generic::Event);
|
||
|
|
||
|
sub gd_preconfig {
|
||
|
# stuff
|
||
|
}
|
||
|
|
||
|
=head1 DESCRIPTION
|
||
|
|
||
|
Daemon::Generic::Event is a subclass of L<Daemon::Generic> that
|
||
|
predefines some methods:
|
||
|
|
||
|
=over 15
|
||
|
|
||
|
=item gd_run()
|
||
|
|
||
|
Setup a periodic callback to C<gd_run_body()> if there is a C<gd_run_body()>.
|
||
|
Call C<Event::loop()>.
|
||
|
|
||
|
=item gd_setup_signals()
|
||
|
|
||
|
Bind SIGHUP to call C<gd_reconfig_event()>.
|
||
|
Bind SIGINT to call C<gd_quit_event()>.
|
||
|
|
||
|
=back
|
||
|
|
||
|
To use Daemon::Generic::Event, you have to provide a C<gd_preconfig()>
|
||
|
method. It can be empty if you have a C<gd_run_body()>.
|
||
|
|
||
|
Set up your own events in C<gd_preconfig()> and C<gd_postconfig()>.
|
||
|
|
||
|
If you have a C<gd_run_body()> method, it will be called once per
|
||
|
second or every C<gd_interval()> seconds if you have a C<gd_interval()>
|
||
|
method. Unlike in L<Daemon::Generic::While1>, C<gd_run_body()> should
|
||
|
not include a call to C<sleep()>.
|
||
|
|
||
|
=head1 THANK THE AUTHOR
|
||
|
|
||
|
If you need high-speed internet services (T1, T3, OC3 etc), please
|
||
|
send me your request-for-quote. I have access to very good pricing:
|
||
|
you'll save money and get a great service.
|
||
|
|
||
|
=head1 LICENSE
|
||
|
|
||
|
Copyright(C) 2006 David Muir Sharnoff <muir@idiom.com>.
|
||
|
This module may be used and distributed on the same terms
|
||
|
as Perl itself.
|
||
|
|
||
| modules/fallback/Daemon/Generic/While1.pm | ||
|---|---|---|
|
# Copyright (C) 2006, David Muir Sharnoff <muir@idiom.com>
|
||
|
|
||
|
package Daemon::Generic::While1;
|
||
|
|
||
|
use strict;
|
||
|
use warnings;
|
||
|
use Carp;
|
||
|
require Daemon::Generic;
|
||
|
require POSIX;
|
||
|
require Exporter;
|
||
|
|
||
|
our @ISA = qw(Daemon::Generic Exporter);
|
||
|
our @EXPORT = @Daemon::Generic::EXPORT;
|
||
|
our $VERSION = 0.3;
|
||
|
|
||
|
sub newdaemon
|
||
|
{
|
||
|
local($Daemon::Generic::caller) = caller() || 'main';
|
||
|
local($Daemon::Generic::package) = __PACKAGE__;
|
||
|
Daemon::Generic::newdaemon(@_);
|
||
|
}
|
||
|
|
||
|
sub gd_setup_signals
|
||
|
{
|
||
|
my ($self) = @_;
|
||
|
$SIG{HUP} = sub {
|
||
|
$self->{gd_sighup} = time;
|
||
|
};
|
||
|
my $child;
|
||
|
$SIG{INT} = sub {
|
||
|
$self->{gd_sigint} = time;
|
||
|
#
|
||
|
# We'll be getting a SIGTERM in a bit if we're not dead, so let's use it.
|
||
|
#
|
||
|
$SIG{TERM} = sub {
|
||
|
$self->gd_quit_event();
|
||
|
kill(15, $child) if $child; # if we're still alive, let's stay that way
|
||
|
};
|
||
|
};
|
||
|
}
|
||
|
|
||
|
sub gd_sleep
|
||
|
{
|
||
|
my ($self, $period) = @_;
|
||
|
croak "Sleep period must be defined" unless defined $period;
|
||
|
my $hires;
|
||
|
if ($period*1000 != int($period*1000)) {
|
||
|
$hires = 1;
|
||
|
require Time::HiRes;
|
||
|
import Time::HiRes qw(time sleep);
|
||
|
}
|
||
|
my $t = time;
|
||
|
while (time - $t < $period) {
|
||
|
return if $self->{gd_sigint};
|
||
|
return if $self->{gd_sighup};
|
||
|
if ($hires) {
|
||
|
my $p = (time - $t < 1)
|
||
|
? time - $t
|
||
|
: 1;
|
||
|
sleep($p);
|
||
|
} else {
|
||
|
sleep(1);
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
|
||
|
sub gd_run
|
||
|
{
|
||
|
my ($self) = @_;
|
||
|
while(1) {
|
||
|
if ($self->{gd_sigint}) {
|
||
|
$self->{gd_sigint} = 0;
|
||
|
$self->gd_quit_event();
|
||
|
}
|
||
|
|
||
|
if ($self->{gd_sighup}) {
|
||
|
$self->{gd_sighup} = 0;
|
||
|
$self->gd_reconfig_event();
|
||
|
}
|
||
|
|
||
|
$self->gd_run_body();
|
||
|
}
|
||
|
}
|
||
|
|
||
|
sub gd_reconfig_event
|
||
|
{
|
||
|
my $self = shift;
|
||
|
print STDERR "Reconfiguration requested\n";
|
||
|
$self->gd_postconfig($self->gd_preconfig());
|
||
|
}
|
||
|
|
||
|
sub gd_quit_event
|
||
|
{
|
||
|
print STDERR "Quitting...\n";
|
||
|
exit(0);
|
||
|
}
|
||
|
|
||
|
|
||
|
sub gd_run_body { die "must override gd_run_body()" }
|
||
|
|
||
|
1;
|
||
|
|
||
|
=head1 NAME
|
||
|
|
||
|
Daemon::Generic::While1 - Daemon framework with default while(1) loop
|
||
|
|
||
|
=head1 SYNOPSIS
|
||
|
|
||
|
@ISA = qw(Daemon::Generic::While1);
|
||
|
|
||
|
sub gd_run_body {
|
||
|
# stuff
|
||
|
}
|
||
|
|
||
|
=head1 DESCRIPTION
|
||
|
|
||
|
This is a slight variation on L<Daemon::Generic>: a default
|
||
|
C<gd_run()> provided. It has a while(1) loop that calls
|
||
|
C<gd_run_body()> over and over. It checks for reconifg and
|
||
|
and terminate events and only actions them between calls
|
||
|
to C<gd_run_body()>.
|
||
|
|
||
|
Terminate events will be forced through after
|
||
|
C<$Daemon::Generic::force_quit_delay> seconds if
|
||
|
C<gd_run_body()> doesn't return quickly enough.
|
||
|
|
||
|
=head1 SUBCLASS METHODS REQUIRD
|
||
|
|
||
|
The following method is required to be overridden to subclass
|
||
|
Daemon::Generic::While1:
|
||
|
|
||
|
=over 15
|
||
|
|
||
|
=item gd_run_body()
|
||
|
|
||
|
This method will be called over and over. This method should
|
||
|
include a call to C<sleep(1)> (or a bit more). Reconfig events
|
||
|
will not interrupt it. Quit events will only interrupt it
|
||
|
after 15 seconds.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 ADDITIONAL METHODS
|
||
|
|
||
|
The following additional methods are available for your use
|
||
|
(as compared to L<Daemon::Generic>):
|
||
|
|
||
|
=over 15
|
||
|
|
||
|
=item gd_sleep($period)
|
||
|
|
||
|
This will sleep for C<$period> seconds but in one-second
|
||
|
intervals so that if a SIGINT or SIGHUP arrives the sleep
|
||
|
period can end more quickly.
|
||
|
|
||
|
Using this makes it safe for C<gd_run_body()> to sleep for
|
||
|
longer than C<$Daemon::Generic::force_quit_delay> seconds
|
||
|
at a time.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 ADDITIONAL MEMBER DATA
|
||
|
|
||
|
The following additional bits of member data are defined:
|
||
|
|
||
|
=over 15
|
||
|
|
||
|
=item gd_sigint
|
||
|
|
||
|
The time at which an (unprocessed) SIGINT was recevied.
|
||
|
|
||
|
=item gd_sighup
|
||
|
|
||
|
The time at which an (unprocessed) SIGHUP was recevied.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 THANK THE AUTHOR
|
||
|
|
||
|
If you need high-speed internet services (T1, T3, OC3 etc), please
|
||
|
send me your request-for-quote. I have access to very good pricing:
|
||
|
you'll save money and get a great service.
|
||
|
|
||
|
=head1 LICENSE
|
||
|
|
||
|
Copyright(C) 2006 David Muir Sharnoff <muir@idiom.com>.
|
||
|
This module may be used and distributed on the same terms
|
||
|
as Perl itself.
|
||
|
|
||
| modules/fallback/File/Flock.pm | ||
|---|---|---|
|
# Copyright (C) 1996, 1998 David Muir Sharnoff
|
||
|
|
||
|
package File::Flock;
|
||
|
|
||
|
require Exporter;
|
||
|
@ISA = qw(Exporter);
|
||
|
@EXPORT = qw(lock unlock lock_rename);
|
||
|
|
||
|
use Carp;
|
||
|
use POSIX qw(EAGAIN EACCES EWOULDBLOCK ENOENT EEXIST O_EXCL O_CREAT O_RDWR);
|
||
|
use Fcntl qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN);
|
||
|
use IO::File;
|
||
|
|
||
|
use vars qw($VERSION $debug $av0debug);
|
||
|
|
||
|
BEGIN {
|
||
|
$VERSION = 2008.01;
|
||
|
$debug = 0;
|
||
|
$av0debug = 0;
|
||
|
}
|
||
|
|
||
|
use strict;
|
||
|
no strict qw(refs);
|
||
|
|
||
|
my %locks; # did we create the file?
|
||
|
my %lockHandle;
|
||
|
my %shared;
|
||
|
my %pid;
|
||
|
my %rm;
|
||
|
|
||
|
sub new
|
||
|
{
|
||
|
my ($pkg, $file, $shared, $nonblocking) = @_;
|
||
|
&lock($file, $shared, $nonblocking) or return undef;
|
||
|
return bless \$file, $pkg;
|
||
|
}
|
||
|
|
||
|
sub DESTROY
|
||
|
{
|
||
|
my ($this) = @_;
|
||
|
unlock($$this);
|
||
|
}
|
||
|
|
||
|
sub lock
|
||
|
{
|
||
|
my ($file, $shared, $nonblocking) = @_;
|
||
|
|
||
|
my $f = new IO::File;
|
||
|
|
||
|
my $created = 0;
|
||
|
my $previous = exists $locks{$file};
|
||
|
|
||
|
# the file may be springing in and out of existance...
|
||
|
OPEN:
|
||
|
for(;;) {
|
||
|
if (-e $file) {
|
||
|
unless (sysopen($f, $file, O_RDWR)) {
|
||
|
redo OPEN if $! == ENOENT;
|
||
|
croak "open $file: $!";
|
||
|
}
|
||
|
} else {
|
||
|
unless (sysopen($f, $file, O_CREAT|O_EXCL|O_RDWR)) {
|
||
|
redo OPEN if $! == EEXIST;
|
||
|
croak "open >$file: $!";
|
||
|
}
|
||
|
print STDERR " {$$ " if $debug; # }
|
||
|
$created = 1;
|
||
|
}
|
||
|
last;
|
||
|
}
|
||
|
$locks{$file} = $created || $locks{$file} || 0;
|
||
|
$shared{$file} = $shared;
|
||
|
$pid{$file} = $$;
|
||
|
|
||
|
$lockHandle{$file} = $f;
|
||
|
|
||
|
my $flags;
|
||
|
|
||
|
$flags = $shared ? LOCK_SH : LOCK_EX;
|
||
|
$flags |= LOCK_NB
|
||
|
if $nonblocking;
|
||
|
|
||
|
local($0) = "$0 - locking $file" if $av0debug && ! $nonblocking;
|
||
|
my $r = flock($f, $flags);
|
||
|
|
||
|
print STDERR " ($$ " if $debug and $r;
|
||
|
|
||
|
if ($r) {
|
||
|
# let's check to make sure the file wasn't
|
||
|
# removed on us!
|
||
|
|
||
|
my $ifile = (stat($file))[1];
|
||
|
my $ihandle;
|
||
|
eval { $ihandle = (stat($f))[1] };
|
||
|
croak $@ if $@;
|
||
|
|
||
|
return 1 if defined $ifile
|
||
|
and defined $ihandle
|
||
|
and $ifile == $ihandle;
|
||
|
|
||
|
# oh well, try again
|
||
|
flock($f, LOCK_UN);
|
||
|
close($f);
|
||
|
return File::Flock::lock($file);
|
||
|
}
|
||
|
|
||
|
return 1 if $r;
|
||
|
if ($nonblocking and
|
||
|
(($! == EAGAIN)
|
||
|
or ($! == EACCES)
|
||
|
or ($! == EWOULDBLOCK)))
|
||
|
{
|
||
|
if (! $previous) {
|
||
|
delete $locks{$file};
|
||
|
delete $lockHandle{$file};
|
||
|
delete $shared{$file};
|
||
|
delete $pid{$file};
|
||
|
}
|
||
|
if ($created) {
|
||
|
# oops, a bad thing just happened.
|
||
|
# We don't want to block, but we made the file.
|
||
|
&background_remove($f, $file);
|
||
|
}
|
||
|
close($f);
|
||
|
return 0;
|
||
|
}
|
||
|
croak "flock $f $flags: $!";
|
||
|
}
|
||
|
|
||
|
#
|
||
|
# get a lock on a file and remove it if it's empty. This is to
|
||
|
# remove files that were created just so that they could be locked.
|
||
|
#
|
||
|
# To do this without blocking, defer any files that are locked to the
|
||
|
# the END block.
|
||
|
#
|
||
|
sub background_remove
|
||
|
{
|
||
|
my ($f, $file) = @_;
|
||
|
|
||
|
if (flock($f, LOCK_EX|LOCK_NB)) {
|
||
|
unlink($file)
|
||
|
if -s $file == 0;
|
||
|
flock($f, LOCK_UN);
|
||
|
return 1;
|
||
|
} else {
|
||
|
$rm{$file} = 1
|
||
|
unless exists $rm{$file};
|
||
|
return 0;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
sub unlock
|
||
|
{
|
||
|
my ($file) = @_;
|
||
|
|
||
|
if (ref $file eq 'File::Flock') {
|
||
|
bless $file, 'UNIVERSAL'; # avoid destructor later
|
||
|
$file = $$file;
|
||
|
}
|
||
|
|
||
|
croak "no lock on $file" unless exists $locks{$file};
|
||
|
my $created = $locks{$file};
|
||
|
my $unlocked = 0;
|
||
|
|
||
|
|
||
|
my $size = -s $file;
|
||
|
if ($created && defined($size) && $size == 0) {
|
||
|
if ($shared{$file}) {
|
||
|
$unlocked =
|
||
|
&background_remove($lockHandle{$file}, $file);
|
||
|
} else {
|
||
|
# {
|
||
|
print STDERR " $$} " if $debug;
|
||
|
unlink($file)
|
||
|
or croak "unlink $file: $!";
|
||
|
}
|
||
|
}
|
||
|
delete $locks{$file};
|
||
|
delete $pid{$file};
|
||
|
|
||
|
my $f = $lockHandle{$file};
|
||
|
|
||
|
delete $lockHandle{$file};
|
||
|
|
||
|
return 0 unless defined $f;
|
||
|
|
||
|
print STDERR " $$) " if $debug;
|
||
|
$unlocked or flock($f, LOCK_UN)
|
||
|
or croak "flock $file UN: $!";
|
||
|
|
||
|
close($f);
|
||
|
return 1;
|
||
|
}
|
||
|
|
||
|
sub lock_rename
|
||
|
{
|
||
|
my ($oldfile, $newfile) = @_;
|
||
|
|
||
|
if (exists $locks{$newfile}) {
|
||
|
unlock $newfile;
|
||
|
}
|
||
|
delete $locks{$newfile};
|
||
|
delete $shared{$newfile};
|
||
|
delete $pid{$newfile};
|
||
|
delete $lockHandle{$newfile};
|
||
|
delete $rm{$newfile};
|
||
|
|
||
|
$locks{$newfile} = $locks{$oldfile} if exists $locks{$oldfile};
|
||
|
$shared{$newfile} = $shared{$oldfile} if exists $shared{$oldfile};
|
||
|
$pid{$newfile} = $pid{$oldfile} if exists $pid{$oldfile};
|
||
|
$lockHandle{$newfile} = $lockHandle{$oldfile} if exists $lockHandle{$oldfile};
|
||
|
$rm{$newfile} = $rm{$oldfile} if exists $rm{$oldfile};
|
||
|
|
||
|
delete $locks{$oldfile};
|
||
|
delete $shared{$oldfile};
|
||
|
delete $pid{$oldfile};
|
||
|
delete $lockHandle{$oldfile};
|
||
|
delete $rm{$oldfile};
|
||
|
}
|
||
|
|
||
|
#
|
||
|
# Unlock any files that are still locked and remove any files
|
||
|
# that were created just so that they could be locked.
|
||
|
#
|
||
|
END {
|
||
|
my $f;
|
||
|
for $f (keys %locks) {
|
||
|
&unlock($f)
|
||
|
if $pid{$f} == $$;
|
||
|
}
|
||
|
|
||
|
my %bgrm;
|
||
|
for my $file (keys %rm) {
|
||
|
my $f = new IO::File;
|
||
|
if (sysopen($f, $file, O_RDWR)) {
|
||
|
if (flock($f, LOCK_EX|LOCK_NB)) {
|
||
|
unlink($file)
|
||
|
if -s $file == 0;
|
||
|
flock($f, LOCK_UN);
|
||
|
} else {
|
||
|
$bgrm{$file} = 1;
|
||
|
}
|
||
|
close($f);
|
||
|
}
|
||
|
}
|
||
|
if (%bgrm) {
|
||
|
my $ppid = fork;
|
||
|
croak "cannot fork" unless defined $ppid;
|
||
|
my $pppid = $$;
|
||
|
my $b0 = $0;
|
||
|
$0 = "$b0: waiting for child ($ppid) to fork()";
|
||
|
unless ($ppid) {
|
||
|
my $pid = fork;
|
||
|
croak "cannot fork" unless defined $pid;
|
||
|
unless ($pid) {
|
||
|
for my $file (keys %bgrm) {
|
||
|
my $f = new IO::File;
|
||
|
if (sysopen($f, $file, O_RDWR)) {
|
||
|
if (flock($f, LOCK_EX)) {
|
||
|
unlink($file)
|
||
|
if -s $file == 0;
|
||
|
flock($f, LOCK_UN);
|
||
|
}
|
||
|
close($f);
|
||
|
}
|
||
|
}
|
||
|
print STDERR " $pppid] $pppid)" if $debug;
|
||
|
}
|
||
|
kill(9, $$); # exit w/o END or anything else
|
||
|
}
|
||
|
waitpid($ppid, 0);
|
||
|
kill(9, $$); # exit w/o END or anything else
|
||
|
}
|
||
|
}
|
||
|
|
||
|
1;
|
||
|
|
||
|
__DATA__
|
||
|
|
||
|
=head1 NAME
|
||
|
|
||
|
File::Flock - file locking with flock
|
||
|
|
||
|
=head1 SYNOPSIS
|
||
|
|
||
|
use File::Flock;
|
||
|
|
||
|
lock($filename);
|
||
|
|
||
|
lock($filename, 'shared');
|
||
|
|
||
|
lock($filename, undef, 'nonblocking');
|
||
|
|
||
|
lock($filename, 'shared', 'nonblocking');
|
||
|
|
||
|
unlock($filename);
|
||
|
|
||
|
my $lock = new File::Flock '/somefile';
|
||
|
|
||
|
lock_rename($oldfilename, $newfilename)
|
||
|
|
||
|
=head1 DESCRIPTION
|
||
|
|
||
|
Lock files using the flock() call. If the file to be locked does not
|
||
|
exist, then the file is created. If the file was created then it will
|
||
|
be removed when it is unlocked assuming it's still an empty file.
|
||
|
|
||
|
Locks can be created by new'ing a B<File::Flock> object. Such locks
|
||
|
are automatically removed when the object goes out of scope. The
|
||
|
B<unlock()> method may also be used.
|
||
|
|
||
|
B<lock_rename()> is used to tell File::Flock when a file has been
|
||
|
renamed (and thus the internal locking data that is stored based
|
||
|
on the filename should be moved to a new name). B<unlock()> the
|
||
|
new name rather than the original name.
|
||
|
|
||
|
=head1 LICENSE
|
||
|
|
||
|
File::Flock may be used/modified/distibuted on the same terms
|
||
|
as perl itself.
|
||
|
|
||
|
=head1 AUTHOR
|
||
|
|
||
|
David Muir Sharnoff <muir@idiom.org>
|
||
|
|
||
|
|
||
Auch abrufbar als: Unified diff
Perl-Module für Daemons