projekt kivitendo

# 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;

# 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.

# 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.

# 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>