# test INTERcal NETworking -- STEAL / SMUGGLE statements

# 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/08steal.t 1.-94.-2.4

use strict;
use POSIX qw(WNOHANG);
use FindBin qw($Bin);
use File::Spec::Functions qw(updir catfile);

use Language::INTERCAL::Time '1.-94.-2.3', qw(current_time);
my $started;
BEGIN { $started = current_time; }

use Language::INTERCAL::Extensions '1.-94.-2.4', qw(load_extension);
BEGIN { load_extension('INET'); }

use Language::INTERCAL::RegTypes '1.-94.-2.2', qw(REG_spot REG_twospot REG_whp);
use Language::INTERCAL::ByteCode '1.-94.-2.4', qw(:BC BC);
use Language::INTERCAL::TestBC '1.-94.-2.4', qw(test_newint test_reginit test_rc test_bc);
use Language::INTERCAL::Theft '1.-94.-2.4';
use Language::INTERCAL::Server::Test '1.-94.-2.4';
use Language::INTERCAL::Rcfile '1.-94.-2.4';
use Language::INTERCAL::Sick '1.-94.-2.4';
use Language::INTERCAL::Interpreter '1.-94.-2.4';
use Language::INTERCAL::INET::Extend '1.-94.-2.4', qw(theft_default_server);
use Language::INTERCAL::GenericIO '1.-94.-2.2', qw($stdsplat);

my @all_tests = (
    ['Start thief process', sub { }], # record what happened before running test_bc()
    ['Start theft server', \&command, 'start theft', 0],
    ['Start victim', \&command, 'start victim', 1],
    ['Steal scalar register', undef, '', "XLII\n", undef, undef,
     'DO STEAL .1 ON :42 FROM :43', [],
      [BC_STE, BC(1), BC_TSP, BC(43), BC(1), BC_TSP, BC(42), BC(1), BC_SPO, BC(1)],
     'DO READ OUT .1', [], [BC_ROU, BC(1), BC_SPO, BC(1)]],
    ['Steal array register', undef, '', "XI\nXII\nXIII\nXIV\n", undef, undef,
     'DO STEAL ,1 ON :42 FROM :43', [],
      [BC_STE, BC(1), BC_TSP, BC(43), BC(1), BC_TSP, BC(42), BC(1), BC_TAI, BC(1)],
     'DO READ OUT ,1 SUB #1 + ,1 SUB #2 + ,1 SUB #3 + ,1 SUB #4',
      [], [BC_ROU, BC(4), BC_SUB, BC(1), BC_TAI, BC(1),
			  BC_SUB, BC(2), BC_TAI, BC(1),
			  BC_SUB, BC(3), BC_TAI, BC(1),
			  BC_SUB, BC(4), BC_TAI, BC(1)]],
    ['Steal class register', undef, '', "MXLII\n", undef, undef,
     'DO STEAL @24 ON :42 FROM :43', [],
      [BC_STE, BC(1), BC_TSP, BC(43), BC(1), BC_TSP, BC(42), BC(1), BC_WHP, BC(24)],
     'DO ENROL .1 TO LEARN #42', [], [BC_ENR, BC(1), BC(42), BC_SPO, BC(1)],
     'DO .1 <- #1042', [], [BC_STO, BC(1042), BC_SPO, BC(1)],
     'DO .1 LEARNS #42', [], [BC_LEA, BC(42), BC_SPO, BC(1)],
     'DO GIVE UP', [], [BC_GUP],
     '(1042) DO READ OUT $@24', [BC_LAB, BC(1042)], [BC_ROU, BC(1), BC_BLM, BC(1), BC_WHP, BC(24)],
     'DO FINISH LECTURE', [], [BC_FIN]],
    ['Steal overloaded scalar register', undef, '', "VI\n", undef, undef,
     'DO STEAL :1 ON :42 FROM :43', [],
      [BC_STE, BC(1), BC_TSP, BC(43), BC(1), BC_TSP, BC(42), BC(1), BC_TSP, BC(1)],
     'DO READ OUT .1', [], [BC_ROU, BC(1), BC_TSP, BC(1)]],
    ['Steal overloaded array register', undef, '', "IX\n", undef, undef,
     'DO STEAL ;1 ON :42 FROM :43', [],
      [BC_STE, BC(1), BC_TSP, BC(43), BC(1), BC_TSP, BC(42), BC(1), BC_HYB, BC(1)],
     'DO READ OUT .1', [], [BC_ROU, BC(1), BC_HYB, BC(1)]],
    ['Steal overloaded array element', undef, '', "XIII\n", undef, undef,
     'DO STEAL ;2 ON :42 FROM :43', [],
      [BC_STE, BC(1), BC_TSP, BC(43), BC(1), BC_TSP, BC(42), BC(1), BC_HYB, BC(2)],
     'DO READ OUT .1', [], [BC_ROU, BC(1), BC_SUB, BC(1), BC_HYB, BC(2)]],
    ['Steal filehandle', undef, '', "MCCXXXVI\n", undef, undef,
     'DO STEAL @1 ON :42 FROM :43', [],
      [BC_STE, BC(1), BC_TSP, BC(43), BC(1), BC_TSP, BC(42), BC(1), BC_WHP, BC(1)],
     'DO WRITE IN .1', [], [BC_WIN, BC(1), BC_SPO, BC(1)],
     'DO READ OUT .1', [], [BC_ROU, BC(1), BC_SPO, BC(1)]],
    ['Stop victim', \&command, 'stop victim'],
    ['Stop theft server', \&command, 'stop theft'],
);

my $rc = Language::INTERCAL::Rcfile->new();
$rc->setoption(nouserrc => 1);
$rc->setoption(nosystemrc => 1);
$rc->rcfind('system');
$rc->rcfind('INET');
$rc->load;

# run all tests in the "thief" process... which we have to create first
$SIG{CHLD} = sub { 1 while waitpid(-1, WNOHANG) > 0 };
my $test = Language::INTERCAL::Server::Test->new;
$test->stdout(1);
my $pid = $test->create(\&thief);
$test->stdout(0);
my %pids;
my $theft_port;
my $timeout;
while (defined (my $info = $test->get_info($pid, 1))) {
    $info eq 'end' and last;
    my $msg;
    eval {
	if (! defined $timeout) {
	    my $now = current_time;
	    $now -= $started;
	    $timeout = int(($now->numify + 31000) / 32000);
	}
	if ($info eq 'start theft') {
	    timeout($timeout, \&start_theft);
	    $msg = $theft_port;
	} elsif ($info eq 'start victim') {
	    timeout($timeout, \&start_victim, $theft_port);
	    $msg = $pids{victim};
	} elsif ($info =~ /^stop\s+(\S+)\s*$/) {
	    my $who = $1;
	    exists $pids{$who} or die "Process $who was never started\n";
	    my $k = delete $pids{$who};
	    for my $sig (qw(INT TERM TERM TERM KILL), undef) {
		defined $sig or die "Could not stop $who\n";
		kill $sig, $k or last;
		select undef, undef, undef, 0.1;
	    }
	    $msg = 'OK';
	} else {
	    # XXX any more commands?
	}
    };
    if ($@) {
	$msg = $@;
	$msg =~ s/\s+/ /g;
	$msg =~ s/^ ?/ERR: /;
    } elsif (! $msg) {
	$msg = "ERR: could not run command ($info)";
    }
    $test->send_request($pid, $msg);
}
exit 0;

sub start_theft {
    # server is in blib/script and we don't want to search for it or we may
    # get the wrong one
    my @theft = (
	$^X,
	(map { ('-I', $_) } @INC),
	catfile($Bin, updir(), qw(blib script theft-server)),
	qw(--port 0 --show-port --show-pid --linger 15 --testing),
	#'--debug',
    );
    my $tp = $test->create(@theft) or die "theft-server: $!\n";
    my ($port, $rp);
    while (defined (my $line = $test->get_info($tp, 1))) {
	$line =~ /^PID:\s*(\d+)\b/ and $rp = $1;
	$line =~ /^PORT:\s*(\d+)\b/ and $port = $1;
	$line =~ /__END__/ and last;
    }
    defined $port or die "theft-server did not indicate listening port\n";
    defined $rp or die "theft-server did not indicate its PID\n";
    $rp == $tp or die "theft-server supposed to be PID $tp but indicate $rp?\n";
    $theft_port = $port;
    $pids{theft} = $tp;
}

sub start_victim {
    my ($port) = @_;
    my $tp = $test->create(\&victim, $port) or die "victim: $!\n";
    my $line = $test->get_info($tp, 1);
    defined $line or die "No answer from victim process\n";
    $pids{victim} = $tp;
}

sub victim {
    my ($server, $theft_port) = @_;
    # set up an interpreter...
    my $obj = new Language::INTERCAL::Interpreter();
    my $theft = Language::INTERCAL::Theft->_new(
	$server,
	$theft_port,
	[],
	[(0) x 16],
	\&Language::INTERCAL::INET::Extend::_theft,
	$obj,
    );
    my $myport = $theft->victim_port;
    theft_default_server($theft);
    $obj->server($server);
    # generate some code to set up some registers and then wait forever
    my @code;
    for my $stmt (
	# a scalar register (.1)
	[BC_STO, BC(42), BC_SPO, BC(1)],
	# an array (,1)
	[BC_STO, BC(4), BC_TAI, BC(1)],
	[BC_STO, BC(11), BC_SUB, BC(1), BC_TAI, BC(1)],
	[BC_STO, BC(12), BC_SUB, BC(2), BC_TAI, BC(1)],
	[BC_STO, BC(13), BC_SUB, BC(3), BC_TAI, BC(1)],
	[BC_STO, BC(14), BC_SUB, BC(4), BC_TAI, BC(1)],
	# a class (@24)
	[BC_STO, BC(1042), BC_SUB, BC(42), BC_WHP, BC(24)],
	# an overloaded scalar register (:1)
	[BC_STO, BC_OVR, BC_INT, BC(1), BC(2), BC_TSP, BC(1), BC_SPO, BC(42)],
	# an overloaded array register (;1)
	[BC_IGN, BC(1), BC_SPO, BC(42)],
	[BC_STO, BC_OVR, BC_INT, BC(2), BC(1), BC_HYB, BC(1), BC_SPO, BC(42)],
	# an overloaded array element (;2 SUB #1)
	[BC_STO, BC(1), BC_HYB, BC(2)],
	[BC_STO, BC_OVR, BC_INT, BC(2), BC(3), BC_SUB, BC(1), BC_HYB, BC(2), BC_SPO, BC(42)],
	# inform that we are ready
	[BC_ROU, BC(2), BC_WHP, BC(42), BC(1)],
	# and now wait for Godot
	[BC_LAB, BC(1), BC_CFL, BC(1)],
	[BC_GUP],
    ) {
	push @code, pack('C*', BC_STS, BC(scalar @code), BC(1), BC(0), BC(0), @$stmt);
    }
    $WARNFH::info_server = $server;
    my $send_info = bless {}, 'WARNFH';
    my $rdata = "ONE TWO THREE SIX\n";
    my $rfh = Language::INTERCAL::GenericIO->new('STRING', 'w', \$rdata);
    eval {
	$obj->object->setbug(0, 0);
	$obj->object->clear_code();
	$obj->object->unit_code(0, 'x' x scalar(@code), scalar @code, \@code);
	$obj->setreg('@OWFH', $rfh, REG_whp);
	$obj->setreg('@ORFH', $stdsplat, REG_whp);
	$obj->setreg('@OSFH', $stdsplat, REG_whp);
	$obj->setreg('@42', $send_info, REG_whp);
	#$obj->setreg('@TRFH', $stdsplat, REG_whp);
	#$obj->setreg('%TM', 1, REG_spot);
	$obj->start()->run()->stop();
    };
    $@ and print STDERR $@;
    my $os = $obj->splat;
    defined $os and print STDERR "*$os\n";
}

sub timeout {
    my ($to, $code, @args) = @_;
    local $SIG{ALRM} = sub { die "Timed out\n" };
    alarm $to;
    $code->(@args);
    alarm 0;
}

# the following is executed in the "thief" process which also has the
# standard output to the test harness
{
    my ($timeout, $server, $theft, @data);

    sub thief {
	($server) = @_;
	test_rc($rc);
	test_newint(sub {
	    my ($int) = @_;
	    $int->server($server);
	    $data[0] or return;
	    if (! $theft) {
		$theft = Language::INTERCAL::Theft->_new(
		    $server,
		    $data[0],
		    [],
		    [(0) x 16],
		    \&Language::INTERCAL::INET::Extend::_theft,
		    $int,
		);
		theft_default_server($theft);
	    }
	    $int->{theft_server} = $theft;
	});
	test_reginit(sub {
	    my ($int) = @_;
	    $data[1] and $int->setreg(':42', $data[1], REG_twospot);
	    $int->setreg(':43', 0x7f000001, REG_twospot);
	    #$int->setreg('@TRFH', $stdsplat, REG_whp);
	    #$int->setreg('%TM', 1, REG_spot);
	});
	test_bc(@all_tests);
	$server->info('end');
    }

    sub command {
	my ($cmd, $store) = @_;
	my $line;
	if (! defined $timeout) {
	    my $now = current_time;
	    $now -= $started;
	    $timeout = int(($now->numify + 15000) / 16000);
	}
	timeout($timeout, sub {
	    $server->info($cmd);
	    $line = $server->write_in('', 1);
	});
	$server->read_out('', 'OK');
	defined $line or die "No reply from command ($cmd)\n";
	$line =~ s/^ERR:\s+// and die "$line\n";
	defined $store and $data[$store] = $line;
    }
}

# used just to READ OUT from the victim to inform parent that it's ready

package WARNFH;

use vars qw(@ISA $info_server);
BEGIN { @ISA = qw(Language::INTERCAL::GenericIO); }

sub read_binary {
    $info_server->info('OK');
}

