
package Mail::Box::Locker;

use strict;
use 5.006;
our $VERSION = v0.9;

use Fcntl         qw/:DEFAULT :flock/;
use IO::File;
use Sys::Hostname;

=head1 NAME

Mail::Box::Locker - Manage the locking of mail-folders

=head1 SYNOPSIS

   use Mail::Box::Locker;
   my $locker = new Mail::Box::Locker;

   $locker->lock($folder);
   $locker->isLocked($folder);
   $locker->hasLock($folder);
   $locker->unlock($folder);

   Mail::Box::Locker->addLockingMethod(...);

   # Because Mail::Box inherits from this class:
   my $folder = new Mail::Box(lock_method => 'dotlock');
   $folder->lock;
   $folder->isLocked;
   $folder->hasLock;
   $folder->unlock;

=head1 DESCRIPTION

Read Mail::Box::Manager first.
The locker module contains the various locking functionalities as
needed when handling folders.

Because Mail::Box inherits from Mail::Box::Locker, this
example works:

    my $folder
    $folder->lock;

=head1 PUBLIC INTERFACE

=over 4

=cut

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

=item new ARGS

Create a new lock.  You may do this, however, in most cases the lock will
not be seperately instantiated but be the second class in a multiple
inheritance construction with a L<Mail::Box>.

ARGS is a reference to a hash, where the following fields are used
for the locker information:

=over 4

=item lock_method => METHOD

Which method has to be used for locking.  Supported are

=over 4

=item * 'dotlock'

The folder handler creates a file which signals that it is in use.  This
is a bit problematic, because all mail-handling software should agree on
the name of the file to be created.

On various folder-types, the lockfile differs.  See each manual-page
and special options to change their default behavior.

=item * 'file'

For some folder handlers, locking is based on simply file-locking
mechanism.  However, this does not work on network filesystems, and
such.  This also doesn't work on directory-type of folders (Mail::Box::Dir
and derived).

=item * 'nfs'

A kind of C<dotlock> file-locking mechanism, but adapted to work over
NFS.  Extra precaution is needed because an C<open O_EXCL> on NFS is
not an atomic action.

=item * 'NONE'

Disable locking.

=back

=item lock_timeout => SECONDS

How long can a lock stand?  When an different e-mail program left a
lock, then this will be removed automatically after the specified
seconds.  The default is one hour.

=item lock_wait => SECONDS

How long to wait for receiving the lock.  The lock-request may fail.
If SECONDS equals 'NOTIMEOUT', then we wait till the lock can be taken.

=item lockfile => FILENAME

Name of the file to take the lock on or to represent a lock (depends on
the kind of lock used).

=back

=cut

my %lock_methods
= ( dotlock => [ qw/dot_lock   dot_test_lock  dot_unlock/  ]
  , file    => [ qw/file_lock  file_test_lock file_unlock/ ]
  , nfs     => [ qw/nfs_lock   nfs_test_lock  nfs_unlock/  ]
  , NONE    => [ sub {1}, sub {0}, sub {} ]
  );

sub new(@) { (bless {}, shift)->init( {@_} ) }

sub init($)
{   my ($self, $args) = @_;

    my $method = $args->{lock_method} || 'dotlock';
    unless(exists $lock_methods{$method})
    {   warn "Unknown lock method $method: locking disabled.\n";
        $method = 'NONE';
    }

    $self->{MBL_method}   = $method;
    $self->{MBL_timeout}  = 3600;
    $self->{MBL_wait}     = 10;
    $self->{MBL_haslock}  = 0;
    $self->lockFilename($args->{lockfile}) if $args->{lockfile};

    $self;
}

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

=item lockingMethod NAME, CODE, CODE, CODE

(class method)  Add locking methods to the set of know methods.  You
need to specify a method-name and three code references, respectively
for the get, test, and un method.  You may also specify method-names
instead of code-references.

=cut

sub lockingMethod($$$$)
{   my ($class, $name) = (shift, shift);
    $lock_methods{$name} = [ @_ ];
    $class;
}

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

=head2 Basic functions

The C<lock>, C<test_lock>, and C<unlock> methods are to be
used.  They call specific methods which implement the right locking
mechanism.   I<Do not call> the various locking methods directly.

=item lock [FOLDER] [METHOD]

Get a lock on a folder, by using the predefined method, or a
specific METHOD.  If you do not specify a FOLDER, it is
assumed the locking functionality is inherited.

Examples:
    $locker->lock($folder);
    $folder->lock;

=cut

sub lock(;$$)
{   my $self     = shift;
    my $folder   = ref $_[0] ? shift : $self;
    my $method   = @_ ? shift : $self->{MBL_method};

    # Never lock twice.
    return 1 if $folder->hasLock;

    my $function = $lock_methods{$method}[0];
    unless(defined $function)
    {   warn "Unknown locking method $method.\n";
        return 1;
    }

    no strict 'refs';
    ref $function ? $function->($folder) : $self->$function($folder);
}

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

=item isLocked [FOLDER] [METHOD]

Test if the folder is locked.

Examples:
    $locker->isLocked($folder);
    $folder->isLocked;

=cut

sub isLocked(;$$)
{   my $self     = shift;
    my $folder   = ref $_[0] ? shift : $self;
    my $method   = @_ ? shift : $self->{MBL_method};

    my $function = $lock_methods{$method}[1];
    unless(defined $function)
    {   warn "Unknown locking method $method.\n";
        return 0;
    }

    no strict 'refs';
    ref $function ? $function->($folder) : $self->$function($folder);
}

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

=item hasLock [FOLDER]

Check wheter the folder has the lock.

Examples:
    $locker->hasLock($folder);
    $folder->hasLock;

=cut

sub hasLock(;$)
{   my $self   = shift;
    my $folder = ref $_[0] ? shift : $self;
    $self->{MBL_haslock};
}

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

=item unlock [FOLDER] [METHOD]

un the lock on a folder.

Examples:
    $locker->unlock($folder);
    $folder->unlock;

=cut

sub unlock(;$$)
{   my $self     = shift;
    my $folder   = ref $_[0] ? shift : $self;
    my $method   = @_ ? shift : $self->{MBL_method};

    my $function = $lock_methods{$method}[2];
    unless(defined $function)
    {   warn "Unknown locking method $method.\n";
        return 1;
    }

    no strict 'refs';
    ref $function ? $function->($folder) : $self->$function($folder);
    delete $self->{MBL_haslock};
}

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

=item lockFilename [FILENAME]

Returns the filename which is used to lock the folder.  It depends on the
locking method how this file is used.

=cut

sub lockFilename(;$)
{   my $self = shift;
    @_ ? $self->{MBL_lockfile} = shift : $self->{MBL_lockfile};
}

#-------------------------------------------
# METHOD dotlock

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

    my $lock = IO::File->new($lockfile,
        O_CREAT|O_EXCL|O_WRONLY|O_NONBLOCK, 0600) or return 0;

    $self->{MBL_haslock} = $lockfile;
    close $lock;

    1;
}

sub do_dot_unlock($)
{   my $self = shift;
    my $lock = $self->{MBL_haslock};
    unlink $lock or warn "Couldn't remove lockfile $lock: $!\n";
    delete $self->{MBL_haslock};
    $self;
}

sub dot_lock
{   my ($self, $folder) = @_;
    my $lockfile = $folder->lockFilename;
    my $end  = $self->{MBL_timeout} eq 'NOTIMEOUT' ? 0 : $self->{MBL_timeout};

    my $timer = 0;

    while($timer != $end)
    {   return 1 if $self->try_dot_lock($lockfile);

        if(   -e $lockfile
           && -A $lockfile > ($self->{MBL_timeout}/86400)
           && unlink $lockfile
          )
        {   warn "Removed expired lockfile $lockfile.\n";
            redo;
        }

        sleep 1;
        $timer++;
    }

    return 0;
}

sub dot_test_lock($)
{   my ($self, $folder) = @_;
    my $lockfile = $folder->lockFilename;

    $self->try_dot_lock($lockfile) or return 0;
    $self->do_dot_unlock;

    1;
}

sub dot_unlock($)
{   my ($self, $folder) = @_;
    return unless $self->hasLock;
    $self->do_dot_unlock;
}


#-------------------------------------------
# METHOD file

sub try_file_lock($)
{   my ($self, $file) = @_;
    flock $file, LOCK_EX|LOCK_NB;
}

sub do_file_unlock($)
{   my ($self, $file) = @_;
    flock $file, LOCK_UN;
}

sub file_lock
{   my ($self, $folder) = @_;
    my $end   = $self->{MBL_timeout} eq 'NOTIMEOUT' ? 0 : $self->{MBL_timeout};
    my $file  = $folder->filehandle;

    my $timer = 0;
    while($timer != $end)
    {   if($self->try_file_lock($file))
        {   $self->{MBL_haslock} = $folder;
            return 1;
        }

        sleep 1;
        $timer++;
    }

    return 0;
}

sub file_test_lock($)
{   my ($self, $folder) = @_;
    my $file  = $folder->filehandle;

    $self->try_file_lock($file) or return 0;
    $self->do_file_unlock($file);
    1;
}

sub file_unlock($)
{   my ($self, $folder) = @_;
    return unless $self->hasLock;
    $self->do_dot_unlock($folder->filehandle);
}

#-------------------------------------------
# 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, $folder) = @_;
    $folder->name . ".lock." . time . ".$$.$hostname";
}

sub construct_tmpfile($)
{   my ($self, $folder) = @_;

    my $tmpfile = $self->tmpfilename($folder);
    my $fh = IO::File->new($tmpfile, O_CREAT|O_WRONLY, 0600) or return;

    $fh->close;
    $tmpfile;
}

sub try_nfs_lock($)
{   my ($self, $tmpfile, $lockfile) = @_;
    link $tmpfile, $lockfile
        or warn "Cannot link $lockfile to $tmpfile.\n";
    my $success = ((stat $tmpfile)[2] == 2);
    unlink $tmpfile;
    $success;
}

sub do_nfs_unlock($)
{   my ($self, $lockfile) = @_;
    unlink $lockfile or warn "Couldn't remove lockfile $lockfile: $!\n";
    $self;
}

sub NFS_lock
{   my ($self, $folder) = @_;

    # Create a file to link to
    my $tmpfile  = $self->construct_tmpfile($folder) or return;
    my $lockfile = $folder->filename.'.lock';
    my $end  = $self->{MBL_timeout} eq 'NOTIMEOUT' ? 0 : $self->{MBL_timeout};

    my $timer = 0;
    while($timer != $end)
    {   if(my $fh = $self->try_nfs_lock($tmpfile, $lockfile))
        {   $fh->close;
            $self->{MBL_haslock} = $lockfile;
            return 1;
        }

        if(   -e $lockfile
           && -A $lockfile > ($self->{MBL_timeout}/86400)
           && unlink $lockfile
          )
        {   warn "Removed expired lockfile $lockfile.\n";
            redo;
        }

        sleep 1;
        $timer++;
    }

    return 0;
}

sub NFS_test_lock($)
{   my ($self, $folder) = @_;
    my $tmpfile  = $self->construct_tmpfile($folder) or return 0;
    my $lockfile = $folder->filename.'.lock';

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

    close $fh;
    $self->do_nfs_unlock($tmpfile, $lockfile);
    1;
}

sub NFS_unlock($)
{   my ($self, $folder) = @_;
    return unless $self->hasLock;

    $self->do_nfs_unlock
     ( $self->tmpfilename($folder)
     , $folder->filename.'.lock'
     );
}




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

=back

=head1 AUTHOR

Mark Overmeer (F<Mark@Overmeer.net>).
All rights reserved.  This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

=head1 VERSION

This code is alpha, version 0.9

=cut

1;
