The Perl Advent Calendar needs more articles for 2022. Submit your idea today!

use FindBin;
require "$FindBin::Bin/wrap.tm";
use File::Slurp;
use Time::HiRes qw(sleep);
use POSIX qw(_exit);
use File::Flock;
use Test::More tests => 20;
use Test::SharedFork;
use strict;
use warnings;


test_lock_held_across_fork();
test_locks_dropped_on_sole_process_exit();
test_locks_dropped_on_multi_process_exit();
test_lock_rename_object();
test_forget_locks();

our $dir; # set in wrap.tt

sub test_lock_held_across_fork
{
	my $lock1 = "$dir/lhaf1";
	my $lock2 = "$dir/lhaf2";

	if (dofork()) {
		lock($lock1);
		my $l = File::Flock->new($lock2);
		write_file("$dir/gate1", "");

		POSIX::_exit(0) unless dofork();
		write_file("$dir/gate2", "");

		sleep(0.1) while ! -e "$dir/gate3";
		ok(! -e "$dir/gotlock1a", "lock held");
		ok(! -e "$dir/gotlock1b", "obj lock held");
		ok(! -e "$dir/gotlock2a", "child lock held");
		ok(! -e "$dir/gotlock2b", "child obj lock held");
		unlock($lock1);
		write_file("$dir/gate4", "");

		sleep(0.1) while ! -e "$dir/gate5";
		ok(-e "$dir/gotlock3a", "lock released");
		ok(! -e "$dir/gotlock3b", "obj lock not released");
		$l->unlock();
		write_file("$dir/gate6", "");

		sleep(0.1) while ! -e "$dir/gate7";
		ok(-e "$dir/gotlock4", "obj lock released");
		write_file("$dir/gate8", "");
	} else {
		sleep(0.1) while ! -e "$dir/gate1";
		# parent has locked lock
		write_file("$dir/gotlock1a", "") if lock($lock1, undef, 'nonblocking');
		write_file("$dir/gotlock1b", "") if lock($lock2, undef, 'nonblocking');

		sleep(0.1) while ! -e "$dir/gate2";
		write_file("$dir/gotlock2a", "") if lock($lock1, undef, 'nonblocking');
		write_file("$dir/gotlock2b", "") if lock($lock2, undef, 'nonblocking');
		write_file("$dir/gate3", "");

		sleep(0.1) while ! -e "$dir/gate4";
		write_file("$dir/gotlock3a", "") if lock($lock1, undef, 'nonblocking');
		write_file("$dir/gotlock3b", "") if lock($lock2, undef, 'nonblocking');
		write_file("$dir/gate5", "");

		sleep(0.1) while ! -e "$dir/gate6";
		write_file("$dir/gotlock4", "") if lock($lock2, undef, 'nonblocking');
		write_file("$dir/gate7", "");
		sleep(0.1) while ! -e "$dir/gate8";
		exit(0);
	}
}

sub test_locks_dropped_on_sole_process_exit
{
	my $p = "$dir/tldospe";

	my $pid;
	if (($pid = dofork())) {
		sleep(0.1) while ! -e "$p.gate1";
		ok(! lock("$p.lock1", undef, 'nonblocking'), "can't get lock");
		write_file("$p.gate2", "");
		waitpid($pid, 0);
		ok(lock("$p.lock1", undef, 'nonblocking'), "can get lock");
	} else {
		lock("$p.lock1");
		write_file("$p.gate1", "");

		sleep(0.1) while ! -e "$p.gate2";
		exit(0);
	}
}

sub test_locks_dropped_on_multi_process_exit
{
	my $p = "$dir/tldompe";

	my $pid;
	if (($pid = dofork())) {
		sleep(0.1) while ! -e "$p.gate1";
		ok(! lock("$p.lock1", undef, 'nonblocking'), "can't get lock");
		write_file("$p.gate2", "");
		waitpid($pid, 0);
		ok(lock("$p.lock1", undef, 'nonblocking'), "can get lock");
		write_file("$p.gate3", "");
	} else {
		lock("$p.lock1");
		if (dofork()) {
			write_file("$p.gate1", "");

			sleep(0.1) while ! -e "$p.gate2";
			exit(0);
		} else {
			sleep(0.1) while ! -e "$p.gate3";
			exit(0);
		}
			
	}
}

sub test_lock_rename_object
{
	my $p = "$dir/tlro";

	my $l = File::Flock->new("$p.oldlock");
	undef $!;
	undef $@;
	ok(eval {rename("$p.oldlock", "$p.newlock")}, "rename file - $!");
	ok(eval {$l->lock_rename("$p.newlock")}, "rename lock - $@");
	ok(eval {$l->unlock()}, "unlock - $@");
}

sub test_forget_locks
{
	my $p = "$dir/tfl";

	my $pid;
	if (($pid = dofork())) {
		sleep(0.1) while ! -e "$p.gate1";
		ok(! lock("$p.lock1", undef, 'nonblocking'), "can't get multi lock");

		write_file("$p.gate2", "");
		# forget locks
		sleep(0.1) while ! -e "$p.gate4";
		ok(! lock("$p.lock1", undef, 'nonblocking'), "still can't get multi lock");

		write_file("$p.gate5", "");
		# sub master quits
		waitpid($pid, 0);
		ok(kill(0, $pid) == 0, "first proc ($pid) is dead");
		ok(! lock("$p.lock1", undef, 'nonblocking'), "and still can't get multi lock");

		write_file("$p.gate3", "");
		my $pid2 = read_file("$p.gate1");
		sleep(0.1) while kill(0, $pid2);
		ok(kill(0, $pid2) == 0, "second proc ($pid2) is dead");

		ok(lock("$p.lock1", undef, 'nonblocking'), "now can get multi lock");
	} else {
		lock("$p.lock1");
		my $subpid;
		if (($subpid = dofork())) {
			write_file("$p.gate1", "$subpid");

			sleep(0.1) while ! -e "$p.gate2";
			forget_locks();
			write_file("$p.gate4", "");

			sleep(0.1) while ! -e "$p.gate5";
			exit(0);
		} else {
			sleep(0.1) while ! -e "$p.gate3";
			exit(0);
		}
			
	}
}


sub dofork
{
	my $p = fork();
	die unless defined $p;
	return $p;
}