|
996
|
1 #!/usr/bin/perl -w
|
|
|
2
|
|
|
3 # INTERNET (INTERcal NETworking) server
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2007-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 require 5.005;
|
|
|
14
|
|
|
15 use strict;
|
|
|
16 use Socket;
|
|
|
17 use Getopt::Long;
|
|
|
18
|
|
|
19 use Language::INTERCAL::Server '1.-94.-2';
|
|
|
20
|
|
|
21 use vars qw($VERSION $PERVERSION);
|
|
|
22 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base bin/theft-server 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
23
|
|
|
24 my ($PERVNUM) = $PERVERSION =~ /\s(\S+)$/;
|
|
|
25
|
|
|
26 if (defined &Getopt::Long::Configure) {
|
|
|
27 Getopt::Long::Configure qw(no_ignore_case auto_abbrev permute bundling);
|
|
|
28 } else {
|
|
|
29 $Getopt::Long::ignorecase = 0;
|
|
|
30 $Getopt::Long::autoabbrev = 1;
|
|
|
31 $Getopt::Long::order = $Getopt::Long::PERMUTE;
|
|
|
32 $Getopt::Long::bundling = 1;
|
|
|
33 }
|
|
|
34
|
|
|
35 my $port = undef;
|
|
|
36 my $debug = 0;
|
|
|
37 my $linger = 600; # time we hang around
|
|
|
38
|
|
|
39 GetOptions(
|
|
|
40 'port|p=i' => \$port,
|
|
|
41 'debug|d!' => \$debug,
|
|
|
42 'linger|l=i' => \$linger,
|
|
|
43 ) or usage();
|
|
|
44
|
|
|
45 defined $port or die "Must specify --port\n";
|
|
|
46
|
|
|
47 unless ($debug) {
|
|
|
48 close STDIN;
|
|
|
49 close STDOUT;
|
|
|
50 close STDERR;
|
|
|
51 my $pid = fork;
|
|
|
52 defined $pid or die "Cannot fork(): $!\n";
|
|
|
53 $pid and exit 0;
|
|
|
54 if (open(TTY, '<', '/dev/tty')) {
|
|
|
55 eval {
|
|
|
56 require 'ioctl.ph';
|
|
|
57 my $x;
|
|
|
58 ioctl(TTY, &TIOCNOTTY, $x);
|
|
|
59 };
|
|
|
60 close TTY;
|
|
|
61 }
|
|
|
62 $SIG{HUP} = 'IGNORE';
|
|
|
63 $SIG{TSTP} = 'IGNORE';
|
|
|
64 $SIG{INT} = 'IGNORE';
|
|
|
65 }
|
|
|
66
|
|
|
67 my $server = Language::INTERCAL::Server->new();
|
|
|
68 $server->tcp_listen(\&_open, \&_line, \&_close, undef, $port);
|
|
|
69 $server->udp_listen($port);
|
|
|
70 $debug and $server->debug;
|
|
|
71
|
|
|
72 $debug and print STDERR time, ": Opened TCP and UDP sockets on port $port\n";
|
|
|
73 my $socket_bitmap = '';
|
|
|
74 my %pids = ();
|
|
|
75 my %ports = ();
|
|
|
76 my %ids = ();
|
|
|
77
|
|
|
78 while ($server->connections || $linger == 0 || time < $server->active + $linger) {
|
|
|
79 my $timeout = $server->connections || $linger == 0
|
|
|
80 ? undef
|
|
|
81 : ($server->active + $linger);
|
|
|
82 $server->progress($timeout);
|
|
|
83 }
|
|
|
84 $debug and print STDERR time, ": Exiting server\n";
|
|
|
85 exit 0;
|
|
|
86
|
|
|
87 sub _open {
|
|
|
88 my ($id, $sockhost, $peerhost, $close) = @_;
|
|
|
89 my $local = $peerhost eq '127.0.0.1';
|
|
|
90 $ids{$id} = [$local, undef, undef];
|
|
|
91 "200 INTERNET on $sockhost (CLC-INTERCAL $PERVNUM)";
|
|
|
92 }
|
|
|
93
|
|
|
94 sub _line {
|
|
|
95 my ($server, $id, $close, $line) = @_;
|
|
|
96 exists $ids{$id}
|
|
|
97 or return "598 Internal error: missing ID";
|
|
|
98 my ($local, $pid, $port) = @{$ids{$id}};
|
|
|
99 $line =~ s/^\s+//;
|
|
|
100 if ($local && $line =~ /^VICTIM\s+(\d+)\s+ON\s+PORT\s+(\d+)/i) {
|
|
|
101 my $new_pid = $1;
|
|
|
102 my $new_port = $2;
|
|
|
103 if (defined $pid || defined $port) {
|
|
|
104 return '530 You have already issued a VICTIM command';
|
|
|
105 } elsif ($new_pid == 0) {
|
|
|
106 return '531 That was an invalid PID';
|
|
|
107 } elsif (exists $pids{$new_pid}) {
|
|
|
108 return '532 I already know about that PID';
|
|
|
109 } elsif ($new_port > 65535 || $new_port == 0) {
|
|
|
110 return '533 That was an invalid PORT';
|
|
|
111 } elsif (exists $ports{$new_port}) {
|
|
|
112 return '534 I already know about that PORT';
|
|
|
113 } else {
|
|
|
114 $ids{$id}[1] = $new_pid;
|
|
|
115 $ids{$id}[2] = $new_port;
|
|
|
116 $pids{$new_pid} = $new_port;
|
|
|
117 $ports{$new_port} = $id;
|
|
|
118 return "230 Welcome $new_pid:$new_port!";
|
|
|
119 }
|
|
|
120 }
|
|
|
121 if ($line =~ /^CASE\s+PID/i) {
|
|
|
122 my @pids = map { "$_ ON PORT $pids{$_}" } keys %pids;
|
|
|
123 my $num = @pids || 'no';
|
|
|
124 my $es = @pids == 1 ? '' : 'es';
|
|
|
125 return (
|
|
|
126 "210 We have $num process$es running",
|
|
|
127 @pids,
|
|
|
128 '.',
|
|
|
129 );
|
|
|
130 }
|
|
|
131 if ($line =~ /^CASE\s+PORT\s+(\d+)/i) {
|
|
|
132 if (exists $pids{$1}) {
|
|
|
133 return "220 $pids{$1} is the port you need";
|
|
|
134 } else {
|
|
|
135 return "520 No such PID";
|
|
|
136 }
|
|
|
137 }
|
|
|
138 if ($line =~ /^THANKS/i) {
|
|
|
139 $$close = 1;
|
|
|
140 return '240 You are welcome';
|
|
|
141 }
|
|
|
142 return '590 Command not understood';
|
|
|
143 }
|
|
|
144
|
|
|
145 sub _close {
|
|
|
146 my ($id) = @_;
|
|
|
147 exists $ids{$id} or return;
|
|
|
148 my ($local, $pid, $port) = @{$ids{$id}};
|
|
|
149 defined $pid and delete $pids{$pid};
|
|
|
150 defined $port and delete $ports{$port};
|
|
|
151 delete $ids{$id};
|
|
|
152 }
|
|
|
153
|
|
|
154 sub usage {
|
|
|
155 (my $p = $0) =~ s#^.*/##;
|
|
|
156 die "Usage: $p [--port=PORT] [--debug] [--linger-TIME]\n";
|
|
|
157 }
|
|
|
158
|
|
|
159 __END__
|
|
|
160
|
|
|
161 =pod
|
|
|
162
|
|
|
163 =head1 NAME
|
|
|
164
|
|
|
165 theft-server - CLC-INTERCAL networking
|
|
|
166
|
|
|
167 =head1 SYNOPSIS
|
|
|
168
|
|
|
169 B<theft-server> --port=I<port> [options]
|
|
|
170
|
|
|
171 =head1 DESCRIPTION
|
|
|
172
|
|
|
173 The B<theft-server> mediates the communication between two CLC-INTERCAL
|
|
|
174 programs with the I<internet> extension. It keeps a list of process IDs
|
|
|
175 running on the current computer so it can provide lists of processes which
|
|
|
176 can be engaged in INTERcal NETworking; it also responds to broadcasts
|
|
|
177 allowing other CLC-INTERCAL programs on the LAN to know there is something
|
|
|
178 happening on this computer.
|
|
|
179
|
|
|
180 Under normal conditions, the B<theft-server> is started automatically
|
|
|
181 by a CLC-INTERCAL programs with the I<internet> extension (unless one
|
|
|
182 is already running, of course!) because the extension cannot operate
|
|
|
183 without a server on the local computer. However, it is possible to
|
|
|
184 start one manually, for example from a F</etc/init.d> or F</etc/rc.d>.
|
|
|
185
|
|
|
186 If the program is started automatically, it uses defaults for all its
|
|
|
187 configuration; when started manually, it accepts the following options:
|
|
|
188
|
|
|
189 =over 4
|
|
|
190
|
|
|
191 =item B<-p>I<port> / B<--port>=I<port>
|
|
|
192
|
|
|
193 Uses the given I<port> (number or service name) for communications,
|
|
|
194 instead of using the default one from a configuration file.
|
|
|
195
|
|
|
196 =item B<-l>I<seconds> / B<--linger>=I<seconds>
|
|
|
197
|
|
|
198 Waits the specified time for a connection, then exit. The default is
|
|
|
199 600 (10 minutes). The timeout applies when the program starts and also
|
|
|
200 when all existing connections are closed. This allows the program to
|
|
|
201 be started on demand by CLC-INTERCAL programs, and to automatically
|
|
|
202 exit when no longer required (unless more programs start up during
|
|
|
203 the timeout).
|
|
|
204
|
|
|
205 This function is disabled by setting the timeout to 0 (i.e. B<-l>I<0>);
|
|
|
206 for example, if starting the server from F</etc/init.d> or equivalent
|
|
|
207 one would disable the timeout.
|
|
|
208
|
|
|
209 =item B<-d> / B<--debug>
|
|
|
210
|
|
|
211 Tells everything it's doing (on Standard Error). Also, prevents the
|
|
|
212 program from detaching from the current terminal and going into the
|
|
|
213 background.
|
|
|
214
|
|
|
215 =head1 BUGS
|
|
|
216
|
|
|
217 IPv6 is not yet implemented.
|
|
|
218
|
