The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;
use File::Spec::Functions qw( catdir catfile updir );
use FindBin               qw( $Bin );
use lib               catdir( $Bin, updir, 'lib' );

use Test::More;
use Test::Requires { version => 0.88 };
use Module::Build;

my $builder; my $notes = {}; my $perl_ver;

BEGIN {
   $builder   = eval { Module::Build->current };
   $builder and $notes = $builder->notes;
   $perl_ver  = $notes->{min_perl_version} || 5.008;
   $Bin =~ m{ : .+ : }mx and plan skip_all => 'Two colons in $Bin path';
}

use Test::Requires "${perl_ver}";
use English qw( -no_match_vars );
use File::DataClass::Exception;
use File::DataClass::IO;

use_ok 'IPC::SRLock';

my $is_win32 = ($OSNAME eq 'MSWin32') || ($OSNAME eq 'cygwin');

my $lock = IPC::SRLock->new( { tempdir => 't', type => 'fake' } );

is ref $lock->list, 'ARRAY', 'Fake list is empty';
is $lock->set( k => 1 ), 1, 'Sets fake lock';
is $lock->reset, 1, 'Resets fake lock';

$lock = IPC::SRLock->new( { tempdir => 't', type => 'fcntl' } ); my $e;

isa_ok $lock, 'IPC::SRLock';

eval { $lock->set() };

if ($e = File::DataClass::Exception->caught()) {
   like "${e}", qr{ \Qnot specified\E }mx, 'Error no key';
}
else {
   ok 0, 'Expected set error missing';
}

eval { $lock->reset( k => $PROGRAM_NAME ) };

if ($e = File::DataClass::Exception->caught()) {
   is $e->error, 'Lock [_1] not set', 'Error not set';
   ok $e->args->[ 0 ] eq $PROGRAM_NAME, 'Error args';
}
else {
   ok 0, 'Expected reset error missing';
}

$lock->set( k => $PROGRAM_NAME );

is [ map { $_->{key} } @{ $lock->list() } ]->[ 0 ], $PROGRAM_NAME,
   'Set - fcntl';

$lock->reset( k => $PROGRAM_NAME );

is [ map { $_->{key} } @{ $lock->list() } ]->[ 0 ], undef, 'Reset - fcntl';

my $lockf = io[ 't', 'ipc_srlock.lck' ]; my $shmf = io[ 't', 'ipc_srlock.shm' ];

ok $lockf->exists && $lockf->is_file, 'Lock file exists - fcntl';
ok $shmf->exists && $shmf->is_file, 'Shm file exists - fcntl';

$lockf->exists and $lockf->unlink; $shmf->exists and $shmf->unlink;

$lockf = io[ 't', 'tlock' ]; $shmf = io[ 't', 'tshm' ];

$lockf->exists and $lockf->unlink; $shmf->exists and $shmf->unlink;

$lock = IPC::SRLock->new( { debug    => 1,
                            lockfile => catfile( qw( t tlock ) ),
                            shmfile  => catfile( qw( t tshm ) ),
                            tempdir  => 't',
                            type     => 'fcntl' } );

$lock->set( k => $PROGRAM_NAME, p => 100, t => 100 );

is $lock->list->[ 0 ]->{pid}, 100, 'Non default pid - fcntl';

is $lock->list->[ 0 ]->{timeout}, 100, 'Non default timeout - fcntl';

is $lock->get_table->{count}, 1, 'Get table has count - fcntl';

like $lock->_implementation->_timeout_error( 0, 0, 0, 0 ),
   qr{ 0 \s set \s by \s 0 }mx, 'Timeout error - fcntl';

is $lock->set( k => $PROGRAM_NAME, async => 1 ), 0, 'Async lock - fcntl';

$lock->reset( k => $PROGRAM_NAME );

is $lock->get_table->{count}, 0, 'Get table has no count - fcntl';

$lockf->exists and $lockf->unlink; $shmf->exists and $shmf->unlink;

SKIP: {
   $is_win32 and skip 'tests: OS unsupported', 5;

   my $key = 12244237 + int( rand( 4096 ) );

   eval { $lock = IPC::SRLock->new( { lockfile => $key, type => 'sysv' } ) };

   my $e = $EVAL_ERROR; $e and $e =~ m{ No \s+ space }mx
      and skip 'tests: No shared memory space', 5;

   $lock->set( k => $PROGRAM_NAME );

   is [ map { $_->{key} } @{ $lock->list() } ]->[ 0 ], $PROGRAM_NAME,
      'Set - sysv';

   $lock->reset( k => $PROGRAM_NAME );

   is [ map { $_->{key} } @{ $lock->list() } ]->[ 0 ], undef, 'Reset - sysv';

   $lock = IPC::SRLock->new( { debug => 1, lockfile => $key, type => 'sysv' } );

   is $lock->set( k => $PROGRAM_NAME, p => 100, t => 100 ), 1,
      'Set returns true - sysv';

   is $lock->list->[ 0 ]->{pid}, 100, 'Non default pid - sysv';

   is $lock->list->[ 0 ]->{timeout}, 100, 'Non default timeout - sysv';

   is $lock->get_table->{count}, 1, 'Get table has count - sysv';

   is $lock->set( k => $PROGRAM_NAME, async => 1 ), 0, 'Async lock - sysv';

   $lock->reset( k => $PROGRAM_NAME );

   is $lock->get_table->{count}, 0, 'Get table has no count - sysv';

   qx{ ipcrm -M $key }; qx{ ipcrm -S $key };
}

SKIP: {
   ($ENV{AUTHOR_TESTING} and $ENV{HAVE_MEMCACHED})
      or skip 'author tests: Needs a memcached server', 2;
   $lock = IPC::SRLock->new( { patience => 10, type => 'memcached' } );
   $lock->set( k => $PROGRAM_NAME );

   is [ map { $_->{key} } @{ $lock->list() } ]->[ 0 ], $PROGRAM_NAME,
      'Set - memcached';

   $lock->reset( k => $PROGRAM_NAME );

   is [ map { $_->{key} } @{ $lock->list() } ]->[ 0 ], undef,
      'Reset - memcached';
}

done_testing;

# Local Variables:
# mode: perl
# tab-width: 3
# End: