File Coverage

blib/lib/JIP/LockFile.pm

Criterion	Covered	Total	%
statement	83	91	91.2
branch	22	28	78.5
condition	1	2	50.0
subroutine	23	23	100.0
pod	3	8	37.5
total	132	152	86.8

package JIP::LockFile;

use 5.006;
use strict;
use warnings;

use IO::File;
use Carp qw(croak);
use Fcntl qw(LOCK_EX LOCK_NB);
use English qw(-no_match_vars);

our $VERSION = '0.062';

sub new {
    my ($class, %param) = @ARG;

    # Mandatory options
    if (!exists $param{'lock_file'}) {
        croak q{Mandatory argument "lock_file" is missing};
    }

    # Check "lock_file"
    my $lock_file = $param{'lock_file'};
    if (!length $lock_file) {
        croak q{Bad argument "lock_file"};
    }

    # Class to object
    return bless(
        {
            is_locked => 0,
            fh        => undef,
            error     => undef,
            lock_file => $lock_file,
        },
        $class,
    );
}

sub is_locked {
    my ($self) = @ARG;

    return $self->{'is_locked'};
}

sub lock_file {
    my ($self) = @ARG;

    return $self->{'lock_file'};
}

sub error {
    my ($self) = @ARG;

    return $self->{'error'};
}

# Lock or raise an exception
sub lock {
    my ($self) = @ARG;

    return $self->_lock();
}

# Or just return undef
sub try_lock {
    my ($self) = @ARG;

    return $self->_lock(try => 1);
}

# You can manually unlock
sub unlock {
    my ($self) = @ARG;

    # Re-unlocking changes nothing
    return $self if !$self->is_locked;

    # Close filehandle before file removing
    $self->_set_fh(undef);

    if (!unlink $self->lock_file) {
        $self->_set_error($OS_ERROR);

        croak sprintf(q{Can't unlink "%s": %s}, $self->lock_file, $self->error);
    }

    return $self->_set_is_locked(0);
}

sub get_lock_data {
    my ($self) = @_;

    my $line;
    {
        my $fh
            = $self->is_locked
            ? $self->_fh
            : $self->_init_file_handle;

        return if !$fh;

        $fh->seek(0, 0);

        $line = $fh->getline();
    }

    return if !$line;

    chomp $line;

    my ($pid, $executable_name) = $line =~ m{
        ^
        {
            "pid":"(\d+)"
            ,
            "executable_name":"( [^""]+ )"
        }
        $
    }x;

    return {
        pid             => $pid,
        executable_name => $executable_name,
    };
}

# unlocking on scope exit
sub DESTROY {
    my ($self) = @ARG;

    return $self->unlock;
}

sub _init_file_handle {
    my ($self) = @ARG;

    my $fh = IO::File->new($self->lock_file, O_RDWR | O_CREAT);

    if (!$fh) {
        $self->_set_error($OS_ERROR);
    }

    return $fh;
}

sub _lock {
    my ($self, %param) = @_;

    # Re-locking changes nothing
    return $self if $self->is_locked;

    my $fh = $self->_init_file_handle;

    if (!$fh) {
        croak sprintf(q{Can't open "%s": %s}, $self->lock_file, $self->error);
    }

    if (!flock $fh, LOCK_EX | LOCK_NB) {
        $self->_set_error($OS_ERROR);

        return if $param{'try'};

        croak sprintf(q{Can't lock "%s": %s}, $self->lock_file, $self->error);
    }

    if (!truncate $fh, 0) {
        $self->_set_error($OS_ERROR);

        croak sprintf(q{Can't truncate "%s": %s}, $self->lock_file, $self->error);
    }

    autoflush $fh 1;

    if (!$fh->print($self->_lock_message)) {
        $self->_set_error($OS_ERROR);

        croak sprintf(q{Can't write message to file: %s}, $self->error);
    }

    return $self->_set_fh($fh)->_set_is_locked(1);
}

sub _lock_message {
    return sprintf(
        q[{"pid":"%s","executable_name":"%s"}],
        $PROCESS_ID,
        $EXECUTABLE_NAME,
    );
}

sub _set_is_locked {
    my ($self, $is_locked) = @ARG;

    $self->{'is_locked'} = $is_locked;

    return $self;
}

sub _fh {
    my ($self) = @ARG;

    return $self->{'fh'};
}

sub _set_fh {
    my ($self, $fh) = @ARG;

    $self->{'fh'} = $fh;

    return $self;
}

sub _set_error {
    my ($self, $error) = @ARG;

    $self->{'error'} = $error || '';

    return $self;
}

1;

__END__