1package File::Pid::Quick;
2
3use 5.006;
4use strict;
5use warnings;
6
7=head1 NAME
8
9File::Pid::Quick - Quick PID file implementation
10
11=head1 SYNOPSIS
12
13use File::Pid::Quick;
14
15use File::Pid::Quick qw( /var/run/myjob.pid );
16
17use File::Pid::Quick qw( /var/run/myjob.pid verbose );
18
19use File::Pid::Quick qw( /var/run/myjob.pid timeout 120 );
20
21File::Pid::Quick->recheck;
22
23File::Pid::Quick->check('/var/run/myjob.pid');
24
25=cut
26
27our $VERSION = '1.02';
28
29use Carp;
30use Fcntl qw( :flock );
31use File::Basename qw( basename );
32use File::Spec::Functions qw( tmpdir catfile );
33
34=head1 DESCRIPTION
35
36This module associates a PID file with your script for the purpose of
37keeping more than one copy from running (concurrency prevention).  It
38creates the PID file, checks for its existence when the script is run,
39terminates the script if there is already an instance running, and
40removes the PID file when the script finishes.
41
42This module's objective is to provide a completely simplified interface
43that makes adding PID-file-based concurrency prevention to your script
44as quick and simple as possible; hence File::Pid::Quick.  For a more
45nuanced implementation of PID files, please see File::Pid.
46
47The absolute simplest way to use this module is:
48
49    use File::Pid::Quick;
50
51A default PID file will be used, located in C<< File::Spec->tmpdir >> and
52named C<< File::Basename::basename($0) . '.pid' >>; for example, if
53C<$0> is F<~/bin/run>, the PID file will be F</tmp/run.pid>.  The PID file
54will be checked and/or generated immediately on use of the module.
55
56Alternately, an import list may be provided to the module.  It can contain
57three kinds of things:
58
59    use File::Pid::Quick qw( verbose );
60
61If the string 'verbose' is passed in the import list, the module will do
62more reporting on its activities than otherwise.  It will use warn() for
63its verbose output.
64
65    use File::Pid::Quick qw( timeout 60 );
66
67If the string 'timeout' is passed in the import list, the next item in
68the import list will be interpreted as a timeout after which, instead of
69terminating itself because another instance was found, the script should
70send a SIGTERM to the other instance and go ahead itself.  The timeout
71must be a positive integer.
72
73    use File::Pid::Quick qw( manual );
74
75If the string 'manual' is passed in the import list, the normal behavior
76of generating a default PID file will be suppressed.  This is essentially
77for cases where you want to control exactly when the PID file check is
78performed by using File::Pid::Quick->check(), below.  The check will still
79be performed immediately if a filename is also provided in the import list.
80
81    use File::Pid::Quick qw( /var/run/myscript.pid );
82
83Any other string passed in the import list is interpreted as a filename
84to be used instead of the default for the PID file.  If more than one such
85string is found, this is an error.
86
87Any combination of the above import list options may be used.
88
89=cut
90
91our @pid_files_created;
92our $verbose;
93our $timeout;
94
95sub import($;@) {
96    my $package = shift;
97    my $filename;
98    my $manual;
99    while(scalar @_) {
100        my $item = shift;
101        if($item eq 'verbose') {
102            $verbose = 1;
103        } elsif($item eq 'manual') {
104            $manual = 1;
105        } elsif($item eq 'timeout') {
106            $timeout = shift;
107            unless(defined $timeout and $timeout =~ /^\d+$/ and int($timeout) eq $timeout and $timeout > 0) {
108                carp 'Invalid timeout ' . (defined $timeout ? '"' . $timeout . '"' : '(undefined)');
109                exit 1;
110            }
111        } else {
112            if(defined $filename) {
113                carp 'Invalid option "' . $item . '" (filename ' . $filename . ' already set)';
114                exit 1;
115            }
116            $filename = $item;
117        }
118    }
119    __PACKAGE__->check($filename, $timeout, 1)
120        unless $^C or ($manual and not defined $filename);
121}
122
123END {
124    foreach my $pid_file_created (@pid_files_created) {
125        next
126            unless open my $pid_in, '<', $pid_file_created;
127        my $pid = <$pid_in>;
128        chomp $pid;
129        $pid =~ s/\s.*//o;
130        if($pid == $$) {
131	        if($^O =~ /^MSWin/) {
132		        close $pid_in;
133		        undef $pid_in;
134			}
135            if(unlink $pid_file_created) {
136                warn "Deleted $pid_file_created for PID $$\n"
137                    if $verbose;
138            } else {
139                warn "Could not delete $pid_file_created for PID $$\n";
140            }
141        } else {
142            warn "$pid_file_created had PID $pid, not $$, leaving in place\n"
143                if $verbose;
144        }
145        close $pid_in
146	        if defined $pid_in;
147    }
148}
149
150=head2 check
151
152    File::Pid::Quick->check('/var/run/myjob.pid', 60);
153
154    File::Pid::Quick->check(undef, undef, 1);
155
156Performs a check of the specified PID file, including generating it
157if necessary, finding whether another instance is actually running,
158and terminating the current process if necesasry.
159
160All arguments are optional.
161
162The first argument, $pid_file, is the filename to check; an undefined
163value results in the default (described above) being used.
164
165The second argument, $use_timeout, is a PID file timeout.  If an
166already-running script instance started more than this many seconds
167ago, don't terminate the current instance; instead, terminate the
168already-running instance (by sending a SIGTERM) and proceed.  If
169defined, this must be a non-negative integer.  An undefined value
170results in the timeout value set by this module's import list being
171used, if any; a value of 0 causes no timeout to be applied, overriding
172the value set by the import list if necessary.
173
174The third argument, $warn_and_exit, controls how the script terminates.
175If it is false, die()/croak() is used.  If it is true, warn()/carp() is
176used to issue the appropriate message and exit(1) is used to terminate.
177This allows the module to terminate the script from inside an eval();
178PID file checks performed based on the module's import list use this
179option.
180
181=cut
182
183sub check($;$$$) {
184    my $package = shift;
185    my $pid_file = shift;
186    my $use_timeout = shift;
187    my $warn_and_exit = shift;
188    $pid_file = catfile(tmpdir, basename($0) . '.pid')
189        unless defined $pid_file;
190    $use_timeout = $timeout
191        unless defined $use_timeout;
192    if(defined $use_timeout and ($use_timeout =~ /\D/ or int($use_timeout) ne $use_timeout or $use_timeout < 0)) {
193        if($warn_and_exit) {
194            carp 'Invalid timeout "' . $use_timeout . '"';
195            exit 1;
196        } else {
197            croak 'Invalid timeout "' . $use_timeout . '"';
198        }
199    }
200    if(open my $pid_in, '<', $pid_file) {
201        flock $pid_in, LOCK_SH;
202        my $pid_data = <$pid_in>;
203        chomp $pid_data;
204        my $pid;
205        my $ptime;
206        if($pid_data =~ /(\d+)\s+(\d+)/o) {
207            $pid = $1;
208            $ptime = $2;
209        } else {
210            $pid = $pid_data;
211        }
212        if($pid != $$ and kill 0, $pid) {
213            my $name = basename($0);
214            if($timeout and $ptime < time - $timeout) {
215                my $elapsed = time - $ptime;
216                warn "Timing out current $name on $timeout sec vs. $elapsed sec, sending SIGTERM and rewriting $pid_file\n"
217                    if $verbose;
218                kill 'TERM', $pid;
219            } else {
220                if($warn_and_exit) {
221                    warn "Running $name found via $pid_file, process $pid, exiting\n";
222                    exit 1;
223                } else {
224                    die "Running $name found via $pid_file, process $pid, exiting\n";
225                }
226            }
227        }
228        close $pid_in;
229    }
230    unless(grep { $_ eq $pid_file } @pid_files_created) {
231	    my $pid_out;
232        unless(open $pid_out, '>', $pid_file) {
233            if($warn_and_exit) {
234                warn "Cannot write $pid_file: $!\n";
235                exit 1;
236            } else {
237                die "Cannot write $pid_file: $!\n";
238            }
239        }
240        flock $pid_out, LOCK_EX;
241        print $pid_out $$, ' ', time, "\n";
242        close $pid_out;
243        push @pid_files_created, $pid_file;
244        warn "Created $pid_file for PID $$\n"
245            if $verbose;
246    }
247}
248
249=head2 recheck
250
251    File::Pid::Quick->recheck;
252
253    File::Pid::Quick->recheck(300);
254
255    File::Pid::Quick->recheck(undef, 1);
256
257Used to reverify that the running process is the owner of the
258appropriate PID file.  Checks all PID files which were created by
259the current process.
260
261All arguments are optional.
262
263The first argument, $timeout, is a timeout value which will be
264applied to PID file checks in exactly the same manner as describe
265for check() above.
266
267The second argument, $warn_and_exit, works identically to the
268$warn_and_exit argument described for check() above.
269
270=cut
271
272sub recheck($;$$) {
273    my $package = shift;
274    my $timeout = shift;
275    my $warn_and_exit = shift;
276    warn "no PID files created\n"
277        unless scalar @pid_files_created;
278    foreach my $pid_file_created (@pid_files_created) {
279        $package->check($pid_file_created, $timeout, $warn_and_exit);
280    }
281}
282
2831;
284
285__END__
286
287=head1 SEE ALSO
288
289L<perl>, L<File::Pid>
290
291=head1 AUTHOR
292
293Matthew Sheahan, E<lt>chaos@lostsouls.orgE<gt>
294
295=head1 COPYRIGHT
296
297Copyright (c) 2007, 2010 Matthew Sheahan.  All rights reserved.
298This module is free software; you can redistribute it and/or modify it
299under the same terms as Perl itself.
300
301=cut
302