File Coverage

lib/IPC/Pidfile.pm

Criterion	Covered	Total	%
statement	34	35	97.1
branch	11	22	50.0
condition	1	3	33.3
subroutine	9	9	100.0
pod	0	6	0.0
total	55	75	73.3

use strict;
use warnings;
package IPC::Pidfile;
$IPC::Pidfile::VERSION = '0.01';
# ABSTRACT: run only instance of a program at a time
our $DEBUG = $ENV{IPC_PIDFILE_DEBUG};
our $PID = pid();

# signal handler
$SIG{TERM} = $SIG{INT} = sub { exit(0) };

pidfile_lock();

END { pidfile_clear() }


sub pidfile_name  { "$0.pid" }

sub pidfile_lock
{
  print "$PID pidfile_lock\n" if $DEBUG;
  die "$0 is already running\n" if (-e pidfile_name()) && pidfile_is_fresh();
  open my $pidfile, '>', pidfile_name() or die 'Unable to open pidfile ' . pidfile_name();
  select((select($pidfile), $| = 1)[0]);
  print $pidfile pid();
  close $pidfile;
  return 1;
}

sub pidfile_is_fresh
{
  print "$PID pidfile_is_stale\n" if $DEBUG;
  # kill isnt portable
  if ($^O ne 'MSWin32')
  {
    my $pid = pidfile_read();
    return kill 0, $pid;
  }
  return 0;
}

sub pid
{
  my $pid = $$;
  # Win32 pids have a trailing newline?!
  chomp $pid;
  return $pid;
}

sub pidfile_read
{
  print "$PID pidfile_read\n" if $DEBUG;
  open my $pidfile, '<', pidfile_name() or die 'Unable to open pidfile ' . pidfile_name();
  my $pid = do { local($/);<$pidfile> };
  close $pidfile;
  chomp $pid;

  # avoid negative pid numbers and garbage
  die "pidfile appears corrupted: $pid\n" unless $pid =~ /^[0-9]+$/;
  return $pid;
}

sub pidfile_clear
{
  print "$PID pidfile_clear\n" if $DEBUG;
  if (pid() eq pidfile_read())
  {
    unlink pidfile_name() or die "Unable to delete pidfile " . pidfile_name();
  }
}
1;

__END__