--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/interps/clc-intercal/inst/bin/theft-server	Sun Dec 09 19:30:08 2012 +0000
@@ -0,0 +1,221 @@
+#!/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.
+