File Coverage

blib/lib/No/Worries/PidFile.pm

Criterion	Covered	Total	%
statement	120	192	62.5
branch	38	118	32.2
condition	5	16	31.2
subroutine	22	25	88.0
pod	7	7	100.0
total	192	358	53.6

#+##############################################################################
#                                                                              #
# File: No/Worries/PidFile.pm                                                  #
#                                                                              #
# Description: pid file handling without worries                               #
#                                                                              #
#-##############################################################################

#
# module definition
#

package No::Worries::PidFile;
use strict;
use warnings;
our $VERSION  = "1.5";
our $REVISION = sprintf("%d.%02d", q$Revision: 1.20 $ =~ /(\d+)\.(\d+)/);

#
# used modules
#

use Fcntl qw(:DEFAULT :flock :seek);
use No::Worries qw($_IntegerRegexp $_NumberRegexp);
use No::Worries::Die qw(dief);
use No::Worries::Export qw(export_control);
use No::Worries::Proc qw(proc_terminate);
use No::Worries::Stat qw(ST_MTIME);
use Params::Validate qw(validate :types);
use POSIX qw(:errno_h);
use Time::HiRes qw();

#
# safely read something from an open file
#

sub _read ($$;$) {
    my($path, $fh, $noclose) = @_;
    my($data, $done);

    flock($fh, LOCK_EX)
        or dief("cannot flock(%s, LOCK_EX): %s", $path, $!);
    sysseek($fh, 0, SEEK_SET)
        or dief("cannot sysseek(%s, 0, SEEK_SET): %s", $path, $!);
    $data = "";
    $done = -1;
    while ($done) {
        $done = sysread($fh, $data, 16, length($data));
        dief("cannot sysread(%s, %d): %s", $path, 16, $!)
            unless defined($done);
    }
    if ($noclose) {
        flock($fh, LOCK_UN)
            or dief("cannot flock(%s, LOCK_UN): %s", $path, $!);
    } else {
        close($fh)
            or dief("cannot close(%s): %s", $path, $!);
    }
    return($data);
}

#
# safely write something to an open file
#

sub _write ($$$) {
    my($path, $fh, $data) = @_;
    my($length, $offset, $done);

    flock($fh, LOCK_EX)
        or dief("cannot flock(%s, LOCK_EX): %s", $path, $!);
    sysseek($fh, 0, SEEK_SET)
        or dief("cannot sysseek(%s, 0, SEEK_SET): %s", $path, $!);
    truncate($fh, 0)
        or dief("cannot truncate(%s, 0): %s", $path, $!);
    $length = length($data);
    $offset = 0;
    while ($length) {
        $done = syswrite($fh, $data, $length, $offset);
        dief("cannot syswrite(%s, %d): %s", $path, $length, $!)
            unless defined($done);
        $length -= $done;
        $offset += $done;
    }
    close($fh)
        or dief("cannot close(%s): %s", $path, $!);
}

#
# check if a process is alive by killing it ;-)
#

sub _alive ($) {
    my($pid) = @_;

    return(1) if kill(0, $pid);
    return(0) if $! == ESRCH;
    dief("cannot kill(0, %d): %s", $pid, $!);
}

#
# kill a process
#

sub _kill ($$$%) {
    my($path, $fh, $pid, %option) = @_;
    my($maxtime);

    # gently
    $option{callback}->("(pid $pid) is being told to quit...");
    _write($path, $fh, "$pid\nquit\n");
    $maxtime = Time::HiRes::time() + $option{linger};
    while (1) {
        last unless _alive($pid);
        last if Time::HiRes::time() > $maxtime;
        Time::HiRes::sleep(0.1);
    }
    if (_alive($pid)) {
        # forcedly
        $option{callback}->("(pid $pid) is still running, killing it now...");
        if ($option{kill}) {
            proc_terminate($pid, kill => $option{kill});
        } else {
            proc_terminate($pid);
        }
        $option{callback}->("(pid $pid) has been successfully killed");
    } else {
        $option{callback}->("does not seem to be running anymore");
    }
}

#
# check a process
#

sub _status ($%) {
    my($path, %option) = @_;
    my($fh, @stat, $data, $pid, $status, $message, $lsb);

    $status = 0;
    unless (sysopen($fh, $path, O_RDWR)) {
        if ($! == ENOENT) {
            ($message, $lsb) =
                ("does not seem to be running (no pid file)", 3);
            goto done;
        }
        dief("cannot sysopen(%s, O_RDWR): %s", $path, $!);
    }
    @stat = stat($fh)
        or dief("cannot stat(%s): %s", $path, $!);
    $data = _read($path, $fh);
    if ($data eq "") {
        # this can happen in pf_set(), between open() and lock()
        ($message, $lsb) =
            ("does not seem to be running yet (empty pid file)", 4);
        goto done;
    }
    if ($data =~ /^(\d+)(\s+([a-z]+))?\s*$/s) {
        $pid = $1;
    } else {
        dief("unexpected pid file contents in %s: %s", $path, $data);
    }
    unless (_alive($pid)) {
        ($message, $lsb) =
            ("(pid $pid) does not seem to be running anymore", 1);
        goto done;
    }
    $data = localtime($stat[ST_MTIME]);
    if ($option{freshness} and
        $stat[ST_MTIME] < Time::HiRes::time() - $option{freshness}) {
        ($message, $lsb) =
            ("(pid $pid) does not seem to be running anymore since $data", 4);
        goto done;
    }
    # so far so good ;-)
    ($status, $message, $lsb) = (1, "(pid $pid) was active on $data", 0);
  done:
    return($status, $message, $lsb);
}

#
# set the pid file
#

my %pf_set_options = (
    pid => { optional => 1, type => SCALAR, regex => $_IntegerRegexp },
);

sub pf_set ($@) {
    my($path, %option, $fh);

    $path = shift(@_);
    %option = validate(@_, \%pf_set_options) if @_;
    $option{pid} ||= $$;
    sysopen($fh, $path, O_WRONLY|O_CREAT|O_EXCL)
        or dief("cannot sysopen(%s, O_WRONLY|O_CREAT|O_EXCL): %s", $path, $!);
    _write($path, $fh, "$option{pid}\n");
}

#
# check the pid file
#

my %pf_check_options = (
    pid => { optional => 1, type => SCALAR, regex => $_IntegerRegexp },
);

sub pf_check ($@) {
    my($path, %option, $fh, $data, $pid, $action);

    $path = shift(@_);
    %option = validate(@_, \%pf_check_options) if @_;
    $option{pid} ||= $$;
    sysopen($fh, $path, O_RDWR)
        or dief("cannot sysopen(%s, O_RDWR): %s", $path, $!);
    $data = _read($path, $fh);
    if ($data =~ /^(\d+)\s*$/s) {
        ($pid, $action) = ($1, "");
    } elsif ($data =~ /^(\d+)\s+([a-z]+)\s*$/s) {
        ($pid, $action) = ($1, $2);
    } else {
        dief("unexpected pid file contents in %s: %s", $path, $data)
    }
    dief("pid file %s has been taken over by pid %d!", $path, $pid)
        unless $pid == $option{pid};
    return($action);
}

#
# touch the pid file
#

sub pf_touch ($) {
    my($path) = @_;
    my($now);

    $now = time();
    utime($now, $now, $path)
        or dief("cannot utime(%d, %d, %s): %s", $now, $now, $path, $!);
}

#
# unset the pid file
#

sub pf_unset ($) {
    my($path) = @_;

    unless (unlink($path)) {
        return if $! == ENOENT;
        dief("cannot unlink(%s): %s", $path, $!);
    }
}

#
# use the pid file to find out the program status
#

my %pf_status_options = (
    freshness => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
    timeout   => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
);

sub pf_status ($@) {
    my($path, %option, $maxtime, $status, $message, $lsb);

    $path = shift(@_);
    %option = validate(@_, \%pf_status_options) if @_;
    if ($option{timeout}) {
        # check multiple times until success or timeout
        $maxtime = Time::HiRes::time() + $option{timeout};
        while (1) {
            ($status, $message, $lsb) = _status($path, %option);
            last if $status or Time::HiRes::time() > $maxtime;
            Time::HiRes::sleep(0.1);
        }
    } else {
        # check only once
        ($status, $message, $lsb) = _status($path, %option);
    }
    return($status, $message, $lsb) if wantarray();
    return($status);
}

#
# use the pid file to make the program quit
#

my %pf_quit_options = (
    callback  => { optional => 1, type => CODEREF },
    linger    => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
    kill      => { optional => 1, type => SCALAR },
);

sub pf_quit ($@) {
    my($path, %option, $fh, $data, $pid);

    $path = shift(@_);
    %option = validate(@_, \%pf_quit_options) if @_;
    $option{callback} ||= sub { printf("%s\n", $_[0]) };
    $option{linger} ||= 5;
    unless (sysopen($fh, $path, O_RDWR)) {
        if ($! == ENOENT) {
            $option{callback}->("does not seem to be running (no pid file)");
            return;
        }
        dief("cannot sysopen(%s, O_RDWR): %s", $path, $!);
    }
    $data = _read($path, $fh, 1);
    if ($data eq "") {
        # this can happen while setting the pid file, between open and lock in pf_set()
        # but what can we do? we wait a bit, try again and complain if itis still empty
        sleep(1);
        $data = _read($path, $fh, 1);
    }
    if ($data =~ /^(\d+)(\s+([a-z]+))?\s*$/s) {
        $pid = $1;
    } else {
        dief("unexpected pid file contents in %s: %s", $path, $data);
    }
    _kill($path, $fh, $pid, %option);
    # in any case, we make sure that _this_ pid file does not exist anymore
    # we have to be extra careful to make sure it is the same pid file
    unless (sysopen($fh, $path, O_RDWR)) {
        return if $! == ENOENT;
        dief("cannot sysopen(%s, O_RDWR): %s", $path, $!);
    }
    $data = _read($path, $fh);
    return if $data eq "";
    if ($data =~ /^(\d+)(\s+([a-z]+))?\s*$/s) {
        return unless $1 == $pid;
    } else {
        dief("unexpected pid file contents in %s: %s", $path, $data);
    }
    # same pid so assume same pid file... remove it
    $option{callback}->("removing stale pid file: $path");
    unless (unlink($path)) {
        # take into account a potential race condition...
        dief("cannot unlink(%s): %s", $path, $!) unless $! == ENOENT;
    }
}

#
# sleep for some time, taking into account an optional pid file
#

my %pf_sleep_options = (
    time => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
);

sub pf_sleep ($@) {
    my($path, %option, $end, $sleep);

    $path = shift(@_);
    %option = validate(@_, \%pf_sleep_options) if @_;
    $option{time} = 1 unless defined($option{time});
    if ($path) {
        $end = Time::HiRes::time() + $option{time} if $option{time};
        while (1) {
            return(0) if pf_check($path) eq "quit";
            pf_touch($path);
            last unless $option{time};
            $sleep = $end - Time::HiRes::time();
            last if $sleep <= 0;
            $sleep = 1 if $sleep > 1;
            Time::HiRes::sleep($sleep);
        }
    } else {
        Time::HiRes::sleep($option{time}) if $option{time};
    }
    return(1);
}

#
# export control
#

sub import : method {
    my($pkg, %exported);

    $pkg = shift(@_);
    grep($exported{$_}++, map("pf_$_",
                              qw(set check touch unset status quit sleep)));
    export_control(scalar(caller()), $pkg, \%exported, @_);
}

1;

__DATA__