1package Proc::Pidfile; 2$Proc::Pidfile::VERSION = '1.09'; 3use 5.006; 4use strict; 5use warnings; 6 7use Fcntl qw/ :flock /; 8use File::Basename qw/ basename /; 9use Carp qw/ carp croak /; 10use Time::HiRes qw/ usleep /; 11use File::Spec::Functions qw/ catfile tmpdir /; 12 13sub new 14{ 15 my $class = shift; 16 my %args = @_; 17 my $self = bless \%args, $class; 18 19 $self->{retries} = 2 unless defined($self->{retries}); 20 21 unless ( $self->{pidfile} ) { 22 my $basename = basename( $0 ); 23 my $dir = tmpdir(); 24 25 croak "Can't write to $dir\n" unless -w $dir; 26 27 my $pidfile = catfile($dir, "$basename.pid"); 28 29 # untaint the path, since it includes externally generated info 30 # TODO: should we be a bit more pedantic on "valid path"? 31 $pidfile = $1 if ($pidfile =~ /^\s*(.*)\s*/); 32 33 $self->_verbose( "pidfile: $pidfile\n" ); 34 $self->{pidfile} = $pidfile; 35 } 36 $self->_create_pidfile(); 37 return $self; 38} 39 40sub DESTROY 41{ 42 my $self = shift; 43 44 $self->_destroy_pidfile(); 45} 46 47sub pidfile 48{ 49 my $self = shift; 50 return $self->{pidfile}; 51} 52 53sub _verbose 54{ 55 my $self = shift; 56 return unless $self->{verbose}; 57 print STDERR @_; 58} 59 60sub _get_pid 61{ 62 my $self = shift; 63 my $pidfile = $self->{pidfile}; 64 $self->_verbose( "get pid from $pidfile\n" ); 65 open( PID, $pidfile ) or croak "can't read pid file $pidfile\n"; 66 flock( PID, LOCK_SH ) or croak "can't lock pid file $pidfile\n"; 67 my $pid = <PID>; 68 if (defined($pid) && $pid =~ /([0-9]+)/) { 69 $pid = $1; 70 } 71 else { 72 croak "can't get pid from pidfile $pidfile\n"; 73 } 74 chomp( $pid ); 75 flock( PID, LOCK_UN ); 76 close( PID ); 77 $self->_verbose( "pid = $pid\n" ); 78 return $pid; 79} 80 81sub _is_running 82{ 83 my $pid = shift; 84 85 if ($^O eq 'riscos') { 86 require Proc::ProcessTable; 87 88 my $table = Proc::ProcessTable->new()->table; 89 my %processes = map { $_->pid => $_ } @$table; 90 return exists $processes{$pid}; 91 } 92 else { 93 return kill(0, $pid) || $!{'EPERM'}; 94 } 95} 96 97sub _create_pidfile 98{ 99 my $self = shift; 100 my $pidfile = $self->{pidfile}; 101 my $attempt = 1; 102 103 while ( -e $pidfile ) { 104 $self->_verbose( "pidfile $pidfile exists\n" ); 105 my $pid = $self->_get_pid(); 106 $self->_verbose( "pid in pidfile $pidfile = $pid\n" ); 107 if ( _is_running( $pid ) ) { 108 109 # this might be a race condition, or parallel smoke testers, 110 # so we'll back off a random amount of time and try again 111 if ($attempt <= $self->{retries}) { 112 ++$attempt; 113 # TODO: let's try this. Guessing we don't have to 114 # bother with increasing backoff times 115 my $backoff = 100 + rand(300); 116 $self->_verbose("backing off for $backoff microseconds before trying again"); 117 usleep(100 + rand(300)); 118 next; 119 } 120 121 if ( $self->{silent} ) { 122 exit; 123 } 124 else { 125 croak "$0 already running: $pid ($pidfile)\n"; 126 } 127 } 128 else { 129 $self->_verbose( "$pid has died - replacing pidfile\n" ); 130 open( PID, ">$pidfile" ) or croak "Can't write to $pidfile\n"; 131 print PID "$$\n"; 132 close( PID ); 133 last; 134 } 135 } 136 137 if (not -e $pidfile) { 138 $self->_verbose( "no pidfile $pidfile\n" ); 139 open( PID, ">$pidfile" ) or croak "Can't write to $pidfile: $!\n"; 140 flock( PID, LOCK_EX ) or croak "Can't lock pid file $pidfile\n"; 141 print PID "$$\n" or croak "Can't write to pid file $pidfile\n"; 142 flock( PID, LOCK_UN ); 143 close( PID ) or croak "Can't close pid file $pidfile: $!\n"; 144 $self->_verbose( "pidfile $pidfile created\n" ); 145 } 146 147 $self->{created} = 1; 148} 149 150sub _destroy_pidfile 151{ 152 my $self = shift; 153 154 return unless $self->{created}; 155 my $pidfile = $self->{pidfile}; 156 $self->_verbose( "destroy $pidfile\n" ); 157 if ( $pidfile and -e $pidfile ) { 158 my $pid = $self->_get_pid(); 159 $self->_verbose( "pid in $pidfile = $pid\n" ); 160 if ( $pid == $$ ) { 161 $self->_verbose( "remove pidfile: $pidfile\n" ); 162 unlink( $pidfile ) if $pidfile and -e $pidfile; 163 } 164 elsif ($^O ne 'MSWin32' && $^O ne 'riscos') { 165 $self->_verbose( "$pidfile not my pidfile - maybe my parent's?\n" ); 166 my $ppid = getppid(); 167 $self->_verbose( "parent pid = $ppid\n" ); 168 if ( $ppid != $pid ) { 169 carp "pid $pid in $pidfile is not mine ($$) - I am $0 - or my parents ($ppid)\n"; 170 } 171 } 172 else { 173 $self->_verbose( "$pidfile not my pidfile - can't check if it's my parent's on this OS\n" ); 174 } 175 } 176 else { 177 carp "pidfile $pidfile doesn't exist\n"; 178 } 179} 180 181#------------------------------------------------------------------------------ 182# 183# Start of POD 184# 185#------------------------------------------------------------------------------ 186 187=head1 NAME 188 189Proc::Pidfile - a simple OO Perl module for maintaining a process id file for 190the curent process 191 192=head1 SYNOPSIS 193 194 my $pp = Proc::Pidfile->new( pidfile => "/path/to/your/pidfile" ); 195 # if the pidfile already exists, die here 196 $pidfile = $pp->pidfile(); 197 undef $pp; 198 # unlink $pidfile here 199 200 my $pp = Proc::Pidfile->new(); 201 # creates pidfile in default location 202 my $pidfile = $pp->pidfile(); 203 # tells you where this pidfile is ... 204 205 my $pp = Proc::Pidfile->new( silent => 1 ); 206 # if the pidfile already exists, exit silently here 207 ... 208 undef $pp; 209 210=head1 DESCRIPTION 211 212Proc::Pidfile is a very simple OO interface which manages a pidfile for the 213current process. 214You can pass the path to a pidfile to use as an argument to the constructor, 215or you can let Proc::Pidfile choose one 216("/$tmpdir/$basename", where C<$tmpdir> is from C<File::Spec>). 217 218Pidfiles created by Proc::Pidfile are automatically removed on destruction of 219the object. At destruction, the module checks the process id in the pidfile 220against its own, and against its parents (in case it is a spawned child of the 221process that originally created the Proc::Pidfile object), and barfs if it 222doesn't match either. 223 224If you pass a "silent" parameter to the constructor, then it will still check 225for the existence of a pidfile, but will exit silently if one is found. This is 226useful for, for example, cron jobs, where you don't want to create a new 227process if one is already running, but you don't necessarily want to be 228informed of this by cron. 229 230=head2 Retries 231 232If another instance of your script is already running, 233we'll retry a couple of times, 234with a random number of microseconds between each attempt. 235 236You can specify the number of retries, for example if you 237want to try more times for some reason: 238 239 $pidfile = $pp->pidfile(retries => 4); 240 241By default this is set to 2, 242which means if the first attempt to set up a pidfile fails, 243it will try 2 more times, so three attempts in total. 244 245Setting retries to 0 (zero) will disable this feature. 246 247 248=head1 SEE ALSO 249 250L<Proc::PID::File> - provides a similar interface. 251 252L<PidFile> - provides effectively the same functionality, 253but via class methods. Hasn't been updated since 2011, 254and has quite a few CPAN Testers fails. 255 256L<IPC::Pidfile> - provides a simple interface, but has some restrictions, 257and its documentation even recommends you consider a different module, 258as it has a race condition. 259 260L<IPC::Lockfile> - very simple interface, and uses a different mechanism: 261it tries to lock the script file which used the module. 262The trouble with that is that you might be running someone else's script, 263and thus can't lock it. 264 265L<Sys::RunAlone> - another one with a simple default interface, 266but can be configured to retry. Based on locking, rather than a pid file. 267Doesn't work on Windows. 268 269L<Linux::Pidfile> - Linux-specific solution. 270 271=head1 REPOSITORY 272 273L<https://github.com/neilbowers/Proc-Pidfile> 274 275=head1 AUTHOR 276 277Ave Wrigley E<lt>awrigley@cpan.orgE<gt> 278 279Now maintained by Neil Bowers E<lt>neilb@cpan.orgE<gt> 280 281=head1 COPYRIGHT 282 283Copyright (c) 2003 Ave Wrigley. All rights reserved. This program is free 284software; you can redistribute it and/or modify it under the same terms as Perl 285itself. 286 287=cut 288 289#------------------------------------------------------------------------------ 290# 291# End of POD 292# 293#------------------------------------------------------------------------------ 294 295 296#------------------------------------------------------------------------------ 297# 298# True ... 299# 300#------------------------------------------------------------------------------ 301 3021; 303 304