package Language::INTERCAL::Server::INET;

# INTERNET (INTERcal NETworking) server

# This file is part of CLC-INTERCAL

# Copyright (c) 2007-2008, 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.

use strict;
use Errno qw(EINPROGRESS EWOULDBLOCK);
use vars qw($VERSION $PERVERSION @ISA);
($VERSION) = ($PERVERSION = "CLC-INTERCAL/INET INTERCAL/Server/INET.pm 1.-94.-1") =~ /\s(\S+)$/;

use Language::INTERCAL::Server::IPv6 '1.-94.-2.4', qw(has_ipv6);
use Socket qw(
    inet_ntoa inet_aton pack_sockaddr_in unpack_sockaddr_in
    AF_INET PF_INET SOCK_STREAM SOCK_DGRAM
);
my ($ip_class, $ipv6);
BEGIN {
    $ipv6 = has_ipv6();
    if ($ipv6) {
	require IO::Socket::IP;
	import Socket qw(
	    inet_ntop inet_pton pack_sockaddr_in6 unpack_sockaddr_in6
	    AF_INET6 PF_INET6
	    IPPROTO_IPV6 IPV6_JOIN_GROUP
	    IPV6_MULTICAST_IF IPV6_MULTICAST_LOOP IPV6_MULTICAST_HOPS
	);
	$ip_class = 'IO::Socket::IP';
	*tcp_socket = \&tcp_socket_ip;
	*check_tcp_socket = \&check_tcp_socket_ip;
    } else {
	require IO::Socket::INET;
	$ip_class = 'IO::Socket::INET';
	*tcp_socket = \&tcp_socket_inet;
	*check_tcp_socket = \&check_tcp_socket_inet;
    }
}
use Carp;
use Language::INTERCAL::Exporter '1.-94.-2.4', qw(import is_object);
use Language::INTERCAL::Server '1.-94.-2.4';
use Language::INTERCAL::Splats '1.-94.-2.3', qw(faint);
use Language::INTERCAL::INET::Constants '1.-94.-2.4', qw(SP_INTERNET);
use Language::INTERCAL::INET::Interface '1.-94.-2.3', qw(
    interface_list address_scope
    ifscope_node
    iflags_loopback iflags_broadcast iflags_multicast iflags_up
    ifitem_name ifitem_index ifitem_flags ifitem_broadcast
    ifitem_address4 ifitem_address6
);
use Language::INTERCAL::Extensions '1.-94.-2.4', qw(load_extension);

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

my ($if_cache, @if_list, @if4_list, @if6_list, @localhost, %localhost4, %localhost6, %if_map, %if_index, @if_index);

sub upgrade {
    @_ == 2 or croak "Usage: Language::INTERCAL::Server::INET->upgrade(SERVER)";
    my ($class, $server) = @_;
    $server->isa($class) && exists $server->{last_request}
	and return $server;
    $server->{tcp_listen} = {};
    $server->{tcp_socket} = {};
    $server->{tcp_incoming} = {};
    $server->{udp_listen} = {};
    $server->{udp_request} = {};
    $server->{udp_seen} = {};
    $server->{newline} = "\015\012";
    $server->{last_request} = 0;
    $server->{last_error} = 'No error';
    $server->{hop_limit} = {};
    _get_interfaces();
    bless $server, $class;
}

# inherit new() from Server, it'll call our upgrade()

sub hop_limit {
    @_ == 3 or croak "Usage: SERVER->hop_limit(GROUP, LIMIT)";
    my ($server, $group, $limit) = @_;
    if ($ipv6) {
	my $pack = inet_pton(&AF_INET6, $group);
	$server->{hop_limit}{$pack} = $limit;
    }
    $server;
}

sub read_out {
    @_ >= 2 or croak "Usage: SERVER->read_out(ID, DATA)";
    my ($server, $fn, @data) = @_;
    if ($server->{debug} && exists $server->{tcp_socket}{$fn}) {
	my $now = time;
	my $peer = $server->{tcp_socket}{$fn}[1];
	print "$now:$peer>> $_\n" for @data;
    }
    $server->SUPER::read_out($fn, @data);
}

sub tcp_listen {
    @_ == 5 || @_ == 6
	or croak "Usage: SERVER->tcp_listen(OPEN, LINE, CLOSE, ARG [, PORT])";
    my ($server, $open, $line, $close, $arg, $port) = @_;
    my @port = $port ? (LocalPort => $port) : ();
    my @has_socket = ();
    my $err;
    if ($ipv6) {
	# some systems require separate IPv4 and IPv6 sockets;
	# even when not required, we find it simpler to use them anyway
	my $sock6 = $ip_class->new(
	    @port,
	    Listen    => 128,
	    Proto     => 'tcp',
	    Type      => SOCK_STREAM,
	    ReuseAddr => 1,
	    ReusePort => 1,
	    Domain    => &PF_INET6,
	    Family    => &AF_INET6,
	    V6Only    => 1,
	);
	if ($sock6) {
	    $sock6->blocking(0);
	    my $fn6 = fileno($sock6);
	    $server->{tcp_listen}{$fn6} = [$sock6, $open, $line, $close, $arg];
	    $server->file_listen($fn6, \&_tcp_accept, \&_tcp_unlisten);
	    push @has_socket, 'IPv6';
	    $port = $sock6->sockport;
	    @port = (LocalPort => $port);
	} else {
	    $err = $!;
	}
    }
    my $sock4 = $ip_class->new(
	@port,
	Listen    => 128,
	Proto     => 'tcp',
	Type      => SOCK_STREAM,
	ReuseAddr => 1,
	ReusePort => 1,
	Domain    => PF_INET,
	Family    => AF_INET,
    );
    if ($sock4) {
	$sock4->blocking(0);
	my $fn4 = fileno($sock4);
	$server->{tcp_listen}{$fn4} = [$sock4, $open, $line, $close, $arg];
	$server->file_listen($fn4, \&_tcp_accept, \&_tcp_unlisten);
	unshift @has_socket, 'IPv4';
	$port = $sock4->sockport;
	@port = (LocalPort => $port);
    } elsif (! $err) {
	$err = $!;
    }
    @has_socket or die "Listening on port $port: $err\n";
    $server->{debug} and print STDERR "Listening on TCP port $port (", join(' and ', @has_socket), ")\n";
    $port;
}

sub _tcp_accept {
    my ($server, $afn) = @_;
    my ($listen, $ocode, $lcode, $ccode, $arg) = @{$server->{tcp_listen}{$afn}};
    my $socket = $listen->accept;
    $socket or return;
    $socket->blocking(0);
    my $fn = fileno $socket;
    my $sockhost = $socket->sockhost;
    $sockhost =~ s/^::ffff\:(\d+(?:\.\d+){0,3})$/$1/;
    my $peerhost = $socket->peerhost;
    $peerhost =~ s/^::ffff\:(\d+(?:\.\d+){0,3})$/$1/;
    my $peer .= $peerhost . ':' . $socket->peerport;
    my $close = 0;
    $server->{tcp_incoming}{$fn} = [$close, $lcode, $ccode, $arg, 0];
    $server->{tcp_socket}{$fn} = [$socket, $peer];
    $server->file_receive($socket, \&_tcp_close, \&_tcp_data);
    $server->file_send($socket, undef, \&_tcp_empty);
    $server->schedule(sub {
	my @w = $ocode->($fn, $sockhost, $peerhost, \$close, $arg);
	$server->{tcp_incoming}{$fn}[0] = $close;
	$server->{debug} and print STDERR time, ":$peer: accepting connection\n";
	$server->read_out($fn, @w);
    });
}

sub _tcp_unlisten {
    # called by file_listen() if the accepting socket has an error
    my ($server, $afn) = @_;
    exists $server->{tcp_listen}{$afn} or return;
    my ($socket) = @{delete $server->{tcp_listen}{$afn}};
    close $socket;
}

sub _tcp_data {
    # file_receive() informs us that some data has arrived
    # $socket is an incoming socket created by _tcp_accept()
    # we check if a complete line is available and if so will
    # call the appropriate callbacks
    my ($server, $socket) = @_;
    my $fn = fileno $socket;
    my (undef, $peerhost) = @{$server->{tcp_socket}{$fn}};
    while (1) {
	exists $server->{tcp_incoming}{$fn} or return;
	my ($close, $lcode, undef, $arg, $alternate) =
	    @{$server->{tcp_incoming}{$fn}};
	$close and return;
	my ($cb, @cb);
	if ($alternate) {
	    my ($size, $code) = @$alternate;
	    my $len = $server->data_length($fn) || 0;
	    $len < $size && ! $close and return;
	    $server->{tcp_incoming}{$fn}[4] = 0;
	    my $data = $server->write_binary($fn, $len > $size ? $size : $len);
	    $cb = $code;
	    @cb = ($data);
	} else {
	    $server->data_count($fn) or return;
	    my $data = $server->write_in($fn);
	    $server->{debug} and print STDERR time, ":$peerhost<< $data\n";
	    $cb = $lcode;
	    @cb = ($server, $fn, \$close, $data, $arg);
	}
	$server->schedule(sub {
	    my @w = $cb->(@cb);
	    $server->read_out($fn, @w);
	    $close and $server->{tcp_incoming}{$fn}[0] = 1;
	});
    }
}

sub _tcp_empty {
    # file_send() will call this when there is no more data to send
    # check if we planned to close connection after doing this
    my ($server, $socket) = @_;
    my $id = fileno($socket);
    defined $id or return;
    exists $server->{tcp_incoming}{$id} or return;
    $server->{tcp_incoming}{$id}[0] or return;
    $server->schedule(sub { $server->_close_tcp($id, time); });
}

sub _tcp_close {
    # file_receive() informs us that the socket has been closed
    # and not because we called file_receive_close()
    my ($server, $socket) = @_;
    $server->schedule(sub { $server->_close_tcp(fileno $socket, time); });
}

sub tcp_socket_ip {
    @_ == 3 || @_ == 4
	or croak "Usage: SERVER->tcp_socket(HOST, PORT [, NONBLOCKING])";
    my ($server, $host, $port, $nonblocking) = @_;
    load_extension('INET'); # to make sure SP_INTERNET is known
    my $blocking = ! $nonblocking;
    # $host lookup can still block even with $nonblocking true;
    # however this is documented and one can use a non-blocking
    # CASE to do lookups, so we don't worry about this here
    my $socket = $ip_class->new(
	PeerAddr   => $host,
	PeerPort   => $port,
	Proto      => 'tcp',
	Type       => SOCK_STREAM,
	Blocking   => $blocking,
	MultiHomed => 1,
    ) or faint(SP_INTERNET, "$host:$port", $!);
    my $fn = fileno($socket);
    if ($blocking) {
	$socket->blocking(1);
	$server->{tcp_socket}{$fn} = [$socket, "$host:$port", $nonblocking];
	$server->file_receive($socket, \&_tcp_close);
	$server->file_send($socket);
	$server->{debug} and print STDERR "Connected to $host:$port\n";
    } else {
	$server->{tcp_delayed}{$fn} = [$socket, "$host:$port", $nonblocking];
    }
    $fn;
}

# called after a non-blocking tcp_socket to determine wheter the
# operation is complete; no-op if the socket was blocking
sub check_tcp_socket_ip {
    @_ == 2 or croak "Usage: SERVER->check_tcp_socket(ID)";
    my ($server, $fn) = @_;
    exists $server->{tcp_delayed}{$fn} or croak "No such ID: $fn";
    my ($socket, $name, $nb) = @{$server->{tcp_delayed}{$fn}};
    $nb or return 1;
    my $wbits = '';
    vec($wbits, $fn, 1) = 1;
    my $ebits = $wbits;
    select undef, $wbits, $ebits, 0;
    vec($wbits, $fn, 1) || vec($ebits, $fn, 1) or return 0;
    if ($socket->connect()) {
	delete $server->{tcp_delayed}{$fn};
	$socket->blocking(1);
	$server->{tcp_socket}{$fn} = [$socket, $name];
	$server->file_receive($socket, \&_tcp_close);
	$server->file_send($socket);
	$server->{debug} and print STDERR "Connected to $name\n";
	return 1;
    }
    $! == EINPROGRESS || $! == EWOULDBLOCK and return 0;
    faint(SP_INTERNET, $name, $!);
}

sub tcp_socket_inet {
    @_ == 3 || @_ == 4
	or croak "Usage: SERVER->tcp_socket(HOST, PORT [, NONBLOCKING])";
    my ($server, $host, $port, $nonblocking) = @_;
    load_extension('INET'); # to make sure SP_INTERNET is known
    # XXX nonblocking is currently not implemented for IO::Socket::INET
    my $socket = $ip_class->new(
	PeerAddr   => $host,
	PeerPort   => $port,
	Proto      => 'tcp',
	Type       => SOCK_STREAM,
	Blocking   => 1,
	MultiHomed => 1,
    ) or faint(SP_INTERNET, "$host:$port", $!);
    # Some versions of IO::Socket::* return a real, but not connected, socket
    # if MultiHomed is 1 and all connection attempts failed.  It's quite easy
    # to fix in the module itsel, however we can't patch something which is
    # part of core Perl and assume everybody has applied the patch, but the
    # workaround is quick and easy, so...
    my $last_error = "$!"; # quotes intentional to force string not number
    defined $socket->peerhost()
	or faint(SP_INTERNET, "$host:$port", $last_error);
    my $fn = fileno($socket);
    $server->{tcp_socket}{$fn} = [$socket, "$host:$port"];
    $server->file_receive($socket, \&_tcp_close);
    $server->file_send($socket);
    $server->{debug} and print STDERR "Connected to $host:$port\n";
    $fn;
}

sub check_tcp_socket_inet {
    return 1;
}

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

sub tcp_socket_close {
    @_ == 2 or croak "Usage: SERVER->tcp_socket_close(ID)";
    my ($server, $fn) = @_;
    exists $server->{tcp_socket}{$fn}
	and $server->_close_tcp($fn, time);
    $server;
}

sub udp_listen {
    @_ == 3 || @_ == 5
	or croak "Usage: SERVER->udp_listen(CALLBACK, PORT, [MC_GROUPS, IFINDEX])";
    my ($server, $callback, $port, $mc_groups, $ifindex) = @_;
    my $pp = $port ? " on $port" : '';
    my @has_socket = ();
    my $err;
    if ($ipv6) {
	# some system require separate IPv6 and IPv4 listening sockets
	my $sock6 = $ip_class->new(
	    LocalPort => $port,
	    Proto     => 'udp',
	    Type      => SOCK_DGRAM,
	    ReuseAddr => 1,
	    ReusePort => 1,
	    Domain    => &PF_INET6,
	    Family    => &AF_INET6,
	);
	if ($sock6) {
	    $sock6->blocking(0);
	    my $fn6 = fileno($sock6);
	    $server->{udp_listen}{$fn6} = [&AF_INET6, $sock6, $port, $callback];
	    $server->file_listen($fn6, \&_udp_data, \&_udp_close);
	    push @has_socket, 'IPv6';
	} else {
	    $err = $!;
	}
	if ($mc_groups) {
	    # join any requested multicast groups on the IPv6 socket;
	    # the group is provided as a packed 128-bit address - note,
	    # not as a 128-bit number forced into a 32-bit register using
	    # a very large hammer, because that requires the INET extension
	    $sock6 or die "Cannot listen on MC groups, no IPv6 socket: $err\n";
	    $ifindex ||= [0];
	    for my $group (@$mc_groups) {
		length($group) == 16 or die "Invalid MC group\n";
		for my $if (@$ifindex)  {
		    # there doesn't appear to be a "pack" function for this
		    # but the struct is the in6_addr followed by the
		    # interfce index in local byte order (not network);
		    # Linux wants this an "int" and NetBSD an "unsigned int"
		    # which makes more sense as the index is never negative;
		    # we use an unsigned int here
		    my $mreq = $group . pack('I', $if);
		    setsockopt($sock6, &IPPROTO_IPV6, &IPV6_JOIN_GROUP, $mreq)
			or die "Listening on " . inet_ntop(&AF_INET6, $group) . ", if=$if: $!\n";
		}
	    }
	}
    }
    my $sock4 = $ip_class->new(
	LocalPort => $port,
	Proto     => 'udp',
	Type      => SOCK_DGRAM,
	ReuseAddr => 1,
	ReusePort => 1,
	Domain    => PF_INET,
	Family    => AF_INET,
    );
    if ($sock4) {
	$sock4->blocking(0);
	my $fn4 = fileno($sock4);
	$server->{udp_listen}{$fn4} = [AF_INET, $sock4, $port, $callback];
	$server->file_listen($fn4, \&_udp_data, \&_udp_close);
	unshift @has_socket, 'IPv4';
    } elsif (! $err) {
	$err = $!;
    }
    @has_socket or die "Listening on port $port: $err\n";
    $server->{debug} and print STDERR "Listening on UDP port $port (", join(' and ', @has_socket), ")\n";
    $port;
}

sub _udp_data {
    # called by file_listen if there may be data
    my ($server, $id) = @_;
    exists $server->{udp_listen}{$id} or return;
    my ($family, $socket, $port, $callback) = @{$server->{udp_listen}{$id}};
    my $x = '';
    my $them = $socket->recv($x, 4096, 0);
    defined $them or return;
    # we seem to receive duplicates, same sender, same data different
    # incoming socket: this is probably because we receive some
    # multicasts over many interfaces, or because we get IPv4 packets
    # via IPv6 sockets too. So we decode the address/port and check
    my ($theirport, $theirip);
    if ($family == &AF_INET6) {
	($theirport, $theirip) = unpack_sockaddr_in6($them);
    } else {
	($theirport, $theirip) = unpack_sockaddr_in($them);
    }
    if ($ipv6) {
	$theirip = eval { inet_ntop($family, $theirip) };
	defined $theirip or $theirip = '(unknown)';
	$theirip =~ s/^::ffff\:(\d+(?:\.\d+){0,3})$/$1/i
    } else {
	$theirip = eval { inet_ntoa($theirip) };
	defined $theirip or $theirip = '(unknown)';
    }
    my $now = time;
    my $seen = $server->{udp_seen};
    for my $tip (keys %$seen) {
	$seen->{$tip} < $now and delete $seen->{$tip};
    }
    my $tip = "$theirip $theirport $x";
    exists $seen->{$tip} and return;
    $seen->{$tip} = $now + 30;
    $server->{debug} and print STDERR "$now:$theirip:$theirport: received ($x)\n";
    $server->schedule($callback, $socket, $port, $them, $theirip, $theirport, $x);
}

sub _udp_close {
    # called by file_listen if the socket gets closed
    my ($server, $id) = @_;
    exists $server->{udp_listen}{$id} or return;
    my (undef, $socket) = @{delete $server->{udp_listen}{$id}};
    close $socket;
}

# send UDP request via multicast and/or broadcast and arrange to receive
# replies; if an IPv4 address is specified as undef, it means all known
# broadcast addresses; otherwise it means just that one;
# IPv6 addresses are represented as triples: [group, hop limit, interface]
# where the interface can be undef to mean all interfaces
# returns an ID which can be used to get replies and cancel the request
sub udp_request {
    @_ > 3 && @_ % 2 == 1
	or croak "Usage: SERVER->udp_request(MESSAGE, PORT, FAMILY => ADDRESSES [, FAMILY => ADDRESSES]...";
    my ($server, $message, $port, %addresses) = @_;
    my %sockets = ();
    my $is_local = 1;
    my @data;
    my $callback = sub {
	# data might be available, have a look
	my (undef, $id) = @_;
	exists $sockets{$id} or return;
	my ($is6, $socket, $if) = @{$sockets{$id}};
	my $message = '';
	my $addr = $socket->recv($message, 4096, 0);
	defined $addr or return;
	push @data, [$if, $is6, $addr, $message];
    };
    if ($addresses{+AF_INET}) {
	# broadcast UDPv4 requests...
	my $any = grep { ! defined } @{$addresses{+AF_INET}};
	for my $item (@if_list) {
	    my ($if, $bc) = @$item;
	    $any || ! (grep { $_ eq $bc } @{$addresses{+AF_INET}})
		or next;
	    my $socket = $ip_class->new(
		PeerPort  => $port,
		Proto     => 'udp',
		Type      => SOCK_DGRAM,
		Broadcast => 1,
		ReuseAddr => 1,
		Domain    => PF_INET,
		Family    => AF_INET,
	    );
	    if ($socket && defined $socket->send($message, 0, pack_sockaddr_in($port, $bc))) {
		my $fn = fileno($socket);
		$sockets{$fn} = [0, $socket, $if];
		$server->file_listen($fn, $callback);
	    } else {
		$server->{last_error} = $!;
	    }
	}
    }
    if ($ipv6 && $addresses{&AF_INET6}) {
	my %addr;
	for my $addr (@{$addresses{&AF_INET6}}) {
	    my ($group, $limit, $interface) = @$addr;
	    defined $interface or $interface = '';
	    push @{$addr{$interface}}, [$group, $limit];
	}
	for my $if (@if6_list) {
	    $addr{''} || $addr{$if} or next;
	    my $socket = $ip_class->new(
		PeerHost  => '::1',
		PeerPort  => $port,
		Proto     => 'udp',
		Type      => SOCK_DGRAM,
		ReuseAddr => 1,
		Domain    => &PF_INET6,
		Family    => &AF_INET6,
	    );
	    if ($socket) {
		my $ifindex = $if_index{$if};
		# we'll need to talk to our local theft server if it's listening
		# on one of these groups
		setsockopt($socket, &IPPROTO_IPV6, &IPV6_MULTICAST_LOOP, pack("I", 1));
		setsockopt($socket, &IPPROTO_IPV6, &IPV6_MULTICAST_IF, pack('I', $ifindex));
		my $any;
		for my $ipv6_gp (@{$addr{''} || []}, @{$addr{$if} || []}) {
		    my ($ipv6_group, $limit) = @$ipv6_gp;
		    exists $server->{hop_limit}{$ipv6_group}
			and $limit = $server->{hop_limit}{$ipv6_group};
		    defined $limit or $limit = 1; # not supposed to happen
		    $limit > 1 and $is_local = 0;
		    setsockopt($socket, &IPPROTO_IPV6, &IPV6_MULTICAST_HOPS, pack('I', $limit));
		    my $p = pack_sockaddr_in6($port, $ipv6_group);
		    if (defined $socket->send($message, 0, $p)) {
			$any = 1;
		    } else {
			$server->{last_error} = $!;
		    }
		}
		$any or next;
		my $fn = fileno($socket);
		$sockets{$fn} = [1, $socket, $if];
		$server->file_listen($fn, $callback);
	    } else {
		$server->{last_error} = $!;
	    }
	}
    }
    keys %sockets or return undef;
    my $id = ++$server->{last_request};
    $server->{udp_request}{$id} = [$is_local, \@data, \%sockets];
    return $id;
}

sub udp_request_timeout {
    @_ == 2 or croak "Usage: SERVER->udp_request_timeout(ID)";
    my ($server, $id) = @_;
    exists $server->{udp_request}{$id} or return undef;
    $server->{udp_request}{$id}[0] ? 2 : 5;
}

sub udp_request_reply {
    @_ == 2 or croak "Usage: SERVER->udp_request_reply(ID)";
    my ($server, $id) = @_;
    exists $server->{udp_request}{$id} or return ();
    @{$server->{udp_request}{$id}[1]} or return ();
    @{shift @{$server->{udp_request}{$id}[1]}};
}

sub udp_request_cancel {
    @_ == 2 or croak "Usage: SERVER->udp_request_cancel(ID)";
    my ($server, $id) = @_;
    exists $server->{udp_request}{$id} or return;
    my $sockets = (delete $server->{udp_request}{$id})[2];
    for my $sid (keys %$sockets) {
	my ($is6, $socket, $if) = @{$sockets->{$sid}};
	eval { $server->file_listen_close($sid) };
	close $socket;
    }
}

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

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

sub _close_tcp {
    my ($server, $fn, $now) = @_;
    $server->{tcp_socket}{$fn} or return;
    my ($socket, $peerhost) = @{$server->{tcp_socket}{$fn}};
    $server->{debug} and print STDERR "$now:$peerhost: closing connection\n";
    eval { $server->file_receive_close($socket); };
    eval { $server->file_send_close($socket); };
    delete $server->{tcp_socket}{$fn};
    if (exists $server->{tcp_incoming}{$fn}) {
	my (undef, undef, $ccode, $arg) = @{$server->{tcp_incoming}{$fn}};
	delete $server->{tcp_incoming}{$fn};
	$ccode and $ccode->($fn, $arg);
    }
    close $socket;
}

sub _get_interfaces {
    return if $if_cache && $if_cache >= time;
    %if_map = ();
    %if_index = ();
    @if_index = ();
    @if_list = ();
    @if4_list = ();
    @if6_list = ();
    @localhost = ();
    %localhost4 = ();
    %localhost6 = ();
    for my $if (interface_list(iflags_up)) {
	my $flags = $if->[ifitem_flags];
	$if_index{$if->[ifitem_name]} = $if->[ifitem_index];
	$if_index[$if->[ifitem_index]] = $if->[ifitem_name];
	if ($flags & iflags_broadcast) {
	    for my $ba (@{$if->[ifitem_broadcast]}) {
		push @if_list, [$if->[ifitem_name], $ba];
		$if_map{$ba} = $if->[ifitem_name];
	    }
	    push @if4_list, $if->[ifitem_name];
	}
	if ($flags & iflags_multicast) {
	    push @if6_list, $if->[ifitem_name];
	}
	if ($flags & iflags_loopback) {
	    $localhost4{$_} = 0 for @{$if->[ifitem_address4]};
	}
	if ($ipv6) {
	    address_scope($_) == ifscope_node and $localhost6{$_} = 0
		for @{$if->[ifitem_address6]};
	}
    }
    if ($ipv6) {
	push @localhost, map { inet_ntop(&AF_INET6, $_) } sort keys %localhost6;
    }
    push @localhost, map { inet_ntoa($_) } sort keys %localhost4;
    @localhost or faint(SP_INTERNET, "localhost", "No local addresses?");
    $if_cache = time + 10;
}

sub is_localhost {
    @_ == 2 or croak "Usage: SERVER->is_localhost(ADDRESS)";
    my ($server, $addr) = @_;
    _get_interfaces();
    my $pack = inet_aton($addr);
    $pack and return exists $localhost4{$pack};
    if ($ipv6) {
	$pack = inet_pton(&AF_INET6, $addr);
	$pack and return exists $localhost6{$pack};
    }
    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 $if_index{$interface} or _get_interfaces();
    return $if_index{$interface};
}

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;
    exists $if_map{$pack} or _get_interfaces();
    return exists $if_map{$pack};
}

sub localhost_addresses {
    @_ == 1 or croak "Usage: SERVER->localhost_addresses";
    _get_interfaces();
    @localhost;
}

sub interfaces4 {
    @_ == 1 or croak "Usage: SERVER->interfaces4";
    _get_interfaces();
    @if4_list;
}

sub broadcasts {
    @_ == 1 or croak "Usage: SERVER->broadcasts";
    _get_interfaces();
    map { $_->[1] } @if_list;
}

sub interfaces6 {
    @_ == 1 or croak "Usage: SERVER->interfaces6";
    _get_interfaces();
    @if6_list;
}

1;
