File Coverage

blib/lib/AnyEvent/FileLock.pm

Criterion	Covered	Total	%
statement	21	64	32.8
branch	0	24	0.0
condition	0	26	0.0
subroutine	7	9	77.7
pod	0	1	0.0
total	28	124	22.5

package AnyEvent::FileLock;

our $VERSION = '0.03';

use strict;
use warnings;
use 5.010;
use Carp;
use AE;

use Fcntl ();
use Method::WeakCallback qw(weak_method_callback);

sub flock {
    my ($class, %opts) = @_;

    my $type = delete $opts{type} // 'flock';
    $type =~ /^(?:flock|fcntl)$/ or croak "invalid lock type '$type'";

    my $mode = delete $opts{mode} // '+<';
    my $lock_mode = delete $opts{lock_mode} // $mode;
    my $delay = delete $opts{delay} || 0.1;

    my $user_cb = delete $opts{cb} // croak "cb argument is missing";

    my $max_time;
    if (defined(my $timeout = delete $opts{timeout})) {
        $max_time = AE::now() + $timeout;
    }

    my $fh;
    my $file = delete $opts{file};
    if (defined $file) {
        my $open_mode = delete $opts{open_mode} // $mode;
        $open_mode =~ /^\+?(?:<|>>?)/ or croak "bad mode specification";
        open $fh, $mode, $file or return
    }
    else {
        $fh = delete $opts{file} // croak "file or fh argument is required";
    }

    my $self = { file => $file,
                 fh => $fh,
                 type => $type,
                 max_time => $max_time,
                 user_cb => $user_cb,
                 delay => $delay };

    bless $self, $class;

    if ($type eq 'fcntl') {
        $self->{$_} = delete($opts{lock_start}) // 0
            for qw(lock_start lock_whence lock_len);
        $self->{operation} = ($lock_mode eq '<' ? Fcntl::F_RDLCK() : Fcntl::F_WRLCK());
    }
    else {
        $self->{operation} = ($lock_mode eq '<' ? Fcntl::LOCK_SH() : Fcntl::LOCK_EX());
    }


    %opts and croak "unkwnown arguments found (".join(', ', sort keys %opts).")";

    my $alcb = $self->{acquire_lock_cb} = weak_method_callback($self, '_acquire_lock');
    &AE::postpone($alcb);

    $self;
}

sub _acquire_lock {
    my $self = shift;
    my $operation = $self->{opertation};
    my $now = AE::now;

    my $ok;
    if ($self->{type} eq 'flock') {
        $ok = CORE::flock($self->{fh}, $self->{operation}|Fcntl::LOCK_NB());
    }
    else {
        require Fcntl::Packer;
        my %flock = (type => $self->{operation});
        $flock{$_} = $self->{"lock_$_"} for qw(whence start len);
        $ok = fcntl($self->{fh}, Fcntl::F_SETLK, Fcntl::Packer::pack_fcntl_flock(\%flock));
    }
    if ($ok) {
        $self->{user_cb}->($self->{fh});
    }
    elsif ($! == Errno::EAGAIN() and
           (!defined($self->{max_time}) or $self->{max_time} <= $now)) {
        # we add some randomness into the delay to avoid the case
        # where all the contenders follow exactly the same pattern so
        # that they end looking for the pattern all at once everytime
        # (and obviosly all but one failing).
        &AE::timer($self->{delay} * (0.8 + rand 0.40), 0, $self->{acquire_lock_cb});
        return;
    }
    else {
        $self->{user_cb}->();
    }
    # release all the references, the object is useless from this
    # point on time.
    %$self = ();
}

1;
__END__