# @(#)$Id: SRLock.pm 210 2013-04-15 20:24:44Z pjf $ package IPC::SRLock; use strict; use warnings; use version; our $VERSION = qv( sprintf '0.9.%d', q$Rev: 210 $ =~ /\d+/gmx ); use parent qw(Class::Accessor::Fast); use Class::MOP; use Class::Null; use Date::Format; use English qw(-no_match_vars); use IPC::SRLock::Exception; use Time::Elapsed qw(elapsed); use Try::Tiny; my %ATTRS = ( debug => 0, log => undef, name => (lc join q(_), split m{ :: }mx, __PACKAGE__), nap_time => 0.1, patience => 0, pid => undef, time_out => 300, type => q(fcntl), ); __PACKAGE__->mk_accessors( keys %ATTRS ); sub new { my ($self, @rest) = @_; my $args = $self->_arg_list( @rest ); my $attrs = __hash_merge( \%ATTRS, $args ); my $class = __PACKAGE__.q(::).(ucfirst $attrs->{type}); $self->_ensure_class_loaded( $class ); # Load factory subclass my $new = bless $attrs, $class; $new->log ( $new->log || Class::Null->new() ); $new->pid ( $PID ); $new->_init( $args ); # Initialise factory subclass return $new; } sub get_table { my $self = shift; my $count = 0; my $data = { align => { id => 'left', pid => 'right', stime => 'right', tleft => 'right'}, count => $count, fields => [ qw(id pid stime tleft) ], hclass => { id => q(most) }, labels => { id => 'Key', pid => 'PID', stime => 'Lock Time', tleft => 'Time Left' }, values => [] }; for my $lock (@{ $self->list }) { my $fields = {}; $fields->{id } = $lock->{key}; $fields->{pid } = $lock->{pid}; $fields->{stime} = time2str( q(%Y-%m-%d %H:%M:%S), $lock->{stime} ); my $tleft = $lock->{stime} + $lock->{timeout} - time; $fields->{tleft} = $tleft > 0 ? elapsed( $tleft ) : 'Expired'; $fields->{class}->{tleft} = $tleft < 1 ? q(error dataValue) : q(odd dataValue); push @{ $data->{values} }, $fields; $count++; } $data->{count} = $count; return $data; } sub list { my $self = shift; return $self->_list; } sub reset { my ($self, @rest) = @_; my $args = $self->_arg_list( @rest ); my $key = $args->{k} or $self->throw( 'No key specified' ); return $self->_reset( q().$key ); } sub set { my ($self, @rest) = @_; my $args = $self->_arg_list( @rest ); $args->{k} = q().$args->{k} or $self->throw( 'No key specified' ); $args->{p} ||= $self->pid; $args->{p} or $self->throw( 'No pid specified' ); $args->{t} ||= $self->time_out; return $self->_set( $args ); } sub throw { my ($self, @rest) = @_; return IPC::SRLock::Exception->throw( @rest ); } sub timeout_error { my ($self, $key, $pid, $when, $after) = @_; my $text; $text = 'Timed out '.$key.' set by '.$pid; $text .= ' on '.time2str( q(%Y-%m-%d at %H:%M), $when ); $text .= ' after '.$after.' seconds'."\n"; return $text; } # Private methods sub _arg_list { my ($self, @rest) = @_; $rest[ 0 ] or return {}; return ref $rest[ 0 ] ? $rest[ 0 ] : { @rest }; } sub _ensure_class_loaded { my ($self, $class, $opts) = @_; $opts ||= {}; my $package_defined = sub { Class::MOP::is_class_loaded( $class ) }; not $opts->{ignore_loaded} and $package_defined->() and return 1; try { Class::MOP::load_class( $class ) } catch { $self->throw( $_ ) }; $package_defined->() and return 1; my $e = 'Class [_1] loaded but package undefined'; $self->throw( error => $e, args => [ $class ] ); return; # Never reached } sub _init { return; } sub _list { my $self = shift; $self->throw( error => 'Method [_1] not overridden in [_2]', args => [ q(_list), ref $self || $self ] ); return; } sub _reset { my $self = shift; $self->throw( error => 'Method [_1] not overridden in [_2]', args => [ q(_reset), ref $self || $self ] ); return; } sub _set { my $self = shift; $self->throw( error => 'Method [_1] not overridden in [_2]', args => [ q(_set), ref $self || $self ] ); return; } # Private subroutines sub __hash_merge { return { %{ $_[ 0 ] }, %{ $_[ 1 ] || {} } }; } 1; __END__ =pod =head1 Name IPC::SRLock - Set/reset locking semantics to single thread processes =head1 Version 0.9.$Revision: 210 $ =head1 Synopsis use IPC::SRLock; my $config = { tempdir => q(path_to_tmp_directory), type => q(fcntl) }; my $lock_obj = IPC::SRLock->new( $config ); $lock_obj->set( k => q(some_resource_identfier) ); # This critical region of code is guaranteed to be single threaded $lock_obj->reset( k => q(some_resource_identfier) ); =head1 Description Provides set/reset locking methods which will force a critical region of code to run single threaded =head1 Configuration and Environment This class defines accessors and mutators for these attributes: =over 3 =item C<debug> Turns on debug output. Defaults to 0 =item C<log> If set to a log object, it's C<debug> method is called if debugging is turned on. Defaults to L<Class::Null> =item C<name> Used as the lock file names. Defaults to I<ipc_srlock> =item C<nap_time> How long to wait between polls of the lock table. Defaults to 0.5 seconds =item C<patience> Time in seconds to wait for a lock before giving up. If set to 0 waits forever. Defaults to 0 =item C<pid> The process id doing the locking. Defaults to this processes id =item C<time_out> Time in seconds before a lock is deemed to have expired. Defaults to 300 =item C<type> Determines which factory subclass is loaded. Defaults to I<fcntl> =back =head1 Subroutines/Methods =head2 new This constructor implements the singleton pattern, ensures that the factory subclass is loaded in initialises it =head2 catch Expose the C<catch> method in L<IPC::SRLock::ExceptionClass> =head2 get_table my $data = $lock_obj->get_table; Returns a hash ref that contains the current lock table contents. The keys/values in the hash are suitable for passing to L<HTML::FormWidgets> =head2 list my $array_ref = $lock_obj->list; Returns an array of hash refs that represent the current lock table =head2 reset $lock_obj->reset( k => q(some_resource_key) ); Resets the lock referenced by the B<k> attribute. =head2 set $lock_obj->set( k => q(some_resource_key) ); Sets the specified lock. Attributes are: =over 3 =item B<k> Unique key to identify the lock. Mandatory no default =item B<p> Explicitly set the process id associated with the lock. Defaults to the current process id =item B<t> Set the time to live for this lock. Defaults to five minutes. Setting it to zero makes the lock last indefinitely =back =head2 throw Expose the C<throw> method in C<IPC::SRLock::ExceptionClass> =head2 timeout_error Return the text of the the timeout message =head2 _arg_list my $args = $self->_arg_list( @rest ); Returns a hash ref containing the passed parameter list. Enables methods to be called with either a list or a hash ref as it's input parameters =head2 _ensure_class_loaded $self->_ensure_class_loaded( $some_class ); Require the requested class, throw an error if it doesn't load =head2 _init Called by the constructor. Optionally overridden in the factory subclass. This allows subclass specific initialisation =head2 _list Should be overridden in the factory subclass =head2 _reset Should be overridden in the factory subclass =head2 _set Should be overridden in the factory subclass =head2 __hash_merge my $hash = __hash_merge( { key1 => val1 }, { key2 => val2 } ); Simplistic merging of two hashes =head1 Diagnostics Setting C<debug> to true will cause the C<set> methods to log the lock record at the debug level =head1 Dependencies =over 3 =item L<Class::Accessor::Fast> =item L<Class::MOP> =item L<Class::Null> =item L<Date::Format> =item L<IPC::SRLock::ExceptionClass> =item L<Time::Elapsed> =back =head1 Incompatibilities The C<Sysv> subclass will not work on C<MSWin32> and C<cygwin> platforms =head1 Bugs and Limitations Testing of the B<memcached> subclass is skipped on all platforms as it requires C<memcached> to be listening on the localhost's default memcached port I<localhost:11211> There are no known bugs in this module. Please report problems to the address below. Patches are welcome =head1 Author Peter Flanigan, C<< <pjfl@cpan.org> >> =head1 License and Copyright Copyright (c) 2008-2012 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: