File Coverage

blib/lib/Proc/PID/File.pm
Criterion Covered Total %
statement 87 93 93.5
branch 32 50 64.0
condition 22 38 57.8
subroutine 16 17 94.1
pod 10 12 83.3
total 167 210 79.5


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__