view release on metacpan or  search on metacpan

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

    $self = $self->unlock;

This method performs unlocking the lock file and removes it

=head1 HISTORY

See C<Changes> file

=head1 TO DO

See C<TODO> file

=head1 SEE ALSO

L<Lock::File>, L<File::TinyLock>, L<JIP::LockFile>, L<LockFile::Simple>,
L<Acrux::FilePid>

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L<https://www.serzik.com> E<lt>abalama@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright (C) 1998-2026 D&D Corporation

=head1 LICENSE

This program is distributed under the terms of the Artistic License Version 2.0

See the C<LICENSE> file or L<https://opensource.org/license/artistic-2-0> for details

=cut

use Carp qw/croak/;
use File::Spec;
use File::Basename qw/basename/;
use IO::File;
use Fcntl qw/O_RDWR O_RDONLY O_WRONLY O_CREAT LOCK_EX LOCK_NB LOCK_UN/;
use Cwd qw/getcwd/;

use constant {
        RETRIES     => 5,
        DELAY       => 60,
    };

sub new {
    my $class = shift;
    my $args = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
    my $self  = bless {%$args}, $class;
    $self->{debug}      ||= 0;
    $self->{error}      = "";
    $self->{file}       //= File::Spec->catfile(getcwd, sprintf("%s.lock", basename($0)));
    $self->{pid}        //= $$; # Current PID by default
    $self->{own}        //= 0; # Owner PID
    $self->{uid}        //= 0; # Owner UID
    $self->{auto}       //= 0;
    $self->{retries}    //= RETRIES;
    $self->{delay}      //= DELAY;
    $self->{'flock'}    ||= 0;
    $self->{fh}         = undef;
    $self->{_is_locked} = 0;

    # PID normalize
    my $raw_pid = $self->{pid} || 0;
       $self->{pid} = abs(int($raw_pid)) if defined($raw_pid) && $raw_pid =~ /^-?\d+$/;
    unless (defined($self->{pid}) && $self->{pid} =~ /^[0-9]{1,11}$/) { # Protect
        croak("Incorrect \"pid\" attribute: $raw_pid");
    }

    # Check etries and delay
    croak("Incorrect \"retries\" attribute: " . $self->{retries}) unless $self->{retries} =~ /^[0-9]{1,5}$/;
    croak("Incorrect \"delay\" attribute: " . $self->{delay}) unless $self->{delay} =~ /^[0-9]{1,5}$/;

    # Lock file
    return $self->lock if $self->{auto};
    return $self;
}

sub file { shift->{file} }
sub pid { shift->{pid} }
sub own { # Owner PID
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{own} = shift;
        return $self;
    }
    return $self->{own};
}
sub uid { # Owner UID
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{uid} = shift;
        return $self;
    }
    return $self->{uid};
}
sub error {
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{error} = shift;
        return $self;
    }
    return $self->{error};
}
sub lock {
    my $self = shift;
       $self->error(undef);
    if ($self->_is_locked) {
        $self->_debug(sprintf("File \"%s\" already locked", $self->file));
        return $self;
    }

    # Signals
    $SIG{HUP} = $SIG{QUIT} = $SIG{INT} = $SIG{TERM} = sub {
        $self->_debug( "Caught SIG$_[0]" );
        exit;
    };

    # Using flock
    if ($self->_use_flock) {
        # Initialize or reuse initialized fh
        $self->{fh} //= IO::File->new($self->file, O_RDWR | O_CREAT);
        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) {
            $self->own(0)->uid(0);
        }
        $self->_debug("Found and removed stale lock file");
    }

    return 0;
}
sub unlock {
    my $self = shift;
       $self->error(undef);

    # Remove lock file
    if ($self->_is_locked) {
        # Release file handler first
        if ($self->{fh}) {
            flock $self->{fh}, LOCK_UN;
            $self->{fh} = undef;
        }

        # Unlink file
        $self->error(sprintf("Can't remove \"%s\": %s", $self->file, $!))->_debug($self->error)
            unless unlink $self->file;
        $self->own(0)->uid(0) unless -f $self->file; # Reset owner PID and UID to 0
    } else {
        $self->own(0)->uid(0) # Reset owner PID and UID to 0
    }

    # Remove temp file in silent mode
    my $tmp_file = sprintf("%s.%d", $self->file, $self->pid);
    unlink $tmp_file if -f $tmp_file;

    return $self;
}

sub _read_owner {
    my $self = shift;

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

    # Try to load file in ReadOnly mode
    my $fh = IO::File->new($self->file, O_RDONLY);
    unless ($fh) {
        $self->_debug(sprintf("Can't read \"%s\": %s", $self->file, $!));
        return 0;
    }

    # Read first line
    $fh->seek(0, 0);
    my $line = $fh->getline() // '';
    chomp $line;

    # Close file
    unless ($fh->close) {
        $self->_debug(sprintf("Can't close \"%s\": %s", $self->file, $!));
        return 0;
    }

    # Parse line
    my ($owner_pid, $owner_uid) = (0, 0);
    if ($line =~ /^(\d+):(\d+)$/) {
        ($owner_pid, $owner_uid) = ($1 * 1, $2 * 1);
    }

    # Set owner PID and UID
    $self->own($owner_pid)->uid($owner_uid);
    $self->_debug(sprintf("Read owner PID=%d, UID=%d from \"%s\"", $owner_pid, $owner_uid, $self->file));

    # Ok
    return 1;
}
sub _rollback {
    my $self = shift;
    $self->{_is_locked} = 0;
    $self->own(0)->uid(0);
    return $self unless $self->{fh};
    flock $self->{fh}, LOCK_UN;
    $self->{fh}->close;
    $self->{fh} = undef;
    return $self;
}
sub _is_locked {
    my $self = shift;
    return ($self->{_is_locked} && -f $self->file) ? 1 : 0
}
sub _use_flock {shift->{'flock'} ? 1 : 0}
sub _debug {
    my $self = shift;
    warn sprintf("%s: %s\n", ref($self), join("\n", @_)) if $self->{debug};
    return $self;
}

sub DESTROY {
    my $self = shift;
    return unless $self->{auto};
    $self->_debug("Cleaning up...");
    $self->unlock();
}

1;

__END__