line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# |
2
|
|
|
|
|
|
|
# Proc::PID::File - pidfile manager |
3
|
|
|
|
|
|
|
# Copyright (C) 2001-2003 Erick Calder |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# This program is free software; you can redistribute it and/or modify |
6
|
|
|
|
|
|
|
# it under the terms of the GNU General Public License as published by |
7
|
|
|
|
|
|
|
# the Free Software Foundation; either version 2 of the License, or |
8
|
|
|
|
|
|
|
# (at your option) any later version. |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
# This program is distributed in the hope that it will be useful, |
11
|
|
|
|
|
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
12
|
|
|
|
|
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
13
|
|
|
|
|
|
|
# GNU General Public License for more details. |
14
|
|
|
|
|
|
|
# |
15
|
|
|
|
|
|
|
# You should have received a copy of the GNU General Public License |
16
|
|
|
|
|
|
|
# along with this program; if not, write to the Free Software |
17
|
|
|
|
|
|
|
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
18
|
|
|
|
|
|
|
# |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
package Proc::PID::File; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=head1 NAME |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
Proc::PID::File - a module to manage process id files |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
=head1 SYNOPSIS |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
use Proc::PID::File; |
29
|
|
|
|
|
|
|
die "Already running!" if Proc::PID::File->running(); |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
Process that spawn child processes may want to protect |
32
|
|
|
|
|
|
|
each separately by using multiple I. |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
my $child1 = Proc::PID::File->new(name => "lock.1"); |
35
|
|
|
|
|
|
|
my $child2 = Proc::PID::File->new(name => "lock.2"); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
which may be checked like this: |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
if $child1->alive(); |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
and should be released manually: |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
$child1->release(); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
=head1 DESCRIPTION |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
This Perl module is useful for writers of daemons and other processes that need to tell whether they are already running, in order to prevent multiple process instances. The module accomplishes this via *nix-style I, which are files that store a process identifier. |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
The module provides two interfaces: 1) a simple call, and |
50
|
|
|
|
|
|
|
2) an object-oriented interface |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=cut |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
require Exporter; |
55
|
|
|
|
|
|
|
@ISA = qw(Exporter); |
56
|
|
|
|
|
|
|
|
57
|
4
|
|
|
4
|
|
5451
|
use strict; |
|
4
|
|
|
|
|
4
|
|
|
4
|
|
|
|
|
97
|
|
58
|
4
|
|
|
4
|
|
12
|
use vars qw($VERSION $RPM_Requires); |
|
4
|
|
|
|
|
5
|
|
|
4
|
|
|
|
|
200
|
|
59
|
4
|
|
|
4
|
|
12
|
use Fcntl qw(:DEFAULT :flock); |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
3253
|
|
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
$VERSION = "1.28"; |
62
|
|
|
|
|
|
|
$RPM_Requires = "procps"; |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
my $RUNDIR = "/var/run"; |
65
|
|
|
|
|
|
|
my ($ME) = $0 =~ m|([^/]+)$|; |
66
|
|
|
|
|
|
|
my $self; |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
# -- Simple Interface -------------------------------------------------------- |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
=head1 Simple Interface |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
The simple interface consists of a call as indicated in the first example |
73
|
|
|
|
|
|
|
of the B section above. This approach avoids causing race |
74
|
|
|
|
|
|
|
conditions whereby one instance of a daemon could read the I |
75
|
|
|
|
|
|
|
after a previous instance has read it but before it has had a chance |
76
|
|
|
|
|
|
|
to write to it. |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
=head2 running [hash[-ref]] |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
The parameter signature for this function is identical to that of the |
81
|
|
|
|
|
|
|
I<-Enew()> method described below in the B section of this document. The method's return value is the same as that of I<-Ealive()>. |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=cut |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
sub running { |
86
|
6
|
|
|
6
|
1
|
6008268
|
$self = shift->new(@_); |
87
|
|
|
|
|
|
|
|
88
|
6
|
|
|
|
|
29
|
local *FH; |
89
|
6
|
|
|
|
|
19
|
my $pid = $self->read(*FH); |
90
|
|
|
|
|
|
|
|
91
|
6
|
50
|
66
|
|
|
79
|
if ($pid && $pid != $$ && kill(0, $pid)) { |
|
|
|
66
|
|
|
|
|
92
|
3
|
|
|
|
|
11
|
$self->debug("running: $pid"); |
93
|
3
|
|
|
|
|
23
|
close FH; |
94
|
3
|
100
|
|
|
|
9
|
return $self->verify($pid) ? $pid : 0; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
3
|
|
|
|
|
15
|
$self->write(*FH); |
98
|
3
|
|
|
|
|
13
|
return 0; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
# -- Object oriented Interface ----------------------------------------------- |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
=head1 OO Interface |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
The following methods are provided: |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
=head2 new [hash[-ref]] |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
This method is used to create an instance object. It automatically calls the I<-Efile()> method described below and receives the same parameters. For a listing of valid keys in this hash please refer to the aforementioned method documentation below. |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
In addition to the above, the following constitute valid keys: |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
=over |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
=item I = 1 | string |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
This parameter implements the second solution outlined in the WARNING section |
118
|
|
|
|
|
|
|
of this document and is used to verify that an existing I correctly |
119
|
|
|
|
|
|
|
represents a live process other than the current. If set to a string, it will |
120
|
|
|
|
|
|
|
be interpreted as a I and used to search within the name |
121
|
|
|
|
|
|
|
of the running process. Alternatively, a 1 may be passed: For Linux/FreeBSD, |
122
|
|
|
|
|
|
|
this indicates that the value of I<$0> will be used (stripped of its full |
123
|
|
|
|
|
|
|
path); for Cygwin, I<$^X> (stripped of path and extension) will be used. |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
If the parameter is not passed, no verification will take place. Please |
126
|
|
|
|
|
|
|
note that verification will only work for the operating systems |
127
|
|
|
|
|
|
|
listed below and that the OS will be auto-sensed. See also DEPENDENCIES |
128
|
|
|
|
|
|
|
section below. |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
Supported platforms: Linux, FreeBSD, Cygwin |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=item I |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
Any non-zero value turns debugging output on. Additionally, if a string |
135
|
|
|
|
|
|
|
is passed containing the character B, the module name will be prefixed |
136
|
|
|
|
|
|
|
to the debugging output. |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
=back |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
=cut |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sub new { |
143
|
7
|
|
|
7
|
1
|
1253086
|
my $class = shift; |
144
|
7
|
|
|
|
|
27
|
my $self = bless({}, $class); |
145
|
7
|
|
|
|
|
26
|
%$self = &args; |
146
|
7
|
|
|
|
|
40
|
$self->file(); # init file path |
147
|
7
|
|
50
|
|
|
56
|
$self->{debug} ||= ""; |
148
|
7
|
|
|
|
|
13
|
return $self; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
=head2 file [hash[-ref]] |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
Use this method to set the path of the I. The method receives an optional hash (or hash reference) with the keys listed below, from which it makes a path of the format: F<$dir/$name.pid>. |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
=over |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
=item I |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
Specifies the directory to place the pid file. If left unspecified, |
160
|
|
|
|
|
|
|
defaults to F. |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
=item I |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
Indicates the name of the current process. When not specified, defaults |
165
|
|
|
|
|
|
|
to I. |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
=back |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
=cut |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
sub file { |
172
|
7
|
|
|
7
|
1
|
13
|
my $self = shift; |
173
|
7
|
|
|
|
|
27
|
%$self = (%$self, &args); |
174
|
7
|
|
33
|
|
|
38
|
$self->{dir} ||= $RUNDIR; |
175
|
7
|
|
33
|
|
|
20
|
$self->{name} ||= $ME; |
176
|
7
|
|
|
|
|
63
|
$self->{path} = sprintf("%s/%s.pid", $self->{dir}, $self->{name}); |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
=head2 alive |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
Returns true when the process is already running. Please note that this |
182
|
|
|
|
|
|
|
call must be made *after* daemonisation i.e. subsequent to the call to |
183
|
|
|
|
|
|
|
fork(). If the B flag was set during the instance creation, the |
184
|
|
|
|
|
|
|
process id is verified, alternatively the flag may be passed directly |
185
|
|
|
|
|
|
|
to this method. |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
=cut |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub alive { |
190
|
3
|
|
|
3
|
1
|
185
|
my $self = shift; |
191
|
|
|
|
|
|
|
|
192
|
3
|
|
|
|
|
11
|
my %args = &args; |
193
|
3
|
100
|
|
|
|
13
|
$self->{verify} = $args{verify} if $args{verify}; |
194
|
|
|
|
|
|
|
|
195
|
3
|
|
50
|
|
|
12
|
my $pid = $self->read() || ""; |
196
|
3
|
|
|
|
|
14
|
$self->debug("alive(): $pid"); |
197
|
|
|
|
|
|
|
|
198
|
3
|
100
|
66
|
|
|
47
|
if ($pid && $pid != $$ && kill(0, $pid)) { |
|
|
|
66
|
|
|
|
|
199
|
2
|
50
|
|
|
|
7
|
return $self->verify($pid) ? $pid : 0; |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
1
|
|
|
|
|
4
|
return 0; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
=head2 touch |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
Causes for the current process id to be written to the I. |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
=cut |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub touch { |
212
|
1
|
|
|
1
|
1
|
169
|
shift->write(); |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
=head2 release |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
This method is used to delete the I and is automatically called by DESTROY method. It should thus be unnecessary to call it directly. |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
=cut |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
sub release { |
222
|
1
|
|
|
1
|
1
|
257
|
my $self = shift; |
223
|
1
|
|
|
|
|
5
|
$self->debug("release()"); |
224
|
1
|
50
|
|
|
|
86
|
unlink($self->{path}) || warn $!; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
=head2 locktime [hash[-ref]] |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
This method returns the I of the I. |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=cut |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
sub locktime { |
234
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
235
|
0
|
|
|
|
|
0
|
return (stat($self->{path}))[10]; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
# -- support functionality --------------------------------------------------- |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
sub verify { |
241
|
5
|
|
|
5
|
1
|
8
|
my ($self, $pid) = @_; |
242
|
5
|
100
|
|
|
|
30
|
return 1 unless $self->{verify}; |
243
|
|
|
|
|
|
|
|
244
|
3
|
|
|
|
|
5
|
my $ret = 0; |
245
|
3
|
|
|
|
|
13
|
$self->debug("verify(): OS = $^O"); |
246
|
3
|
50
|
|
|
|
29
|
if ($^O =~ /linux|freebsd|cygwin/i) { |
247
|
3
|
|
|
|
|
7
|
my $me = $self->{verify}; |
248
|
3
|
100
|
66
|
|
|
20
|
if (!$me || $me eq "1") { |
249
|
2
|
|
|
|
|
3
|
$me = $ME; |
250
|
2
|
50
|
|
|
|
8
|
if ($^O eq "cygwin") { |
251
|
0
|
|
|
|
|
0
|
$^X =~ m|([^/]+)$|; |
252
|
0
|
|
|
|
|
0
|
($me = $1) =~ s/\.exe$//; |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
} |
255
|
3
|
|
|
|
|
22
|
my $cols = delete($ENV{'COLUMNS'}); # prevents `ps` from wrapping |
256
|
3
|
|
50
|
|
|
13839
|
my @ps = split m|$/|, qx/ps -fp $pid/ |
257
|
|
|
|
|
|
|
|| die "ps utility not available: $!"; |
258
|
3
|
|
|
|
|
53
|
s/^\s+// for @ps; # leading spaces confuse us |
259
|
|
|
|
|
|
|
|
260
|
3
|
50
|
|
|
|
22
|
$ENV{'COLUMNS'} = $cols if defined($cols); |
261
|
4
|
|
|
4
|
|
17
|
no warnings; # hate that deprecated @_ thing |
|
4
|
|
|
|
|
15
|
|
|
4
|
|
|
|
|
2033
|
|
262
|
3
|
|
|
|
|
27
|
my $n = split(/\s+/, $ps[0]); |
263
|
3
|
|
|
|
|
19
|
@ps = split /\s+/, $ps[1], $n; |
264
|
3
|
|
|
|
|
90
|
$ret = $ps[$n - 1] =~ /\Q$me\E/;; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
3
|
|
|
|
|
53
|
$self->debug(" - ret: [$ret]"); |
268
|
3
|
|
|
|
|
48
|
$ret; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
# Returns the process id currently stored in the file set. If the method |
272
|
|
|
|
|
|
|
# is passed a file handle, it will return the value, leaving the file handle |
273
|
|
|
|
|
|
|
# locked. This is useful for atomic operations where the caller needs to |
274
|
|
|
|
|
|
|
# write to the file after the read without allowing other dirty writes. |
275
|
|
|
|
|
|
|
# |
276
|
|
|
|
|
|
|
# Please note, when passing a file handle, caller is responsible for |
277
|
|
|
|
|
|
|
# closing it. Also, file handles must be passed by reference! |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
sub read { |
280
|
13
|
|
|
13
|
1
|
44
|
my ($self, $fh) = @_; |
281
|
|
|
|
|
|
|
|
282
|
13
|
50
|
|
|
|
806
|
sysopen($fh, $self->{path}, O_RDWR|O_CREAT) |
283
|
|
|
|
|
|
|
|| die qq/Cannot open pid file "$self->{path}": $!\n/; |
284
|
13
|
50
|
|
|
|
91
|
flock($fh, LOCK_EX | LOCK_NB) |
285
|
|
|
|
|
|
|
|| die qq/pid "$self->{path}" already locked: $!\n/; |
286
|
13
|
|
|
|
|
328
|
my ($pid) = <$fh> =~ /^(\d+)/; |
287
|
13
|
100
|
|
|
|
233
|
close $fh if @_ == 1; |
288
|
|
|
|
|
|
|
|
289
|
13
|
|
100
|
|
|
101
|
$self->debug("read(\"$self->{path}\") = " . ($pid || "")); |
290
|
13
|
|
|
|
|
42
|
return $pid; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
# Causes for the current process id to be written to the selected |
294
|
|
|
|
|
|
|
# file. If a file handle it passed, the method assumes it has already |
295
|
|
|
|
|
|
|
# been opened, otherwise it opens its own. Please note that file |
296
|
|
|
|
|
|
|
# handles must be passed by reference! |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
sub write { |
299
|
4
|
|
|
4
|
0
|
7
|
my ($self, $fh) = @_; |
300
|
|
|
|
|
|
|
|
301
|
4
|
|
|
|
|
28
|
$self->debug("write($$)"); |
302
|
4
|
100
|
|
|
|
14
|
if (@_ == 1) { |
303
|
1
|
50
|
|
|
|
76
|
sysopen($fh, $self->{path}, O_RDWR|O_CREAT) |
304
|
|
|
|
|
|
|
|| die qq/Cannot open pid file "$self->{path}": $!\n/; |
305
|
1
|
50
|
|
|
|
11
|
flock($fh, LOCK_EX | LOCK_NB) |
306
|
|
|
|
|
|
|
|| die qq/pid "$self->{path}" already locked: $!\n/; |
307
|
|
|
|
|
|
|
} |
308
|
4
|
|
|
|
|
24
|
sysseek $fh, 0, 0; |
309
|
4
|
|
|
|
|
216
|
truncate $fh, 0; |
310
|
4
|
|
|
|
|
155
|
syswrite $fh, "$$\n", length("$$\n"); |
311
|
4
|
50
|
|
|
|
54
|
close $fh || die qq/Cannot write pid file "$self->{path}": $!\n/; |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
sub args { |
315
|
17
|
50
|
|
17
|
0
|
152
|
!defined($_[0]) ? () : ref($_[0]) ? %{$_[0]} : @_; |
|
0
|
100
|
|
|
|
0
|
|
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
sub debug { |
319
|
30
|
|
|
30
|
1
|
41
|
my $self = shift; |
320
|
30
|
|
33
|
|
|
58
|
my $msg = shift || $_; |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
$msg = "> Proc::PID::File - $msg" |
323
|
30
|
50
|
|
|
|
60
|
if $self->{debug} =~ /M/; # prefix with module name |
324
|
|
|
|
|
|
|
print $msg |
325
|
30
|
50
|
|
|
|
61
|
if $self->{debug}; |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
sub DESTROY { |
329
|
4
|
|
|
4
|
|
5001027
|
my $self = shift; |
330
|
|
|
|
|
|
|
|
331
|
4
|
50
|
|
|
|
17
|
if (exists($INC{'threads.pm'})) { |
332
|
0
|
0
|
|
|
|
0
|
return if threads->tid() != 0; |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
|
335
|
4
|
|
|
|
|
15
|
my $pid = $self->read(); |
336
|
|
|
|
|
|
|
$self->release() |
337
|
4
|
50
|
66
|
|
|
104
|
if $self->{path} && $pid && $pid == $$; |
|
|
|
66
|
|
|
|
|
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
1; |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
__END__ |