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