The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.

use strict;
use Test;

# use a BEGIN block so we print our plan before MyModule is loaded
BEGIN { plan tests => 12, todo => [] }
BEGIN { $| = 1 }

# load your module...
use lib './';
use Fcntl qw( );

use File::Util qw( SL NL );
my($f) = File::Util->new();
my($tmpf) = 'flock_test';
my($probe_flock) = sub { local($@); eval(<<'__canflock__'); $@ ? 0 : 1 };
flock(STDIN, &Fcntl::LOCK_SH);
flock(STDIN, &Fcntl::LOCK_UN);
__canflock__
my($skip) = !$f->can_write('.') || !$f->can_write('t');

$skip = $skip ? &skipmsg() : $skip;

# using flock? get/set flock-ing usage toggle
ok($f->use_flock( ),1);                                                # test 1
ok($f->use_flock(1),1);                                                # test 2
ok($f->use_flock(0),0);                                                # test 3
ok($f->use_flock( ),0);                                                # test 4
ok($f->use_flock(1),1);                                                # test 5

# get/set flock-ing failure policy
ok(qq[@{[$f->flock_rules()]}],'NOBLOCKEX FAIL');                       # test 6
ok(join(' ', $f->flock_rules(qw/ NOBLOCKEX ZERO /)),q[NOBLOCKEX ZERO]);# test 7

# can the system lock file IO?  does it?
skip(!$probe_flock, $f->can_flock, 1);                                 # test 8

# does it really work?
skip(!$probe_flock, &test_flock());                                    # test 9

exit;

# put flock to the "test"
sub test_flock {

   # lock file, keep open handle on it
   my($fh);

	unless ($skip) {
		$fh = $f->open_handle('file' => $tmpf);

		# write something into the file
		my($tstr) = 'Hello world!' . NL;
		print($fh $tstr x 50);

	}

   # try to $f->trunc locked file (should fail)
   skip(
		$skip,
		sub { # test 10

			# FORKING!!
			my($pid) = fork; $| = 1; die(qq{Can't fork: $!}) unless defined($pid);

			if (!$pid) { $f->trunc($tmpf); exit } else { waitpid($pid, 0) }

			# DONE WITH THAT NOW.
			-s $tmpf
	});

   # test 11 - try to $f->write_file on locked file (should fail)
   skip(
		$skip,
		sub {

			# FORKING!!
			my($pid) = fork; $| = 1; die(qq{Can't fork: $!}) unless defined($pid);

			if (!$pid) {

				$f->write_file(
					'file' => $tmpf,
					'content' => '',
					'--empty-writes-OK'
				);

				exit
			}
			else { waitpid($pid, 0) }

			# DONE WITH THAT NOW.
			-s $tmpf
	});

   # unlock file
   close($fh) unless $skip;

   # test 12 - try to trunc the file; should succeed
   #  - skip this on solaris...
   if ($^O =~ /solaris/i) {
      skip(&skip_trunc_solaris(), 0, 0);
   }
   else {
      skip($skip, sub { $f->trunc($tmpf); return -s $tmpf }, 0);
   }

   # try to delete the file; should succeed
   unlink($tmpf) unless $skip;

   !-e $tmpf;
}

sub skipmsg { <<'__WHYSKIP__' }
Insufficient permissions to perform IO in this directory.  Can't perform tests!
__WHYSKIP__

sub skip_trunc_solaris { <<'__WHYSKIP__' }
Solaris can flock, but won't let go of discretionary lock yet.
__WHYSKIP__