File Coverage

blib/lib/No/Worries/PidFile.pm
Criterion Covered Total %
statement 120 192 62.5
branch 38 118 32.2
condition 5 16 31.2
subroutine 22 25 88.0
pod 7 7 100.0
total 192 358 53.6


line stmt bran cond sub pod time code
1             #+##############################################################################
2             # #
3             # File: No/Worries/PidFile.pm #
4             # #
5             # Description: pid file handling without worries #
6             # #
7             #-##############################################################################
8              
9             #
10             # module definition
11             #
12              
13             package No::Worries::PidFile;
14 1     1   338 use strict;
  1         2  
  1         26  
15 1     1   4 use warnings;
  1         3  
  1         65  
16             our $VERSION = "1.5";
17             our $REVISION = sprintf("%d.%02d", q$Revision: 1.20 $ =~ /(\d+)\.(\d+)/);
18              
19             #
20             # used modules
21             #
22              
23 1     1   5 use Fcntl qw(:DEFAULT :flock :seek);
  1         2  
  1         285  
24 1     1   6 use No::Worries qw($_IntegerRegexp $_NumberRegexp);
  1         2  
  1         9  
25 1     1   5 use No::Worries::Die qw(dief);
  1         2  
  1         6  
26 1     1   6 use No::Worries::Export qw(export_control);
  1         2  
  1         5  
27 1     1   300 use No::Worries::Proc qw(proc_terminate);
  1         5  
  1         10  
28 1     1   478 use No::Worries::Stat qw(ST_MTIME);
  1         4  
  1         9  
29 1     1   10 use Params::Validate qw(validate :types);
  1         3  
  1         183  
30 1     1   9 use POSIX qw(:errno_h);
  1         3  
  1         10  
31 1     1   513 use Time::HiRes qw();
  1         3  
  1         2922  
32              
33             #
34             # safely read something from an open file
35             #
36              
37             sub _read ($$;$) {
38 2     2   8 my($path, $fh, $noclose) = @_;
39 2         4 my($data, $done);
40              
41 2 50       14 flock($fh, LOCK_EX)
42             or dief("cannot flock(%s, LOCK_EX): %s", $path, $!);
43 2 50       9 sysseek($fh, 0, SEEK_SET)
44             or dief("cannot sysseek(%s, 0, SEEK_SET): %s", $path, $!);
45 2         6 $data = "";
46 2         3 $done = -1;
47 2         6 while ($done) {
48 4         15 $done = sysread($fh, $data, 16, length($data));
49 4 50       12 dief("cannot sysread(%s, %d): %s", $path, 16, $!)
50             unless defined($done);
51             }
52 2 50       5 if ($noclose) {
53 0 0       0 flock($fh, LOCK_UN)
54             or dief("cannot flock(%s, LOCK_UN): %s", $path, $!);
55             } else {
56 2 50       15 close($fh)
57             or dief("cannot close(%s): %s", $path, $!);
58             }
59 2         7 return($data);
60             }
61              
62             #
63             # safely write something to an open file
64             #
65              
66             sub _write ($$$) {
67 1     1   5 my($path, $fh, $data) = @_;
68 1         4 my($length, $offset, $done);
69              
70 1 50       13 flock($fh, LOCK_EX)
71             or dief("cannot flock(%s, LOCK_EX): %s", $path, $!);
72 1 50       8 sysseek($fh, 0, SEEK_SET)
73             or dief("cannot sysseek(%s, 0, SEEK_SET): %s", $path, $!);
74 1 50       31 truncate($fh, 0)
75             or dief("cannot truncate(%s, 0): %s", $path, $!);
76 1         3 $length = length($data);
77 1         2 $offset = 0;
78 1         4 while ($length) {
79 1         32 $done = syswrite($fh, $data, $length, $offset);
80 1 50       4 dief("cannot syswrite(%s, %d): %s", $path, $length, $!)
81             unless defined($done);
82 1         3 $length -= $done;
83 1         2 $offset += $done;
84             }
85 1 50       13 close($fh)
86             or dief("cannot close(%s): %s", $path, $!);
87             }
88              
89             #
90             # check if a process is alive by killing it ;-)
91             #
92              
93             sub _alive ($) {
94 1     1   2 my($pid) = @_;
95              
96 1 50       16 return(1) if kill(0, $pid);
97 0 0       0 return(0) if $! == ESRCH;
98 0         0 dief("cannot kill(0, %d): %s", $pid, $!);
99             }
100              
101             #
102             # kill a process
103             #
104              
105             sub _kill ($$$%) {
106 0     0   0 my($path, $fh, $pid, %option) = @_;
107 0         0 my($maxtime);
108              
109             # gently
110 0         0 $option{callback}->("(pid $pid) is being told to quit...");
111 0         0 _write($path, $fh, "$pid\nquit\n");
112 0         0 $maxtime = Time::HiRes::time() + $option{linger};
113 0         0 while (1) {
114 0 0       0 last unless _alive($pid);
115 0 0       0 last if Time::HiRes::time() > $maxtime;
116 0         0 Time::HiRes::sleep(0.1);
117             }
118 0 0       0 if (_alive($pid)) {
119             # forcedly
120 0         0 $option{callback}->("(pid $pid) is still running, killing it now...");
121 0 0       0 if ($option{kill}) {
122 0         0 proc_terminate($pid, kill => $option{kill});
123             } else {
124 0         0 proc_terminate($pid);
125             }
126 0         0 $option{callback}->("(pid $pid) has been successfully killed");
127             } else {
128 0         0 $option{callback}->("does not seem to be running anymore");
129             }
130             }
131              
132             #
133             # check a process
134             #
135              
136             sub _status ($%) {
137 2     2   8 my($path, %option) = @_;
138 2         6 my($fh, @stat, $data, $pid, $status, $message, $lsb);
139              
140 2         6 $status = 0;
141 2 100       53 unless (sysopen($fh, $path, O_RDWR)) {
142 1 50       11 if ($! == ENOENT) {
143 1         4 ($message, $lsb) =
144             ("does not seem to be running (no pid file)", 3);
145 1         9 goto done;
146             }
147 0         0 dief("cannot sysopen(%s, O_RDWR): %s", $path, $!);
148             }
149 1 50       13 @stat = stat($fh)
150             or dief("cannot stat(%s): %s", $path, $!);
151 1         5 $data = _read($path, $fh);
152 1 50       3 if ($data eq "") {
153             # this can happen in pf_set(), between open() and lock()
154 0         0 ($message, $lsb) =
155             ("does not seem to be running yet (empty pid file)", 4);
156 0         0 goto done;
157             }
158 1 50       8 if ($data =~ /^(\d+)(\s+([a-z]+))?\s*$/s) {
159 1         4 $pid = $1;
160             } else {
161 0         0 dief("unexpected pid file contents in %s: %s", $path, $data);
162             }
163 1 50       3 unless (_alive($pid)) {
164 0         0 ($message, $lsb) =
165             ("(pid $pid) does not seem to be running anymore", 1);
166 0         0 goto done;
167             }
168 1         34 $data = localtime($stat[ST_MTIME]);
169 1 50 33     10 if ($option{freshness} and
170             $stat[ST_MTIME] < Time::HiRes::time() - $option{freshness}) {
171 0         0 ($message, $lsb) =
172             ("(pid $pid) does not seem to be running anymore since $data", 4);
173 0         0 goto done;
174             }
175             # so far so good ;-)
176 1         4 ($status, $message, $lsb) = (1, "(pid $pid) was active on $data", 0);
177 2         14 done:
178             return($status, $message, $lsb);
179             }
180              
181             #
182             # set the pid file
183             #
184              
185             my %pf_set_options = (
186             pid => { optional => 1, type => SCALAR, regex => $_IntegerRegexp },
187             );
188              
189             sub pf_set ($@) {
190 2     2 1 817 my($path, %option, $fh);
191              
192 2         6 $path = shift(@_);
193 2 50       8 %option = validate(@_, \%pf_set_options) if @_;
194 2   33     20 $option{pid} ||= $$;
195 2 100       85 sysopen($fh, $path, O_WRONLY|O_CREAT|O_EXCL)
196             or dief("cannot sysopen(%s, O_WRONLY|O_CREAT|O_EXCL): %s", $path, $!);
197 1         10 _write($path, $fh, "$option{pid}\n");
198             }
199              
200             #
201             # check the pid file
202             #
203              
204             my %pf_check_options = (
205             pid => { optional => 1, type => SCALAR, regex => $_IntegerRegexp },
206             );
207              
208             sub pf_check ($@) {
209 2     2 1 1321 my($path, %option, $fh, $data, $pid, $action);
210              
211 2         7 $path = shift(@_);
212 2 50       9 %option = validate(@_, \%pf_check_options) if @_;
213 2   33     17 $option{pid} ||= $$;
214 2 100       59 sysopen($fh, $path, O_RDWR)
215             or dief("cannot sysopen(%s, O_RDWR): %s", $path, $!);
216 1         6 $data = _read($path, $fh);
217 1 50       10 if ($data =~ /^(\d+)\s*$/s) {
    0          
218 1         7 ($pid, $action) = ($1, "");
219             } elsif ($data =~ /^(\d+)\s+([a-z]+)\s*$/s) {
220 0         0 ($pid, $action) = ($1, $2);
221             } else {
222 0         0 dief("unexpected pid file contents in %s: %s", $path, $data)
223             }
224             dief("pid file %s has been taken over by pid %d!", $path, $pid)
225 1 50       5 unless $pid == $option{pid};
226 1         5 return($action);
227             }
228              
229             #
230             # touch the pid file
231             #
232              
233             sub pf_touch ($) {
234 2     2 1 880 my($path) = @_;
235 2         5 my($now);
236              
237 2         6 $now = time();
238 2 100       96 utime($now, $now, $path)
239             or dief("cannot utime(%d, %d, %s): %s", $now, $now, $path, $!);
240             }
241              
242             #
243             # unset the pid file
244             #
245              
246             sub pf_unset ($) {
247 2     2 1 1085 my($path) = @_;
248              
249 2 100       82 unless (unlink($path)) {
250 1 50       12 return if $! == ENOENT;
251 0         0 dief("cannot unlink(%s): %s", $path, $!);
252             }
253             }
254              
255             #
256             # use the pid file to find out the program status
257             #
258              
259             my %pf_status_options = (
260             freshness => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
261             timeout => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
262             );
263              
264             sub pf_status ($@) {
265 2     2 1 316 my($path, %option, $maxtime, $status, $message, $lsb);
266              
267 2         7 $path = shift(@_);
268 2 50       9 %option = validate(@_, \%pf_status_options) if @_;
269 2 50       10 if ($option{timeout}) {
270             # check multiple times until success or timeout
271 0         0 $maxtime = Time::HiRes::time() + $option{timeout};
272 0         0 while (1) {
273 0         0 ($status, $message, $lsb) = _status($path, %option);
274 0 0 0     0 last if $status or Time::HiRes::time() > $maxtime;
275 0         0 Time::HiRes::sleep(0.1);
276             }
277             } else {
278             # check only once
279 2         9 ($status, $message, $lsb) = _status($path, %option);
280             }
281 2 50       7 return($status, $message, $lsb) if wantarray();
282 2         6 return($status);
283             }
284              
285             #
286             # use the pid file to make the program quit
287             #
288              
289             my %pf_quit_options = (
290             callback => { optional => 1, type => CODEREF },
291             linger => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
292             kill => { optional => 1, type => SCALAR },
293             );
294              
295             sub pf_quit ($@) {
296 1     1 1 560 my($path, %option, $fh, $data, $pid);
297              
298 1         4 $path = shift(@_);
299 1 50       33 %option = validate(@_, \%pf_quit_options) if @_;
300 1   50 0   9 $option{callback} ||= sub { printf("%s\n", $_[0]) };
  0         0  
301 1   50     10 $option{linger} ||= 5;
302 1 50       16 unless (sysopen($fh, $path, O_RDWR)) {
303 1 50       8 if ($! == ENOENT) {
304 1         4 $option{callback}->("does not seem to be running (no pid file)");
305 1         6 return;
306             }
307 0         0 dief("cannot sysopen(%s, O_RDWR): %s", $path, $!);
308             }
309 0         0 $data = _read($path, $fh, 1);
310 0 0       0 if ($data eq "") {
311             # this can happen while setting the pid file, between open and lock in pf_set()
312             # but what can we do? we wait a bit, try again and complain if itis still empty
313 0         0 sleep(1);
314 0         0 $data = _read($path, $fh, 1);
315             }
316 0 0       0 if ($data =~ /^(\d+)(\s+([a-z]+))?\s*$/s) {
317 0         0 $pid = $1;
318             } else {
319 0         0 dief("unexpected pid file contents in %s: %s", $path, $data);
320             }
321 0         0 _kill($path, $fh, $pid, %option);
322             # in any case, we make sure that _this_ pid file does not exist anymore
323             # we have to be extra careful to make sure it is the same pid file
324 0 0       0 unless (sysopen($fh, $path, O_RDWR)) {
325 0 0       0 return if $! == ENOENT;
326 0         0 dief("cannot sysopen(%s, O_RDWR): %s", $path, $!);
327             }
328 0         0 $data = _read($path, $fh);
329 0 0       0 return if $data eq "";
330 0 0       0 if ($data =~ /^(\d+)(\s+([a-z]+))?\s*$/s) {
331 0 0       0 return unless $1 == $pid;
332             } else {
333 0         0 dief("unexpected pid file contents in %s: %s", $path, $data);
334             }
335             # same pid so assume same pid file... remove it
336 0         0 $option{callback}->("removing stale pid file: $path");
337 0 0       0 unless (unlink($path)) {
338             # take into account a potential race condition...
339 0 0       0 dief("cannot unlink(%s): %s", $path, $!) unless $! == ENOENT;
340             }
341             }
342              
343             #
344             # sleep for some time, taking into account an optional pid file
345             #
346              
347             my %pf_sleep_options = (
348             time => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
349             );
350              
351             sub pf_sleep ($@) {
352 0     0 1 0 my($path, %option, $end, $sleep);
353              
354 0         0 $path = shift(@_);
355 0 0       0 %option = validate(@_, \%pf_sleep_options) if @_;
356 0 0       0 $option{time} = 1 unless defined($option{time});
357 0 0       0 if ($path) {
358 0 0       0 $end = Time::HiRes::time() + $option{time} if $option{time};
359 0         0 while (1) {
360 0 0       0 return(0) if pf_check($path) eq "quit";
361 0         0 pf_touch($path);
362 0 0       0 last unless $option{time};
363 0         0 $sleep = $end - Time::HiRes::time();
364 0 0       0 last if $sleep <= 0;
365 0 0       0 $sleep = 1 if $sleep > 1;
366 0         0 Time::HiRes::sleep($sleep);
367             }
368             } else {
369 0 0       0 Time::HiRes::sleep($option{time}) if $option{time};
370             }
371 0         0 return(1);
372             }
373              
374             #
375             # export control
376             #
377              
378             sub import : method {
379 1     1   14 my($pkg, %exported);
380              
381 1         5 $pkg = shift(@_);
382 1         13 grep($exported{$_}++, map("pf_$_",
383             qw(set check touch unset status quit sleep)));
384 1         9 export_control(scalar(caller()), $pkg, \%exported, @_);
385             }
386              
387             1;
388              
389             __DATA__