<commit_before>#!/usr/bin/perl

# Driver for testing Text-User-Interfaces (e.g. curses applications).

use strict;
use warnings;
use diagnostics;
use English '-no_match_vars';

use Data::Dumper;
use IO::Pty::Easy;
use Term::VT102;
use Time::HiRes qw{ gettimeofday };
use POSIX qw{ floor :sys_wait_h };

use Exporter;
use base qw{ Exporter };
use vars qw{ @EXPORT_OK };
@EXPORT_OK = qw{ application_under_test
                 run_test_script
                 test_script
                 testtuiset };

my (@application_under_test,
    @script,
    %setters,
    $pty,
    $terminal,
    $write_timeout,
    $read_timeout,
    $until_timeout,
    $until_fraction,
    $exit_timeout,
    $expect_wait,
    $write_default_wait,
    $trace,
    $debug,
    $dump,
    $term_lines,
    $term_cols,
    $last_was_write,
    $child_pid,
    $child_status);

sub REAPER {
    my $pid;

    while (($pid = waitpid(-1, WNOHANG)) > 0) {
        if ($pid == $child_pid) {
            $child_status = $CHILD_ERROR;
        }
    }
    $SIG{CHLD} = \&REAPER;
}
$SIG{CHLD} = \&REAPER;

$expect_wait = 200;
$write_default_wait = 100;
$until_timeout = 1000;
$until_fraction = $until_timeout / 10;
$read_timeout = 2 / 1000;
$write_timeout = 500 / 1000;
$exit_timeout = 5e3;
$trace = 0;
$debug = 0;
$dump = 0;
$term_lines = 24;
$term_cols = 80;
$last_was_write = 0;

sub application_under_test {
    @application_under_test = @_;
}

sub test_script {
    my ($script) = @_;
    @script = @{ $script };
}

sub testtuiset {
    my ($data) = @_;

    if (ref $data ne q{HASH}) {
        print "# testtuiset: argument needs to be a hashref.\n";
        clean_exit(42);
    }

    foreach my $key (sort keys %{ $data }) {
        if (defined $setters{$key}) {
            $setters{$key}->($data->{$key});
        } else {
            print "# testtuiset: Unknown parameter `$key'.\n";
            clean_exit(42);
        }
    }
}

%setters = (
    expect_wait => sub { $expect_wait = $_[0] },
    write_wait => sub { $write_default_wait = $_[0] },
    until_timeout => sub { $until_timeout = $_[0] },
    until_fraction => sub { $until_fraction = $_[0] },
    write_timeout => sub { $write_timeout = $_[0] / 1000 },
    read_timeout => sub { $read_timeout = $_[0] / 1000 },
    debug => sub { $debug = ($_[0] != 0) ? 1 : 0 },
    dump => sub { $dump = ($_[0] != 0) ? 1 : 0 },
    trace => sub { $trace = ($_[0] != 0) ? 1 : 0 },
    terminal_lines => sub { $term_lines = $_[0] },
    terminal_columns => sub { $term_cols = $_[0] }
);

sub print_if {
    my ($cond, @rest) = @_;
    print @rest if ($cond);
}

sub trace {
    print_if($trace, @_);
}

sub debug {
    print_if($debug, @_);
}

sub use_if_defined {
    my ($what, $else) = @_;

    return $what if (defined $what);
    return $else;
}

sub tt_index {
    my ($idx) = @_;
    print "# That is entry #$idx in the test-script (index starting at 0).\n";
}

sub tt_dump {
    my ($head, $thing) = @_;
    print "# $head\n";
    print "# ----------\n";
    map { print "# $_\n" } split(/\n/, Dumper($thing));
    print "# ----------\n";
}

sub tt_terminal_dump {
    print "# /--------- ---------- ---------- ----------\n";
    for my $i (1 .. $terminal->rows()) {
        print "# |", $terminal->row_plaintext($i), "\n";
    }
    print "# \\--------- ---------- ---------- ----------\n";
}

sub read_a_bit {
    my $data = $pty->read($read_timeout);
    my $l = (defined $data) ? length $data : 0;
    if ($l > 0) {
        debug("#    -*- Sending $l byte(s) to terminal buffer\n");
    } else {
        #debug("#    -*- Sending nothing to terminal buffer\n");
    }
    $terminal->process($data);
}

sub tt_wait {
    my ($duration) = @_;
    my $timestamp = get_msec_timestamp();

    while (!timeouted($duration, $timestamp)) {
        read_a_bit();
    }
    tt_terminal_dump() if ($dump);
}

sub get_msec_timestamp {
    my ($sec, $usec) = gettimeofday();
    return ($sec * 1000) + ($usec / 1000);
}

sub timeouted {
    my ($timeout, $timestamp) = @_;
    my $new = get_msec_timestamp();
    my $test = $timestamp + $timeout;
    #debug("#    -*- $new >? $test\n");
    return $new > $test;
}

sub unexpected_death {
    my ($thing, $num) = @_;

    tt_dump("Application under test:", \@application_under_test);
    tt_dump(
        "...died unexpectedly before the following could be handled:", $thing);
    print "# That is entry #$num in the test-script (index starting at 0).\n";
    clean_exit(23);
}

sub broken_test_script {
    my ($thing, $num) = @_;
    tt_dump("Unknown/Disallowed entry in test-script:", $thing);
    tt_index($num);
    print "# ...giving up.\n";
    clean_exit(42);
}<commit_msg>Use floor in get_msec_timestamp()<commit_after>#!/usr/bin/perl

# Driver for testing Text-User-Interfaces (e.g. curses applications).

use strict;
use warnings;
use diagnostics;
use English '-no_match_vars';

use Data::Dumper;
use IO::Pty::Easy;
use Term::VT102;
use Time::HiRes qw{ gettimeofday };
use POSIX qw{ floor :sys_wait_h };

use Exporter;
use base qw{ Exporter };
use vars qw{ @EXPORT_OK };
@EXPORT_OK = qw{ application_under_test
                 run_test_script
                 test_script
                 testtuiset };

my (@application_under_test,
    @script,
    %setters,
    $pty,
    $terminal,
    $write_timeout,
    $read_timeout,
    $until_timeout,
    $until_fraction,
    $exit_timeout,
    $expect_wait,
    $write_default_wait,
    $trace,
    $debug,
    $dump,
    $term_lines,
    $term_cols,
    $last_was_write,
    $child_pid,
    $child_status);

sub REAPER {
    my $pid;

    while (($pid = waitpid(-1, WNOHANG)) > 0) {
        if ($pid == $child_pid) {
            $child_status = $CHILD_ERROR;
        }
    }
    $SIG{CHLD} = \&REAPER;
}
$SIG{CHLD} = \&REAPER;

$expect_wait = 200;
$write_default_wait = 100;
$until_timeout = 1000;
$until_fraction = $until_timeout / 10;
$read_timeout = 2 / 1000;
$write_timeout = 500 / 1000;
$exit_timeout = 5e3;
$trace = 0;
$debug = 0;
$dump = 0;
$term_lines = 24;
$term_cols = 80;
$last_was_write = 0;

sub application_under_test {
    @application_under_test = @_;
}

sub test_script {
    my ($script) = @_;
    @script = @{ $script };
}

sub testtuiset {
    my ($data) = @_;

    if (ref $data ne q{HASH}) {
        print "# testtuiset: argument needs to be a hashref.\n";
        clean_exit(42);
    }

    foreach my $key (sort keys %{ $data }) {
        if (defined $setters{$key}) {
            $setters{$key}->($data->{$key});
        } else {
            print "# testtuiset: Unknown parameter `$key'.\n";
            clean_exit(42);
        }
    }
}

%setters = (
    expect_wait => sub { $expect_wait = $_[0] },
    write_wait => sub { $write_default_wait = $_[0] },
    until_timeout => sub { $until_timeout = $_[0] },
    until_fraction => sub { $until_fraction = $_[0] },
    write_timeout => sub { $write_timeout = $_[0] / 1000 },
    read_timeout => sub { $read_timeout = $_[0] / 1000 },
    debug => sub { $debug = ($_[0] != 0) ? 1 : 0 },
    dump => sub { $dump = ($_[0] != 0) ? 1 : 0 },
    trace => sub { $trace = ($_[0] != 0) ? 1 : 0 },
    terminal_lines => sub { $term_lines = $_[0] },
    terminal_columns => sub { $term_cols = $_[0] }
);

sub print_if {
    my ($cond, @rest) = @_;
    print @rest if ($cond);
}

sub trace {
    print_if($trace, @_);
}

sub debug {
    print_if($debug, @_);
}

sub use_if_defined {
    my ($what, $else) = @_;

    return $what if (defined $what);
    return $else;
}

sub tt_index {
    my ($idx) = @_;
    print "# That is entry #$idx in the test-script (index starting at 0).\n";
}

sub tt_dump {
    my ($head, $thing) = @_;
    print "# $head\n";
    print "# ----------\n";
    map { print "# $_\n" } split(/\n/, Dumper($thing));
    print "# ----------\n";
}

sub tt_terminal_dump {
    print "# /--------- ---------- ---------- ----------\n";
    for my $i (1 .. $terminal->rows()) {
        print "# |", $terminal->row_plaintext($i), "\n";
    }
    print "# \\--------- ---------- ---------- ----------\n";
}

sub read_a_bit {
    my $data = $pty->read($read_timeout);
    my $l = (defined $data) ? length $data : 0;
    if ($l > 0) {
        debug("#    -*- Sending $l byte(s) to terminal buffer\n");
    } else {
        #debug("#    -*- Sending nothing to terminal buffer\n");
    }
    $terminal->process($data);
}

sub tt_wait {
    my ($duration) = @_;
    my $timestamp = get_msec_timestamp();

    while (!timeouted($duration, $timestamp)) {
        read_a_bit();
    }
    tt_terminal_dump() if ($dump);
}

sub get_msec_timestamp {
    my ($sec, $usec) = gettimeofday();
    return ($sec * 1000) + floor($usec / 1000);
}

sub timeouted {
    my ($timeout, $timestamp) = @_;
    my $new = get_msec_timestamp();
    my $test = $timestamp + $timeout;
    #debug("#    -*- $new >? $test\n");
    return $new > $test;
}

sub unexpected_death {
    my ($thing, $num) = @_;

    tt_dump("Application under test:", \@application_under_test);
    tt_dump(
        "...died unexpectedly before the following could be handled:", $thing);
    print "# That is entry #$num in the test-script (index starting at 0).\n";
    clean_exit(23);
}

sub broken_test_script {
    my ($thing, $num) = @_;
    tt_dump("Unknown/Disallowed entry in test-script:", $thing);
    tt_index($num);
    print "# ...giving up.\n";
    clean_exit(42);
}
{'fraction_non_alphanumeric': 0.19187479901382784, 'fraction_numerical': 0.018865902025940615, 'mean_word_length': 2.397669337217771, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 45, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2591878', 'n_tokens_mistral': 3519, 'n_tokens_neox': 3317, 'n_words': 821}