From: Moritz Bunkus Date: Mon, 1 Nov 2010 10:24:56 +0000 (+0100) Subject: Perl-Module für Daemons X-Git-Tag: release-2.6.3~61^2~7^2~1^2~2^2~113 X-Git-Url: http://wagnertech.de/git?a=commitdiff_plain;h=23d894990d46c57b3d354b080ca8a373dbeeb756;p=kivitendo-erp.git Perl-Module für Daemons --- diff --git a/modules/fallback/Daemon/Generic.pm b/modules/fallback/Daemon/Generic.pm new file mode 100644 index 000000000..c185e8ae6 --- /dev/null +++ b/modules/fallback/Daemon/Generic.pm @@ -0,0 +1,553 @@ + +# Copyright (C) 2006, David Muir Sharnoff + +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; diff --git a/modules/fallback/Daemon/Generic/Event.pm b/modules/fallback/Daemon/Generic/Event.pm new file mode 100644 index 000000000..2279a1ee9 --- /dev/null +++ b/modules/fallback/Daemon/Generic/Event.pm @@ -0,0 +1,126 @@ + +# Copyright (C) 2006, David Muir Sharnoff + +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 that +predefines some methods: + +=over 15 + +=item gd_run() + +Setup a periodic callback to C if there is a C. +Call C. + +=item gd_setup_signals() + +Bind SIGHUP to call C. +Bind SIGINT to call C. + +=back + +To use Daemon::Generic::Event, you have to provide a C +method. It can be empty if you have a C. + +Set up your own events in C and C. + +If you have a C method, it will be called once per +second or every C seconds if you have a C +method. Unlike in L, C should +not include a call to C. + +=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 . +This module may be used and distributed on the same terms +as Perl itself. + diff --git a/modules/fallback/Daemon/Generic/While1.pm b/modules/fallback/Daemon/Generic/While1.pm new file mode 100644 index 000000000..9c2691449 --- /dev/null +++ b/modules/fallback/Daemon/Generic/While1.pm @@ -0,0 +1,189 @@ +# Copyright (C) 2006, David Muir Sharnoff + +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: a default +C provided. It has a while(1) loop that calls +C over and over. It checks for reconifg and +and terminate events and only actions them between calls +to C. + +Terminate events will be forced through after +C<$Daemon::Generic::force_quit_delay> seconds if +C 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 (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): + +=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 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 . +This module may be used and distributed on the same terms +as Perl itself. + diff --git a/modules/fallback/File/Flock.pm b/modules/fallback/File/Flock.pm new file mode 100644 index 000000000..f9b62c184 --- /dev/null +++ b/modules/fallback/File/Flock.pm @@ -0,0 +1,327 @@ +# 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 object. Such locks +are automatically removed when the object goes out of scope. The +B method may also be used. + +B 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 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 + +