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