package IPC::SRLock::Sysv;

# @(#)$Id: Sysv.pm 52 2008-05-23 17:12:42Z pjf $

use strict;
use warnings;
use base qw(IPC::SRLock);
use IPC::SysV qw(IPC_CREAT);
use Readonly;
use Time::HiRes qw(usleep);

use version; our $VERSION = qv( sprintf '0.1.%d', q$Rev: 52 $ =~ /\d+/gmx );

Readonly my %ATTRS => ( lockfile  => 195_911_405,
                        mode      => oct q(0666),
                        num_locks => 100,
                        shmfile   => 195_911_405,
                        size      => 300, );

__PACKAGE__->mk_accessors( keys %ATTRS );

# Private methods

sub _init {
   my $me = shift;

   $me->{ $_ } = $ATTRS{ $_ } for (grep { ! defined $me->{ $_ } } keys %ATTRS);

   return;
}

sub _get_semid {
   my $me = shift; my $semid = semget $me->lockfile, 1, 0;

   return $semid if (defined $semid);

   $semid = semget $me->lockfile, 1, IPC_CREAT | $me->mode;

   unless (defined $semid) {
      $me->throw( error => q(eCannotCreateSemaphore), arg1 => $me->lockfile );
   }

   unless (semop $semid, pack q(s!s!s!), 0, 1, 0) {
      $me->throw( error => q(eCannotPrimeSemaphore), arg1 => $me->lockfile );
   }

   return $semid;
}

sub _get_shmid {
   my $me = shift; my ($shmid, $size);

   $size  = $me->size * $me->num_locks;
   $shmid = shmget $me->shmfile, $size, 0;

   return $shmid if (defined $shmid);

   $shmid = shmget $me->shmfile, $size, IPC_CREAT | $me->mode;

   unless (defined $shmid) {
      $me->throw( error => q(eCannotCreateMemorySegment),
                  arg1  => $me->shmfile );
   }

   shmwrite $shmid, q(EOF,), 0, $me->size;
   return $shmid;
}

sub _list {
   my $me = shift; my (@flds, $line, $lock_no, $self, $semid, $shmid);

   $self  = [];
   $semid = $me->_get_semid();

   unless (semop $semid, pack q(s!s!s!), 0, -1, 0) {
      $me->throw( error => q(eCannotSetSemaphore), arg1 => $me->lockfile );
   }

   $shmid = $me->_get_shmid();

   for $lock_no (0 .. $me->num_locks - 1) {
      shmread $shmid, $line, $me->size * $lock_no, $me->size;

      last if ($line =~ m{ \A EOF, }mx);

      @flds = split m{ , }mx, $line;
      push @{ $self }, { key     => $flds[0],
                         pid     => $flds[1],
                         stime   => $flds[2],
                         timeout => $flds[3] };
   }

   unless (semop $semid, pack q(s!s!s!), 0, 1, 0) {
      $me->throw( error => q(eCannotReleaseSemaphore), arg1 => $me->lockfile );
   }

   return $self;
}

sub _reset {
   my ($me, $key) = @_; my ($found, $line, $lock_no, $semid, $shmid);

   $semid = $me->_get_semid();

   unless (semop $semid, pack q(s!s!s!), 0, -1, 0) {
      $me->throw( error => q(eCannotSetSemaphore), arg1 => $me->lockfile );
   }

   $shmid = $me->_get_shmid();
   $found = 0;

   for $lock_no (0 .. $me->num_locks - 1) {
      shmread $shmid, $line, $me->size * $lock_no, $me->size;

      if ($found) {
         shmwrite $shmid, $line, $me->size * ($lock_no - 1), $me->size;
      }

      last       if ($line =~ m{ \A EOF, }mx);
      $found = 1 if ($line =~ m{ \A $key , }mx);
   }

   unless (semop $semid, pack q(s!s!s!), 0, 1, 0) {
      $me->throw( error => q(eCannotReleaseSemaphore), arg1 => $me->lockfile );
   }

   $me->throw( error => q(eLockNotSet), arg1 => $key ) unless ($found);

   return 1;
}

sub _set {
   my ($me, $key, $pid, $timeout) = @_;
   my ($found, $line, $lock_no, $lock_set, $lpid, $ltime, $ltimeout, $now);
   my ($rec, $semid, $start, $shmid, $text);

   $semid = $me->_get_semid();
   $shmid = $me->_get_shmid();
   $start = time;

   while (!$lock_set) {
      unless (semop $semid, pack q(s!s!s!), 0, -1, 0) {
         $me->throw( error => q(eCannotSetSemaphore), arg1 => $me->lockfile );
      }

      $found = 0; $now = time;

      for $lock_no (0 .. $me->num_locks - 1) {
         shmread $shmid, $line, $me->size * $lock_no, $me->size;

         if ($line =~ m{ \A EOF, }mx) {
            $rec = $key.q(,).$pid.q(,).$now.q(,).$timeout.q(,);
            shmwrite $shmid, $rec, $me->size * $lock_no, $me->size
               unless ($lock_set);
            shmwrite $shmid, q(EOF,), $me->size * ($lock_no + 1), $me->size;
            $me->log->debug( 'Set lock '.$rec."\n" ) if ($me->debug);
            $lock_set = 1;
            last;
         }

         next if ($line !~ m{ \A $key [,] }mx);
         (undef, $lpid, $ltime, $ltimeout) = split m{ [,] }mx, $line;
         if ($now < $ltime + $ltimeout) { $found = 1; last }

         $rec = $key.q(,).$pid.q(,).$now.q(,).$timeout.q(,);
         shmwrite $shmid, $rec, $me->size * $lock_no, $me->size;
         $text = $me->timeout_error( $key, $lpid, $ltime, $ltimeout );
         $me->log->error( $text );
         $lock_set = 1;
      }

      unless (semop $semid, pack q(s!s!s!), 0, 1, 0) {
         $me->throw( error => q(eCannotReleaseSemaphore),
                     arg1  => $me->lockfile );
      }

      if (!$lock_set && $me->patience && $now - $start > $me->patience) {
         $me->throw( error => q(ePatienceExpired), arg1 => $key );
      }

      usleep( 1_000_000 * $me->nap_time ) if ($found);
   }

   return 1;
}

1;

__END__

=pod

=head1 Name

IPC::SRLock::Sysv - Set/reset locks using semop and shmop

=head1 Version

0.1.$Revision: 52 $

=head1 Synopsis

   use IPC::SRLock;

   my $config   = { tempdir => q(path_to_tmp_directory), type => q(sysv) };

   my $lock_obj = IPC::SRLock->new( $config );

=head1 Description

Uses System V semaphores to lock access to a shared memory file

=head1 Configuration and Environment

This class defines accessors and mutators for these attributes:

=over 3

=item lockfile

The key the the semaphore. Defaults to 195_911_405

=item mode

Mode to create the shared memory file. Defaults to 0666

=item num_locks

Maximum number of simultaneous locks. Defaults to 100

=item shmfile

The key to the shared memory file. Defaults to 195_911_405

=item size

Maximum size of a lock record. Limits the lock key to 255
bytes. Defaults to 300

=back

=head1 Subroutines/Methods

=head2 _init

Initialise the object

=head2 _get_semid

Return the semaphore reference

=head2 _get_shmid

Return the shared memory reference

=head2 _list

List the contents of the lock table

=head2 _reset

Delete a lock from the lock table

=head2 _set

Set a lock in the lock table

=head1 Diagnostics

None

=head1 Dependencies

=over 4

=item L<IPC::SRLock>

=item L<IPC::SysV>

=item L<Readonly>

=back

=head1 Incompatibilities

There are no known incompatibilities in this module

=head1 Bugs and Limitations

There are no known bugs in this module.
Please report problems to the address below.
Patches are welcome

=head1 Author

Peter Flanigan, C<< <Support at RoxSoft.co.uk> >>

=head1 License and Copyright

Copyright (c) 2008 Peter Flanigan. All rights reserved

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L<perlartistic>

This program is distributed in the hope that it will be useful,
but WITHOUT WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE

=cut

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