1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
#! /bin/sh /usr/share/dpatch/dpatch-run
## 10mbox-locking.dpatch by Niko Tyni <ntyni@iki.fi>
##
## All lines beginning with `## DP:' are a description of the patch.
## DP: Policy-compliant mbox locking (hopefully).
@DPATCH@
--- a/lib/Email/LocalDelivery/Mbox.pm
+++ b/lib/Email/LocalDelivery/Mbox.pm
@@ -12,7 +12,7 @@
use File::Path;
use File::Basename;
use Email::Simple 1.998; # needed for ->header_obj
-use Fcntl ':flock';
+use Fcntl qw(:DEFAULT :seek);
use Symbol qw(gensym);
sub deliver {
@@ -42,7 +42,7 @@
# This will make streaming a bit more annoying. -- rjbs, 2007-05-25
print $fh "\n" unless $email->as_string =~ /\n$/;
- $class->_close_fh($fh) || next;
+ $class->_close_fh($fh, $file) || next;
push @rv, $file;
}
return @rv;
@@ -55,14 +55,14 @@
my $fh = gensym;
open $fh, ">> $file" or return;
- $class->getlock($fh) || return;
+ $class->getlock($fh, $file) || return;
seek $fh, 0, 2;
return $fh;
}
sub _close_fh {
- my ($class, $fh) = @_;
- $class->unlock($fh) || return;
+ my ($class, $fh, $file) = @_;
+ $class->unlock($fh, $file) || return;
close $fh or return;
return 1;
}
@@ -103,17 +103,69 @@
}
sub getlock {
+ my ($class, $fh, $file) = @_;
+ for (1..10) {
+ return 0 unless $class->getlock_fcntl($fh);
+ return 1 if $class->getlock_dotlock($file);
+ sleep int(rand(10 * $_));
+ }
+ $class->unlock_fcntl($fh);
+ return 0;
+
+}
+
+sub getlock_fcntl {
my ($class, $fh) = @_;
- for (1 .. 10) {
- return 1 if flock($fh, LOCK_EX | LOCK_NB);
+ my $lock = pack('ss@256', F_WRLCK, SEEK_SET);
+ for (1..10) {
+ return 1 if fcntl($fh, F_SETLK, $lock);
sleep $_;
}
+ return 0 ;
+}
+
+sub getlock_dotlock {
+ my ($class, $file) = @_;
+ my $lockfile = $file . ".lock";
+ my $cmd = "/usr/bin/dotlockfile";
+ system($cmd, $lockfile);
+ return 1 unless $?;
+ if ($? == -1) {
+ die("Couldn't exec $cmd: $!");
+ }
+ if ($? & 127) {
+ warn("$cmd exited with signal " . ($? & 127));
+ }
return 0;
}
sub unlock {
+ my ($class,$fh, $file) = @_;
+ return 0 unless $class->unlock_dotlock($file);
+ return 0 unless $class->unlock_fcntl($fh);
+ return 1;
+}
+
+sub unlock_fcntl {
my ($class, $fh) = @_;
- flock($fh, LOCK_UN);
+ my $lock = pack('ss@256', F_UNLCK, SEEK_SET);
+ return 1 if fcntl($fh, F_SETLK, $lock);
+ return 0;
+}
+
+sub unlock_dotlock {
+ my ($class, $file) = @_;
+ my $lockfile = $file . ".lock";
+ my $cmd = "/usr/bin/dotlockfile";
+ system($cmd, "-u", $lockfile);
+ return 1 unless $?;
+ if ($? == -1) {
+ die("Couldn't exec $cmd: $!");
+ }
+ if ($? & 127) {
+ warn("$cmd exited with signal " . ($? & 127));
+ }
+ return 0;
}
1;
|
