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