The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;

use Test::More;

use File::Spec::Functions;

use constant FORKS => 20;
use constant TIME  => 10; # how many seconds to test for

BEGIN {
	if ( File::Spec->isa("File::Spec::Unix") ) {
		plan tests => 3 + TIME;
	} else {
		plan skip_all => "not running on something UNIXish";
	}
}

use Test::TempDir qw(scratch);

use ok 'Directory::Transactional';


my $s = scratch();

$s->create_tree({
	'account_1.txt' => "0",
	'account_2.txt' => "0",
	'account_3.txt' => "0",
});

my @pids;

sub spawn {
	my $pid = fork;

	unless ( defined $pid ) {
		# probably a resource availability problem
		# wait a while and try again
		select( undef, undef, undef, 0.1 );
		return;
	}

	if ( $pid ) {
		push @pids, $pid;
	} else {
		srand($$); # otherwise rand returns the same in all children

		alarm 5;
		my $d = Directory::Transactional->new(
			global_lock => ( rand(1) < 0.5 ),
			root        => $s->base,
		);
		alarm 0;

		while ( 1 ) {
			eval {
				$d->txn_do(sub {
					# test for atomicity by modifying two files together in a dependent way

					my @accounts = ( 1 .. 3 );
					splice(@accounts, int(rand 3), 1); # remove one at random

					$d->lock_path_write("account_${_}.txt") for @accounts;

					my @balances = map { scalar readline $d->openr("account_${_}.txt") } @accounts;

					my $diff = ( int(rand 1000) - 500 );

					$balances[0] += $diff;
					$balances[1] -= $diff;

					$d->openw("account_${_}.txt")->print( shift @balances ) for @accounts;
				});
			};

			if ( $@ ) {
				use POSIX qw(_exit);
				_exit(0);
			}
		}
	}
}

my $checks = 0;

sub check_state {
	eval {
		alarm 5;
		my $d = Directory::Transactional->new( root => $s->base ); # this may die if there is a crashed txn and multiple other dirs are still live
		alarm 0;

		$d->txn_do(sub {
			# avoid deadlocks by locking for writing
			$d->lock_path_write("account_${_}.txt") for 1 .. 3;
			my $one   = readline $d->openr("account_1.txt");
			my $two   = readline $d->openr("account_2.txt");
			my $three = readline $d->openr("account_3.txt");

			chomp for $one, $two, $three;

			$checks++;
			is( $one + $two + $three, 0, "accounts are balanced ($one, $two, $three)" );
		});
	}
}

my $t = time + TIME;

my $last = time;

do {
	if ( @pids <= 1 ) {
		while ( time < $t and @pids < FORKS ) {
			spawn();
		}
	}

	select(undef, undef, undef, 0.01) if rand() < 0.5;

	my $kid = splice(@pids, int(rand @pids), 1);
	kill 9, $kid;
	waitpid $kid, 0;

	if ( time > $last and $checks < TIME ) {
		check_state();
		$last = time;
	}
} while ( @pids );

if ( $checks < TIME ) {
	SKIP: { skip "failed to obtain exclusive recovery lock", TIME - $checks; };
}

check_state();
ok( !$@, "no error in final check" );

{
	local $SIG{__WARN__} = sub { }; # make Directory::Scratch shut up
	undef $s; undef $s;
}