File Coverage

lib/Lock/File.pm

Criterion	Covered	Total	%
statement	143	159	89.9
branch	53	70	75.7
condition	27	37	72.9
subroutine	24	28	85.7
pod	7	12	58.3
total	254	306	83.0

package Lock::File;
{
  $Lock::File::VERSION = '1.03';
}

# ABSTRACT: file locker with an automatic out-of-scope unlocking mechanism


use strict;
no warnings;
use Fcntl qw(:DEFAULT :flock);

use Lock::File::Alarm;

use Log::Any qw($log);
use POSIX qw(:errno_h);
use Carp;

use base qw(Exporter);
our @EXPORT_OK = qw( lockfile lockfile_multi lockfile_any lockf lockf_multi lockf_any );
our %EXPORT_TAGS = (all => \@EXPORT_OK);

sub DESTROY {
    local $@;
    my ($self) = @_;
    my $fh = $self->{_fh};
    return unless defined $fh; # already released
    unlink $self->{_fname} if $self->{_remove} and $self->{_fname};
    flock $fh, LOCK_UN; # don't check result code - sometimes this handle appeares to be already closed
    delete $self->{_fh}; # closes the file if opened by us
}

my %defaults = (
    shared => 0,
    blocking => 1,
    timeout => undef,
    mode => undef,
    remove => 0,
);

sub _validate {
    my ($opts, @attrs) = @_;
    my $opts_copy = {%$opts};
    delete $opts_copy->{$_} for @attrs;
    die "Unexpected options: ".join(',', keys %$opts_copy) if %$opts_copy;
}

sub lockfile ($;$) {
    return __PACKAGE__->new(@_);
}

sub lockf ($;$) {
    warn "lockf() is deprecated, use lockfile() instead";
    goto &lockfile;
}

sub new {
    my $class = shift;
    my ($param, $opts) = @_;
    if (@_ > 2 or @_ < 1) {
        croak "invalid lockfile arguments";
    }

    $opts ||= {};
    _validate($opts, qw/ blocking shared timeout mode remove /);

    if (exists $opts->{blocking} and not $opts->{blocking} and defined $opts->{timeout}) {
        die "non-blocking mode is incompatible with timeout option";
    }
    $opts = {%defaults, %$opts};

    my ($fh, $fname);
    if (ref $param eq "") { # filename instead of filehandle
        $fname = $param;
    } else {
        $fh = $param;
    }

    $fh = _lock_and_check($fh, $fname, $opts);
    unless ($fh) {
        return;
    }

    return bless {
        _fh => $fh,
        _fname => $fname,
        _remove => $opts->{remove},
    } => $class;
}

sub _log_message ($;$) {
    my ($bang, $question) = @_;
    my @msg;
    if ($bang) {
        push @msg, "error ".int($bang)." '$bang'";
    }
    if (defined $question and $question > 0) {
        push @msg, "kill by signal ".($question & 127) if ($question & 127);
        push @msg, "core dumped" if ($question & 128);
        push @msg, "exit code ".($question >> 8) if $question >> 8;
    }
    return join ", ", @msg;
}

sub _open {
    my ($chmod, $fname) = @_;

    my $fh;
    my $res;
    if (defined $chmod) {
        $chmod = oct($chmod) if $chmod =~ s/^0//;
        my $mode = O_WRONLY|O_CREAT|O_APPEND;
        my $umask = umask(0);
        $res = sysopen $fh, $fname, $mode, $chmod;
        umask($umask);
    }
    else {
        $res = open $fh, '>>', $fname;
    }
    die "open $fname with mode $chmod failed: ", _log_message($!) unless $res;
    return $fh;
}

sub _lock_and_check {
    my ($fh, $fname, $opts) = @_;

    unless (defined $fname) { # no unlink/lockile race when locking an already opened filehandle
        return _lock(@_) ? $fh : undef;
    }

    while () {
        $fh = _open($opts->{mode}, $fname);
        my $lock = _lock($fh, $fname, $opts);
        return unless $lock;

        unless (-e $fname) {
            $log->debug("$fname: locked but removed");
            next;
        }
        unless ((stat $fh)[1] eq (stat $fname)[1]) {
            $log->debug("$fname: locked but removed and created back");
            next;
        }
        return $fh;
    }
}

sub _xflock {
    my ($fh, $mode) = @_;
    flock $fh, $mode or die "flock failed: $!";
}

sub _lock {
    my ($fh, $fname, $opts) = @_;

    $fname ||= ''; # TODO - discover $fname from $fh, it's possible in most cases with some /proc magic

    my $mode = ($opts->{shared} ? LOCK_SH : LOCK_EX);

    if (
        not $opts->{blocking}
        or (defined $opts->{timeout} and not $opts->{timeout}) # timeout=0
    ) {
        return 1 if flock ($fh, $mode | LOCK_NB);
        if ($! == EWOULDBLOCK) {
            croak "flock $fname failed: timed out" if defined $opts->{timeout}; # timeout=0
            return 0;
        }
        croak "flock ".($fname || '')." failed: $!";
    }

    unless (flock ($fh, $mode | LOCK_NB)) {
        my $msg = "$fname already locked, wait...";
        $log->debug($msg);
    } else {
        return 1;
    }

    if ($opts->{timeout}) {
        local $SIG{ALRM} = sub { croak "flock $fname failed: timed out" };
        my $alarm = Lock::File::Alarm->new($opts->{timeout});
        _xflock($fh, $mode);
    } else {
        _xflock($fh, $mode);
    }
    return 1;
}

sub lockfile_multi ($$;$) {
    my ($fname, $max, $opts) = @_;
    $opts ||= {};
    _validate($opts, qw/ remove mode /);

    # to make sure no one will mess up the things
    # TODO - apply opts to metalock too?
    my $metalock = lockfile("$fname.meta", { remove => 1 });

    my %flist = map { $_ => 1 } grep { /^\Q$fname\E\.\d+$/ } glob "\Q$fname\E.*";

    my $locked = 0;
    my $ret;

    # try to get lock on existing file
    for my $file (keys %flist) {
        my $lock = lockfile($file, { blocking => 0, %$opts });
        $locked++ unless $lock;
        $ret ||= $lock;
        if ($locked >= $max) {
            undef $ret;
            last;
        }
    }

    # try non-existing files
    if ($locked < $max and not $ret) {
        for my $i (0 .. ($max-1)) {
            my $file = "$fname.$i";
            next if $flist{$file};
            my $lock = lockfile($file, { blocking => 0, %$opts });
            die "Unable to obtain lock on new multilock file $file" unless $lock; # this should never happen
            $ret = $lock;
            last;
        }
    }

    return $ret if defined $ret;
    return undef;
}

sub lockf_multi {
    warn "lockf_multi() is deprecated, use lockfile_multi() instead";
    goto &lockfile_multi;
}

sub lockfile_any ($;$) {
    my ($flist, $opts) = @_;
    $opts ||= {};
    _validate($opts, qw/ remove mode /);

    for my $fname (@$flist) {
        my $lock = lockfile($fname, { blocking => 0, %$opts });
        return $lock if $lock;
    }

    return undef;
}

sub lockf_any {
    warn "lockf_any() is deprecated, use lockfile_any() instead";
    goto &lockfile_any;
}

sub name {
    my $self = shift;
    return $self->{_fname};
}

sub share {
    my $self = shift;
    _xflock($self->{_fh}, LOCK_SH);
}

sub unshare {
    my $self = shift;
    _xflock($self->{_fh}, LOCK_EX);
}

sub unlock {
    my $self = shift;
    $self->DESTROY();
}

sub unlockf {
    warn "unlockf() method is deprecated, use ->unlock() instead";
    goto &{ $_[0]->can('unlock') };
}


1;

__END__