view release on metacpan or  search on metacpan

lib/Acrux/FileLock.pm  view on Meta::CPAN

    die $fl->error if $fl->error;

... or with auto-lock and auto-unlock:

    my $fl = Acrux::FileLock->new(
        file => '/tmp/file.lock',
        pid  => $$,
        auto => 1,
    );

    die $fl->error if $fl->error;
    die "Already running" if $fl->check;

    # . . . do stuff . . .

=head1 DESCRIPTION

The Lock File simple interface

This package manages a lock files. It will create a lock file,
query the process within to discover if it's still running, and remove
the lock file. This module based on L<Lock::File>, L<File::TinyLock>,
L<JIP::LockFile>, L<LockFile::Simple> and L<Acrux::FilePid>.

=head1 METHODS

This module implements the following methods

=head2 new

    my $fl = Acrux::FileLock->new(
        file    => '/tmp/file.lock',
        delay   => 60,
        retries => 5,
        pid     => $$,
        auto    => 1,
    );

This constructor takes several optional attributes:

=over 4

=item auto

    auto => 0

If this flag specified as true, then
will be saved the lock file automatically while instance create and
removed the lock file automatically on DESTROY phase. Default: false

=item debug

    debug => 0

Print debugging messages to STDERR (0=Off (default), 1=On)

=item delay

    delay => 60

Number of seconds to wait between retries to getting a lockfile

Default: 60

=item file

    file => '/tmp/test.lock'

The name of the lock file to work on. If not specified, a lock
file located in current directory will be created that matches F<./basename($0).lock>.

=item flock

    flock => 1

If this flag is set to true then lockfile will be lock by system with flock

Default: 0

=item pid

    pid => $$

The pid to write to a new lockfile. If not specified, C<$$> is
used when the lock file doesn't exist. When the lock file does exist, the
pid inside it is used.


=item retries

    retries => 5

Number of times to retry getting a lockfile

Default: 5

=back

=head2 check

    if ( $fl->check ) {
        warn $fl->error if $fl->error;
        die "Already running: $fl->own";
    }

This method checks whether the lock is currently considered active.

Returns C<1> if the lock is active or C<0> if the lock is free.
The return value is always boolean and does not contain the PID of the
lock owner.

Before checking the lock state, this method reads the owner information
from the lock file and updates the C<own> and C<uid> attributes when the
file contains valid owner data. These values represent the metadata
stored in the lock file at the time of the call and must not be
considered proof that the corresponding process currently owns the
lock.

When C<flock> mode is enabled, the lock state is determined exclusively
by the system file lock. The C<own> and C<uid> attributes are still
updated from the lock file, but they do not participate in determining

lib/Acrux/FileLock.pm  view on Meta::CPAN

        if (my $fh = $self->{fh}) {
            unless (flock $fh, LOCK_EX | LOCK_NB) {
                $self->error(sprintf("Can't lock \"%s\": %s", $self->file, $!));
                $self->_debug($self->error);
                $self->{fh} = undef;
                return $self;
            }

            # Truncate file
            unless (truncate $fh, 0) {
                $self->error(sprintf("Can't truncate \"%s\": %s", $self->file, $!));
                $self->_debug($self->error);
                return $self->_rollback;
            }
            seek $fh, 0, 0;

            # Write data
            unless ($fh->printf("%d:%d\n", $self->pid || $$, $>)) {
                $self->error(sprintf("Can't write message to \"%s\": %s", $self->file, $!));
                $self->_debug($self->error);
                return $self->_rollback;
            }

            # Ok
            $self->{_is_locked} = 1;
            $self->own($self->pid || $$)->uid($>);
            $self->_debug("Got lock file (flock=true)");
        } else {
            $self->error(sprintf("Can't open \"%s\": %s", $self->file, $!));
            $self->_debug($self->error);
        }
        return $self;
    }

    # Regular case: save temp file first
    my $tmp_file = sprintf("%s.%d", $self->file, $self->pid);
    if (my $fh = IO::File->new($tmp_file, O_WRONLY | O_CREAT)) {
        unless ($fh->printf("%d:%d\n", $self->pid || $$, $>)) {
            $self->error(sprintf("Can't write message to \"%s\": %s", $tmp_file, $!));
            $self->_debug($self->error);
            unlink $tmp_file if -f $tmp_file;
            return $self;
        }
        unless ($fh->close) {
            $self->error(sprintf("Can't close \"%s\": %s", $tmp_file, $!));
            $self->_debug($self->error);
            unlink $tmp_file if -f $tmp_file;
            return $self;
        }

        # Rename temp file to lock file
        for my $try (0 .. $self->{retries}) {
            unless ($self->check()) { # not exists, ok
                if (rename($tmp_file, $self->file)) {
                    $self->{_is_locked} = 1;
                    $self->_debug("Got lock file (flock=false)");
                    return $self;
                }
            }
            if ($self->{retries} && ($try != $self->{retries})) {
                $self->_debug(sprintf("Retrying in %d seconds", $self->{delay}));
                sleep $self->{delay} unless ($try == $self->{retries});
            }
        }
    } else {
        $self->error(sprintf("Can't open \"%s\": %s", $tmp_file, $!));
        $self->_debug($self->error);
    }

    # Remove temp file in silent mode
    unlink $tmp_file if -f $tmp_file;

    # Ok
    return $self;
}
sub check {
    my $self = shift;
       $self->error(undef);

    # Read owner-data of existed file (see own and uid accessors)
    $self->_read_owner;

    return $self->_is_locked
        if $self->_use_flock;

    # File not exists. Returns 0
    return 0 unless -f $self->file;

    # Check current PID and owner PID
    if ($self->own == $self->pid) {
        $self->_debug(sprintf("An attempt to call the check method twice was detected for PID=%d", $self->own));
        return 1;
    }

    # Check owner PID
    if ($self->own && kill(0, $self->own)) {
        # Oops! Process already exists
        $self->_debug(sprintf("Found valid existing lock file for PID=%d", $self->own));
        return 1;
    }

    # Process for owner PID not exists. Check owner UID
    else {
        # Owner UID is current user?
        if ($self->uid && $self->uid != $>) {
            $self->_debug("The owner of the lock file owns NOT current user");
            # Check process by by /proc/PID (for linux only!)
            if (-d File::Spec->catfile("/proc", $self->own)) {
                $self->_debug(sprintf("Found valid existing lock file for PID=%d (by /proc/%d)", $self->own, $self->own));
                return 1;
            }
        }

        # Try unlink the not my lock file
        unless (unlink $self->file) {
            $self->_debug(sprintf("Can't remove stale lock file \"%s\": %s", $self->file, $!));
            return 1;
        }

        # File has removed. Reset owner PID and UID to 0
        unless (-f $self->file) {