File Coverage

blib/lib/Mail/Box/Locker/NFS.pm

Criterion	Covered	Total	%
statement	50	63	79.3
branch	10	26	38.4
condition	3	6	50.0
subroutine	12	13	92.3
pod	3	3	100.0
total	78	111	70.2

# This code is part of Perl distribution Mail-Box version 4.01.
# The POD got stripped from this file by OODoc version 3.05.
# For contributors see file ChangeLog.

# This software is copyright (c) 2001-2025 by Mark Overmeer.

# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later


package Mail::Box::Locker::NFS;{
our $VERSION = '4.01';
}

use parent 'Mail::Box::Locker';

use strict;
use warnings;

use Log::Report      'mail-box', import => [ qw/__x fault warning/ ];

use Sys::Hostname    qw/hostname/;
use Fcntl            qw/O_CREAT O_WRONLY/;

#--------------------

sub name() { 'NFS' }

#--------------------

# METHOD nfs
# This hack is copied from the Mail::Folder packages, as written
# by Kevin Jones.  Cited from his code:
#    Whhheeeee!!!!!
#    In NFS, the O_CREAT|O_EXCL isn't guaranteed to be atomic.
#    So we create a temp file that is probably unique in space
#    and time ($folder.lock.$time.$pid.$host).
#    Then we use link to create the real lock file. Since link
#    is atomic across nfs, this works.
#    It loses if it's on a filesystem that doesn't do long filenames.

my $hostname = hostname;

sub _tmpfilename()
{	my $self = shift;
	$self->{MBLN_tmp} ||= $self->filename . $$;
}

sub _construct_tmpfile()
{	my $self    = shift;
	my $tmpfile = $self->_tmpfilename;

	sysopen my $fh, $tmpfile, O_CREAT|O_WRONLY, 0600
		or return undef;

	$fh->close;
	$tmpfile;
}

sub _try_lock($$)
{	my ($self, $tmpfile, $lockfile) = @_;

	link $tmpfile, $lockfile
		or return undef;

	my $linkcount = (stat $tmpfile)[3];

	unlink $tmpfile;
	$linkcount == 2;
}


sub lock()
{	my $self     = shift;
	my $folder   = $self->folder;

	$self->hasLock
		and warning(__x"folder {name} already locked over NFS.", name => $folder), return 1;

	my $lockfile = $self->filename;
	my $tmpfile  = $self->_construct_tmpfile or return;
	my $timeout  = $self->timeout;
	my $end      = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
	my $expires  = $self->expires / 86400;  # in days for -A

	if(-e $lockfile && -A $lockfile > $expires)
	{	unlink $lockfile
			or fault __x"Unable to remove expired lockfile {file}", file => $lockfile;

		warning __x"removed expired lockfile {file}.", file => $lockfile;
	}

	while(1)
	{	return $self->SUPER::lock
			if $self->_try_lock($tmpfile, $lockfile);

		--$end or last;
		sleep 1;
	}

	return 0;
}

sub isLocked()
{	my $self     = shift;
	my $tmpfile  = $self->_construct_tmpfile or return 0;
	my $lockfile = $self->filename;

	my $fh = $self->_try_lock($tmpfile, $lockfile) or return 0;
	close $fh;

	$self->_unlock($tmpfile, $lockfile);
	$self->SUPER::unlock;

	1;
}


sub _unlock($$)
{	my ($self, $tmpfile, $lockfile) = @_;

	unlink $lockfile
		or fault __x"couldn't remove lockfile {file}", file => $lockfile;

	unlink $tmpfile;
	$self;
}

sub unlock($)
{	my $self   = shift;
	$self->hasLock or return $self;

	$self->_unlock($self->_tmpfilename, $self->filename);
	$self->SUPER::unlock;
	$self;
}

1;