=head1 NAME

SuikaWiki::DB::Util::Lock --- SuikaWiki WikiDatabase: Generalized lock support

=head1 DESCRIPTION

This module provides "file lock" for WikiDatabase modules.
It does not depend implementation of database or filesystem.

The lock mechanism implemented in this module is based on 
Yuki::YukiWikiDB2's one.

This module is part of SuikaWiki.

=cut

package SuikaWiki::DB::Util::Lock;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.11 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

#use overload
#      'bool' => sub { 1 },
#      fallback => 1;

sub _make_lock_file_name ($$) {
  my ($self, $o) = @_;
  return sprintf '%s.%d.%d.%d.lock', $o->{prefix}, $o->{seq},
                                     $o->{time}, $o->{creation};
}

sub _match_lock_file_name ($$%) {
  my ($self, $fname, %o) = @_;
  if ($fname =~ /^\Q$o{prefix}\E\.([0-9]+)\.([0-9]+)\.([0-9]+)\.lock$/) {
    return {prefix => $o{prefix}, seq => $1, time => $2,
            creation => $3};
  }
  return undef;
}

## Lock
## Returns 1 if lock successed and 0 otherwise.
sub _lock ($$$;%) {
  my ($self, $old_lock_name, $status, %opt) = @_;
  
  ## Share lock
  if ($self->{-share}) {
    return "0 but true" if $self->{-no_lock};
    if ($opt{force}) {	# force lock
      $status->{seq} = 1;
      $status->{time} = time;
      $status->{creation} = time;
    } elsif (	# normal lock
        ($status->{seq} == 0 && $status->{time} == 0)	# not locked
     || ($status->{seq} && $status->{time})) {	# share locked
      return 0 if $self->{-limit} > 0 and $status->{seq} >= $self->{-limit};
      $status->{time} = time;	## Update locked date
      $status->{creation} = time if ++$status->{seq} == 1;
    } else {	# Exclusively locked or unknown error
      return 0;
    }
  ## Exclusive lock
  } else {
    if ($opt{force}	# force lock
    || ($status->{seq} == 0 && $status->{time} == 0)) {	# not locked
      $status->{seq} = 0;
      $status->{time} = time;	## Locked date
      $status->{creation} = time;
    } else {	# Already locked
      return 0;
    }
  }
  
  my $newname = $self->{-directory}.$self->_make_lock_file_name
                                      ($status);
  if (rename $self->{-directory}.$old_lock_name => $newname) {
    &{$self->{-error_handler}} ($self, level => 'detaillog',
                                msg => qq(_lock: $self->{-directory}$old_lock_name => $newname: locked successfully));
    return 1;
  } else {
    &{$self->{-error_handler}} ($self, level => 'log',
      msg => qq(_lock: $self->{-directory}$old_lock_name => $newname: $!));
    return 0;
  }
}

sub _unlock ($$$) {
  my ($self, $old_lock_name, $status) = @_;
  
  ## Share lock
  if ($self->{-share}) {
    return "0 but true" if $self->{-no_lock};
    if ($status->{seq} && $status->{time}) {
      ## I'm the last lock owner
      if ($status->{seq} == 1) {
        $status->{seq} = 0;
        $status->{time} = 0;
	$status->{creation} = 0;
      } else {
        $status->{seq}--;
        #$status->{time} unchanged
      }
    } else {
      return 0;
    }
  ## Exclusive lock
  } else {
    if ($status->{seq} == 0 && $status->{time}) {
      $status->{time} = 0;
      $status->{creation} = 0;
    } else {
      return 0;
    }
  }
  
  my $newname = $self->{-directory}.$self->_make_lock_file_name
                                      ($status);
  if (rename $self->{-directory}.$old_lock_name => $newname) {
    &{$self->{-error_handler}} ($self, level => 'detaillog',
	                        msg => qq(_unlock: $self->{-directory}$old_lock_name => $newname: unlocked successfully));
    return 1;
  } else {
    &{$self->{-error_handler}} ($self, level => 'log',
      msg => qq(_unlock: $self->{-directory}$old_lock_name => $newname: $!));
    return 0;
  }
}

=head1 METHODS

=over 4

=item $locker = SuikaWiki::DB::Util::Lock->new (%options)

Generates a new instance of this module.
This method does NOT lock yet.

=over 4 options:

=item -directory => path-to-lock (REQUIRED)

Lock files' directory. Example: C</var/lock/suikawiki>

=item -limit => -1/1/2/... (Default: C<-1>)

How many attempts to lock can be allowed at the same time.
C<-1> means that infinite locks.  This option effects only to shared lock.

=item -name => 1*filename-char (REQUIRED)

Base name of lock file. Example: C<wikipage>

=item -share => 0/1 (Default: 0)

Type of lock. C<1>: Share lock.  Read only. C<0>: Exclusive lock.
Read and/or write.

=item -retry => -1/0/1/2/.. (Default: 8)

How many times retry. C<-1>: No retry (total one time of try).
C<0>: Infinite times.  (Actual number is determined by timeout seconds.)
n (n > 0): n times (total (n + 1) times of tries).

=item -timeout => n (Default: 500)

Timeout seconds.  After this duration, lock file is ignored as accidentally-
not-removed-lock.

=item -error_handler => CODE (Default: warn or die)

Error handler.  Errors and log messages are passed to this procedure.
Example:

  -error_handler => sub {
    my ($self, %argv) = @_;
    if ($argv{level} eq 'fatal') {
      die $argv{msg};
    } else {
      warn $argv{msg};
    }
  },

=cut

sub new ($%) {
  my $class = shift;
  my $self = bless {@_}, $class;
  $self->{-retry} = 8 unless defined $self->{-retry};
  $self->{-timeout} ||= 500;
  $self->{-limit} ||= -1;
  $self->{-error_handler} ||= sub {
    my (undef, %o) = @_;
    if ($o{level} eq 'fatal') {
      die sprintf '%d: %s', scalar time, $o{msg};
    } else {
      warn sprintf '%d: %s', scalar time, $o{msg};
    }
  };
  $self->{-directory} .= '/'
    unless substr ($self->{-directory}, -1) eq '/';
  return $self;
}

=item 1/0 = $locker->lock ()

Lock.  Returns C<1> if lock is successed.  Otherwise C<0> is returned.


=cut

sub lock ($) {
  my $self = shift;
  return 1 if $self->{locked};
  
  ## Get lock file
  my ($lockfile, $status) = $self->_make_new_lock ();
  
  ## Try locking
  if ($self->_lock ($lockfile, $status)) {
    ## Success
    $self->{creation} = $status->{creation};
    $self->{locked} = 1;
    return 1;
  } else {	## Failure
    return 0 if $self->{-retry} == -1;	# No retry
    
    ## How many times retry?
    my $trytime = $self->{-retry} || $self->{-timeout};
    $trytime = $self->{-timeout} if $self->{-retry} > $trytime;
    
    for (my $try = 0; $try < $trytime; $try++) {
      my ($lockfile, $status) = $self->_make_new_lock ();
      
      ## Already unlocked
      if ($status->{seq} == 0 && $status->{time} == 0
                              && $status->{creation} == 0) {
        if ($self->_lock ($lockfile, $status)) {
          $self->{creation} = $status->{creation};
          $self->{locked} = 1;
          return 1;
        }
        # ->retry
      ## Expired lock
      } elsif ($self->{-timeout} < time - $status->{time}) {
        &{$self->{-error_handler}} ($self, level => 'log',
          msg => qq(lock: $lockfile: lockfile already expired));
        
        #if ($self->_lock ($lockfile, $status, force => 1)) {
        #  $self->{creation} = $status->{creation};
        #  $self->{locked} = 1;
        #  return 1;
        #} else {
        #  &{$self->{-error_handler}} ($self, level => 'warn',
        #    msg => qq(lock: force lock failed));
        #  # -> retry
        #}
        
        unlink $self->{-directory} . $lockfile
          or &{$self->{-error_handler}} ($self, level => 'log',
               msg => qq(lock: $lockfile: cannot remove expired lockfile));
        # -> retry (to avoid race condition)
      ## Locked
      } else {
        if ($self->_lock ($lockfile, $status)) {
          $self->{creation} = $status->{creation};
          $self->{locked} = 1;
          return 1;
        } else {
          # -> retry
        }
      }
      
      ## Wait and retry
      &{$self->{-error_handler}} ($self, level => 'log',
        msg => qq(lock: retry ($try/$trytime) failed (wait for $lockfile)));
      sleep 1;	# 1 second
    }	# for
  }
  
  return 0;
}

=item 1/0 = $locker->unlock ()

Unlock.  Returns C<1> if unlock is success.  C<-1> if lock file is
lost.  Otherwise C<0> is returned.

=cut

sub unlock ($) {
  my $self = shift;
  return unless $self->{locked};
  
  ## Get lock file
  my ($lockfile, $status) = $self->_make_new_lock ();
  
  ## Current lock file is not same as what was used to lock
  if ($self->{creation} != $status->{creation}) {
    &{$self->{-error_handler}} ($self, level => 'log',
      msg => qq(unlock: $lockfile: original lock ($self->{creation}) was lost));
    $self->{creation} = undef;
    $self->{locked} = 0;
    return -1;
  }
  
  ## Try unlocking
  if ($self->_unlock ($lockfile, $status)) {
    ## Success
    $self->{creation} = undef;
    $self->{locked} = 0;
    return 1;
  } else {	## Failure
    if ($self->{-retry} == -1) {	# No retry
      $self->{creation} = undef;
      return 0;
    }
    
    ## How many times retry?
    my $trytime = $self->{-retry} || $self->{-timeout};
    $trytime = $self->{-timeout} if $self->{-retry} > $trytime;
    
    for (my $try = 0; $try < $trytime; $try++) {
      my ($lockfile, $status) = $self->_make_new_lock ();
      
      ## Current lock file is not same as what was used to lock
      if ($self->{creation} != $status->{creation}) {
        &{$self->{-error_handler}} ($self, level => 'log',
          msg => qq(unlock: $lockfile: original lock ($self->{creation}) was lost));
        $self->{creation} = undef;
	$self->{locked} = 0;
        return -1;
      } elsif ($self->_unlock ($lockfile, $status)) {
        $self->{creation} = undef;
	$self->{locked} = 0;
        return 1;
      }
      
      ## Wait
      &{$self->{-error_handler}} ($self, level => 'log',
        msg => qq(unlock: retry ($try/$trytime) failed));
      #sleep 1;	# 1 second
    }	# for
  }
  
  $self->{creation} = undef;
  return 0;
}

=item 1/0 = $locker->readable ()

Returns whether readable or not.  If locked, C<1> is returned.

=item 1/0 = $locker->writable ()

Returns whether writable or not.  If exclusively locked, C<1> is returned.

=item 1/0 = $locker->appendable ()

Retruns whether line-appendable or not.  If exclusively locked, C<1> is
returned.

=item 1/0 = $locker->locked ()

Returns whether locked or not.       

=cut


sub readable ($) {
  my $self = shift;
  return $self->{locked};
}

sub writable ($) {
  my $self = shift;
  return $self->{locked} && !$self->{-share};
}

sub appendable ($) {
  my $self = shift;
  return $self->{locked} && !$self->{-share};
}

sub locked ($) {
  return $_[0]->{locked};
}

=back

Note that when the final referrence to $locker (instance of this module)
is deleted, unlock is automatically done if ever locked.
So you can write lock-but-no-unlock code, while it is deprecated 'cause of
readability matter.

=cut

sub DESTROY ($) {
    my $self = shift;
    $self->unlock if $self->{locked};
    &{$self->{-error_handler}} ($self, level => 'detaillog', msg => 'DESTROY');
}

## Makes new lock file and returns its name.
## If already exists, returns its name.
sub _make_new_lock ($) {
  my $self = shift;
  my @lockfile;
  opendir LOCKDIR, $self->{-directory}
    or &{$self->{-error_handler}}
         ($self, msg => qq(_make_new_lock: $self->{-directory}: $!),
          level => 'fatal'); {
    my $pfx_length = length $self->{-name};
    @lockfile = grep {substr ($_, 0, $pfx_length)
                         eq $self->{-name}}
                   readdir LOCKDIR;
  } closedir LOCKDIR;
  
  my $lockfile;
  my $status;
  for (@lockfile) {
    $status = $self->_match_lock_file_name
                ($_, prefix => $self->{-name});
    if ($status) {
      $lockfile = $_;
      last;
    }
  }
  ## Lock file not exist -- Make new lock file
  unless ($lockfile) {
    $status = {prefix => $self->{-name}, seq => 0, time => 0,
               creation => 0};
    $lockfile = $self->_make_lock_file_name ($status);
    open LOCKFILE, '>', $self->{-directory}.$lockfile
      or &{$self->{-error_handler}}
        ($self, msg => qq(_make_new_lock: $self->{-directory}.$lockfile: $!),
         level => 'fatal');
      print LOCKFILE scalar localtime;	# dummy data
    close LOCKFILE;
  }
  return ($lockfile, $status);
}

=head1 EXAMPLE

    require SuikaWiki::DB::Util::Lock;
    my $locker = SuikaWiki::DB::Util::Lock->new (
			-directory => './lock/',
			-name      => 'example-db',
                        -retry     => 15,
                        -timeout   => 5,
                        -error_handler => sub {
			    my ($self, %argv) = @_;
			    open LOG, '>>', '/path/to/log';
			    print LOG scalar gmtime, "\t$argv{msg}\n";
			    close LOG;
			    if ($argv{level} eq 'fatal') {
				die $argv{msg};
			    }
                        },
    );			
    
    $locker->lock or die "Can't lock";
    
    open DATA, 'foo.txt';
    while (<DATA>) {
      # something
    }
    close DATA;
    
    open NEWDATA, '>', 'bar.txt';
      # something
    close NEWDATA;
    
    $locker->unlock or die "Can't unlock";

=head1 AUTHOR

Wakaba <w@suika.fam.cx>

Original locking algorithm is taken from that of C<Yuki::YukiWikiDB2>.

=head1 TO DO

Lock check (relock if timeouted), lock update (safe unlock-and-lock)

Issue: Should Message::Util::Error based error reporting system
be employed instead of current original simple reportimg mechanism?

=head1 SEE ALSO

SuikaWiki:"SuikaWiki//WikiDB", C<SuikaWiki::DB::Util>

=head1 LICENSE

Copyright 2003-2004 Wakaba <w@suika.fam.cx>.  All rights reserved.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1; # $Date: 2004/04/02 04:30:57 $