# @(#)$Id: Sysv.pm 164 2010-12-18 18:19:08Z pjf $ package IPC::SRLock::Sysv; use strict; use warnings; use version; our $VERSION = qv( sprintf '0.6.%d', q$Rev: 164 $ =~ /\d+/gmx ); use parent qw(IPC::SRLock); use English qw(-no_match_vars); use IPC::ShareLite qw(:lock); use Storable qw(nfreeze thaw); use Time::HiRes qw(usleep); use Try::Tiny; my %ATTRS = ( lockfile => 12244237, mode => q(0666), size => 65_536, _share => undef ); __PACKAGE__->mk_accessors( keys %ATTRS ); # Private methods sub _init { my $self = shift; my $share; for (grep { not defined $self->{ $_ } } keys %ATTRS) { $self->{ $_ } = $ATTRS{ $_ }; } try { $self->_share( IPC::ShareLite->new( '-key' => $self->lockfile, '-create' => 1, '-mode' => oct $self->mode, '-size' => $self->size ) ) } catch { $self->throw( "$ERRNO: $_" ) }; return; } sub _fetch_share_data { my ($self, $for_update) = @_; my $data; defined $self->_share->lock( $for_update ? LOCK_EX : LOCK_SH ) or $self->throw( 'Failed to set semaphore' ); try { $data = $self->_share->fetch } catch { $self->throw( "$ERRNO: $_" ) }; not $for_update and $self->_unlock_share; return $data ? thaw( $data ) : {}; } sub _list { my $self = shift; my $hash = $self->_fetch_share_data; my $list = []; while (my ($key, $lock) = each %{ $hash }) { push @{ $list }, { key => $key, pid => $lock->{pid }, stime => $lock->{stime }, timeout => $lock->{timeout} }; } return $list; } sub _reset { my ($self, $key) = @_; my $hash = $self->_fetch_share_data( 1 ); my $found; if ($found = delete $hash->{ $key }) { try { $self->_share->store( nfreeze( $hash ) ) } catch { $self->throw( "$ERRNO: $_" ) }; } $self->_unlock_share; $found or $self->throw( error => 'Lock [_1] not set', args => [ $key ] ); return 1; } sub _set { my ($self, $key, $pid, $timeout) = @_; my $lock_set; my $start = time; while (not $lock_set) { my ($lock, $lpid, $ltime, $ltimeout); my $found = 0; my $now = time; my $timedout = 0; my $hash = $self->_fetch_share_data( 1 ); if (exists $hash->{ $key } and $lock = $hash->{ $key }) { $lpid = $lock->{pid }; $ltime = $lock->{stime }; $ltimeout = $lock->{timeout}; if ($now > $ltime + $ltimeout) { $lock_set = $self->_set_lock( $hash, $key, $pid, $now, $timeout ); $timedout = 1; } else { $found = 1 } } else { $lock_set = $self->_set_lock( $hash, $key, $pid, $now, $timeout ); } $self->_unlock_share; if ($timedout) { my $text = $self->timeout_error( $key, $lpid, $ltime, $ltimeout ); $self->log->error( $text ); } if (!$lock_set && $self->patience && $now - $start > $self->patience) { $self->throw( error => 'Lock [_1] timed out', args => [ $key ] ); } $found and usleep( 1_000_000 * $self->nap_time ); } $self->debug and $self->log->debug( "Lock $key set by $pid\n" ); return 1; } sub _set_lock { my ($self, $hash, $key, $pid, $now, $timeout) = @_; $hash->{ $key } = { pid => $pid, stime => $now, timeout => $timeout }; try { $self->_share->store( nfreeze( $hash ) ) } catch { $self->throw( "$ERRNO: $_" ) }; return 1; } sub _unlock_share { my $self = shift; defined $self->_share->unlock or $self->throw( 'Failed to unset semaphore' ); return; } 1; __END__ =pod =head1 Name IPC::SRLock::Sysv - Set/reset locks using semop and shmop =head1 Version 0.6.$Revision: 164 $ =head1 Synopsis use IPC::SRLock; my $config = { 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 12_244_237 =item mode Mode to create the shared memory file. Defaults to 0666 =item size Maximum size of a shared memory segment. Defaults to 65_536 =back =head1 Subroutines/Methods =head2 _init Initialise the object =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 3 =item L<IPC::SRLock> =item L<IPC::ShareLite> =item L<Storable> =item L<IPC::SysV> =item L<Time::HiRes> =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: