/usr/bin/theft-server is in clc-intercal 1:1.0~4pre1.-94.-2-3.
This file is owned by root:root, with mode 0o755.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 | #!/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.
|