File Coverage

blib/lib/File/Lockfile/Emacs.pm

Criterion	Covered	Total	%
statement	56	91	61.5
branch	16	54	29.6
condition	5	15	33.3
subroutine	8	11	72.7
pod	4	4	100.0
total	89	175	50.8

package File::Lockfile::Emacs;

use 5.010001;
use strict;
use warnings;
use Log::ger;

use Exporter qw(import);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2025-03-13'; # DATE
our $DIST = 'File-Lockfile-Emacs'; # DIST
our $VERSION = '0.002'; # VERSION

our @EXPORT_OK = qw(
                       emacs_lockfile_get
                       emacs_lockfile_lock
                       emacs_lockfile_locked
                       emacs_lockfile_unlock
);

our %SPEC;

our %argspec0_target_file = (
    target_file => {
        summary => 'Target file',
        schema => 'filename*',
        req => 1,
        pos => 0,
    },
);

our %argspecopt_force = (
    force => {
        schema => 'bool*',
        cmdline_aliases => {f=>{}},
    },
);

sub _lockfile_path {
    my ($target_path) = @_;
    my $lockfile_path = $target_path;
    if ($lockfile_path =~ m!/!) {
        $lockfile_path =~ s!(.*/)(.*)!"$1#$2"!
    } else {
        $lockfile_path = ".#$target_path";
    }
    log_trace "Lockfile path: %s", $lockfile_path;
    $lockfile_path;
}

sub _read_lockfile {
    my ($target_path) = @_;

    my $lockfile_path = _lockfile_path($target_path);
    my $is_symlink = -l $lockfile_path;
    my $res = {exists=>0, path=>$lockfile_path};
    my $content;
    if ($is_symlink) {
        $res->{exists} = 1;
        $content = readlink($lockfile_path);
        if (!defined($content)) {
            $res->{error} = "Can't read link: $!";
            return $res;
        }
    } else {
        open my($fh), "<", $lockfile_path
            or do { $res->{error} = "Can't read file: $!"; return $res };
        { local $/ = undef; $content = <$fh>; close $fh }
    }
    log_trace "Lockfile content: %s", $content;
    $content =~ /\A(.+)\@(.+)\.(\d+)(?::(\d+))?\R?\z/s
        or do { $res->{error} = "Bad syntax in lock file content, does not match user\@host.pid:boot"; return $res };

    $res->{user} = $1;
    $res->{host} = $2;
    $res->{pid}  = $3;
    $res->{boot} = $4 if $4;

    $res;
}

$SPEC{emacs_lockfile_get} = {
    v => 1.1,
    summary => "Get information on an Emacs lockfile of a target file",
    args => {
        %argspec0_target_file,
    },
    description => <<'MARKDOWN',

MARKDOWN
};
sub emacs_lockfile_get {
    my %args = @_;
    defined(my $target_file = $args{target_file}) or return [400, "Please specify target_file"];

    my $lockinfo = _read_lockfile($target_file);

    return [500, $lockinfo->{error}] if $lockinfo->{error};
    [200, "OK", $lockinfo];
}

$SPEC{emacs_lockfile_lock} = {
    v => 1.1,
    summary => "Lock a file using Emacs-style lockfile",
    args => {
        %argspec0_target_file,
        %argspecopt_force,
    },
    description => <<'MARKDOWN',

Will return 412 if target file does not exist (unless `force` option is set to
true, in which case we proceed to locking anyway).

Will return 304 if target file is already locked using Emacs-style lockfile by
the same process as us.

Will return 409 if target file is already locked using Emacs-style lockfile by
another process (unless when `force` option is set to true, in which case will
take over the lock). Note that there are race conditions when using the `force`
option (between checking that the lockfile, unlinking it, and creating our own).
It is not recommended to use the `force` option.

Will return 500 if there's an error in reading the lockfile.

Will return 412 if we are not the same process that locks the file (unless
`force` option is set to true, in which case we proceed to unlocking anyway).

Will return 500 if there's an error in removing the lockfile.

Will return 200 if everything goes ok.

MARKDOWN
};
sub emacs_lockfile_lock {
    my %args = @_;
    defined(my $target_file = $args{target_file}) or return [400, "Please specify target_file"];
    my $force = $args{force};

    return [412, "Target file does not exist"] if !$force && !(-f $target_file);

    my $new_lockinfo = {
        user => $ENV{USERNAME} // $ENV{USER} // $ENV{LOGNAME},
        host => do { require Sys::Hostname; Sys::Hostname::hostname() },
        pid  => $$,
        boot => do { require Unix::Uptime; time() - Unix::Uptime->uptime },
    };
    my $lockfile_path = _lockfile_path($target_file);

  L1:

    # try creating a lock
    if (symlink "$new_lockinfo->{user}\@$new_lockinfo->{host}.$new_lockinfo->{pid}:$new_lockinfo->{boot}", $lockfile_path) {
        return [200, "Locked"];
    }

    # file is probably already locked
    my $old_lockinfo = _read_lockfile($target_file);

    return [500, "Couldn't create lockfile but lockfile doesn't exist, probably permission problem"]
        unless $old_lockinfo->{exists};

    return [500, "Can't get lockfile information: $old_lockinfo->{error}"]
        if $old_lockinfo->{error};

    if ($new_lockinfo->{pid} != $old_lockinfo->{pid}) {
        if ($force) {
            # note that there are race conditions between checking existing lock
            # above, unlinking it, and creating the new lock. Thus it's not
            # really recommended to use the `force` option.

            # unlock this old lockfile
            unlink $lockfile_path or return [500, "Can't remove old lockfile '$lockfile_path': $!"];
            goto L1;
        }

        return [412, "Target file was not locked by us (pid $$) but by pid $old_lockinfo->{pid}"];
    }

    return [304, "File was already locked"];
}

$SPEC{emacs_lockfile_locked} = {
    v => 1.1,
    summary => "Check whether a target file is locked using Emacs-style lockfile",
    args => {
        %argspec0_target_file,
        by_us => {
            summary => 'If set to true, only return true when lockfile is created by us; if false, then will only return true when lockfile is created by others',
            schema => 'bool',
        },
    },
};
sub emacs_lockfile_locked {
    my %args = @_;
    defined(my $target_file = $args{target_file}) or return [400, "Please specify target_file"];

    my $lockinfo = _read_lockfile($target_file);

    return [500, $lockinfo->{error}] if $lockinfo->{error};
    return [200, "OK", 0] unless $lockinfo->{exists};
    return [200, "OK", 1] unless defined $args{by_us};
    return [200, "OK", $args{by_us} ? ($$ == $lockinfo->{pid}) : ($$ != $lockinfo->{pid})];
}

$SPEC{emacs_lockfile_unlock} = {
    v => 1.1,
    summary => "Unlock a file locked with Emacs-style lockfile",
    args => {
        %argspec0_target_file,
        %argspecopt_force,
    },
    description => <<'MARKDOWN',

Note that there is a race condition between reading the lockfile and unlinking
it.

Will return 412 if target file does not exist (unless `force` option is set to
true, in which case we proceed to unlocking anyway).

Will return 304 if target file is not currently locked using Emacs-style
lockfile.

Will return 500 if there's an error in reading the lockfile.

Will return 412 if we are not the same process that locks the file (unless
`force` option is set to true, in which case we proceed to unlocking anyway).

Will return 500 if there's an error in removing the lockfile.

Will return 200 if everything goes ok.

MARKDOWN
};
sub emacs_lockfile_unlock {
    my %args = @_;
    defined(my $target_file = $args{target_file}) or return [400, "Please specify target_file"];
    my $force = $args{force};

    return [412, "Target file does not exist"] if !$force && !(-f $target_file);
    my $lockinfo = _read_lockfile($target_file);

    return [304, "Target file was not unlocked"] unless $lockinfo->{exists};

    return [500, $lockinfo->{error}] if $lockinfo->{error};

    return [412, "Target file was not locked by us (pid $$) but by pid $lockinfo->{pid}"]
        if !$force && ($$ != $lockinfo->{pid});

    unlink $lockinfo->{path}
        or return [500, "Can't unlink lockfile '$lockinfo->{path}': $!"];

    [200, "Unlocked"];
}

1;
# ABSTRACT: Create/check/delete Emacs-style lockfiles

__END__