view release on metacpan or  search on metacpan

lib/App/ptimeout.pm  view on Meta::CPAN

package App::ptimeout;

use strict;
use warnings;
no warnings 'numeric';

use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
use POSIX qw(WNOHANG);
use Proc::ProcessTable;

our $VERSION = '1.0.3';

sub _run {
    my($timeout, @argv) = @_;

    if($timeout =~ /m$/) { $timeout *= 60 }
     elsif($timeout =~ /h$/) { $timeout *= 3600 }

    pipe(my $stderr_reader, my $stderr_writer)
        or die("Error creating stderr pipe\n");
    _set_nonblocking($stderr_reader);

    my $pid = fork();
    if(!defined($pid)) {
        die("Error forking\n")
    } elsif(!$pid) {
        # the child process, which runs the command

        # only the parent cares about this end of the pipe, so close the copy in this process
        close $stderr_reader or die("Error closing stderr reader\n");
        # re-open STDERR as a duplicate of the pipe we inherited from the parent
        open STDERR, '>&', $stderr_writer
            or die("Error redirecting stderr\n");
        # now that we've duplicated it we don't need another copy
        close $stderr_writer or die("Error closing stderr writer\n");

        my $status = system @argv;
        exit _normalise_status($status);
    }

    # only the parent process, the watchdog, gets here

    # only the child cares about this end of the pipe, it now has a copy, so close ours
    close $stderr_writer or die("Error closing stderr writer\n");

    my $deadline = time + $timeout;
    my $timed_out = 0;
    my $child_status;
    my $stderr_buffer = '';
    my $held_line;

    # Loop while the process we're monitoring does its thang
    while(1) {
        # The background process is running, and its STDERR is being captured.
        # If it's said anything on its STDERR, flush it to the *real* STDERR.
        _pump_stderr(
            $stderr_reader,
            \$stderr_buffer,
            \$held_line,
            timed_out => $timed_out,
        );

        # Has the process finished?
        my $waited = waitpid($pid, WNOHANG);
        if($waited == $pid) {   # yes, and it exited
            $child_status = $?;
            last;
        }
        if($waited == -1) {     # it's all gone wrong
            die("Error waiting for child process\n");
        }

        if(time >= $deadline) { # still running, but been running too long
            # looks like dpulicate code, but it avoids a race condition
            $waited = waitpid($pid, WNOHANG);
            if($waited == $pid) {
                $child_status = $?;
                last;
            }
            warn "timed out\n";
            $timed_out = 1;
            $child_status = _terminate_process_tree($pid);
            last;
        }

        select undef, undef, undef, 0.1;
    }

    _flush_remaining_stderr(
        $stderr_reader,
        \$stderr_buffer,
        \$held_line,
        timed_out => $timed_out,
    );
    close $stderr_reader or die("Error closing stderr reader\n");

    exit($timed_out ? 124 : _normalise_status($child_status));
}

sub _normalise_status {
    my($status) = @_;

    return 255 if($status == -1);
    return $status >> 8;
}

sub _set_nonblocking {
    my($fh) = @_;

    my $flags = fcntl($fh, F_GETFL, 0);
    defined($flags) or die("Error reading stderr flags\n");
    fcntl($fh, F_SETFL, $flags | O_NONBLOCK)
        or die("Error setting stderr nonblocking\n");
}