package SemaforeFile;
#$Id: SemaforeFile.pm,v 1.64 2017/09/27 06:41:39 sofc Exp $
use strict;
use warnings;
use Fcntl qw(:DEFAULT :flock);
use File::stat;
use File::Touch;
use Debug;
use File::ReadBackwards;
our @ISA = qw(Debug);

######################################################################################################## 
## 
## 
##
## 
##          Package SemaforeFile
## 
## 
## 
## This package makes file inout/output on multiprocess systems more easy by encapsulating file locking.
## To define a new semaforefile use the new method:
## 
## my $id = SemaforeFile->new($filename,$lockfile); 
## 
## my $id = SemaforeFile->new($filename); 
## 
## If the lockfile is not specified, the default (/var/lock/SemaforeFile/SemaforeFile.lock or 
## /tmp/SemaforeFile.lock) is used instead. 
## This form should generally notbe used however, as in some cases /var/lock/SemaforeFile/SemaforeFile.lock can
## not be used and files in /tmp/ will from time to time be deleted...
## 
## The package includes the following simple public methods on semafore files:
## 
## $id->readonly()      Returns true if the file is readonly for the current user
## $id->exist()         Returns false if the file does not exists;
## $id->chmod($)        Sets the file permissions according to CORE::chmod
## $id->filename()      Returns the filename of the semafore file
## $id->readlines()     Returns the content of the file as an array with one line in each element
##                      Note thet it removes any trailing newline from the read lines!
## $id->writeline(@)    Writes the arguments to the file (NB: Overwrites file and add a newline to
##                      each argument if they do not already have it).
## $id->append(@)       Appends the arguments to the file (Also adds newlines if nescesarry).
##
## It is not nescesarry to check for file esistence in readlines as an empty array is returned if the file does note exist
## Note that the readlines function should only be used on small files as it globs the entire content to memory!
## For large files, use the more advanced member functions (see below). Also note that trailing newlines are removed
## from the individual lines. If this are not desired, use the readline() method described below.
## 
## 
## The module also includes the following methods for advanced use: 
## Note none of these functions check if the file exist before trying to open!
## The unsafe versions of open and close does not lock or unlock (assumes the user does this explicitly!)
## 
## $id->lock_ex()       Locks file for exclusive use (Read, Write or Anppend)
## $id->lock_sh()       Locks file for shared access (Read only)
## $id->lock_ex_nb()    Locks file for exclusive use non blocking (Check return status!)
## $id->lock_sh_nb()    Locks file for shared access non blocking (Check return status!)
## $id->unlock()        Unlocks file
## $id->open_read()     Opens the file for reading (locks file shared if not already locked)
## $id->open_readback() Opens the file for reading backwards (locks file shared if not already locked)
## $id->open_write()    Opens the file for writing (locks file exclusive if not already locked exclusive)
## $id->open_append()   Opens the file for appending (locks file exclusive if not already locked exclusive)
## $id->close()         Closes the file and unlocks it
## $id->open_read_unsafe()     
## $id->open_readback_unsafe()
## $id->open_write_unsafe()    
## $id->open_append_unsafe()
## $id->close_unsafe()   
## $id->mtime()         Returns the time of modification of the file as reported by File::stat->mtime,
##                      returns 0 if the file does not exist.
## $id->readline()      Reads and returns the next line from the file, assumes an open file
##                      Raises an excpeption (die) if not. 
## $id->fh()            Returns the underlying file handle for direct IO (Use with care!)
## 
## Additionally the $id->debug($) member function (inherited from Debug.pm) can turn debug information on and off
## $id->debug($level) turns debug on and $id->debug(0) turns debug off ($level is the debug level, 1 - 5)
## This may be usefull if deadlock is encountered (so that the individual file locking operations can
## be monitored! If $id->debug() is called without arguments it returns the status (i-e if debug in on
## 1 is returned else 0. 
## 
######################################################################################################## 

my $LOCK;

BEGIN {
    use Exporter ();
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
    $VERSION = 1.0;
    %EXPORT_TAGS = (
        'standard'=>[],
                    );
    Exporter::export_ok_tags('standard');
    Exporter::export_tags('standard');
    @ISA = qw(Exporter);
    mkdir '/var/lock/SemaforeFile' if (!-d '/var/lock/SemaforeFile' && -w '/var/lock/');
    $LOCK = '/var/lock/SemaforeFile/'.'SemaforeFile.lock';
    if (!-e $LOCK && -w '/var/lock/SemaforeFile/')
    {
        sysopen(FH, $LOCK, O_WRONLY | O_CREAT) or CORE::die "Error: Could not open $LOCK $!";
        chmod 0666, $LOCK;
        CORE::close FH;
    }
    ### Fallback of default lockfile to '/tmp/' if /var/lock is not possible    ###
    ### Although this is bad form it is nescesarry, however applications should ###
    ### use an explicit lock file name...                                       ###
    unless (-e $LOCK)
    {
	$LOCK = '/tmp/SemaforeFile.lock';
        sysopen(FH, $LOCK, O_WRONLY | O_CREAT) or CORE::die "Error: Could not open $LOCK $!";
        chmod 0666, $LOCK;
        CORE::close FH;
    }
}

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new();
    $self->{'_filename'} = undef;
    $self->{'_lock'} = undef;
    $self->{'_lock_fn'} = undef;
    $self->{'_readonly'} = 0;
    $self->{'_fhread'} = undef;
    $self->{'_fhwrite'} = undef;
    $self->{'_fhback'} = undef;
    $self->{'_locked'} = 0;
    bless $self,$class;
    ### Class invariant: $self->{'_locked'} contains the locked status of the file ###
    ### 0 for unlocked, 1 for share locked and 2 for exclusive lock.               ###
    ### Calling lock_ex twice for instance only locks thhe file the frist time as  ###
    ### the second time around it knows it is already locked!                      ###
    my $fn = shift;
    $self->die("Undefined filename specified for SemaforeFile, aborting!") unless (defined($fn) && $fn);    
    $self->{'_filename'} = $fn;
    ### Assume file is writeable if it does not exist, check if it exists and set readonly accordingly ###
    ### Only allwo normal files or symbolic links to be writable (no directories, pipes or sockets)
    $self->{'_readonly'} = 1 if (-e $fn && !(-w _ && (-f _ || -l _))); 
    if (@_)
    {
	$self->{'_lock_fn'} = shift;
    }
    else
    {
	$self->{'_lock_fn'} = $LOCK;
    }
    return $self;
};

return 1;


sub open_lock_fh()
{
    my $self = shift;
    return if ($self->{'_lock'});
    my $fn = $self->{'_lock_fn'};
    unless (defined($fn) && -e $fn)
    {
	$self->writedebug("Lockfilename: '$fn' does not exist, creating the lock.",1); 
	sysopen($self->{'_lock'}, $fn, O_WRONLY | O_CREAT) or $self->die("Error: Could not open lockfile '$fn' $!");
	chmod 0666, $fn;
    }
    else
    {
	sysopen($self->{'_lock'}, $fn, O_WRONLY | O_CREAT) or $self->die("Error: Could not open lockfile '$fn' $!");
    }
}

sub close_lock_fh()
{
    my $self = shift;
    CORE::close($self->{'_lock'}) if ($self->{'_lock'});
    $self->{'_lock'} = undef;
}

sub chmod($)
{
    my $self = shift;
    my $mode = shift;
    return unless (defined($mode));
    $self->lock_ex();
    unless ($self->exist())
    {
	touch($self->filename);
    }
    CORE::chmod $mode,$self->filename;
    $self->lock_un();
}

sub check_lock()
{
    my $self = shift;
    return if -e $self->{'_lock_fn'};
    $self->writedebug('WARNING! Lockfile "'.$self->{'_lock_fn'}.'" does not exist although it should have been created uppon instance construction, perhaps it was deleted by another process, semafore possibly corrupt! Creating the lock.',1);
    $self->open_lock_fh();
}

sub mtime()
{
    my $self = shift;
    return 0 unless (-e $self->{'_filename'});
    return stat($self->{'_filename'})->mtime;
}

sub filename
{
    my $self = shift;
    return $self->{'_filename'};
}

sub readonly()
{
    my $self = shift;
    return $self->{'_readonly'};
}

sub exist()
{
    my $self = shift;
    return -e $self->{'_filename'};
}

sub fh()
{
    my $self = shift;
    return $self->{'_fhwrite'} if ($self->{'_fhwrite'});
    return $self->{'_fhread'} if ($self->{'_fhread'});
    return $self->{'_fhback'} if ($self->{'_fhback'});
}

sub writeline(@)
{
    my $self = shift;
    $self->die("File $self->{'_filename'} already opened for reading!") if ($self->{'_fhread'} || $self->{'_fhback'});
    $self->die("Can not write to file '$self->{'_filename'}' as it is read only!") if ($self->readonly);
    my $status = $self->{'_locked'};
    my $fh = $self->{'_fhwrite'};
    $self->lock_ex() unless ($status > 1);
    unless ($fh)
    {
	$self->writedebug("Open '$self->{'_filename'}' for writing") if ($self->debug > 2);
	CORE::open($self->{'_fhwrite'},'>',$self->{'_filename'}) or $self->die("Could not open file $self->{'_filename'} for writing $!");
    }
    my $pfh = $self->{'_fhwrite'};
    while (@_)
    {
	my $st = shift;
	next unless (defined($st));
	chomp $st;
	print $pfh $st,"\n";
    }
    unless ($fh)
    {
	$self->writedebug("Closing '$self->{'_filename'}'") if ($self->debug > 2);
	CORE::close $self->{'_fhwrite'};
	$self->{'_fhwrite'} = undef;
    }
    $self->lock($status)
}

sub append(@)
{
    my $self = shift;
    $self->die("File $self->{'_filename'} already opened for reading!") if ($self->{'_fhread'} || $self->{'_fhback'});
    $self->die("Can not write to file '$self->{'_filename'}' as it is read only!") if ($self->readonly);
    my $status = $self->{'_locked'};
    my $fh = $self->{'_fhwrite'};
    $self->lock_ex() unless ($status > 1);
    unless ($fh)
    {
	$self->writedebug("Open '$self->{'_filename'}' for append") if ($self->debug > 2);
	CORE::open($self->{'_fhwrite'},'>>',$self->{'_filename'}) or $self->die("Could not open file $self->{'_filename'} for appending $!");
    }
    my $pfh = $self->{'_fhwrite'};
    while (@_)
    {
	my $st = shift;
	next unless (defined($st));
	chomp $st;
	print $pfh $st,"\n";
    }
    unless ($fh)
    {
	$self->writedebug("Closing '$self->{'_filename'}'") if ($self->debug > 2);
	CORE::close $self->{'_fhwrite'};
	$self->{'_fhwrite'} = undef;
    }
    $self->lock($status)
}

sub readline()
{
    my $self = shift;
    my $rfh = $self->{'_fhread'};
    my $bfh = $self->{'_fhback'};
    if ($bfh)
    {
	my $str = $bfh->readline();
	return $str;
    }
    die "File not opened for reading!" unless ($rfh);
    my $str = <$rfh>;
    return $str;
}


sub readlines()
{
    my $self = shift;
    my @res = ();
    $self->die("File $self->{'_filename'} already opened for writing or reading backwards!") if ($self->{'_fhwrite'} || $self->{'_fhback'});
    my $status = $self->{'_locked'};
    my $fh = $self->{'_fhread'};
    $self->lock_sh() unless ($status);
    unless ($fh)
    {
	### Return empty array if file does not exist ###
	unless ($self->exist)
	{
	    $self->lock($status);
	    return () 
	}
	$self->writedebug("Open '$self->{'_filename'}' for reading") if ($self->debug > 2);
	CORE::open $self->{'_fhread'},'<',$self->{'_filename'} or $self->die("Could not open file $self->{'_filename'} for reading $!");
    }
    my $rfh = $self->{'_fhread'};
    while (my $st = <$rfh>)
    {
	chomp $st;
	push @res,$st;
    }
    unless ($fh)
    {
	$self->writedebug("Closing '$self->{'_filename'}'") if ($self->debug > 2);
	CORE::close $self->{'_fhread'};
	$self->{'_fhread'} = undef;
    }
    $self->lock($status);
    return @res;
}

sub open_read()
{
    my $self = shift;
    $self->lock_sh unless ($self->{'_locked'});
    $self->open_read_unsafe;
}

sub open_readback()
{
    my $self = shift;
    $self->lock_sh unless ($self->{'_locked'});
    $self->open_readback_unsafe;
}

sub open_write()
{
    my $self = shift;
    $self->lock_ex unless ($self->{'_locked'} > 1);
    $self->open_write_unsafe;
}

sub open_append()
{
    my $self = shift;
    $self->lock_ex unless ($self->{'_locked'} > 1);
    $self->open_append_unsafe;
}

sub open_read_unsafe()
{
    my $self = shift;
    return if ($self->{'_fhread'});
    $self->writedebug("Open '$self->{'_filename'}' for reading") if ($self->debug > 2);
    $self->die("File already opened for writing or reading backwards! Reading form a file opened for wirting or reading backwards can result in undefined behaviour!") if ($self->{'_fhwrite'} || $self->{'_fhback'});
    CORE::open $self->{'_fhread'},'<',$self->{'_filename'} or $self->die("Could not open file $self->{'_filename'} for reading: $!");
}

sub open_readback_unsafe()
{
    my $self = shift;
    return if ($self->{'_fhback'});
    $self->writedebug("Open '$self->{'_filename'}' for reading") if ($self->debug > 2);
    $self->die("File already opened for reading or writing! Reading backwards form a file opened for reading or wirting can result in undefined behaviour!") if ($self->{'_fhwrite'} || $self->{'_fhread'});
    $self->{'_fhback'} = File::ReadBackwards->new($self->{'_filename'}) or $self->die("Could not open file $self->{'_filename'} for reading backwards: $!");
}

sub open_write_unsafe()
{
    my $self = shift;
    return if ($self->{'_fhwrite'});
    $self->writedebug("Open '$self->{'_filename'}' for write") if ($self->debug > 2);
    $self->die("File already opened for reading! Reading form a file opened fro wirting can result in undefined behaviour!") if ($self->{'_fhread'} || $self->{'_fhback'});
    CORE::open $self->{'_fhwrite'},'>',$self->{'_filename'} or $self->die("Could not open file $self->{'_filename'} for writing: $!");
}

sub open_append_unsafe()
{
    my $self = shift;
    return if ($self->{'_fhwrite'});
    $self->writedebug("Open '$self->{'_filename'}' for append") if ($self->debug > 2);
    $self->die("File already opened for reading! Reading form a file opened fro wirting can result in undefined behaviour!") if ($self->{'_fhread'} || $self->{'_fhback'});
    CORE::open $self->{'_fhwrite'},'>>',$self->{'_filename'} or $self->die("Could not open file $self->{'_filename'} for appending: $!");
}

sub close()
{
    my $self = shift;
    $self->close_unsafe;
    $self->unlock;
}

sub close_unsafe()
{
    my $self = shift;
    $self->writedebug("Closing '$self->{'_filename'}'") if ($self->debug > 2);
    CORE::close($self->{'_fhread'}) if ($self->{'_fhread'});
    CORE::close($self->{'_fhwrite'}) if ($self->{'_fhwrite'});
    $self->{'_fhback'}->close if ($self->{'_fhback'});
    $self->{'_fhread'} = undef;
    $self->{'_fhwrite'} = undef;
    $self->{'_fhback'} = undef;
}

sub lock_un()
{
    my $self = shift;
    return $self->unlock();
}


sub lock_sh()
{
    my $self = shift;
    $self->open_lock_fh();
    return $self->{'_locked'} if ($self->{'_locked'} == 1);
    $self->writedebug("Share locking '$self->{'_filename'}' with lockfile '$self->{'_lock_fn'}'") if ($self->debug > 1);
    flock($self->{'_lock'},LOCK_SH);
    $self->{'_locked'} = 1;
}

sub lock_sh_nb()
{
    my $self = shift;
    $self->open_lock_fh();
    return $self->{'_locked'} if ($self->{'_locked'} == 1);
    $self->writedebug("Share locking (non blocking!) '$self->{'_filename'}' with lockfile '$self->{'_lock_fn'}'") if ($self->debug > 1);
    my $res = flock($self->{'_lock'},LOCK_SH | LOCK_NB);
    $self->{'_locked'} = 1 if ($res);
    return $res;
}

sub lock_ex()
{
    my $self = shift;
    $self->open_lock_fh();
    return $self->{'_locked'} if ($self->{'_locked'} == 2);
    $self->writedebug("Exclusive locking '$self->{'_filename'}' with lockfile '$self->{'_lock_fn'}'") if ($self->debug > 1);
    flock($self->{'_lock'},LOCK_EX);
    $self->{'_locked'} = 2;
}

sub lock_ex_nb()
{
    my $self = shift;
    $self->open_lock_fh();
    return $self->{'_locked'} if ($self->{'_locked'} == 2);
    $self->writedebug("Exclusive locking (non blocking!) '$self->{'_filename'}' with lockfile '$self->{'_lock_fn'}'") if ($self->debug > 1);
    my $res = flock($self->{'_lock'},LOCK_EX | LOCK_NB);
    $self->{'_locked'} = 2 if ($res);
    return $res;
}

sub lock($)
{
    my $self = shift;
    my $level = shift;
    $self->lock_ex if ($level == 2);
    $self->lock_sh if ($level == 1);
    $self->unlock if ($level == 0);
}

sub unlock()
{
    my $self = shift;
    $self->check_lock();
    return $self->{'_locked'} if ($self->{'_locked'} == 0);
    $self->writedebug("Unlocking '$self->{'_filename'}' with lockfile '$self->{'_lock_fn'}'") if ($self->debug > 1);
    flock($self->{'_lock'},LOCK_UN);
    $self->{'_locked'} = 0;
    $self->close_lock_fh();
}

sub DESTROY
{
    my $self = shift;
    CORE::close($self->{'_fhread'}) if ($self->{'_fhread'});
    CORE::close($self->{'_fhwrite'}) if ($self->{'_fhwrite'});
    $self->{'_fhback'}->close if ($self->{'_fhback'});
    if ($self->{'_locked'} && $self->{'_lock'})
    {
	$self->writedebug("Unlocking '$self->{'_filename'}'") if ($self->debug > 2);
	$self->check_lock();
	flock($self->{'_lock'},LOCK_UN);
    }
    CORE::close($self->{'_lock'}) if ($self->{'_lock'});
    $self->{'_lock'} = undef;
    $self->{'_fhback'} = undef;
}
