clc-intercal 1:1.0~4pre1.-94.-2-2 / usr / bin / theft-server

#!/usr/bin/perl -w

eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
    if 0; # not running under some shell

# INTERNET (INTERcal NETworking) server

# This file is part of CLC-INTERCAL

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

require 5.005;

use strict;
use Socket;
use Getopt::Long;

use Language::INTERCAL::Server '1.-94.-2';

use vars qw($VERSION $PERVERSION);
($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base bin/theft-server 1.-94.-2") =~ /\s(\S+)$/;

my ($PERVNUM) = $PERVERSION =~ /\s(\S+)$/;

if (defined &Getopt::Long::Configure) {
    Getopt::Long::Configure qw(no_ignore_case auto_abbrev permute bundling);
} else {
    $Getopt::Long::ignorecase = 0;
    $Getopt::Long::autoabbrev = 1;
    $Getopt::Long::order = $Getopt::Long::PERMUTE;
    $Getopt::Long::bundling = 1;
}

my $port = undef;
my $debug = 0;
my $linger = 600; # time we hang around

GetOptions(
    'port|p=i'      => \$port,
    'debug|d!'      => \$debug,
    'linger|l=i'    => \$linger,
) or usage();

defined $port or die "Must specify --port\n";

unless ($debug) {
    close STDIN;
    close STDOUT;
    close STDERR;
    my $pid = fork;
    defined $pid or die "Cannot fork(): $!\n";
    $pid and exit 0;
    if (open(TTY, '<', '/dev/tty')) {
	eval {
	    require 'ioctl.ph';
	    my $x;
	    ioctl(TTY, &TIOCNOTTY, $x);
	};
	close TTY;
    }
    $SIG{HUP} = 'IGNORE';
    $SIG{TSTP} = 'IGNORE';
    $SIG{INT} = 'IGNORE';
}

my $server = Language::INTERCAL::Server->new();
$server->tcp_listen(\&_open, \&_line, \&_close, undef, $port);
$server->udp_listen($port);
$debug and $server->debug;

$debug and print STDERR time, ": Opened TCP and UDP sockets on port $port\n";
my $socket_bitmap = '';
my %pids = ();
my %ports = ();
my %ids = ();

while ($server->connections || $linger == 0 || time < $server->active + $linger) {
    my $timeout = $server->connections || $linger == 0
		? undef
		: ($server->active + $linger);
    $server->progress($timeout);
}
$debug and print STDERR time, ": Exiting server\n";
exit 0;

sub _open {
    my ($id, $sockhost, $peerhost, $close) = @_;
    my $local = $peerhost eq '127.0.0.1';
    $ids{$id} = [$local, undef, undef];
    "200 INTERNET on $sockhost (CLC-INTERCAL $PERVNUM)";
}

sub _line {
    my ($server, $id, $close, $line) = @_;
    exists $ids{$id}
	or return "598 Internal error: missing ID";
    my ($local, $pid, $port) = @{$ids{$id}};
    $line =~ s/^\s+//;
    if ($local && $line =~ /^VICTIM\s+(\d+)\s+ON\s+PORT\s+(\d+)/i) {
	my $new_pid = $1;
	my $new_port = $2;
	if (defined $pid || defined $port) {
	    return '530 You have already issued a VICTIM command';
	} elsif ($new_pid == 0) {
	    return '531 That was an invalid PID';
	} elsif (exists $pids{$new_pid}) {
	    return '532 I already know about that PID';
	} elsif ($new_port > 65535 || $new_port == 0) {
	    return '533 That was an invalid PORT';
	} elsif (exists $ports{$new_port}) {
	    return '534 I already know about that PORT';
	} else {
	    $ids{$id}[1] = $new_pid;
	    $ids{$id}[2] = $new_port;
	    $pids{$new_pid} = $new_port;
	    $ports{$new_port} = $id;
	    return "230 Welcome $new_pid:$new_port!";
	}
    }
    if ($line =~ /^CASE\s+PID/i) {
	my @pids = map { "$_ ON PORT $pids{$_}" } keys %pids;
	my $num = @pids || 'no';
	my $es = @pids == 1 ? '' : 'es';
	return (
	    "210 We have $num process$es running",
	    @pids,
	    '.',
	);
    }
    if ($line =~ /^CASE\s+PORT\s+(\d+)/i) {
	if (exists $pids{$1}) {
	    return "220 $pids{$1} is the port you need";
	} else {
	    return "520 No such PID";
	}
    }
    if ($line =~ /^THANKS/i) {
	$$close = 1;
	return '240 You are welcome';
    }
    return '590 Command not understood';
}

sub _close {
    my ($id) = @_;
    exists $ids{$id} or return;
    my ($local, $pid, $port) = @{$ids{$id}};
    defined $pid and delete $pids{$pid};
    defined $port and delete $ports{$port};
    delete $ids{$id};
}

sub usage {
    (my $p = $0) =~ s#^.*/##;
    die "Usage: $p [--port=PORT] [--debug] [--linger-TIME]\n";
}

__END__

=pod

=head1 NAME

theft-server - CLC-INTERCAL networking

=head1 SYNOPSIS

B<theft-server> --port=I<port> [options]

=head1 DESCRIPTION

The B<theft-server> mediates the communication between two CLC-INTERCAL
programs with the I<internet> extension. It keeps a list of process IDs
running on the current computer so it can provide lists of processes which
can be engaged in INTERcal NETworking; it also responds to broadcasts
allowing other CLC-INTERCAL programs on the LAN to know there is something
happening on this computer.

Under normal conditions, the B<theft-server> is started automatically
by a CLC-INTERCAL programs with the I<internet> extension (unless one
is already running, of course!) because the extension cannot operate
without a server on the local computer. However, it is possible to
start one manually, for example from a F</etc/init.d> or F</etc/rc.d>.

If the program is started automatically, it uses defaults for all its
configuration; when started manually, it accepts the following options:

=over 4

=item B<-p>I<port> / B<--port>=I<port>

Uses the given I<port> (number or service name) for communications,
instead of using the default one from a configuration file.

=item B<-l>I<seconds> / B<--linger>=I<seconds>

Waits the specified time for a connection, then exit. The default is
600 (10 minutes). The timeout applies when the program starts and also
when all existing connections are closed. This allows the program to
be started on demand by CLC-INTERCAL programs, and to automatically
exit when no longer required (unless more programs start up during
the timeout).

This function is disabled by setting the timeout to 0 (i.e. B<-l>I<0>);
for example, if starting the server from F</etc/init.d> or equivalent
one would disable the timeout.

=item B<-d> / B<--debug>

Tells everything it's doing (on Standard Error). Also, prevents the
program from detaching from the current terminal and going into the
background.

=head1 BUGS

IPv6 is not yet implemented.