File Coverage

blib/lib/Cache/Memcached/Semaphore.pm

Criterion	Covered	Total	%
statement	12	55	21.8
branch	0	24	0.0
condition	0	12	0.0
subroutine	4	8	50.0
pod	3	3	100.0
total	19	102	18.6

package Cache::Memcached::Semaphore;
use strict;
require 5.007003;

use base qw(Exporter);
#---------------------------------------------------------------------
our %EXPORT_TAGS = (
						all	=> [ qw(
									&acquire
									&wait_acquire
								) ],
					);
#---------------------------------------------------------------------

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
#---------------------------------------------------------------------

our $VERSION = '0.3';

use Time::HiRes qw( usleep gettimeofday );
use Digest::MD5 qw(md5_hex);

#---------------------------------------------------------------------
sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;

	my %args = (
					name	=> undef,
					memd	=> undef,
					force	=> 0,	# force lock is experimental
					timeout	=> undef,
					@_,
				);

	if ( $args{name} && $args{memd}) {
		my $memd = $args{memd};

		if ( $memd ) {
			my $key = "__lock__" . $args{name};
			my $val = md5_hex( gettimeofday() . $$ );
			my $res = $memd->add( $key, $val );
			if ( $res || $args{force}) {
				unless ( $res ) {
					$memd->set( $key, $val );
					return undef unless $memd->get( $key ) eq $val;
				}
				my $self = {
								key		=> $key,
								val		=> $val,
								memd	=> $memd,
								timeout	=> $args{timeout},
							};

				bless $self, $class;

				return $self;
			}
		}
	}

	return undef;
}
#---------------------------------------------------------------------

sub DESTROY {
	my $self = shift;
	my $memd = $self->{memd};

	if ( $memd ) {
		my $val = $memd->get( $self->{key} );
		$val = "" unless $val;
		if ( $val eq $self->{val} ) {
			my $res = $memd->delete( $self->{key}, $self->{timeout} );
		} else {
			warn "Wrong value at $self->{key} while unlocking.\nExpected $self->{val}\nGot $val" ;
		}
	} else {
		warn "No memd $self->{memd_id}. Cannot unlock $self->{key}";
	}
}
#---------------------------------------------------------------------

sub acquire {
	my %args = (
					name	=> undef,
					memd	=> undef,
					timeout	=> undef,
					@_,
				);

	return Cache::Memcached::Semaphore->new( %args );
}
#---------------------------------------------------------------------

sub wait_acquire {
	my %args = (
					name		=> undef,
					memd		=> undef,
					timeout		=> undef,
					max_wait	=> undef,
					poll_time	=> 0.1,
					force_after_timeout	=> 0,
					@_,
				);

	my $wait_indef = 0;
	$wait_indef = 1 unless $args{max_wait};
	my $wait_left = $args{max_wait};
	my $wait_time = $args{poll_time};

	my $lock = Cache::Memcached::Semaphore->new(
									name	=> $args{name},
									memd	=> $args{memd},
									timeout	=> $args{timeout},
								);

	while ( !$lock  ) {
		usleep( $wait_time );

		$lock = Cache::Memcached::Semaphore->new(
									name	=> $args{name},
									memd	=> $args{memd},
									timeout	=> $args{timeout},
								);

		unless( $wait_indef ) {
			$wait_left -= $wait_time;
			last if ( $wait_left <= 0 );
		}
	}

	if ( !$lock && $args{force_after_timeout} ) {
		$lock = Cache::Memcached::Semaphore->new(
									name	=> $args{name},
									memd	=> $args{memd},
									timeout	=> $args{timeout},
									force	=> 1,
								);
	}

	return $lock;
}
#---------------------------------------------------------------------

1;
__END__