lib/PublicInbox/MboxLock.pm

   1 # Copyright (C) 2021 all contributors <meta@public-inbox.org>
   2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   3
   4 # Various mbox locking methods
   5 package PublicInbox::MboxLock;
   6 use strict;
   7 use v5.10.1;
   8 use PublicInbox::OnDestroy;
   9 use Fcntl qw(:flock F_SETLK F_SETLKW F_RDLCK F_WRLCK
  10                         O_CREAT O_EXCL O_WRONLY SEEK_SET);
  11 use Carp qw(croak);
  12 use PublicInbox::DS qw(now); # ugh...
  13
  14 our $TMPL = do {
  15         if ($^O eq 'linux') { \'s @32' }
  16         elsif ($^O =~ /bsd/) { \'@20 s @256' } # n.b. @32 may be enough...
  17         else { eval { require File::FcntlLock; 1 } }
  18 };
  19
  20 # This order matches Debian policy on Linux systems.
  21 # See policy/ch-customized-programs.rst in
  22 # https://salsa.debian.org/dbnpolicy/policy.git
  23 sub defaults { [ qw(fcntl dotlock) ] }
  24
  25 sub acq_fcntl {
  26         my ($self) = @_;
  27         my $op = $self->{nb} ? F_SETLK : F_SETLKW;
  28         my $t = $self->{rw} ? F_WRLCK : F_RDLCK;
  29         my $end = now + $self->{timeout};
  30         $TMPL or die <<EOF;
  31 "struct flock" layout not available on $^O, install File::FcntlLock?
  32 EOF
  33         do {
  34                 if (ref $TMPL) {
  35                         return if fcntl($self->{fh}, $op, pack($$TMPL, $t));
  36                 } else {
  37                         my $fl = File::FcntlLock->new;
  38                         $fl->l_type($t);
  39                         $fl->l_whence(SEEK_SET);
  40                         $fl->l_start(0);
  41                         $fl->l_len(0);
  42                         return if $fl->lock($self->{fh}, $op);
  43                 }
  44                 select(undef, undef, undef, $self->{delay});
  45         } while (now < $end);
  46         croak "fcntl lock $self->{f}: $!";
  47 }
  48
  49 sub acq_dotlock {
  50         my ($self) = @_;
  51         my $dot_lock = "$self->{f}.lock";
  52         my ($pfx, $base) = ($self->{f} =~ m!(\A.*?/)([^/]+)\z!);
  53         $pfx //= '';
  54         my $pid = $$;
  55         my $end = now + $self->{timeout};
  56         do {
  57                 my $tmp = "$pfx.$base-".sprintf('%x,%x,%x',
  58                                         rand(0xffffffff), $pid, time);
  59                 if (sysopen(my $fh, $tmp, O_CREAT|O_EXCL|O_WRONLY)) {
  60                         if (link($tmp, $dot_lock)) {
  61                                 unlink($tmp) or die "unlink($tmp): $!";
  62                                 $self->{".lock$pid"} = $dot_lock;
  63                                 return;
  64                         }
  65                         unlink($tmp) or die "unlink($tmp): $!";
  66                         select(undef, undef, undef, $self->{delay});
  67                 } else {
  68                         croak "open $tmp (for $dot_lock): $!" if !$!{EXIST};
  69                 }
  70         } while (now < $end);
  71         croak "dotlock $dot_lock";
  72 }
  73
  74 sub acq_flock {
  75         my ($self) = @_;
  76         my $op = $self->{rw} ? LOCK_EX : LOCK_SH;
  77         $op |= LOCK_NB if $self->{nb};
  78         my $end = now + $self->{timeout};
  79         do {
  80                 return if flock($self->{fh}, $op);
  81                 select(undef, undef, undef, $self->{delay});
  82         } while (now < $end);
  83         croak "flock $self->{f}: $!";
  84 }
  85
  86 sub acq {
  87         my ($cls, $f, $rw, $methods) = @_;
  88         my $fh;
  89         unless (open $fh, $rw ? '+>>' : '<', $f) {
  90                 croak "open($f): $!" if $rw || !$!{ENOENT};
  91         }
  92         my $self = bless { f => $f, fh => $fh, rw => $rw }, $cls;
  93         my $m = "@$methods";
  94         if ($m ne 'none') {
  95                 my @m = map {
  96                         if (/\A(timeout|delay)=([0-9\.]+)s?\z/) {
  97                                 $self->{$1} = $2 + 0;
  98                                 ();
  99                         } else {
 100                                 $cls->can("acq_$_") // $_
 101                         }
 102                 } split(/[, ]/, $m);
 103                 my @bad = grep { !ref } @m;
 104                 croak "Unsupported lock methods: @bad\n" if @bad;
 105                 croak "No lock methods supplied with $m\n" if !@m;
 106                 $self->{nb} = $#m || defined($self->{timeout});
 107                 $self->{delay} //= 0.1;
 108                 $self->{timeout} //= 5;
 109                 $_->($self) for @m;
 110         }
 111         $self;
 112 }
 113
 114 sub DESTROY {
 115         my ($self) = @_;
 116         if (my $f = $self->{".lock$$"}) {
 117                 unlink($f) or die "unlink($f): $! (lock stolen?)";
 118         }
 119 }
 120
 121 1;