package Yuki::YukiWikiDB_Lock;
($VERSION) = q($Revision: 1.2 $) =~ m/\x20([\d.]+)\x20/;
use strict;

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}) {
    if ($opt{force}) {	# force lock
      $status->{seq} = 0;
      $status->{time} = time;
      $status->{creation} = time;
    } elsif (	# normal lock
        ($status->{seq} == 0 && $status->{time} == 0)	# not locked
     || ($status->{seq} && $status->{time})) {	# share locked
      $status->{seq}++;	## Increase lock count
      $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: locking successd));
    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}) {
    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: unlocking successed));
    return 1;
  } else {
    &{$self->{-error_handler}} ($self, level => 'log',
      msg => qq(_unlock: $self->{-directory}$old_lock_name => $newname: $!));
    return 0;
  }
}

## -directory => path         Lock files' directory
## -name => 1*filename-char   Base name of lock file
## -share => 0/1
##                  - 1: Share lock
##                  - 0: Exclusive lock (default)
## -retry => -1/0/1..
##                  - -1: No retry
##                  - 0: Infinite times of retries
##                  - n (n > 0): n times of retries (default 8)
## -timeout => n (second) (default 20)
## -error_handler => CODE      : Error handler (default: die)
## 
sub new ($%) {
  my $class = shift;
  my $self = bless {@_}, $class;
  $self->{-retry} = 8 unless defined $self->{-retry};
  $self->{-timeout} ||= 20;
  $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;
}

sub lock ($) {
  my $self = shift;
  return 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 ();
      my $duration = time - $status->{time};
      
      ## Expired lock
      if ($self->{-timeout} < $duration) {
        &{$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
        }
      ## Locked
      } else {
        if ($self->_lock ($lockfile, $status)) {
          $self->{creation} = $status->{creation};
	  $self->{locked} = 1;
          return 1;
        } else {
          # -> retry
        }
      }
      
      ## Wait
      &{$self->{-error_handler}} ($self, level => 'log',
        msg => qq(lock: retry ($try/$trytime) failed));
      sleep 1;	# 1 second
    }	# for
  }
  
  return 0;
}

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;
}

sub DESTROY ($) {
    my $self = shift;
    $self->unlock if $self->{locked};
    &{$self->{-error_handler}} ($self, level => 'log', 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 LICENSE

Copyright 2003 Wakaba <w@suika.fam.cx>

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

=cut

1; # $Date: 2003/07/29 09:16:06 $