view release on metacpan or  search on metacpan

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

    $self->{pid}        ||= $$; # Current PID by default
    $self->{own}        ||= 0; # Owner PID
    $self->{auto}       //= 0;
    $self->{retries}    //= RETRIES;
    $self->{delay}      //= DELAY;
    $self->{_is_locked} = 0;
    croak("Incorrect pid attribute") unless $self->{pid} =~ /^[0-9]{1,11}$/;
    croak("Incorrect retries attribute") unless $self->{retries} =~ /^[0-9]{1,5}$/;
    croak("Incorrect delay attribute") 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 { # own pid
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{own} = shift;
        return $self;
    }
    return $self->{own};
}
sub owner { # numeric user ID of file's owner
    my $self = shift;
    return unless length($self->file) && -f $self->file;
    return File::stat::stat($self->file)->uid;
}
sub error {
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{error} = shift;
        return $self;
    }
    return $self->{error};
}
sub lock {
    my $self = shift;
    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;
    };

    # Save temp file
    my $tmp_file = sprintf("%s.%d", $self->file, $self->pid);
    if (open(my $fh, '>', $tmp_file)) {
        printf $fh "%d\n", $self->pid || $$;
        close $fh;

        # 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");
                    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("Could not write to %s: $!", $tmp_file))->_debug($self->error);
    }

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

    # Ok
    return $self;
}
sub check {
    my $self = shift;
    return 0 unless -f $self->file;

    # Load file
    if (open(my $fh, $self->file)) {
        chomp(my $line = <$fh>);
        close $fh;
        $self->own(($line || 0) * 1) if $line =~ /^\d+$/;
        $self->_debug(sprintf("Found owner PID=%d in %s", $self->own, $self->file));

        # Check 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 $self->own;
        }

        # Check owner PID
        if ( kill(0, $self->own) ) {
            $self->_debug(sprintf("Found valid existing lock file for PID=%d", $self->own));
            return $self->own;
        } else {
            my $owner_uid = $self->owner || 0;
            if ($owner_uid && $owner_uid != $>) {
                $self->_debug("The owner of the lock file owns NOT current user");
                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 $self->own;
                }
            }

            # Try unlink the lock file
            $self->error(sprintf("Could not unlink %s: $!", $self->file))->_debug($self->error)
                unless unlink $self->file;
            $self->own(0) unless -f $self->file; # Reset owner PID to 0
            $self->_debug("Found and removed stale lock file");
        }
    } else {
        $self->error(sprintf("Could not read %s: $!", $self->file))->_debug($self->error);