File Coverage

lib/Ubic/Lockf.pm

Criterion	Covered	Total	%
statement	58	67	86.5
branch	18	28	64.2
condition	7	15	46.6
subroutine	12	14	85.7
pod	3	3	100.0
total	98	127	77.1

package Ubic::Lockf;
$Ubic::Lockf::VERSION = '1.58_01'; # TRIAL
use strict;
use warnings;

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


use Fcntl qw(:flock);

use Params::Validate;
use POSIX qw(:errno_h);
use Carp;

use Ubic::Lockf::Alarm;

use parent qw(Exporter);

our @EXPORT = qw(lockf);


sub DESTROY ($) {
    my ($self) = @_;
    local $@;
    my $fh = $self->{_fh};
    return unless defined $fh; # already released or dissolved
    flock $fh, LOCK_UN;
    delete $self->{_fh}; # closes the file if opened by us
}

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

sub lockf ($;$) {
    my ($param, $opts) = validate_pos(@_, 1, 0);
    $opts ||= {};
    $opts = validate(@{ [ $opts ] }, {
        blocking => 0,
        shared => 0,
        silent => 0, # deprecated option, does nothing
        timeout => 0,
        mode => 0,
    });
    $opts = {%defaults, %$opts};

    my ($fh, $fname);
    if (ref $param eq "") { # filename instead of filehandle
        open $fh, ">>", $param or die "Can't open $param: $!";
        $fname = $param;
    } else {
        $fh = $param;
    }

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

    # don't check chmod success - it can fail and it's ok
    chmod ($opts->{mode}, ($fname || $fh)) if defined $opts->{mode};

    return bless {
        _fh => $fh,
        _fname => $fname,
    };
}

sub _lockf ($$;$) {
    my ($fh, $opts, $fname) = @_;
    $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);
        return 0 if ($! == EWOULDBLOCK);
        croak "flock ".($fname || '')." failed: $!";
    }

    unless (flock ($fh, $mode | LOCK_NB)) {
        my $msg = "$fname already locked, wait...";
        if (-t STDOUT) {
            print $msg;
        }
    } else {
        return 1;
    }

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

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

sub dissolve {
    my $self = shift;
    undef $self->{_fh};
}

1;

__END__