DB/Util/Lock.pm


=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.10 $=~/\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/03/19 11:23:40 $
1	wakaba	1.1
2			=head1 NAME
3
4			SuikaWiki::DB::Util::Lock --- SuikaWiki WikiDatabase: Generalized lock support
5
6			=head1 DESCRIPTION
7
8			This module provides "file lock" for WikiDatabase modules.
9			It does not depend implementation of database or filesystem.
10
11	wakaba	1.6	The lock mechanism implemented in this module is based on
12			Yuki::YukiWikiDB2's one.
13
14	wakaba	1.1	This module is part of SuikaWiki.
15
16			=cut
17
18			package SuikaWiki::DB::Util::Lock;
19			use strict;
20	wakaba	1.11	our $VERSION=do{my @r=(q$Revision: 1.10 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
21	wakaba	1.7
22			#use overload
23			# 'bool' => sub { 1 },
24			# fallback => 1;
25	wakaba	1.1
26			sub _make_lock_file_name ($$) {
27			my ($self, $o) = @_;
28			return sprintf '%s.%d.%d.%d.lock', $o->{prefix}, $o->{seq},
29			$o->{time}, $o->{creation};
30			}
31
32			sub _match_lock_file_name ($$%) {
33			my ($self, $fname, %o) = @_;
34			if ($fname =~ /^\Q$o{prefix}\E\.([0-9]+)\.([0-9]+)\.([0-9]+)\.lock$/) {
35			return {prefix => $o{prefix}, seq => $1, time => $2,
36			creation => $3};
37			}
38			return undef;
39			}
40
41			## Lock
42			## Returns 1 if lock successed and 0 otherwise.
43			sub _lock ($$$;%) {
44			my ($self, $old_lock_name, $status, %opt) = @_;
45
46			## Share lock
47			if ($self->{-share}) {
48	wakaba	1.9	return "0 but true" if $self->{-no_lock};
49	wakaba	1.1	if ($opt{force}) { # force lock
50	wakaba	1.8	$status->{seq} = 1;
51	wakaba	1.1	$status->{time} = time;
52			$status->{creation} = time;
53			} elsif ( # normal lock
54			($status->{seq} == 0 && $status->{time} == 0) # not locked
55			\|\| ($status->{seq} && $status->{time})) { # share locked
56	wakaba	1.10	return 0 if $self->{-limit} > 0 and $status->{seq} >= $self->{-limit};
57	wakaba	1.1	$status->{time} = time; ## Update locked date
58	wakaba	1.8	$status->{creation} = time if ++$status->{seq} == 1;
59	wakaba	1.1	} else { # Exclusively locked or unknown error
60			return 0;
61			}
62			## Exclusive lock
63			} else {
64			if ($opt{force} # force lock
65			\|\| ($status->{seq} == 0 && $status->{time} == 0)) { # not locked
66			$status->{seq} = 0;
67			$status->{time} = time; ## Locked date
68			$status->{creation} = time;
69			} else { # Already locked
70			return 0;
71			}
72			}
73
74			my $newname = $self->{-directory}.$self->_make_lock_file_name
75			($status);
76			if (rename $self->{-directory}.$old_lock_name => $newname) {
77			&{$self->{-error_handler}} ($self, level => 'detaillog',
78	wakaba	1.8	msg => qq(_lock: $self->{-directory}$old_lock_name => $newname: locked successfully));
79	wakaba	1.1	return 1;
80			} else {
81			&{$self->{-error_handler}} ($self, level => 'log',
82			msg => qq(_lock: $self->{-directory}$old_lock_name => $newname: $!));
83			return 0;
84			}
85			}
86
87			sub _unlock ($$$) {
88			my ($self, $old_lock_name, $status) = @_;
89
90			## Share lock
91			if ($self->{-share}) {
92	wakaba	1.9	return "0 but true" if $self->{-no_lock};
93	wakaba	1.1	if ($status->{seq} && $status->{time}) {
94			## I'm the last lock owner
95			if ($status->{seq} == 1) {
96			$status->{seq} = 0;
97			$status->{time} = 0;
98			$status->{creation} = 0;
99			} else {
100			$status->{seq}--;
101			#$status->{time} unchanged
102			}
103			} else {
104			return 0;
105			}
106			## Exclusive lock
107			} else {
108			if ($status->{seq} == 0 && $status->{time}) {
109			$status->{time} = 0;
110			$status->{creation} = 0;
111			} else {
112			return 0;
113			}
114			}
115
116			my $newname = $self->{-directory}.$self->_make_lock_file_name
117			($status);
118			if (rename $self->{-directory}.$old_lock_name => $newname) {
119			&{$self->{-error_handler}} ($self, level => 'detaillog',
120	wakaba	1.8	msg => qq(_unlock: $self->{-directory}$old_lock_name => $newname: unlocked successfully));
121	wakaba	1.1	return 1;
122			} else {
123			&{$self->{-error_handler}} ($self, level => 'log',
124			msg => qq(_unlock: $self->{-directory}$old_lock_name => $newname: $!));
125			return 0;
126			}
127			}
128
129			=head1 METHODS
130
131			=over 4
132
133			=item $locker = SuikaWiki::DB::Util::Lock->new (%options)
134
135			Generates a new instance of this module.
136			This method does NOT lock yet.
137
138			=over 4 options:
139
140			=item -directory => path-to-lock (REQUIRED)
141
142			Lock files' directory. Example: C</var/lock/suikawiki>
143
144	wakaba	1.10	=item -limit => -1/1/2/... (Default: C<-1>)
145
146			How many attempts to lock can be allowed at the same time.
147			C<-1> means that infinite locks. This option effects only to shared lock.
148
149	wakaba	1.1	=item -name => 1*filename-char (REQUIRED)
150
151			Base name of lock file. Example: C<wikipage>
152
153			=item -share => 0/1 (Default: 0)
154
155			Type of lock. C<1>: Share lock. Read only. C<0>: Exclusive lock.
156			Read and/or write.
157
158			=item -retry => -1/0/1/2/.. (Default: 8)
159
160			How many times retry. C<-1>: No retry (total one time of try).
161			C<0>: Infinite times. (Actual number is determined by timeout seconds.)
162			n (n > 0): n times (total (n + 1) times of tries).
163
164	wakaba	1.6	=item -timeout => n (Default: 500)
165	wakaba	1.1
166			Timeout seconds. After this duration, lock file is ignored as accidentally-
167			not-removed-lock.
168
169			=item -error_handler => CODE (Default: warn or die)
170
171			Error handler. Errors and log messages are passed to this procedure.
172			Example:
173
174			-error_handler => sub {
175			my ($self, %argv) = @_;
176			if ($argv{level} eq 'fatal') {
177			die $argv{msg};
178			} else {
179			warn $argv{msg};
180			}
181			},
182
183			=cut
184
185			sub new ($%) {
186			my $class = shift;
187			my $self = bless {@_}, $class;
188			$self->{-retry} = 8 unless defined $self->{-retry};
189	wakaba	1.6	$self->{-timeout} \|\|= 500;
190	wakaba	1.10	$self->{-limit} \|\|= -1;
191	wakaba	1.1	$self->{-error_handler} \|\|= sub {
192			my (undef, %o) = @_;
193			if ($o{level} eq 'fatal') {
194			die sprintf '%d: %s', scalar time, $o{msg};
195			} else {
196			warn sprintf '%d: %s', scalar time, $o{msg};
197			}
198			};
199			$self->{-directory} .= '/'
200			unless substr ($self->{-directory}, -1) eq '/';
201			return $self;
202			}
203
204			=item 1/0 = $locker->lock ()
205
206			Lock. Returns C<1> if lock is successed. Otherwise C<0> is returned.
207
208
209			=cut
210
211			sub lock ($) {
212			my $self = shift;
213			return 1 if $self->{locked};
214
215			## Get lock file
216			my ($lockfile, $status) = $self->_make_new_lock ();
217
218			## Try locking
219			if ($self->_lock ($lockfile, $status)) {
220			## Success
221			$self->{creation} = $status->{creation};
222			$self->{locked} = 1;
223			return 1;
224			} else { ## Failure
225			return 0 if $self->{-retry} == -1; # No retry
226
227			## How many times retry?
228			my $trytime = $self->{-retry} \|\| $self->{-timeout};
229			$trytime = $self->{-timeout} if $self->{-retry} > $trytime;
230
231			for (my $try = 0; $try < $trytime; $try++) {
232			my ($lockfile, $status) = $self->_make_new_lock ();
233
234	wakaba	1.8	## Already unlocked
235			if ($status->{seq} == 0 && $status->{time} == 0
236			&& $status->{creation} == 0) {
237			if ($self->_lock ($lockfile, $status)) {
238	wakaba	1.1	$self->{creation} = $status->{creation};
239	wakaba	1.8	$self->{locked} = 1;
240	wakaba	1.1	return 1;
241			}
242	wakaba	1.8	# ->retry
243			## Expired lock
244			} elsif ($self->{-timeout} < time - $status->{time}) {
245			&{$self->{-error_handler}} ($self, level => 'log',
246			msg => qq(lock: $lockfile: lockfile already expired));
247
248			#if ($self->_lock ($lockfile, $status, force => 1)) {
249			# $self->{creation} = $status->{creation};
250			# $self->{locked} = 1;
251			# return 1;
252			#} else {
253			# &{$self->{-error_handler}} ($self, level => 'warn',
254			# msg => qq(lock: force lock failed));
255			# # -> retry
256			#}
257
258			unlink $self->{-directory} . $lockfile
259			or &{$self->{-error_handler}} ($self, level => 'log',
260			msg => qq(lock: $lockfile: cannot remove expired lockfile));
261			# -> retry (to avoid race condition)
262	wakaba	1.1	## Locked
263			} else {
264			if ($self->_lock ($lockfile, $status)) {
265			$self->{creation} = $status->{creation};
266	wakaba	1.8	$self->{locked} = 1;
267	wakaba	1.1	return 1;
268			} else {
269			# -> retry
270			}
271			}
272
273	wakaba	1.8	## Wait and retry
274	wakaba	1.1	&{$self->{-error_handler}} ($self, level => 'log',
275	wakaba	1.8	msg => qq(lock: retry ($try/$trytime) failed (wait for $lockfile)));
276	wakaba	1.1	sleep 1; # 1 second
277			} # for
278			}
279
280			return 0;
281			}
282
283			=item 1/0 = $locker->unlock ()
284
285			Unlock. Returns C<1> if unlock is success. C<-1> if lock file is
286			lost. Otherwise C<0> is returned.
287
288			=cut
289
290			sub unlock ($) {
291			my $self = shift;
292			return unless $self->{locked};
293
294			## Get lock file
295			my ($lockfile, $status) = $self->_make_new_lock ();
296
297			## Current lock file is not same as what was used to lock
298			if ($self->{creation} != $status->{creation}) {
299			&{$self->{-error_handler}} ($self, level => 'log',
300			msg => qq(unlock: $lockfile: original lock ($self->{creation}) was lost));
301			$self->{creation} = undef;
302			$self->{locked} = 0;
303			return -1;
304			}
305
306			## Try unlocking
307			if ($self->_unlock ($lockfile, $status)) {
308			## Success
309			$self->{creation} = undef;
310			$self->{locked} = 0;
311			return 1;
312			} else { ## Failure
313			if ($self->{-retry} == -1) { # No retry
314			$self->{creation} = undef;
315			return 0;
316			}
317
318			## How many times retry?
319			my $trytime = $self->{-retry} \|\| $self->{-timeout};
320			$trytime = $self->{-timeout} if $self->{-retry} > $trytime;
321
322			for (my $try = 0; $try < $trytime; $try++) {
323			my ($lockfile, $status) = $self->_make_new_lock ();
324
325			## Current lock file is not same as what was used to lock
326			if ($self->{creation} != $status->{creation}) {
327			&{$self->{-error_handler}} ($self, level => 'log',
328			msg => qq(unlock: $lockfile: original lock ($self->{creation}) was lost));
329			$self->{creation} = undef;
330			$self->{locked} = 0;
331			return -1;
332			} elsif ($self->_unlock ($lockfile, $status)) {
333			$self->{creation} = undef;
334			$self->{locked} = 0;
335			return 1;
336			}
337
338			## Wait
339			&{$self->{-error_handler}} ($self, level => 'log',
340			msg => qq(unlock: retry ($try/$trytime) failed));
341			#sleep 1; # 1 second
342			} # for
343			}
344
345			$self->{creation} = undef;
346			return 0;
347			}
348
349	wakaba	1.2	=item 1/0 = $locker->readable ()
350
351			Returns whether readable or not. If locked, C<1> is returned.
352
353			=item 1/0 = $locker->writable ()
354
355	wakaba	1.11	Returns whether writable or not. If exclusively locked, C<1> is returned.
356
357			=item 1/0 = $locker->appendable ()
358
359			Retruns whether line-appendable or not. If exclusively locked, C<1> is
360			returned.
361	wakaba	1.2
362	wakaba	1.5	=item 1/0 = $locker->locked ()
363
364			Returns whether locked or not.
365
366	wakaba	1.2	=cut
367
368
369			sub readable ($) {
370			my $self = shift;
371			return $self->{locked};
372			}
373
374			sub writable ($) {
375			my $self = shift;
376			return $self->{locked} && !$self->{-share};
377			}
378
379	wakaba	1.11	sub appendable ($) {
380			my $self = shift;
381			return $self->{locked} && !$self->{-share};
382			}
383
384	wakaba	1.5	sub locked ($) {
385			return $_[0]->{locked};
386			}
387
388	wakaba	1.1	=back
389
390			Note that when the final referrence to $locker (instance of this module)
391			is deleted, unlock is automatically done if ever locked.
392			So you can write lock-but-no-unlock code, while it is deprecated 'cause of
393			readability matter.
394
395			=cut
396
397			sub DESTROY ($) {
398			my $self = shift;
399			$self->unlock if $self->{locked};
400	wakaba	1.4	&{$self->{-error_handler}} ($self, level => 'detaillog', msg => 'DESTROY');
401	wakaba	1.1	}
402
403			## Makes new lock file and returns its name.
404			## If already exists, returns its name.
405			sub _make_new_lock ($) {
406			my $self = shift;
407			my @lockfile;
408			opendir LOCKDIR, $self->{-directory}
409			or &{$self->{-error_handler}}
410			($self, msg => qq(_make_new_lock: $self->{-directory}: $!),
411			level => 'fatal'); {
412			my $pfx_length = length $self->{-name};
413			@lockfile = grep {substr ($_, 0, $pfx_length)
414			eq $self->{-name}}
415			readdir LOCKDIR;
416			} closedir LOCKDIR;
417
418			my $lockfile;
419			my $status;
420			for (@lockfile) {
421			$status = $self->_match_lock_file_name
422			($_, prefix => $self->{-name});
423			if ($status) {
424			$lockfile = $_;
425			last;
426			}
427			}
428			## Lock file not exist -- Make new lock file
429			unless ($lockfile) {
430			$status = {prefix => $self->{-name}, seq => 0, time => 0,
431			creation => 0};
432			$lockfile = $self->_make_lock_file_name ($status);
433			open LOCKFILE, '>', $self->{-directory}.$lockfile
434			or &{$self->{-error_handler}}
435			($self, msg => qq(_make_new_lock: $self->{-directory}.$lockfile: $!),
436			level => 'fatal');
437			print LOCKFILE scalar localtime; # dummy data
438			close LOCKFILE;
439			}
440			return ($lockfile, $status);
441			}
442
443			=head1 EXAMPLE
444
445			require SuikaWiki::DB::Util::Lock;
446			my $locker = SuikaWiki::DB::Util::Lock->new (
447			-directory => './lock/',
448			-name => 'example-db',
449			-retry => 15,
450			-timeout => 5,
451			-error_handler => sub {
452			my ($self, %argv) = @_;
453			open LOG, '>>', '/path/to/log';
454			print LOG scalar gmtime, "\t$argv{msg}\n";
455			close LOG;
456			if ($argv{level} eq 'fatal') {
457			die $argv{msg};
458			}
459			},
460			);
461
462			$locker->lock or die "Can't lock";
463
464			open DATA, 'foo.txt';
465			while (<DATA>) {
466			# something
467			}
468			close DATA;
469
470			open NEWDATA, '>', 'bar.txt';
471			# something
472			close NEWDATA;
473
474			$locker->unlock or die "Can't unlock";
475
476			=head1 AUTHOR
477
478			Wakaba <w@suika.fam.cx>
479
480	wakaba	1.8	Original locking algorithm is taken from that of C<Yuki::YukiWikiDB2>.
481	wakaba	1.1
482	wakaba	1.2	=head1 TO DO
483
484			Lock check (relock if timeouted), lock update (safe unlock-and-lock)
485
486	wakaba	1.8	Issue: Should Message::Util::Error based error reporting system
487			be employed instead of current original simple reportimg mechanism?
488
489	wakaba	1.1	=head1 SEE ALSO
490
491	wakaba	1.3	SuikaWiki:"SuikaWiki//WikiDB", C<SuikaWiki::DB::Util>
492	wakaba	1.1
493			=head1 LICENSE
494
495	wakaba	1.8	Copyright 2003-2004 Wakaba <w@suika.fam.cx>. All rights reserved.
496	wakaba	1.1
497			This program is free software; you can redistribute it and/or
498			modify it under the same terms as Perl itself.
499
500			=cut
501
502	wakaba	1.11	1; # $Date: 2004/03/19 11:23:40 $