File Coverage

blib/lib/Apache/Session/Lock/File.pm
Criterion Covered Total %
statement 64 85 75.2
branch 23 62 37.1
condition 3 12 25.0
subroutine 10 12 83.3
pod 3 7 42.8
total 103 178 57.8


line stmt bran cond sub pod time code
1             ############################################################################
2             #
3             # Apache::Session::Lock::File
4             # flock(2) locking for Apache::Session
5             # Copyright(c) 1998, 1999, 2000, 2004 Jeffrey William Baker (jwbaker@acm.org)
6             # Distribute under the Perl License
7             #
8             ############################################################################
9            
10             package Apache::Session::Lock::File;
11            
12 3     3   2035 use strict;
  3         5  
  3         100  
13            
14 3     3   16 use Fcntl qw(:flock);
  3         6  
  3         393  
15 3     3   18 use Symbol;
  3         6  
  3         194  
16 3     3   20 use vars qw($VERSION);
  3         5  
  3         3272  
17            
18             $VERSION = '1.04';
19            
20             $Apache::Session::Lock::File::LockDirectory = '/tmp';
21            
22             sub new {
23 7     7 0 1061 my $class = shift;
24            
25 7         31 return bless { read => 0, write => 0, opened => 0, id => 0 }, $class;
26             }
27            
28             sub acquire_read_lock {
29 2 50 33 2 1 25 if ($^O eq 'MSWin32' or $^O eq 'cygwin') {
30             #Windows cannot escalate lock, so all locks will be exclusive
31 0         0 return &acquire_write_lock;
32             }
33             #Works for acquire_read_lock => acquire_write_lock => release_all_locks
34             #This hack does not support release_read_lock
35             #Changed by Alexandr Ciornii, 2006-06-21
36            
37 2         5 my $self = shift;
38 2         4 my $session = shift;
39            
40 2 50       8 return if $self->{read};
41             #does not support release_read_lock
42            
43 2 50       8 if (!$self->{opened}) {
44 2         7 my $fh = Symbol::gensym();
45            
46             my $LockDirectory = $session->{args}->{LockDirectory} ||
47 2   33     31 $Apache::Session::Lock::File::LockDirectory;
48            
49 2 50       122 open($fh, "+>".$LockDirectory."/Apache-Session-".$session->{data}->{_session_id}.".lock") || die "Could not open file (".$LockDirectory."/Apache-Session-".$session->{data}->{_session_id}.".lock) for writing: $!";
50            
51 2         10 $self->{fh} = $fh;
52 2         6 $self->{opened} = 1;
53             }
54            
55 2 50       8 if (!$self->{write}) {
56             #acquiring read lock, when write lock is in effect will clear write lock
57 2 50       24 flock($self->{fh}, LOCK_SH) || die "Cannot lock: $!";
58             }
59            
60 2         11 $self->{read} = 1;
61             }
62            
63             sub acquire_write_lock {
64 5     5 0 13 my $self = shift;
65 5         8 my $session = shift;
66            
67 5 50       21 return if $self->{write};
68            
69 5 100       16 if (!$self->{opened}) {
70 4         10 my $fh = Symbol::gensym();
71            
72             my $LockDirectory = $session->{args}->{LockDirectory} ||
73 4   33     58 $Apache::Session::Lock::File::LockDirectory;
74            
75 4 50       265 open($fh, "+>".$LockDirectory."/Apache-Session-".$session->{data}->{_session_id}.".lock") || die "Could not open file (".$LockDirectory."/Apache-Session-".$session->{data}->{_session_id}.".lock) for writing: $!";
76            
77 4         21 $self->{fh} = $fh;
78 4         12 $self->{opened} = 1;
79             }
80            
81 5 50       58 flock($self->{fh}, LOCK_EX) || die "Cannot lock: $!";
82 5         23 $self->{write} = 1;
83             }
84            
85             sub release_read_lock {
86 0 0 0 0 1 0 if ($^O eq 'MSWin32' or $^O eq 'cygwin') {
87 0         0 die "release_read_lock is not supported on Win32 or Cygwin";
88             }
89 0         0 my $self = shift;
90 0         0 my $session = shift;
91            
92 0 0       0 die "No read lock to release in release_read_lock" unless $self->{read};
93            
94 0 0       0 if (!$self->{write}) {
95 0 0       0 flock($self->{fh}, LOCK_UN) || die "Cannot unlock: $!";
96 0 0       0 close $self->{fh} || die "Could no close file: $!";
97 0         0 $self->{opened} = 0;
98             }
99            
100 0         0 $self->{read} = 0;
101             }
102            
103             sub release_write_lock {
104 0     0 0 0 my $self = shift;
105 0         0 my $session = shift;
106            
107 0 0       0 die "No write lock acquired" unless $self->{write};
108            
109 0 0       0 if ($self->{read}) {
110 0 0       0 flock($self->{fh}, LOCK_SH) || die "Cannot lock: $!";
111             }
112             else {
113 0 0       0 flock($self->{fh}, LOCK_UN) || die "Cannot unlock: $!";
114 0 0       0 close $self->{fh} || die "Could not close file: $!";
115 0         0 $self->{opened} = 0;
116             }
117            
118 0         0 $self->{write} = 0;
119             }
120            
121             sub release_all_locks {
122 12     12 0 346 my $self = shift;
123 12         20 my $session = shift;
124            
125 12 100       30 if ($self->{opened}) {
126 6 50       65 flock($self->{fh}, LOCK_UN) || die "Cannot unlock: $!";
127 6 50       81 close $self->{fh} || die "Could not close file: $!";
128             }
129            
130 12         30 $self->{opened} = 0;
131 12         18 $self->{read} = 0;
132 12         320 $self->{write} = 0;
133             }
134            
135             sub DESTROY {
136 7     7   693 my $self = shift;
137            
138 7         17 $self->release_all_locks;
139             }
140            
141             sub clean {
142 2     2 1 19 my $self = shift;
143 2         4 my $dir = shift;
144 2         4 my $time = shift;
145            
146 2         5 my $now = time();
147            
148 2 50       71 opendir(DIR, $dir) || die "Could not open directory $dir: $!";
149 2         70 my @files = readdir(DIR);
150 2         8 foreach my $file (@files) {
151 27 100       56 if ($file =~ /^Apache-Session.*\.lock$/) {
152 1 50       18 if ($now - (stat($dir.'/'.$file))[8] >= $time) {
153 1 50       5 if ($^O eq 'MSWin32') {
154             #Windows cannot unlink open file
155 0 0       0 unlink($dir.'/'.$file) || next;
156             } else {
157 1 50       52 open(FH, "+>$dir/".$file) || next;
158 1 50       13 flock(FH, LOCK_EX) || next;
159 1 50       27 unlink($dir.'/'.$file) || next;
160 1         8 flock(FH, LOCK_UN);
161 1         22 close(FH);
162             }
163             }
164             }
165             }
166 2         54 closedir(DIR);
167             }
168            
169             1;
170            
171             =pod
172            
173             =head1 NAME
174            
175             Apache::Session::Lock::File - Provides mutual exclusion using flock
176            
177             =head1 SYNOPSIS
178            
179             use Apache::Session::Lock::File;
180            
181             my $locker = Apache::Session::Lock::File->new;
182            
183             $locker->acquire_read_lock($ref);
184             $locker->acquire_write_lock($ref);
185             $locker->release_read_lock($ref);
186             $locker->release_write_lock($ref);
187             $locker->release_all_locks($ref);
188            
189             $locker->clean($dir, $age);
190            
191             =head1 DESCRIPTION
192            
193             Apache::Session::Lock::File fulfills the locking interface of
194             Apache::Session. Mutual exclusion is achieved through the use of temporary
195             files and the C function.
196            
197             =head1 CONFIGURATION
198            
199             The module must know where to create its temporary files. You must pass an
200             argument in the usual Apache::Session style. The name of the argument is
201             LockDirectory and its value is the path where you want the lockfiles created.
202             Example:
203            
204             tie %s, 'Apache::Session::Blah', $id, {LockDirectory => '/var/lock/sessions'}
205            
206             If you do not supply this argument, temporary files will be created in /tmp.
207            
208             =head1 NOTES
209            
210             =head2 clean
211            
212             This module does not unlink temporary files, because it interferes with proper
213             locking. This can cause problems on certain systems (Linux) whose file systems
214             (ext2) do not perform well with lots of files in one directory. To prevent this
215             you should use a script to clean out old files from your lock directory.
216             The meaning of old is left as a policy decision for the implementor, but a
217             method is provided for implementing that policy. You can use the C
218             method of this module to remove files unmodified in the last $age seconds.
219             Example:
220            
221             my $l = Apache::Session::Lock::File->new;
222             $l->clean('/var/lock/sessions', 3600) #remove files older than 1 hour
223            
224             =head2 acquire_read_lock
225            
226             Will do nothing if write lock is in effect, only set readlock flag to true.
227            
228             =head2 release_read_lock
229            
230             Will do nothing if write lock is in effect, only set readlock flag to false.
231            
232             =head2 Win32 and Cygwin
233            
234             Windows cannot escalate lock, so all locks will be exclusive.
235            
236             release_read_lock not supported - it is not used by Apache::Session.
237            
238             When deleting files, they are not locked (Win32 only).
239            
240             =head1 AUTHOR
241            
242             This module was written by Jeffrey William Baker .
243            
244             =head1 SEE ALSO
245            
246             L