Commit dd49ff70 authored by Mark Overmeer's avatar Mark Overmeer Committed by Mark Overmeer

distribution Mail-Box-3.001.tar.gz

parent 133ed11d
===== ChangeLog of Mail::Box version 3.*
version 3.001: Mon 6 Feb 17:07:53 CET 2017
Fixes:
- test on windows, cause the path syntax differences
- posix lock on BSD [Slaven Rezic]
- SEE ALSO links broken.
rt.cpan.org#120119 [Christophe Deroulers]
- do not test multi-lock on BSDs
Improvements:
- Mail::Box::Locker* cleaner OO
- ::Locker::Multi uses FcntlLock, not POSIX by default
version 3.000: Thu 2 Feb 15:50:36 CET 2017
Changes:
......
......@@ -4,7 +4,7 @@ require 5.010;
use IO::Handle;
my $VERSION = '3.000';
my $VERSION = '3.001';
my %prereq =
( Carp => 0
......
......@@ -118,7 +118,7 @@ number of seconds.
Which FOLDER is to be locked, a M<Mail::Box> object.
=option timeout SECONDS|'NOTIMEOUT'
=default timeout 10 seconds
=default timeout 10
How long to wait while trying to acquire the lock. The lock request will
fail when the specified number of seconds is reached. If C<'NOTIMEOUT'> is
......@@ -190,6 +190,30 @@ sub init($)
#-------------------------------------------
=section Attributes
=method timeout [SECONDS]
Get/Set the timeout. Not available for all lockers.
=method expires [SECONDS]
Get/Set the expiration time. Not available for all lockers.
=cut
sub timeout(;$)
{ my $self = shift;
@_ ? $self->{MBL_timeout} = shift : $self->{MBL_timeout};
}
sub expires(;$)
{ my $self = shift;
@_ ? $self->{MBL_expires} = shift : $self->{MBL_expires};
}
#-------------------------------------------
=section The Locker
=method name
......
......@@ -90,7 +90,7 @@ sub _try_lock($)
sub unlock()
{ my $self = shift;
$self->{MBL_has_lock}
$self->hasLock
or return $self;
my $lock = $self->filename;
......@@ -98,7 +98,7 @@ sub unlock()
unlink $lock
or $self->log(WARNING => "Couldn't remove lockfile $lock: $!");
delete $self->{MBL_has_lock};
$self->SUPER::unlock;
$self;
}
......@@ -117,13 +117,13 @@ sub lock()
return 1;
}
my $end = $self->{MBL_timeout} eq 'NOTIMEOUT' ? -1
: $self->{MBL_timeout};
my $expire = $self->{MBL_expires}/86400; # in days for -A
my $timeout = $self->timeout;
my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
my $expire = $self->expires/86400; # in days for -A
while(1)
{
return $self->{MBL_has_lock} = 1
return $self->SUPER::lock
if $self->_try_lock($lockfile);
if(-e $lockfile && -A $lockfile > $expire)
......
......@@ -56,7 +56,6 @@ sub _unlock($)
my $fl = File::FcntlLock->new;
$fl->l_type(F_UNLCK);
$fl->lock($file, F_SETLK);
delete $self->{MBL_has_lock};
$self;
}
......@@ -94,18 +93,20 @@ sub lock()
return 0;
}
my $end = $self->{MBL_timeout} eq 'NOTIMEOUT' ? -1 : $self->{MBL_timeout};
my $timeout = $self->timeout;
my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
while(1)
{ if($self->_try_lock($file))
{ $self->{MBL_has_lock} = 1;
{ $self->SUPER::lock;
$self->{MBLF_filehandle} = $file;
return 1;
}
unless($!==EAGAIN)
{ $self->log(ERROR =>
"Will never get a FcntlLock lock on $filename for $self->{MBL_folder}: $!");
{ my $folder = $self->folder;
$self->log(ERROR =>
"Will never get a FcntlLock lock on $filename for $folder: $!");
last;
}
......@@ -116,6 +117,7 @@ sub lock()
return 0;
}
=method isLocked
=error Unable to check lock file $filename for $folder: $!
......@@ -132,14 +134,17 @@ sub isLocked()
my $file = IO::File->new($filename, "r");
unless($file)
{ $self->log(ERROR =>
"Unable to check lock file $filename for $self->{MBL_folder}: $!");
{ my $folder = $self->folder;
$self->log(ERROR =>
"Unable to check lock file $filename for $folder: $!");
return 0;
}
$self->_try_lock($file)==0 or return 0;
$self->_unlock($file);
$file->close;
$self->SUPER::unlock;
1;
}
......@@ -149,6 +154,7 @@ sub unlock()
$self->_unlock(delete $self->{MBLF_filehandle})
if $self->hasLock;
$self->SUPER::unlock;
$self;
}
......
......@@ -43,7 +43,6 @@ sub _try_lock($)
sub _unlock($)
{ my ($self, $file) = @_;
flock $file, LOCK_UN;
delete $self->{MBL_has_lock};
$self;
}
......@@ -87,13 +86,13 @@ sub lock()
return 0;
}
my $end = $self->{MBL_timeout} eq 'NOTIMEOUT' ? -1 : $self->{MBL_timeout};
my $timeout = $self->timeout;
my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
while(1)
{ if($self->_try_lock($file))
{ $self->{MBL_has_lock} = 1;
$self->{MBLF_filehandle} = $file;
return 1;
{ $self->{MBLF_filehandle} = $file;
return $self->SUPER::lock;
}
if($! != EAGAIN)
......@@ -123,8 +122,9 @@ sub isLocked()
my $file = IO::File->new($filename, $lockfile_access_mode);
unless($file)
{ $self->log(ERROR =>
"Unable to check lock file $filename for $self->{MBL_folder}: $!");
{ my $folder = $self->folder;
$self->log(ERROR =>
"Unable to check lock file $filename for $folder: $!");
return 0;
}
......@@ -132,6 +132,7 @@ sub isLocked()
$self->_unlock($file);
$file->close;
$self->SUPER::unlock;
1;
}
......@@ -141,6 +142,7 @@ sub unlock()
$self->_unlock(delete $self->{MBLF_filehandle})
if $self->hasLock;
$self->SUPER::unlock;
$self;
}
......
......@@ -55,7 +55,7 @@ sub init($)
my @use
= exists $args->{use} ? @{delete $args->{use}}
: $^O eq 'MSWin32' ? qw/Flock/
: qw/NFS POSIX Flock/;
: qw/NFS FcntlLock Flock/;
my (@lockers, @used);
......@@ -107,10 +107,11 @@ sub _try_lock($)
sub unlock()
{ my $self = shift;
return $self unless $self->{MBL_has_lock};
$self->hasLock
or return $self;
$_->unlock foreach $self->lockers;
delete $self->{MBL_has_lock};
$self->SUPER::unlock;
$self;
}
......@@ -119,10 +120,11 @@ sub lock()
{ my $self = shift;
return 1 if $self->hasLock;
my $end = $self->{MBL_timeout} eq 'NOTIMEOUT' ? -1 : $self->{MBL_timeout};
my $timeout = $self->timeout;
my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
while(1)
{ return $self->{MBL_has_lock} = 1
{ return $self->SUPER::lock
if $self->_try_lock;
last unless --$end;
......@@ -134,7 +136,11 @@ sub lock()
sub isLocked()
{ my $self = shift;
# Try get a lock
$self->_try_lock($self->filename) or return 0;
# and release it immediately
$self->unlock;
1;
}
......
......@@ -30,8 +30,8 @@ The name of the program. May be a relative or absolute path.
sub init($)
{ my ($self, $args) = @_;
$self->SUPER::init($args);
$self->{MBLM_exe} = $args->{exe} || 'mutt_dotlock';
$self;
}
......@@ -39,19 +39,21 @@ sub init($)
sub name() {'MUTT'}
sub lockfile() { shift->filename . '.lock' }
=method exe
Returns the name of the external binary.
=cut
sub exe() {shift->{MBLM_exe}}
=method unlock
=warning Couldn't remove mutt-unlock $folder: $!
=cut
sub unlock()
{ my $self = shift;
$self->{MBL_has_lock}
$self->hasLock
or return $self;
unless(system($self->exe, '-u', $self->filename))
......@@ -59,11 +61,10 @@ sub unlock()
$self->log(WARNING => "Couldn't remove mutt-unlock $folder: $!");
}
delete $self->{MBL_has_lock};
$self->SUPER::unlock;
$self;
}
#-------------------------------------------
=method lock
=warning Folder $folder already mutt-locked
......@@ -82,9 +83,9 @@ sub lock()
my $filename = $self->filename;
my $lockfn = $self->lockfile;
my $end = $self->{MBL_timeout} eq 'NOTIMEOUT' ? -1
: $self->{MBL_timeout};
my $expire = $self->{MBL_expires}/86400; # in days for -A
my $timeout = $self->timeout;
my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
my $expire = $self->expires / 86400; # in days for -A
my $exe = $self->exe;
while(1)
......@@ -96,7 +97,7 @@ sub lock()
}
}
else
{ return $self->{MBL_has_lock} = 1;
{ return $self->SUPER::lock;
}
if(-e $lockfn && -A $lockfn > $expire)
......@@ -119,7 +120,6 @@ sub lock()
return 0;
}
#-------------------------------------------
sub isLocked()
{ my $self = shift;
......@@ -127,7 +127,5 @@ sub isLocked()
WIFEXITED($?) && WEXITSTATUS($?)==3;
}
#-------------------------------------------
1;
......@@ -52,10 +52,7 @@ my $hostname = hostname;
sub _tmpfilename()
{ my $self = shift;
return $self->{MBL_tmp} if $self->{MBL_tmp};
my $folder = $self->{MBL_folder};
$self->{MBL_tmp} = $self->filename . $$;
$self->{MBLN_tmp} ||= $self->filename . $$;
}
sub _construct_tmpfile()
......@@ -114,7 +111,7 @@ lock file, so we need to wait until it vanishes by some external cause.
sub lock()
{ my $self = shift;
my $folder = $self->{MBL_folder};
my $folder = $self->folder;
if($self->hasLock)
{ $self->log(WARNING => "Folder $folder already locked over nfs");
......@@ -123,9 +120,9 @@ sub lock()
my $lockfile = $self->filename;
my $tmpfile = $self->_construct_tmpfile or return;
my $end = $self->{MBL_timeout} eq 'NOTIMEOUT' ? -1
: $self->{MBL_timeout};
my $expires = $self->{MBL_expires}/86400; # in days for -A
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)
{ if(unlink $lockfile)
......@@ -135,10 +132,8 @@ sub lock()
}
while(1)
{ if($self->_try_lock($tmpfile, $lockfile))
{ $self->{MBL_has_lock} = 1;
return 1;
}
{ return $self->SUPER::lock
if $self->_try_lock($tmpfile, $lockfile);
last unless --$end;
sleep 1;
......@@ -158,6 +153,8 @@ sub isLocked()
close $fh;
$self->_unlock($tmpfile, $lockfile);
$self->SUPER::unlock;
1;
}
......@@ -168,7 +165,7 @@ sub unlock($)
return $self unless $self->hasLock;
$self->_unlock($self->_tmpfilename, $self->filename);
delete $self->{MBL_has_lock};
$self->SUPER::unlock;
$self;
}
......
......@@ -8,6 +8,12 @@ use Fcntl;
use IO::File;
use Errno qw/EAGAIN/;
# fcntl() should not be used without XS: the below is sensitive
# for changes in the structure. However, at the moment it seems
# there are only two options: either SysV-style or BSD-style
my $pack_pattern = $^O =~ /bsd|darwin/i ? '@20 s @256' : 's @256';
=chapter NAME
Mail::Box::Locker::POSIX - lock a folder using kernel file-locking
......@@ -21,7 +27,12 @@ Mail::Box::Locker::POSIX - lock a folder using kernel file-locking
This locker object is created by the folder to get an exclusive lock on
the file which contains the data using the kernel's POSIX facilities. This
lock is created on a separate file-handle to the folder file, so not the
handle which is reading. Not all platforms support POSIX locking.
handle which is reading.
B<WARNING>: Not all platforms support POSIX locking (via fcntl) and not
always in the same way. This implementation does not use XS to access
the structure of fcntl(): it is better to use the ::FcntlLock which does.
No, this implementation "guesses" the location of the bytes.
=chapter METHODS
......@@ -45,19 +56,19 @@ sub name() {'POSIX'}
sub _try_lock($)
{ my ($self, $file) = @_;
my $p = pack 's @256', F_WRLCK;
my $p = pack $pack_pattern, F_WRLCK;
$? = fcntl($file, F_SETLK, $p) || ($!+0);
$?==0;
}
sub _unlock($)
{ my ($self, $file) = @_;
my $p = pack 's @256', F_UNLCK;
my $p = pack $pack_pattern, F_UNLCK;
fcntl $file, F_SETLK, $p;
delete $self->{MBL_has_lock};
$self;
}
=method lock
=warning Folder $folder already lockf'd
......@@ -83,27 +94,27 @@ sub lock()
}
my $filename = $self->filename;
my $folder = $self->folder;
my $file = IO::File->new($filename, 'r+');
my $file = IO::File->new($filename, 'r+');
unless(defined $file)
{ my $folder = $self->folder;
$self->log(ERROR =>
{ $self->log(ERROR =>
"Unable to open POSIX lock file $filename for $folder: $!");
return 0;
}
my $end = $self->{MBL_timeout} eq 'NOTIMEOUT' ? -1 : $self->{MBL_timeout};
my $timeout = $self->timeout;
my $end = $timeout eq 'NOTIMEOUT' ? -1 : $timeout;
while(1)
{ if($self->_try_lock($file))
{ $self->{MBL_has_lock} = 1;
$self->{MBLF_filehandle} = $file;
return 1;
{ $self->{MBLF_filehandle} = $file;
return $self->SUPER::lock;
}
unless($!==EAGAIN)
{ $self->log(ERROR =>
"Will never get a POSIX lock on $filename for $self->{MBL_folder}: $!");
"Will never get a POSIX lock on $filename for $folder: $!");
last;
}
......@@ -130,14 +141,16 @@ sub isLocked()
my $file = IO::File->new($filename, "r");
unless($file)
{ $self->log(ERROR =>
"Unable to check lock file $filename for $self->{MBL_folder}: $!");
{ my $folder = $self->folder;
$self->log(ERROR => "Unable to check lock file $filename for $folder: $!");
return 0;
}
$self->_try_lock($file)==0 or return 0;
$self->_unlock($file);
$file->close;
$self->SUPER::unlock;
1;
}
......@@ -147,6 +160,7 @@ sub unlock()
$self->_unlock(delete $self->{MBLF_filehandle})
if $self->hasLock;
$self->SUPER::unlock;
$self;
}
......
......@@ -135,7 +135,7 @@ sub inbox(;$)
#-------------------------------------------
=section Manage existing folders
=section Manage folders
=method topfolder
Returns the top folder of the user's mailbox storage.
......@@ -143,7 +143,6 @@ Returns the top folder of the user's mailbox storage.
sub topfolder() { shift->{MBMU_topfolder} }
#-------------------------------------------
=method folder $name
Returns the folder description, a M<Mail::Box::Identity>.
......@@ -158,7 +157,6 @@ sub folder($)
$top->folder(@path);
}
#-------------------------------------------
=method folderCollection $name
Returns a pair: the folder collection (M<Mail::Box::Collection>) and
......@@ -180,7 +178,6 @@ sub folderCollection($)
($top->folder(@path), $base);
}
#-------------------------------------------
=method create $name, %options
Creates a new folder with the specified name. An folder's administrative
......@@ -262,7 +259,6 @@ sub create($@)
$id;
}
#-------------------------------------------
=method delete $name
Remove all signs from the folder on the file-system. Messages still in
......@@ -288,7 +284,6 @@ sub delete($)
$self->SUPER::delete($name);
}
#-------------------------------------------
=method rename $oldname, $newname, %options
Rename the folder with name $oldname to $newname. Both names are full
......
......@@ -48,7 +48,7 @@ BEGIN {
$winsrc = File::Spec->catfile($folderdir, $winfn);
$cpy = File::Spec->catfile($folderdir, $cpyfn);
($src, $fn) = $crlf_platform ? ($winsrc, $winfn) : ($unixsrc, $unixfn);
($src, $fn) = $windows ? ($winsrc, $winfn) : ($unixsrc, $unixfn);
# ensure to test the Perl Parser not the C-Parser (separate distribution)
require Mail::Box::Parser::Perl;
......
......@@ -39,7 +39,9 @@ ok(!defined $second, 'open same folder fails');
my @errors = $manager->report('ERRORS');
cmp_ok(@errors, "==", 1, 'mgr noticed double');
$errors[-1] =~ s#[\\/]mbox\.win#/mbox.src#g; # Windows
my $error = $errors[-1];
$error =~ s#mbox\.win#mbox.src#g; # Windows mutulated path
$error =~ s#\\#/#g;
is($errors[-1], "Folder t/folders/mbox.src is already open.");
cmp_ok($manager->openFolders, "==", 1, 'only one folder open');
......
......@@ -8,6 +8,7 @@ use warnings;
use Mail::Box::Test;
use Mail::Box::Locker::DotLock;
use Mail::Box;
use Test::More tests => 7;
use File::Spec;
......
......@@ -9,6 +9,7 @@ use warnings;
use Mail::Box::Test;
use Mail::Box::Locker::Flock;
use Mail::Box;
use Test::More;
use File::Spec;
......
......@@ -8,6 +8,7 @@ use warnings;
use Mail::Box::Test;
use Mail::Box::Locker::NFS;
use Mail::Box;
use Test::More;
use File::Spec;
......
......@@ -8,6 +8,7 @@ use warnings;
use Mail::Box::Test;
use Mail::Box::Locker::POSIX;
use Mail::Box;
use Test::More;
use File::Spec;
......
......@@ -8,10 +8,18 @@ use warnings;
use Mail::Box::Test;
use Mail::Box::Locker::Multi;
use Mail::Box;
use Test::More tests => 7;
use Test::More;
use File::Spec;
# The problem is that 'isLocked' on BSD behaves differently from the
# calls on SysV (like Linux). It's about the same process attempting
# to lock the same file twice.
$^O !~ /bsd|darwin/
or plan skip_all => 'not tested for BSD-likes';
plan tests => 7;
my $fakefolder = bless {MB_foldername=> 'this'}, 'Mail::Box';
my $lockfile = File::Spec->catfile($folderdir, 'lockfiletest');
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment