--- /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;
--- /dev/null
+
+# 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.
+
--- /dev/null
+# 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.
+
--- /dev/null
+# 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>
+
+
projects / kivitendo-erp.git / commitdiff