# Check the GenericIO code / REMOTE

# Copyright (c) 2023 Claudio Calvelli, all rights reserved.

# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
# and distribute it is granted provided that the conditions set out in the
# licence agreement are met. See files README and COPYING in the distribution.

# PERVERSION: CLC-INTERCAL/INET t/01io.t 1.-94.-2.4

use strict;

use POSIX ':sys_wait_h';
use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END);

use Language::INTERCAL::GenericIO '1.-94.-2.2';
use Language::INTERCAL::GenericIO::REMOTE '1.-94.-2.4';
use Language::INTERCAL::Server::Test '1.-94.-2.4';
use Language::INTERCAL::INET::Extend '1.-94.-2.4';
use Language::INTERCAL::Extensions '1.-94.-2.4', qw(load_extension);

use constant NEED_SERVER       => 0x01;
use constant NEED_PROV         => 0x02;
use constant NEED_USER         => 0x04;

use constant PROV              => 0;
use constant USER              => 1;

# port to use for the REMOTE filehandle: this is not a real TCP port but
# rather one to use with Server::Test
use constant FH_PORT           => 12345;
use constant FH_HOST           => '192.168.1.2';
use constant FH_DATA           => join(':', FH_HOST, FH_PORT);

use constant MESSAGE1          => "Black lives matter. ";
use constant MESSAGE2          => "Homophobes and transphobes are terrorists. ";

load_extension('INET');

my (@pids, $server, $tell1, $tell2);
my $ft = 42;

my @tests = (
    ['Setup test server', 0, \&setup_server],
    ['Start provider process', NEED_SERVER, \&start, PROV],
    ['Start user process', NEED_PROV, \&start, USER],

    # tests on a seekable filehandle
    ['Describe (prov)', NEED_PROV, \&describe, PROV, qr/^STRING\(r\+, ARRAY\(.*\)\)$/],
    ['Describe (user)', NEED_USER, \&describe, USER, 'REMOTE(' . FH_HOST . ':' . FH_PORT . ')'],
    ['Read out 1', NEED_USER | NEED_PROV, \&read_out, USER, MESSAGE1],
    ['Tell 1 (user)', NEED_USER | NEED_PROV, \&tell, USER, \$tell1],
    ['Write in 1 (prov)', NEED_PROV, \&write_in, PROV, 0, MESSAGE1],
    ['Write in 1 (user)', NEED_USER | NEED_PROV, \&write_in, USER, 0, MESSAGE1],
    ['Tell 1 (prov)', NEED_PROV, \&tell, PROV, \$tell1],
    ['Read out 2', NEED_USER | NEED_PROV, \&read_out, USER, MESSAGE2],
    ['Tell 2 (user)', NEED_USER | NEED_PROV, \&tell, USER, \$tell2],
    ['Write in 2 (prov)', NEED_PROV, \&write_in, PROV, \$tell1, MESSAGE2],
    ['Write in 2 (user)', NEED_USER | NEED_PROV, \&write_in, USER, \$tell1, MESSAGE2],
    ['Tell 2 (prov)', NEED_PROV, \&tell, PROV, \$tell2],
    ['seek start (user)', NEED_USER | NEED_PROV, \&seek, USER, 0, 'SET'],
    ['seek cur (user)', NEED_USER | NEED_PROV, \&seek, USER, $ft, 'CUR'],
    # check that all the seeks on user did not change file pos on provider
    ['Tell 3 (prov)', NEED_PROV, \&tell, PROV, \$tell2],
    ['Tell 3 (user)', NEED_USER | NEED_PROV, \&tell, USER, \$ft],
    ['seek end (user)', NEED_USER | NEED_PROV, \&seek, USER, 0, 'END'],
    ['Tell 4 (user)', NEED_USER | NEED_PROV, \&tell, USER, \$tell2],
    # check that all the seeks on user did not change file pos on provider
    ['Tell 4 (prov)', NEED_PROV, \&tell, PROV, \$tell2],

    # tests on a non-seekable filehandle
    ['Reopen', NEED_PROV, \&reopen],
    ['Describe (prov)', NEED_PROV, \&describe, PROV, 'ARRAY'],
    ['Describe (user)', NEED_USER, \&describe, USER, 'REMOTE(' . FH_HOST . ':' . FH_PORT . ')'],
    ['Write in (user)', NEED_USER | NEED_PROV, \&write_in, USER, '-', MESSAGE1],
    ['Write in (prov)', NEED_PROV, \&write_in, PROV, '-', MESSAGE2],

    ['Stop user process', NEED_USER, \&stop, USER],
    ['Stop provider process', NEED_PROV, \&stop, PROV],
);

my $num_tests = @tests;
print "1..$num_tests\n";

$SIG{CHLD} = sub { 1 while waitpid(-1, WNOHANG) > 0 };

my $num = 0;
$| = 1;
for my $test (@tests) {
    my ($name, $flags, $code, @args) = @$test;
    eval {
	($flags & NEED_SERVER) && ! $server
	    and die "Cannot run test without a test server\n";
	($flags & NEED_PROV) && ! $pids[PROV]
	    and die "Cannot run test without a provider process\n";
	($flags & NEED_USER) && ! $pids[USER]
	    and die "Cannot run test without a user process\n";
	$code->(@args);
    };
    if ($@) {
	print "not ok ", ++$num, " $name -> $@";
    } else {
	print "ok ", ++$num, " $name\n";
    }
}

sub setup_server {
    $server = Language::INTERCAL::Server::Test->new;
}

sub start {
    my ($which) = @_;
    my $pid = $server->create(\&process, $which);
    local $SIG{ALRM} = sub { die "Timed out\n" };
    alarm 5;
    $server->send_request($pid, "Q");
    alarm 0;
    $pids[$which] = $pid;
}

sub stop {
    my ($which) = @_;
    my $pid = $pids[$which];
    $server->send_request($pid, "G");
    kill 0, $pid or return;
    my @signal = (('INT') x 2, ('TERM') x 2, 'KILL');
    while (@signal) {
	my $s = shift @signal;
	if (kill $s, $pid) {
	    select undef, undef, undef, 0.4;
	    kill 0, $pid and next;
	}
	$pids[$which] = undef;
	return;
    }
}

sub tell {
    my ($which, $expected) = @_;
    my $msg = $server->send_request($pids[$which], "T");
    defined $msg or die "No reply from process\n";
    $msg =~ /^OK\s*(\d+)\b/ or die "$msg\n";
    my $pos = $1;
    if (defined $$expected) {
	$pos == $$expected or die "Invalid reply: expected <$$expected>, got <$pos>\n";
    } else {
	$$expected = $pos;
    }
}

sub seek {
    my ($which, $pos, $end) = @_;
    my $msg = $server->send_request($pids[$which], "S$pos $end");
    defined $msg or die "No reply from process\n";
    $msg =~ /^OK/ or die "$msg\n";
}

sub read_out {
    my ($which, $message) = @_;
    my $msg = $server->send_request($pids[$which], "R$message");
    defined $msg or die "No reply from process\n";
    $msg =~ /^OK/ or die "$msg\n";
}

sub write_in {
    my ($which, $pos, $expected) = @_;
    my $len = length $expected;
    ref $pos and $pos = $$pos;
    my $msg = $server->send_request($pids[$which], "W$pos $len");
    defined $msg or die "No reply from process\n";
    $msg =~ s/^OK// or die "$msg\n";
    $msg eq $expected or die "Invalid reply: expected <$expected>, got <$msg>\n";
}

sub reopen {
    my $msg = $server->send_request($pids[PROV], "X");
    defined $msg or die "No reply from process\n";
    $msg =~ /^OK/ or die "$msg\n";
}

sub describe {
    my ($which, $expected) = @_;
    my $msg = $server->send_request($pids[$which], "D");
    defined $msg or die "No reply from process\n";
    $msg =~ s/^OK\s*// or die "$msg\n";
    if (ref $expected) {
	$msg =~ $expected
	    or die "Invalid description returned: <$msg>, expected to match $expected\n";
    } else {
	$msg eq $expected
	    or die "Invalid description returned: <$msg>, expected <$expected>\n";
    }
}

sub process {
    my ($server, $which) = @_;
    my $handle;
    if ($which == USER) {
	$handle = Language::INTERCAL::GenericIO->new('REMOTE', 'r+', FH_DATA, $server);
    } elsif ($which == PROV) {
	my $data = '';
	$handle = Language::INTERCAL::GenericIO->new('STRING', 'r+', \$data);
	Language::INTERCAL::INET::Extend::_fh_export($server, $handle, FH_PORT);
    }
    while (1) {
	my $line = $server->write_in('', 1);
	defined $line or last;
	eval {
	    if ($line =~ /^Q/) {
		$server->read_out('', "OK");
	    } elsif ($line =~ /^G/) {
		$server->read_out('', "OK");
		$server->progress(0);
		last;
	    } elsif ($line =~ s/^R//) {
		$handle->read_text($line);
		$server->read_out('', "OK");
	    } elsif ($line =~ /^T/) {
		my $pos = $handle->tell;
		$server->read_out('', "OK$pos");
	    } elsif ($line =~ /^W\s*(-|\d+)\s+(\d+)\b/) {
		my ($seek, $len) = ($1, $2);
		$seek ne '-' and $handle->seek($seek);
		my $data = $handle->write_binary($len);
		$server->read_out('', "OK$data");
	    } elsif ($line =~ /^S\s*(\d+)\s+(SET|CUR|END)\b/) {
		my ($seek, $end) = ($1, $2);
		$end = { SET => SEEK_SET, CUR => SEEK_CUR, END => SEEK_END }->{$end};
		$handle->seek($seek, $end);
		$server->read_out('', "OK");
	    } elsif ($which == PROV && $line =~ s/^X//) {
		my @data = (MESSAGE1, MESSAGE2);
		my $nh = Language::INTERCAL::GenericIO->new('ARRAY', 'w', \@data);
		Language::INTERCAL::INET::Extend::_fh_reopen($handle, $nh);
		$server->read_out('', "OK");
	    } elsif ($line =~ s/^D//) {
		my $d = $handle->describe;
		defined $d or die "Describe: no information\n";
		$server->read_out('', "OK$d");
	    } else {
		$server->read_out('', "Unknown message <$line>");
	    }
	};
	if ($@) {
	    print STDERR $@;
	    (my $msg = $@) =~ s/\s+/ /g;
	    $server->read_out('', "ERR: $msg");
	}
    }
}

