File Coverage

blib/lib/Unix/PID/Tiny.pm
Criterion Covered Total %
statement 143 151 94.7
branch 89 106 83.9
condition 37 44 84.0
subroutine 16 17 94.1
pod 8 8 100.0
total 293 326 89.8


line stmt bran cond sub pod time code
1             package Unix::PID::Tiny;
2              
3 6     6   1259593 use strict;
  6         27  
  6         182  
4 6     6   31 use warnings;
  6         12  
  6         8103  
5              
6             our $VERSION = '0.95';
7              
8             sub new {
9 83     83 1 80485 my ( $self, $args_hr ) = @_;
10              
11 83         298 my %DEFAULTS = (
12             'keep_open' => 0,
13             'check_proc_open_fds' => 0
14             );
15              
16 83   100     587 $args_hr ||= {};
17 83         209 %{$args_hr} = ( %DEFAULTS, %{$args_hr} );
  83         202  
  83         242  
18 83 100 66     424 $args_hr->{'minimum_pid'} = 11 if !exists $args_hr->{'minimum_pid'} || $args_hr->{'minimum_pid'} !~ m{\A\d+\z}ms; # this does what one assumes m{^\d+$} would do
19              
20 83 100       376 if ( defined $args_hr->{'ps_path'} ) {
21 25 100       105 $args_hr->{'ps_path'} .= '/' if $args_hr->{'ps_path'} !~ m{/$};
22 25 100 100     280 if ( !-d $args_hr->{'ps_path'} || !-x "$args_hr->{'ps_path'}ps" ) {
23 15         3205 $args_hr->{'ps_path'} = '';
24             }
25             }
26             else {
27 58         142 $args_hr->{'ps_path'} = '';
28             }
29              
30             return bless {
31             'ps_path' => $args_hr->{'ps_path'},
32             'minimum_pid' => $args_hr->{'minimum_pid'},
33             'keep_open' => $args_hr->{'keep_open'},
34 83         3586 'check_proc_open_fds' => $args_hr->{'check_proc_open_fds'},
35             'open_handles' => []
36             }, $self;
37             }
38              
39             sub kill {
40 20     20 1 4085 my ( $self, $pid, $give_kill_a_chance ) = @_;
41 20 100       70 $give_kill_a_chance = int $give_kill_a_chance if defined $give_kill_a_chance;
42 20         40 $pid = int $pid;
43 20         65 my $min = int $self->{'minimum_pid'};
44 20 100       55 if ( $pid < $min ) {
45              
46             # prevent bad args from killing the process group (IE '0')
47             # or general low level ones
48 5         85 warn "kill() called with integer value less than $min";
49 5         405 return;
50             }
51              
52             # CORE::kill 0, $pid : may be false but still running, see `perldoc -f kill`
53 15 100       45 if ( $self->is_pid_running($pid) ) {
54              
55             # RC from CORE::kill is not a boolean of if the PID was killed or not, only that it was signaled
56             # so it is not an indicator of "success" in killing $pid
57 10         100 _kill( 15, $pid ); # TERM
58 10         85 _kill( 2, $pid ); # INT
59 10         65 _kill( 1, $pid ); # HUP
60 10         60 _kill( 9, $pid ); # KILL
61              
62             # give kill() some time to take effect?
63 10 100       50 if ($give_kill_a_chance) {
64 5         20 sleep($give_kill_a_chance);
65             }
66 10 100       3045 return if $self->is_pid_running($pid);
67             }
68 10         75 return 1;
69             }
70              
71             sub is_pid_running {
72 71     71 1 28255 my ( $self, $check_pid ) = @_;
73              
74 71         378 $check_pid = int $check_pid;
75 71 100 100     1698 return if !$check_pid || $check_pid < 0;
76              
77 36 100 66     451 return 1 if $> == 0 && _kill( 0, $check_pid ); # if we are superuser we can avoid the the system call. For details see `perldoc -f kill`
78              
79             # If the proc filesystem is available, it's a good test. If not, continue on to system call
80 25 100 33     485 return 1 if -e "/proc/$$" && -r "/proc/$$" && -r "/proc/$check_pid";
      66        
81              
82             # even if we are superuser, go ahead and call ps just in case CORE::kill 0's false RC was erroneous
83 20         7780 my @outp = $self->_raw_ps( 'u', '-p', $check_pid );
84 20         135 chomp @outp;
85 20 100       80 return 1 if defined $outp[1];
86 15         345 return;
87             }
88              
89             sub pid_info_hash {
90 45     45 1 7195 my ( $self, $pid ) = @_;
91 45         300 $pid = int $pid;
92 45 100 100     1355 return if !$pid || $pid < 0;
93              
94 15         70 my @outp = $self->_raw_ps( 'u', '-p', $pid );
95 15         80 chomp @outp;
96 15         40 my %info;
97 15         570 @info{ split( /\s+/, $outp[0], 11 ) } = split( /\s+/, $outp[1], 11 );
98 15 100       195 return wantarray ? %info : \%info;
99             }
100              
101             sub _raw_ps {
102 25     25   6915 my ( $self, @ps_args ) = @_;
103 25         175 my $psargs = join( ' ', @ps_args );
104 25         149490 my @res = `$self->{'ps_path'}ps $psargs`;
105 25 100       1265 return wantarray ? @res : join '', @res;
106             }
107              
108             sub get_pid_from_pidfile {
109 68     68 1 2522972 my ( $self, $pid_file ) = @_;
110              
111             # if this function is ever changed to use $self as a hash object, update pid_file() to not do a class method call
112 68 100       751 return 0 if !-e $pid_file;
113              
114 53 50       11586 open my $pid_fh, '<', $pid_file or return;
115 53         10742 chomp( my $pid = <$pid_fh> );
116 53         1161 close $pid_fh;
117              
118 53         901 return int( abs($pid) );
119             }
120              
121             sub _sets_match {
122 5     5   40 my ( $left, $right ) = @_;
123              
124 5         30 my $count = scalar @{$left};
  5         20  
125              
126 5 50       10 return 0 unless scalar @{$right} == $count;
  5         80  
127              
128 5         55 for ( my $i = 0; $i < $count; $i++ ) {
129 10 50       95 return 0 unless $left->[$i] eq $right->[$i];
130             }
131              
132 5         20 return 1;
133             }
134              
135             sub is_pidfile_running {
136 30     30 1 5760 my ( $self, $pid_file, $since ) = @_;
137 30   100     150 my $pid = $self->get_pid_from_pidfile($pid_file) || return;
138              
139 25 50       390 my @pidfile_st = stat $pid_file or return;
140              
141 25 100       4285 if ( defined $since ) {
142 5 50       80 return if $pidfile_st[9] < $since;
143             }
144              
145 20 100       125 if ( $self->{'check_proc_open_fds'} ) {
146 10         100 my $dir = "/proc/$pid/fd";
147 10         55 my $found = 0;
148              
149 10 100       115 opendir my $dh, $dir or return;
150              
151 5         600 while ( my $dirent = readdir $dh ) {
152 15 100 100     1010 next if $dirent eq '.' || $dirent eq '..';
153              
154 5         55 my $path = "$dir/$dirent";
155 5 50       80 my $dest = readlink $path or next;
156 5 50       420 my @st = stat $dest or next;
157              
158 5 50       1080 if ( _sets_match( [ @pidfile_st[ 0, 1 ] ], [ @st[ 0, 1 ] ] ) ) {
159 5         35 $found = 1;
160              
161 5         35 last;
162             }
163             }
164              
165 5         35 closedir $dh;
166              
167 5 50       370 return unless $found;
168             }
169             else {
170 10 100       65 return unless $self->is_pid_running($pid);
171             }
172              
173 10         145 return $pid;
174             }
175              
176             sub pid_file {
177 22     22 1 7947 my ( $self, $pid_file, $newpid, $retry_conf ) = @_;
178 22 100       162 $newpid = $$ if !$newpid;
179              
180 22         101 my $rc = $self->pid_file_no_unlink( $pid_file, $newpid, $retry_conf );
181 22 100 66     364 if ( $rc && $newpid == $$ ) {
182              
183             # prevent forked childrens' END from killing parent's pid files
184             # 'unlink_end_use_current_pid_only' is undocumented as this may change, feedback welcome!
185             # 'carp_unlink_end' undocumented as it is only meant for testing (rt57462, use Test::Carp to test END behavior)
186 7 50       78 if ( $self->{'unlink_end_use_current_pid_only'} ) {
187 0         0 eval 'END { unlink $pid_file if $$ eq ' . $$ . '}'; ## no critic qw(ProhibitStringyEval)
188 0 0       0 if ( $self->{'carp_unlink_end'} ) {
189              
190             # eval 'END { require Carp;Carp::carp("[info] $$ !unlink $pid_file (current pid check)") if $$ ne ' . $$ . '}'; ## no critic qw(ProhibitStringyEval)
191 0         0 eval 'END { require Carp;Carp::carp("[info] $$ unlink $pid_file (current pid check)") if $$ eq ' . $$ . '}'; ## no critic qw(ProhibitStringyEval)
192             }
193             }
194             else {
195 7 50   5   1379 eval 'END { unlink $pid_file if Unix::PID::Tiny->get_pid_from_pidfile($pid_file) eq $$ }'; ## no critic qw(ProhibitStringyEval)
  5         424701  
196 7 50       93 if ( $self->{'carp_unlink_end'} ) {
197              
198             # eval 'END { require Carp;Carp::carp("[info] $$ !unlink $pid_file (pid file check)") if Unix::PID::Tiny->get_pid_from_pidfile($pid_file) ne $$ }'; ## no critic qw(ProhibitStringyEval)
199 0         0 eval 'END { require Carp;Carp::carp("[info] $$ unlink $pid_file (pid file check)") if Unix::PID::Tiny->get_pid_from_pidfile($pid_file) eq $$ }'; ## no critic qw(ProhibitStringyEval)
200             }
201             }
202             }
203              
204 22 100 100     182 return 1 if defined $rc && $rc == 1;
205 15 100 66     165 return 0 if defined $rc && $rc == 0;
206 10         60 return;
207             }
208              
209 6     6   48 no warnings 'once';
  6         12  
  6         389  
210              
211             # more intuitively named alias
212             *pid_file_no_cleanup = \&pid_file_no_unlink;
213 6     6   37 use warnings 'once';
  6         13  
  6         3083  
214              
215             sub pid_file_no_unlink {
216 15     15 1 9442 my ( $self, $pid_file, $newpid, $retry_conf ) = @_;
217 15 100       190 $newpid = $$ if !$newpid;
218              
219 15 100       204 if ( ref($retry_conf) eq 'ARRAY' ) {
    100          
220 1         7 $retry_conf->[0] = int( abs( $retry_conf->[0] ) );
221 1         4 for my $idx ( 1 .. scalar( @{$retry_conf} ) - 1 ) {
  1         13  
222 6 100       123 next if ref $retry_conf->[$idx] eq 'CODE';
223 5         49 $retry_conf->[$idx] = int( abs( $retry_conf->[$idx] ) );
224             }
225             }
226             elsif ( ref($retry_conf) eq 'HASH' ) {
227 3   100     29 $retry_conf->{'num_of_passes'} ||= 3;
228 3   100     16 $retry_conf->{'passes_config'} ||= [ 1, 2 ];
229 3         6 $retry_conf = [ int( $retry_conf->{'num_of_passes'} ), @{ $retry_conf->{'passes_config'} } ];
  3         12  
230             }
231             else {
232 11         98 $retry_conf = [ 3, 1, 2 ];
233             }
234              
235 15         33 my $passes = 0;
236 15         288 require Fcntl;
237              
238 35         120 EXISTS:
239             $passes++;
240 35 100       320 if ( -e $pid_file ) {
241 7         1533 my $curpid = $self->get_pid_from_pidfile($pid_file);
242              
243             # TODO: narrow even more the race condition where $curpid stops running and a new PID is put in
244             # the file between when we pull in $curpid above and check to see if it is running/unlink below
245              
246 7 100 100     138 return 1 if int $curpid == $$ && $newpid == $$; # already setup
247 4 100       47 return if int $curpid == $$; # can't change it while $$ is alive
248 1 50       35 return if $self->is_pid_running( int $curpid );
249              
250 0         0 unlink $pid_file; # must be a stale PID file, so try to remove it for sysopen()
251             }
252              
253             # write only if it does not exist:
254 28         4585 my $pid_fh = _sysopen($pid_file);
255 28 100       148 if ( !$pid_fh ) {
256 25 100       90 return 0 if $passes >= $retry_conf->[0];
257 20 100       48 if ( ref( $retry_conf->[$passes] ) eq 'CODE' ) {
258 1         6 $retry_conf->[$passes]->( $self, $pid_file, $passes );
259             }
260             else {
261 19 100       69 sleep( $retry_conf->[$passes] ) if $retry_conf->[$passes];
262             }
263 20         486 goto EXISTS;
264             }
265              
266 3         122 syswrite( $pid_fh, int( abs($newpid) ) );
267              
268 3 50       205 if ( $self->{'keep_open'} ) {
269 0         0 push @{ $self->{'open_handles'} }, $pid_fh;
  0         0  
270             }
271             else {
272 3         41 close $pid_fh;
273             }
274              
275 3         29 return 1;
276             }
277              
278             sub _sysopen {
279 3     3   30 my ($pid_file) = @_;
280 3 50       68 sysopen( my $pid_fh, $pid_file, Fcntl::O_WRONLY() | Fcntl::O_EXCL() | Fcntl::O_CREAT() ) || return;
281 3         1155 return $pid_fh;
282             }
283              
284             sub _kill { ## no critic(RequireArgUnpacking
285 0     0   0 return CORE::kill(@_); # goto &CORE::kill; is problematic
286             }
287              
288             1;
289              
290             __END__