#! /usr/bin/perl
# Jack Applin

use strict;
use warnings;

use IO::Pty;
use Getopt::Long qw(:config bundling require_order);
use File::Temp 'tempdir';
use Cwd 'abs_path';
use Config;
use POSIX 'sysconf';

# TODO: Separate stdout & stderr
# TODO: Read a char if raw, a line if cooked
# TODO: Kill program if some limit exceeded

$0 =~ s!.*/!!;				# Reduce program name to basename

my $previous_io = "invalid value";

# Options:
my $input_timeout = 0.01;	# When reading from program, wait a centisecond
my $crlf_translate = 1;		# Translate CRLF => newline in program output
my $debug = 0;			# Produce debug output
my $playpen = 0;		# Don’t use a temporary playpen directory.
my $max_cpu = 60;		# Allow program 60 seconds of CPU time.
my $max_real = 600;		# Allow program 600 seconds of real time.
my $max_eof = 20;		# Allow program to read at EOF 20 times.
my $max_lines = 10000;		# Max lines the program may produce
my $max_chars = 100000;		# Max chars the program may produce

# Program information
my $pid;			# Process ID of child program
my $pty = new IO::Pty;
my $exit_code;
my $count_eof = 0;		# How many times has the program read from EOF?
my $count_lines = 0;		# How many lines has the program emitted?
my $count_chars = 0;		# How many chars has the program emitted?

# Emit this message to stderr, if debugging is enabled.
sub bugout {
    warn "*** ", @_, "\n" if $debug;
}

sub sigchld {
    wait;
    $exit_code = $?;
    bugout "Caught SIGCHLD, exit code is $exit_code";
    $SIG{CHLD} = \&sigchld;
}
$SIG{CHLD} = \&sigchld;

sub spawn {
    my (@argv) = @_;

    # A relative path won’t work if we chdir to a playpen directory:
    $argv[0] = abs_path($argv[0]) if $playpen;

    # Create playpen dir in parent so our exit will clean it up:
    my $playpen_dir = $playpen ? tempdir("runner-XXXXXX", TMPDIR => 1, CLEANUP => 1) : ".";

    $pid = fork;
    die "$0: fork failed: $!\n" unless defined($pid);
    if ($pid == 0) {					# child process
        my $slave = $pty->slave;
        my $fileno = $slave->fileno;
        $pty->make_slave_controlling_terminal;
        close $pty;
        # Reopen the standard file descriptors in the child to use the pty:
        open STDIN,  "<&$fileno" or die "$0: can't reopen STDIN: $!\n";
        open STDOUT, ">&$fileno" or die "$0: can't reopen STDOUT: $!\n";
        open STDERR, ">&$fileno" or die "$0: can't reopen STDERR: $!\n";
        close $slave;
	chdir $playpen_dir or die "$0: can't chdir $playpen_dir: $!\n";
        exec @argv or die "$0: can't exec @argv: $!\n";
    }
    bugout "Spawned @argv as pid $pid on ", $pty->ttyname, " in $playpen_dir";
    $pty->close_slave;
}

sub show_exit_code() {
    bugout "exit code is ", $exit_code // "undefined";
    return unless defined($exit_code);
    if ($exit_code & 127) {
    	my $sig = (split / /,$Config{sig_name})[$exit_code & 127] || "UNKNOWN";
	print "$ARGV[0] terminated with signal SIG$sig\n";
    }
}

sub slurp($) {
    my ($filename) = @_;
    open my $fh, "<", $filename or return "";
    local $/;					# enable local slurp mode
    return <$fh> // "";
}

# Given a process id, is that proces blocked reading from a tty?
# Further, is this a new read, and not the same read that we noted last time?
# It may be that the process hasn’t had time to do the previous read, yet.
#
# Java uses a threaded interpreter (at least on my machine)
# so extend this concept to any of the threads.

sub wants_input() {
    for my $dir (</proc/$pid/task/*>) {
	# Is this process waiting for a read from a tty, or stuck in poll?
	next unless slurp("$dir/wchan")
			=~ /^(n_tty_read|poll_schedule_timeout)$/;

	# Fine, it’s reading.  Is this the same old read as last time?
	my $io = slurp("$dir/io");
	my $success = $io ne $previous_io;
	$previous_io = $io;
	return 1 if $success;
    }

    return 0;				# no luck, indicate failure
}

# Get this only once:
my $clock_ticks = POSIX::sysconf(&POSIX::_SC_CLK_TCK);

sub check_cpu_time() {
    open my $fh, "/proc/$pid/stat" or return 0;
    my $line = <$fh>;
    defined($line) or return 0;
    my @data = split(/ /, $line);
    @data >= 14 or return 0;			# It’s the 14th field
    my $used = $data[13] / $clock_ticks;
    warn "$0: program used $used seconds of CPU, max is $max_cpu.\n"
	if $used > $max_cpu;
}

sub check_real_time() {
    my $used = time() - $^T;
    warn "$0: program took $used seconds real time, max is $max_real.\n"
	if $used > $max_real;
}

sub check_eof_reads() {
    warn "$0: program read at end of file $count_eof times, max is $max_eof.\n"
        if $count_eof > $max_eof;
}

sub check_lines() {
    warn "$0: program wrote $count_lines lines, max is $max_lines.\n"
        if $count_lines > $max_lines;
}

sub check_chars() {
    warn "$0: program wrote $count_chars chars, max is $max_chars.\n"
        if $count_chars > $max_chars;
}


sub usage() {
    die "usage: $0 [options] program [args] [<input]\n",
	"-t S, --timeout S  timeout, in seconds, reading from process\n",
	"--maxeof N         allow no more than N reads from EOF\n",
	"--maxcpu S         cpu limit, in seconds\n",
	"--maxreal S        real time limit, in seconds\n",
	"--maxlines N       maximum number of output lines\n",
	"--maxchars N       maximum number of output characters\n",
	"-p, --playpen      run in a temporary directory\n",
	"--no-crlf          don't translate CRLF to newline\n",
	"-d, --debug        produce debug output\n";
}

### Main:

GetOptions("t|timeout=f"     => \$input_timeout,
           "maxeof=i"        => \$max_eof,
	   "maxcpu=i"        => \$max_cpu,
	   "maxreal=i"       => \$max_real,
	   "maxchars=i"      => \$max_chars,
	   "maxlines=i"      => \$max_lines,
	   "p|playpen!"	     => \$playpen,
	   "crlf!"	     => \$crlf_translate,
	   "d|debug!"	     => \$debug)
    or usage();

@ARGV or usage();

spawn(@ARGV);

until (check_cpu_time() || check_real_time() || check_eof_reads() ||
       check_lines() || check_chars()) {

    vec(my $rin = '', fileno($pty), 1) = 1;
    if (select($rin, undef, undef, $input_timeout) > 0) {
	my $count = $pty->sysread(my $output, 8192);
	bugout "sysread from program returned ", ($count // "undef");
	last unless $count;				# end on EOF or error
	$output =~ s/\r\n/\n/g if $crlf_translate;
	$count_lines += ($output =~ tr/\n/\n/);
	$count_chars += length($output);
	print $output; $|=1;
    }
    elsif (wants_input()) {
	my $line = <STDIN>;
	bugout "read ", (defined($line) ? length($line) : "undef"), " stdin bytes";
	unless (defined($line)) {
	    ++$count_eof;
	    $line = "\cD";		# control-D means EOF for a tty/pty
	}
	$line =~ tr/\n/\r/;		# line from file has \n, pty wants \r
	$pty->syswrite($line);		# Send it to program
    }
}

show_exit_code();
$exit_code ||= 0;			# In case it’s undefined
exit $exit_code;