package Language::INTERCAL::Server::Test;

# Pseudo INTERNET (INTERcal NETworking) server to use for testing
# (or for tunnelling actually)

# This file is part of CLC-INTERCAL

# 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.

# it is intended that only one Server::Test object runs in a single perl
# interpreter; however it needs to look like an object so that it can be
# be passed to functions which expect a Server::INET object

# This Server consists of a central "router" process and a number of
# other processes which run the programs to test; the test program
# creates the "router" and then asks it to create all necessary processes

# Note that there is no upgrade() method and this does not provide the
# full Server; test programs need to explicitly create a Server::Test
# and use it, cannot accept an existing Server to use instead. However
# the object passed as server to the child processes will work as a
# normal Server or Server::INET except that it uses the emulated network.

# Emulated IPv6 is supported if the host supports it (or at least has
# inet_ntop() and inet_pton())

use strict;
use vars qw($VERSION $PERVERSION);
($VERSION) = ($PERVERSION = "CLC-INTERCAL/INET INTERCAL/Server/Test.pm 1.-94.-2.4") =~ /\s(\S+)$/;

use Carp;
use Socket qw(inet_aton);
use IO::Handle;
use Language::INTERCAL::Server::IPv6 '1.-94.-2.4', qw(has_ipv6);
use Language::INTERCAL::Exporter '1.-94.-2.4';
use Language::INTERCAL::Server '1.-94.-2.4';
use Language::INTERCAL::Extensions '1.-94.-2.4', qw(load_extension);
use Language::INTERCAL::Splats '1.-94.-2.3', qw(faint);

load_extension('INET');

my $has_ipv6 = has_ipv6();
my %interfaces = (
    lo   => [1, '127.0.0.1',   undef],
    test => [2, '10.1.2.3',    '10.255.255.255'],
    alt  => [3, '192.168.1.2', '192.168.255.255'],
);
my (%local_ip4, %local_ip6, %broadcast);
for my $if (keys %interfaces) {
    my (undef, $ip, $bc) = @{$interfaces{$if}};
    $local_ip4{inet_aton($ip)} = $if;
    defined $bc and $broadcast{inet_aton($bc)} = $if;
}
my @localhost4 = ($interfaces{lo}[0]);
my @localhost6;

if ($has_ipv6) {
    import Socket qw(inet_pton inet_ntop AF_INET6);
    push @{$interfaces{lo}}, '::1';
    @localhost6 = '::1';
    my @test = qw(2001:db8:1::1 fe80::db8:1:1);
    my @alt = qw(2001:db8:2::1 fe80::db8:2:1);
    push @{$interfaces{test}}, @test;
    push @{$interfaces{alt}}, @alt;
    $local_ip6{$_} = 'test' for map { inet_pton(&AF_INET6, $_) } @test;
    $local_ip6{$_} = 'alt' for map { inet_pton(&AF_INET6, $_) } @alt;
}

sub new {
    @_ == 1 or croak "Usage: Language::INTERCAL::Server::Test->new";
    my ($class) = @_;
    my $server = Language::INTERCAL::Server->new();
    my $test = bless {
	procs      => {},
	server     => $server,
	pipes      => {},
	tcp_port   => {},
	udp_port   => {},
	seqno      => 0,
	replies    => {},
	msgrepl    => {},
	info       => {},
	last_error => 'No error',
	stdout     => 0,
    }, $class;
    $server->{test_server} = $test;
    $test;
}

# special object which can only be used to get interface lists etc
# it will give an error if used in any other way
sub interfaces {
    @_ == 1 or croak "Usage: Language::INTERCAL::Server::Test->interfaces";
    Language::INTERCAL::Server::Test::Child->interfaces();
}

sub progress {
    @_ == 1 || @_ == 2 or croak "Usage: TEST->progress [(TIMEOUT)]";
    my $test = shift;
    $test->{server}->progress(@_);
    $test;
}

sub stdout {
    @_ == 2 or croak "Usage: TEST->stdout(ALLOWED?)";
    my ($test, $stdout) = @_;
    $test->{stdout} = $stdout;
    $test;
}

sub create {
    @_ >= 2 or croak "Usage: TEST->create(CODE [, ARGS]...)";
    my ($test, $code, @args) = @_;
    # each sub-process requires two pipes, one from router to process
    # and one in the other direction
    pipe(my $child_recv, my $parent_send) or die "pipe: $!\n";
    pipe(my $parent_recv, my $child_send) or die "pipe: $!\n";
    STDOUT->flush;
    STDERR->flush;
    my $pid = fork;
    defined $pid or die "fork: $!\n";
    if ($pid == 0) {
	# child process; make sure we don't return to caller, even
	# if for example it's in an eval
	eval {
	    close $parent_send;
	    close $parent_recv;
	    if (ref $code) {
		# execute this code as child process
		close STDIN;
		$test->{stdout} or close STDOUT;
		for my $pid (keys %{$test->{procs}}) {
		    close $test->{procs}{$pid}{send};
		    close $test->{procs}{$pid}{recv};
		}
		delete $test->{server};
		undef $test;
		my $server =
		    Language::INTERCAL::Server::Test::Child->new($child_send, $child_recv);
		$code->($server, @args);
	    } else {
		# $code is a program to exec and we expect it to use STDIN/STDOUT to talk to us
		open(STDIN, '<&', $child_recv) or die "reopen STDIN: $!\n";
		open(STDOUT, '>&', $child_send) or die "reopen STDOUT: $!\n";
		exec { $code } $code, @args;
		die "exec($code): $!\n";
	    }
	};
	$@ or exit(0);
	print STDERR $@;
	exit(1);
    }
    close $child_send;
    close $child_recv;
    $parent_send->autoflush(1);
    $parent_recv->blocking(0);
    $test->{procs}{$pid} = {
	send => $parent_send,
	recv => $parent_recv,
    };
    $test->{pipes}{fileno($parent_send)} = $pid;
    $test->{pipes}{fileno($parent_recv)} = $pid;
    $test->{server}->file_send($parent_send, \&_close);
    $test->{server}->file_receive($parent_recv, \&_close, \&_child_packet);
    $test->{server}->progress(0);
    $pid;
}

# this sets up a Server object for use by a process exec()-ed by create()
sub child {
    @_ == 1 or croak "Usage: Language::INTERCAL::Server::Test->child";
    Language::INTERCAL::Server::Test::Child->new(\*STDOUT, \*STDIN);
}

sub send_request {
    @_ == 3 or croak "Usage: SERVER->send_request(PID, MESSAGE)";
    my ($test, $pid, $message) = @_;
    exists $test->{procs}{$pid} or return undef;
    my $send = $test->{procs}{$pid}{send};
    delete $test->{msgrepl}{$pid};
    my $seqno = ++$test->{seqno};
    $test->{server}->read_out(fileno $send,
			      "+$seqno P" . encode_message($message));
    while (! exists $test->{msgrepl}{$pid}) {
	$test->{server}->progress();
	exists $test->{procs}{$pid} or return undef;
    }
    my $reply = delete $test->{msgrepl}{$pid};
    delete $test->{replies}{$seqno};
    $reply;
}

# one of the pipes to/from a child has been closed
sub _close {
    my ($server, $pipe) = @_;
    my $test = $server->{test_server} or return;
    my $id = fileno $pipe;
    exists $test->{pipes}{$id} or return;
    $test->close_child($test->{pipes}{$id});
}

sub close_child {
    @_ == 2 or croak "Usage: TEST->close_child(PID)";
    my ($test, $pid) = @_;
    exists $test->{procs}{$pid} or return $test;
    my $proc = delete $test->{procs}{$pid};
    eval { $test->{server}->file_send_close($proc->{send}); };
    eval { $test->{server}->file_receive_close($proc->{recv}); };
    close $proc->{send};
    close $proc->{recv};
    kill 'INT', $pid or return $test;
    select undef, undef, undef, 0.1;
    kill 'TERM', $pid or return $test;
    select undef, undef, undef, 0.1;
    kill 'KILL', $pid;
    $test;
}

sub get_info {
    @_ == 2 || @_ == 3 or croak "Usage: TEST->get_info(PID [, PROGRESS?])";
    my ($test, $pid, $progress) = @_;
    exists $test->{procs}{$pid} or return undef;
    while (! ($test->{info}{$pid} && @{$test->{info}{$pid}})) {
	$progress or return undef;
	$test->{server}->progress;
	exists $test->{procs}{$pid} or return undef;
    }
    shift @{$test->{info}{$pid}};
}

# one of the child processes has sent a packet
sub _child_packet {
    my ($server, $pipe) = @_;
    my $test = $server->{test_server} or return;
    my $id = fileno $pipe;
    exists $test->{pipes}{$id} or return;
    my $pid = $test->{pipes}{$id};
    my $recv = $test->{procs}{$pid}{recv};
    fileno($recv) == $id or return;
    # we could receive multiple packets at once, and we won't get
    # another notifications for them
    while (defined (my $req = $server->write_in($id, 0))) {
	$req =~ s/^\s*([-+])(\d+)\s+// or next;
	my ($direction, $seqno) = ($1, $2);
	if ($direction eq '+') {
	    # incoming request from sub-process
	    my $send = $test->{procs}{$pid}{send};
	    my $reply = 0;
	    if ($req =~ /^U\s*(\d+)\b/) {
		# is this TCP port in use?
		my $port = $1;
		exists $test->{tcp_port}{$port} and $reply = 1;
	    } elsif ($req =~ /^P\s*(\d+)\b/) {
		# I'd like to listen on this TCP port (0 to get one assigned)
		my $port = $1;
		if (! $port || ! exists $test->{tcp_port}{$port}) {
		    if (! $port) {
			$port = 2048 + int(rand 63487);
			while (exists $test->{tcp_port}{$port}) {
			    $port = 2048 + int(rand 63487);
			}
		    }
		    $test->{tcp_port}{$port} = $pid;
		    $reply = $port;
		}
	    } elsif ($req =~ /^S\s*(\d+)\b/) {
		# closing TCP listening socket
		my $port = $1;
		if (exists $test->{tcp_port}{$port} && $test->{tcp_port}{$port} == $pid) {
		    $reply = 1;
		    delete $test->{tcp_port}{$port};
		}
	    } elsif ($req =~ /^R\s*(\S.*)$/) {
		# reply for send_request()
		my $line = decode_message($1);
		$test->{msgrepl}{$pid} = $line;
		$reply = 1;
	    } elsif ($req =~ /^I\s*(\S.*)$/) {
		# info() call
		my $line = decode_message($1);
		push @{$test->{info}{$pid}}, $line;
		$reply = 1;
	    } elsif ($req =~ /^M\s*(\d+)\s+(\S.*)$/) {
		# send TCP message to this port
		my ($port, $message) = ($1, $2);
		if (exists $test->{tcp_port}{$port}) {
		    # queue this to the other end, we'll forward the reply when it arrives
		    my $npid = $test->{tcp_port}{$port};
		    my $nseq = ++$test->{seqno};
		    my $nsend = $test->{procs}{$npid}{send};
		    $server->read_out(fileno($nsend), "+$nseq M$port $message");
		    $test->{replies}{$nseq} = [$pid, $seqno, 1];
		    $server->progress(0);
		    next;
		}
	    } elsif ($req =~ /^UJ\s*(\d+)\s+(\S+)\b/) {
		# listen for UDP4 broadcast / join IPv6 multicast group
		my ($port, $address) = ($1, $2);
		push @{$test->{udp_port}{$address}}, $pid;
		$reply = $port;
	    } elsif ($req =~ /^US\s*(\d+)\s+(\S+)\s+(\S.*)$/) {
		# send UDP packet to this UDP group; we do not reply but one
		# or more of the recipients could decide to send a reply;
		# for the replies, we use the same mechanism as for TCP
		# so all we need to do is set it up and wait
		my ($port, $address, $message) = ($1, $2, $3);
		if (exists $test->{udp_port}{$address}) {
		    my $nseq;
		    for my $rpid (@{$test->{udp_port}{$address}}) {
			exists $test->{procs}{$rpid} or next; # terminated?
			my $nsend = $test->{procs}{$rpid}{send} or next;
			defined $nseq or $nseq = ++$test->{seqno};
			$server->read_out(fileno($nsend), "+$nseq US$port $address $message");
		    }
		    defined $nseq and $test->{replies}{$nseq} = [$pid, $seqno, 0];
		}
		next;
	    } else {
		# XXX any other requests
	    }
	    $server->read_out(fileno $send, "-$seqno $reply");
	} else {
	    # one of the child processes has sent a reply, we need to forward
	    # it to the child which sent the original request; if it is a
	    # TCP request, we only accept one reply; for UDP we accept any
	    # number of replies but append the originating PID to the message
	    # to emulate recv() returning the peer's address
	    exists $test->{replies}{$seqno} or next;
	    my ($rpid, $rseq, $tcp) = @{$test->{replies}{$seqno}};
	    if ($tcp) {
		delete $test->{replies}{$seqno};
	    } else {
		$req = "$pid $req";
	    }
	    my $rsend = $test->{procs}{$rpid}{send} or next;
	    $server->read_out(fileno($rsend), "-$rseq $req");
	}
    }
}

sub decode_message {
    my ($message) = @_;
    $message =~ s/%([[:xdigit:]]{2})/chr(hex $1)/ge;
    $message;
}

sub encode_message {
    my ($message) = @_;
    $message =~ s/([%\\\s])/sprintf "%%%02X", ord($1)/ge;
    $message;
}

package Language::INTERCAL::Server::Test::Child;

use Carp;
use Socket qw(inet_aton inet_ntoa AF_INET pack_sockaddr_in);
use Language::INTERCAL::Exporter '1.-94.-2.4', qw(has_type);
use Language::INTERCAL::Splats '1.-94.-2.4', qw(faint);
use Language::INTERCAL::INET::Constants '1.-94.-2.4', qw(SP_INTERNET);

$has_ipv6 and import Socket qw(inet_pton inet_ntop AF_INET6 pack_sockaddr_in6);

use vars qw(@ISA);
@ISA = qw(Language::INTERCAL::Server);

# pretend we are a Server::INET if anybody asks
sub isa {
    my ($server, $class) = @_;
    $class eq 'Language::INTERCAL::Server::INET' and return 1;
    $server->SUPER::isa($class);
}

sub new {
    @_ == 3 or croak "Usage: Language::INTERCAL::Server::Test::Child->new(PIPES)";
    my ($class, $send, $recv) = @_;
    my $server = Language::INTERCAL::Server->new();
    $send->autoflush(1);
    $recv->blocking(0);
    $server->{test_send} = $send;
    $server->{test_recv} = $recv;
    $server->{test_seqno} = 0;
    $server->{test_replies} = {};
    $server->{test_ports} = {};
    $server->{last_request} = 0; # to better pretend we are a Server::INET
    $server->{tcp_socket} = { '' => [] };
    $server->{udp_listen} = {};
    $server->file_send($send, \&_close);
    $server->file_receive($recv, \&_close, \&_parent_packet);
    bless $server, $class;
}

# setting hop_limit is a NO-OP here
sub hop_limit { }

# special object which can only be used to get interface lists etc
# it will give an error if used in any other way
sub interfaces {
    @_ == 1 or croak "Usage: Language::INTERCAL::Server::Test::Child->interfaces";
    my ($class) = @_;
    bless [], $class;
}

sub interfaces_only {
    @_ == 1 or croak "Usage: SERVER->interfaces_only";
    my ($server) = @_;
    ref $server or return 1;
    has_type($server, 'ARRAY');
}

*encode_message = \&Language::INTERCAL::Server::Test::encode_message;
*decode_message = \&Language::INTERCAL::Server::Test::decode_message;

sub port_used {
    @_ == 2 or croak "Usage: SERVER->port_used(PORT)";
    my ($server, $port) = @_;
    exists $server->{test_ports}{$port} and return 1; # we are
    _request($server, "U$port");
}

sub write_in {
    @_ == 2 || @_ == 3
	or croak "Usage: SERVER->write_in(ID [, PROGRESS])";
    my ($server, $id, $progress) = @_;
    exists $server->{tcp_socket}{$id}
	or return $server->SUPER::write_in($id, $progress);
    if (! @{$server->{tcp_socket}{$id}}) {
	$progress or return undef;
	while (! @{$server->{tcp_socket}{$id}}) {
	    $server->progress();
	}
    }
    my ($type, $line) = @{shift @{$server->{tcp_socket}{$id}}};
    $type eq 'L' or die "Expected line, got binary data\n";
    $line;
}

sub write_binary {
    @_ == 3 || @_ == 4
	or croak "Usage: SERVER->write_binary(ID, SIZE [, PROGRESS])";
    my ($server, $id, $size, $progress) = @_;
    exists $server->{tcp_socket}{$id}
	or return $server->SUPER::write_binary($id, $size, $progress);
    if (! @{$server->{tcp_socket}{$id}}) {
	$progress or return undef;
	while (! @{$server->{tcp_socket}{$id}}) {
	    $server->progress();
	}
    }
    my ($type, $line) = @{shift @{$server->{tcp_socket}{$id}}};
    $type eq 'B' or die "Expected line, got binary data\n";
    substr($line, 0, $size);
}

sub data_count {
    @_ == 2 || @_ == 3
	or croak "Usage: SERVER->data_count(ID [, PROGRESS])";
    my ($server, $id, $progress) = @_;
    exists $server->{tcp_socket}{$id}
	or return $server->SUPER::data_count($id, $progress);
    if (! @{$server->{tcp_socket}{$id}}) {
	$progress or return 0;
	$server->progress while (! @{$server->{tcp_socket}{$id}});
    }
    1;
}

sub data_length {
    @_ == 2 or croak "Usage: SERVER->data_length(ID)";
    my ($server, $id) = @_;
    exists $server->{tcp_socket}{$id}
	or return $server->SUPER::data_length($id);
    @{$server->{tcp_socket}{$id}} or return undef;
    my ($type, $line) = @{$server->{tcp_socket}{$id}[0]};
    length $line;
}

sub read_out {
    @_ >= 2 or croak "Usage: SERVER->read_out(ID, DATA)";
    my ($server, $id, @data) = @_;
    exists $server->{tcp_socket}{$id}
	or return $server->SUPER::read_out($id, @data);
    $server->_tread($id, 'L', @data);
}

sub read_binary {
    @_ >= 2 or croak "Usage: SERVER->read_binary(ID, DATA)";
    my ($server, $id, @data) = @_;
    exists $server->{tcp_socket}{$id}
	or return $server->SUPER::read_binary($id, @data);
    $server->_tread($id, 'B', @data);
}

sub info {
    @_ >= 1 or croak "Usage: SERVER->info(DATA)";
    my ($server, @data) = @_;
    $server->_tread('', '', @data);
}

sub _tread {
    my ($server, $id, $type, @data) = @_;
    exists $server->{tcp_socket}{$id} or return $server;
    my $msg;
    if ($id eq '') {
	$msg = $type eq '' ? 'I' : 'R';
    } else {
	my ($port, $srcport) = split(/\s+/, $id);
	$msg = "M$srcport $type$port";
    }
    for my $data (@data) {
	_request($server, $msg . ' ' . encode_message($data));
    }
    $server;
}

sub tcp_listen {
    @_ == 5 || @_ == 6
	or croak "Usage: SERVER->tcp_listen(OPEN, LINE, CLOSE, ARG [, PORT])";
    my ($server, $open, $line, $close, $arg, $reqport) = @_;
    my $port = _request($server, 'P' . ($reqport || 0));
    $port && (! $reqport || $reqport == $port)
	or faint(SP_INTERNET, "Listen($reqport)", "I/O error");
    $server->{tcp_listen}{$port} = [$open, $line, $close, $arg];
    $port;
}

sub tcp_socket {
    @_ == 3 or croak "Usage: SERVER->tcp_socket(HOST, PORT)";
    my ($server, $host, $port) = @_;
    $server->port_used($port) or die "$host:$port: Connection refused\n";
    my $srcport = _request($server, "P0");
    # need to have this in place before the request, or we might miss
    # a connection banner
    my $id = "$srcport $port";
    $server->{tcp_socket}{$id} = [];
    _request($server, "M$port T$srcport") or die "$host:$port: Connection refused\n";
    $id;
}

sub tcp_socket_close {
    @_ == 2 or croak "Usage: SERVER->tcp_socket_close(ID)";
    my ($server, $id) = @_;
    $server->_tcp_close($id, 1);
}

sub _tcp_close {
    my ($server, $id, $remote) = @_;
    exists $server->{tcp_socket}{$id} or return $server;
    if (exists $server->{tcp_incoming}{$id}) {
	my ($close, $lcode, $ccode, $arg) = @{delete $server->{tcp_incoming}{$id}};
	$ccode and $ccode->($id, $arg);
    }
    delete $server->{tcp_socket}{$id};
    if ($remote) {
	my ($port, $srcport) = split(/\s+/, $id);
	_request($server, "M$srcport C$port");
    }
    $server;
}

sub alternate_callback {
    @_ == 4 or croak "Usage: SERVER->alternate_callback(ID, SIZE, CODE)";
    my ($server, $id, $size, $code) = @_;
    exists $server->{tcp_incoming}{$id} or croak "No such ID: $id";
    $server->{tcp_incoming}{$id}[4] = [$size, $code, ''];
    $server;
}

sub udp_listen {
    @_ == 3 || @_ == 5
	or croak "Usage: SERVER->udp_listen(CALLBACK, PORT, [MC_GROUPS, IFINDEX])";
    my ($server, $callback, $port, $mc_groups, $ifindex) = @_;
    if ($has_ipv6 && $mc_groups && @$mc_groups) {
	for my $group (@$mc_groups) {
	    length($group) == 16 or die "Invalid MC group\n";
	    my $prn = inet_ntop(&AF_INET6, $group);
	    _request($server, "UJ$port $prn")
		or die "Error listening on $prn port $port\n";
	    $server->{udp_listen}{$port}{$prn} = $callback;
	}
    }
    _request($server, "UJ$port V4")
	or die "Error listening on port $port (V4)\n";
    $server->{udp_listen}{$port}{'V4'} = $callback;
    $port;
}

sub udp_request {
    @_ > 3 && @_ % 2 == 1
	or croak "Usage: SERVER->udp_request(MESSAGE, PORT, FAMILY => ADDRESSES [, FAMILY => ADDRESSES]...";
    my ($server, $message, $port, %addresses) = @_;
    my $send = fileno($server->{test_send});
    my $id4 = 0;
    if ($addresses{&AF_INET}) {
	# broadcast UDPv4 requests...
	my @bc;
	if (grep { ! defined } @{$addresses{&AF_INET}}) {
	    @bc = keys %broadcast;
	} else {
	    @bc = @{$addresses{&AF_INET}};
	}
	my $seqno;
	for my $bc (@bc) {
	    defined $seqno or $seqno = ++$server->{test_seqno};
	    my $addr = inet_ntoa($bc);
	    $server->SUPER::read_out($send, "+$seqno US$port $addr $message");
	}
	if (defined $seqno) {
	    $server->{udp_request}{$seqno} = [];
	    $id4 = $seqno;
	}
    }
    my $id6 = 0;
    if ($has_ipv6 && $addresses{&AF_INET6}) {
	my %group;
	for my $addr (@{$addresses{&AF_INET6}}) {
	    my ($group, $limit, $interface) = @$addr;
	    $group{$group} = 1;
	}
	my $seqno;
	for my $group (keys %group) {
	    defined $seqno or $seqno = ++$server->{test_seqno};
	    my $addr = inet_ntop(&AF_INET6, $group);
	    $server->SUPER::read_out($send, "+$seqno US$port $addr $message");
	}
	if (defined $seqno) {
	    $server->{udp_request}{$seqno} = [];
	    $id6 = $seqno;
	}
    }
    $id4 || $id6 or return undef;
    return "$id4 $id6";
}

# Emulated network is always a very fast "LAN"
sub udp_request_timeout { 0.25 }

sub udp_request_reply {
    @_ == 2 or croak "Usage: SERVER->udp_request_reply(ID)";
    my ($server, $id) = @_;
    my @id = split(/\s+/, $id);
    for my $is6 (0, 1) {
	my $id = $id[$is6];
	$id or next;
	$server->{udp_request}{$id} or next;
	@{$server->{udp_request}{$id}} or next;
	my $msg = shift @{$server->{udp_request}{$id}};
	$msg =~ s/^\s*(\d+)\s+// or next;
	my $pid = $1;
	my ($pack) = $is6 ? keys(%local_ip6) : keys(%local_ip4);
	my $port = int(rand 65535) + 1;
	my $addr = $is6 ? pack_sockaddr_in6($port, $pack) : pack_sockaddr_in($port, $pack);
	my $if = $is6 ? $local_ip6{$pack} : $local_ip4{$pack};
	return ($if, $is6, $addr, $msg);
    }
    return ();
}

sub udp_request_cancel {
    @_ == 2 or croak "Usage: SERVER->udp_request_cancel(ID)";
    my ($server, $id) = @_;
    delete $server->{udp_request}{$id};
}

sub last_error {
    @_ == 1 or croak "Usage: SERVER->last_error";
    my ($server) = @_;
    $server->{last_error};
}

sub connections {
    @_ == 1 or croak "Usage: SERVER->last_error";
    my ($server) = @_;
    scalar keys %{$server->{tcp_incoming}};
}

sub is_localhost {
    @_ == 2 or croak "Usage: SERVER->is_localhost(ADDRESS)";
    my ($server, $addr) = @_;
    my $pack = inet_aton($addr);
    $pack and return exists $local_ip4{$pack} && $local_ip4{$pack} eq 'lo';
    if ($has_ipv6) {
	$pack = inet_pton(&AF_INET6, $addr);
	$pack and return exists $local_ip6{$pack} && $local_ip6{$pack} eq 'lo';
    }
    faint(SP_INTERNET, $addr, "Can't figure out what this address is");
}

sub interface_index {
    @_ == 2 or croak "Usage: SERVER->interface_index(ADDRESS)";
    my ($server, $interface) = @_;
    exists $interfaces{$interface} or return undef;
    $interfaces{$interface}[0];
}

sub interface_has_broadcast {
    @_ == 2 or croak "Usage: SERVER->interface_has_broadcast(ADDRESS)";
    my ($server, $addr) = @_;
    my $pack = inet_aton($addr);
    $pack or return undef;
    $broadcast{$pack};
}

sub localhost_addresses {
    @_ == 1 || @_ == 2 or croak "Usage: SERVER->localhost_addresses [(4|6)]";
    my (undef, $which) = @_;
    my @l;
    defined $which && $which ne '4' or push @l, @localhost4;
    defined $which && $which ne '6' or push @l, @localhost6;
    @l;
}

sub interfaces4 {
    @_ == 1 or croak "Usage: SERVER->interfaces4";
    sort { $interfaces{$a}[0] <=> $interfaces{$b}[0] } keys %interfaces;
}
*interfaces6 = \&interfaces4;

sub broadcasts {
    @_ == 1 or croak "Usage: SERVER->broadcasts";
    my ($server) = @_;
    sort keys %broadcast;
}

sub _request {
    my ($server, $message) = @_;
    my $seqno = ++$server->{test_seqno};
    my $send = $server->{test_send};
    $server->SUPER::read_out(fileno($send), "+$seqno $message");
    $server->progress();
    my $timeout = time + 10;
    while (! exists $server->{test_replies}{$seqno}) {
	time >= $timeout and die "Request ($message) timed out\n";
	$server->progress();
    }
    delete $server->{test_replies}{$seqno};
}

# one of the pipes to/from the parent has been closed
sub _close {
    exit(1);
}

# there is a packet from the parent
sub _parent_packet {
    my ($server) = @_;
    my $recv = $server->{test_recv};
    while (defined (my $req = $server->write_in(fileno($recv), 0))) {
	$req =~ s/^\s*([-+])(\d+)\s+// or next;
	my ($direction, $seqno) = ($1, $2);
	if ($direction eq '+') {
	    my $reply = 0;
	    if ($req =~ /^M\s*(\d+)\s+T\s*(\d+)\b/) {
		# open TCP connection
		my ($port, $srcport) = ($1, $2);
		my $id = "$port $srcport";
		if (exists $server->{tcp_listen}{$port} && ! exists $server->{tcp_incoming}{$id}) {
		    my ($ocode, $lcode, $ccode, $arg) = @{$server->{tcp_listen}{$port}};
		    my $close = 0;
		    $server->{tcp_incoming}{$id} = [$close, $lcode, $ccode, $arg, 0];
		    $server->{tcp_socket}{$id} = [];
		    $server->schedule(sub {
			my @w = $ocode->($id, $port, $srcport, \$close, $arg);
			$server->{tcp_incoming}{$id}[0] = $close;
			$server->_tread($id, 'L', @w);
		    });
		    $reply = 1;
		}
	    } elsif ($req =~ /^P\s*(\S.*)$/) {
		my $line = decode_message($1);
		push @{$server->{tcp_socket}{''}}, ['L', $line];
		next;
	    } elsif ($req =~ /^M\s*(\d+)\s+([LB])\s*(\d+)\s+(\S.*)$/) {
		# send data on TCP connection
		my ($port, $type, $srcport, $line) = ($1, $2, $3, $4);
		my $id = "$port $srcport";
		$line = decode_message($line);
		if (exists $server->{tcp_incoming}{$id}) {
		    my ($close, $lcode, $ccode, $arg, $alternate) =
			@{$server->{tcp_incoming}{$id}};
		    my ($cb, @cb);
		    if ($alternate) {
			my ($size, $code, $buffer) = @$alternate;
			if (length($buffer) + length($line) >= $size) {
			    $server->{tcp_incoming}{$id}[4] = 0;
			    $cb = $code;
			    @cb = (substr($buffer . $line, 0, $size));
			} else {
			    $alternate->[2] .= $line;
			}
		    } else {
			$cb = $lcode;
			@cb = ($server, $id, \$close, $line, $arg);
		    }
		    $cb and $server->schedule(sub {
			my @w = $cb->(@cb);
			$server->read_out($id, @w);
			$close and $server->{tcp_incoming}{$id}[0] = 1;
		    });
		    $reply = 1;
		} elsif (exists $server->{tcp_socket}{$id}) {
		    push @{$server->{tcp_socket}{$id}}, [$type, $line];
		    $reply = 1;
		}
	    } elsif ($req =~ /^M\s*(\d+)\s+C\s*(\d+)\b/) {
		# close TCP connection
		my ($port, $srcport) = ($1, $2);
		my $id = "$port $srcport";
		$server->_tcp_close($id, 0);
		$reply = 1;
	    } elsif ($req =~ /^US\s*(\d+)\s+(\S+)\s+(\S.*)$/) {
		# UDP broadcast or multicast - we send a reply if the
		# callback asks us to
		my ($port, $address, $message) = ($1, $2, $3);
		exists $server->{udp_listen}{$port}{$address} or next;
		my $callback = $server->{udp_listen}{$port}{$address};
		# we need a fake socket with a send() method...
		my $socket = bless [
		    $server,
		    $seqno,
		    fileno($server->{test_send}),
		], 'Language::INTERCAL::Server::Test::UDPsocket';
		$server->schedule($callback, $socket, $port, $seqno, $address, $port, $message);
		next;
	    } else {
		# XXX any other requests?
	    }
	    my $send = $server->{test_send};
	    $server->read_out(fileno($send), "-$seqno $reply");
	} elsif (exists $server->{udp_request}{$seqno}) {
	    push @{$server->{udp_request}{$seqno}}, $req;
	} else {
	    $server->{test_replies}{$seqno} = $req;
	}
    }
}

# fake "UDP" socket
package Language::INTERCAL::Server::Test::UDPsocket;

sub send {
    my ($socket, $packet) = @_;
    my ($server, $seqno, $id) = @$socket;
    $server->read_out($id, "-$seqno $packet");
}

1;
