|
996
|
1 package Language::INTERCAL::Server;
|
|
|
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 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Server.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Socket;
|
|
|
18 use IO::Socket::INET;
|
|
|
19 use Getopt::Long;
|
|
|
20 use Carp;
|
|
|
21 use Language::INTERCAL::Splats '1.-94.-2', qw(faint SP_INTERNET);
|
|
|
22
|
|
|
23 # note we are not assuming the perl interpreter is threaded - a future release
|
|
|
24 # may have two versions of the server, one threaded and one unthreaded, but for
|
|
|
25 # now we just have the unthreaded one - using select and friends to avoid
|
|
|
26 # deadlocks when we are doing things like stealing from self.
|
|
|
27
|
|
|
28 sub new {
|
|
|
29 @_ == 1 or croak "Usage: Language::INTERCAL::Server->new";
|
|
|
30 my ($class) = @_;
|
|
|
31 bless {
|
|
|
32 write_in_bitmap => '',
|
|
|
33 read_out_bitmap => '',
|
|
|
34 tcp_listen => {},
|
|
|
35 tcp_socket => {},
|
|
|
36 udp_listen => {},
|
|
|
37 file_listen => {},
|
|
|
38 children => {},
|
|
|
39 debug => 0,
|
|
|
40 active => time,
|
|
|
41 in_progress => 0,
|
|
|
42 }, $class;
|
|
|
43 }
|
|
|
44
|
|
|
45 sub debug {
|
|
|
46 @_ == 1 or croak "Usage: SERVER->debug";
|
|
|
47 my ($server) = @_;
|
|
|
48 $server->{debug} = 1;
|
|
|
49 }
|
|
|
50
|
|
|
51 sub file_listen {
|
|
|
52 @_ == 3 or croak "Usage: SERVER->file_listen(ID, CALLBACK)";
|
|
|
53 my ($server, $id, $code) = @_;
|
|
|
54 $server->{file_listen}{$id} = $code;
|
|
|
55 vec($server->{write_in_bitmap}, $id, 1) = 1;
|
|
|
56 $server;
|
|
|
57 }
|
|
|
58
|
|
|
59 sub file_listen_close {
|
|
|
60 @_ == 2 or croak "Usage: SERVER->file_listen_close(ID)";
|
|
|
61 my ($server, $id) = @_;
|
|
|
62 exists $server->{file_listen}{$id}
|
|
|
63 or croak "file_listen_close: unknown ID";
|
|
|
64 delete $server->{file_listen}{$id};
|
|
|
65 vec($server->{write_in_bitmap}, $id, 1) = 0;
|
|
|
66 $server;
|
|
|
67 }
|
|
|
68
|
|
|
69 sub tcp_listen {
|
|
|
70 @_ == 5 || @_ == 6
|
|
|
71 or croak "Usage: SERVER->tcp_listen(OPEN, LINE, CLOSE, ARG [, PORT])";
|
|
|
72 my ($server, $open, $line, $close, $arg, $port) = @_;
|
|
|
73 my @port = $port ? (LocalPort => $port) : ();
|
|
|
74 $port = $port ? " on $port" : '';
|
|
|
75 my $socket = IO::Socket::INET->new(
|
|
|
76 @port,
|
|
|
77 Listen => 128,
|
|
|
78 Proto => 'tcp',
|
|
|
79 Type => SOCK_STREAM,
|
|
|
80 ReuseAddr => 1,
|
|
|
81 ) or die "TCP listen$port: $!\n";
|
|
|
82 my $fn = fileno($socket);
|
|
|
83 $server->{tcp_listen}{$fn} = [$socket, $open, $line, $close, $arg];
|
|
|
84 vec($server->{write_in_bitmap}, $fn, 1) = 1;
|
|
|
85 $port = $socket->sockport;
|
|
|
86 $server->{debug} and print STDERR "Listening on $port\n";
|
|
|
87 $port;
|
|
|
88 }
|
|
|
89
|
|
|
90 sub tcp_socket {
|
|
|
91 @_ == 3 or croak "Usage: SERVER->tcp_socket(HOST, PORT)";
|
|
|
92 my ($server, $host, $port) = @_;
|
|
|
93 my $socket = IO::Socket::INET->new(
|
|
|
94 PeerHost => $host,
|
|
|
95 PeerPort => $port,
|
|
|
96 Proto => 'tcp',
|
|
|
97 Type => SOCK_STREAM,
|
|
|
98 Blocking => 1,
|
|
|
99 ) or faint(SP_INTERNET, "$host:$port", $!);
|
|
|
100 my $fn = fileno($socket);
|
|
|
101 $server->{tcp_socket}{$fn} = [$socket, '', '', 0, 0];
|
|
|
102 vec($server->{write_in_bitmap}, $fn, 1) = 1;
|
|
|
103 $server->{debug} and print STDERR "Connected to $host:$port\n";
|
|
|
104 $fn;
|
|
|
105 }
|
|
|
106
|
|
|
107 sub udp_listen {
|
|
|
108 @_ == 2 or croak "Usage: SERVER->udp_listen(PORT)";
|
|
|
109 my ($server, $port) = @_;
|
|
|
110 my $pp = $port ? " on $port" : '';
|
|
|
111 my $socket = IO::Socket::INET->new(
|
|
|
112 LocalPort => $port,
|
|
|
113 Proto => 'udp',
|
|
|
114 Type => SOCK_DGRAM,
|
|
|
115 ReuseAddr => 1,
|
|
|
116 Broadcast => 1,
|
|
|
117 ) or die "UDP listen$pp: $!\n";
|
|
|
118 my $fn = fileno($socket);
|
|
|
119 $server->{udp_listen}{$fn} = [$socket, $port];
|
|
|
120 vec($server->{write_in_bitmap}, $fn, 1) = 1;
|
|
|
121 $socket->sockport;
|
|
|
122 }
|
|
|
123
|
|
|
124 sub read_out {
|
|
|
125 @_ > 2 or croak "Usage: SERVER->read_out(ID, DATA)";
|
|
|
126 my ($server, $fn, @data) = @_;
|
|
|
127 my $data = join('', map { "$_\015\012" } @data);
|
|
|
128 _read($server, $fn, $data);
|
|
|
129 $server;
|
|
|
130 }
|
|
|
131
|
|
|
132 sub read_binary {
|
|
|
133 @_ > 2 or croak "Usage: SERVER->read_binary(ID, DATA)";
|
|
|
134 my ($server, $fn, @data) = @_;
|
|
|
135 my $data = join('', @data);
|
|
|
136 _read($server, $fn, $data);
|
|
|
137 $server;
|
|
|
138 }
|
|
|
139
|
|
|
140 sub _read {
|
|
|
141 my ($server, $fn, $data) = @_;
|
|
|
142 if (exists $server->{tcp_socket}{$fn}) {
|
|
|
143 $server->{tcp_socket}{$fn}[1] .= $data;
|
|
|
144 } elsif (exists $server->{children}{$fn}) {
|
|
|
145 $server->{children}{$fn}[1] .= $data;
|
|
|
146 } else {
|
|
|
147 croak "No such ID";
|
|
|
148 }
|
|
|
149 vec($server->{read_out_bitmap}, $fn, 1) = 1;
|
|
|
150 }
|
|
|
151
|
|
|
152 sub alternate_callback {
|
|
|
153 @_ == 4 or croak "Usage: SERVER->alternate_callback(ID, SIZE, CODE)";
|
|
|
154 my ($server, $fn, $size, $code) = @_;
|
|
|
155 exists $server->{children}{$fn} or croak "No such ID";
|
|
|
156 $server->{children}{$fn}[8] = [$size, $code];
|
|
|
157 $server;
|
|
|
158 }
|
|
|
159
|
|
|
160 sub write_in {
|
|
|
161 @_ == 2 || @_ == 3
|
|
|
162 or croak "Usage: SERVER->write_in(ID [, PROGRESS])";
|
|
|
163 my ($server, $fn, $progress) = @_;
|
|
|
164 exists $server->{tcp_socket}{$fn} or croak "No such ID";
|
|
|
165 my $data = $server->{tcp_socket}{$fn};
|
|
|
166 if ($data->[2] =~ s/^(.*?)\012//) {
|
|
|
167 my $line = $1;
|
|
|
168 $line =~ s/\015$//;
|
|
|
169 return $line;
|
|
|
170 }
|
|
|
171 if ($data->[4]) {
|
|
|
172 my $line = $data->[2];
|
|
|
173 $data->[2] = '';
|
|
|
174 return $line;
|
|
|
175 }
|
|
|
176 $progress or return undef;
|
|
|
177 while (1) {
|
|
|
178 $server->progress;
|
|
|
179 exists $server->{tcp_socket}{$fn} or return undef;
|
|
|
180 if ($data->[2] =~ s/^(.*?)\012//) {
|
|
|
181 my $line = $1;
|
|
|
182 $line =~ s/\015$//;
|
|
|
183 return $line;
|
|
|
184 }
|
|
|
185 if ($data->[4]) {
|
|
|
186 my $line = $data->[2];
|
|
|
187 $data->[2] = '';
|
|
|
188 return $line;
|
|
|
189 }
|
|
|
190 }
|
|
|
191 }
|
|
|
192
|
|
|
193 sub write_binary {
|
|
|
194 @_ == 3 || @_ == 4
|
|
|
195 or croak "Usage: SERVER->write_binary(ID, SIZE [, PROGRESS])";
|
|
|
196 my ($server, $fn, $size, $progress) = @_;
|
|
|
197 exists $server->{tcp_socket}{$fn} or croak "No such ID";
|
|
|
198 my $data = $server->{tcp_socket}{$fn};
|
|
|
199 if (length($data->[2]) >= $size || ! $progress || $data->[4]) {
|
|
|
200 return substr($data->[2], 0, $size, '');
|
|
|
201 }
|
|
|
202 while (1) {
|
|
|
203 $server->progress;
|
|
|
204 exists $server->{tcp_socket}{$fn} or return undef;
|
|
|
205 if (length($data->[2]) >= $size || $data->[4]) {
|
|
|
206 return substr($data->[2], 0, $size, '');
|
|
|
207 }
|
|
|
208 }
|
|
|
209 }
|
|
|
210
|
|
|
211 sub data_count {
|
|
|
212 @_ == 2 || @_ == 3
|
|
|
213 or croak "Usage: SERVER->data_count(ID [, PROGRESS])";
|
|
|
214 my ($server, $fn, $progress) = @_;
|
|
|
215 exists $server->{tcp_socket}{$fn} or return undef;
|
|
|
216 my $data = $server->{tcp_socket}{$fn};
|
|
|
217 index($data->[2], "\012") >= 0 and return 1;
|
|
|
218 $progress or return 0;
|
|
|
219 while (1) {
|
|
|
220 $server->progress;
|
|
|
221 exists $server->{tcp_socket}{$fn} or return undef;
|
|
|
222 index($data->[2], "\012") >= 0 and return 1;
|
|
|
223 }
|
|
|
224 }
|
|
|
225
|
|
|
226 sub tcp_socket_close {
|
|
|
227 @_ == 2 or croak "Usage: SERVER->tcp_socket_close(ID)";
|
|
|
228 my ($server, $fn) = @_;
|
|
|
229 exists $server->{tcp_socket}{$fn} or return undef;
|
|
|
230 _close_id($server, $fn, time);
|
|
|
231 }
|
|
|
232
|
|
|
233 sub progress {
|
|
|
234 @_ == 1 || @_ == 2
|
|
|
235 or croak "Usage: SERVER->progress [(TIMEOUT)]";
|
|
|
236 my ($server, $timeout) = @_;
|
|
|
237 $server->{in_progress} and croak "SERVER->progress is not reentrant";
|
|
|
238 while (1) {
|
|
|
239 my $wibm = $server->{write_in_bitmap};
|
|
|
240 my $robm = $server->{read_out_bitmap};
|
|
|
241 my $ebm = $wibm | $robm;
|
|
|
242 my $nfound = select $wibm, $robm, $ebm, $timeout;
|
|
|
243 $nfound or return $server;
|
|
|
244 $server->{in_progress} = 1;
|
|
|
245 $@ = '';
|
|
|
246 eval {
|
|
|
247 $timeout = 0.01;
|
|
|
248 my $debug = $server->{debug};
|
|
|
249 my $now = time;
|
|
|
250 # file activity?
|
|
|
251 for my $fid (keys %{$server->{file_listen}}) {
|
|
|
252 vec($wibm, $fid, 1) or next;
|
|
|
253 &{$server->{file_listen}{$fid}}();
|
|
|
254 }
|
|
|
255 # are they opening a new connection?
|
|
|
256 for my $tcp (keys %{$server->{tcp_listen}}) {
|
|
|
257 vec($wibm, $tcp, 1) or next;
|
|
|
258 my ($tcp_listen, $ocode, $lcode, $ccode, $arg) =
|
|
|
259 @{$server->{tcp_listen}{$tcp}};
|
|
|
260 my $sock = $tcp_listen->accept;
|
|
|
261 if ($sock) {
|
|
|
262 $sock->blocking(0);
|
|
|
263 my $child = fileno $sock;
|
|
|
264 my $sockhost = $sock->sockhost;
|
|
|
265 my $peerhost = $sock->peerhost;
|
|
|
266 my $close = 0;
|
|
|
267 my @w = $ocode->($child, $sockhost, $peerhost, \$close, $arg);
|
|
|
268 $peerhost .= ':' . $sock->peerport;
|
|
|
269 $debug
|
|
|
270 and print STDERR "$now:$peerhost: accepting connection\n";
|
|
|
271 my $w = join('', map { "$_\015\012" } @w);
|
|
|
272 $server->{children}{$child} =
|
|
|
273 [$sock, $w, '', $peerhost, $close, $lcode, $ccode, $arg, 0];
|
|
|
274 vec($server->{read_out_bitmap}, $child, 1) = 1 if @w;
|
|
|
275 vec($server->{write_in_bitmap}, $child, 1) = 1;
|
|
|
276 $server->{active} = $now;
|
|
|
277 }
|
|
|
278 }
|
|
|
279 # any broadcasts?
|
|
|
280 for my $udp (keys %{$server->{udp_listen}}) {
|
|
|
281 vec($wibm, $udp, 1) or next;
|
|
|
282 my ($udp_listen, $port) = @{$server->{udp_listen}{$udp}};
|
|
|
283 my $x = '';
|
|
|
284 my $them = $udp_listen->recv($x, 1, 0);
|
|
|
285 my ($p, $h) = unpack_sockaddr_in($them);
|
|
|
286 $h = inet_ntoa($h);
|
|
|
287 $debug and print STDERR "$now:$h:$p: received broadcast ($x)\n";
|
|
|
288 my $udp_send = IO::Socket::INET->new(
|
|
|
289 LocalPort => $port,
|
|
|
290 PeerHost => $h,
|
|
|
291 PeerPort => $p,
|
|
|
292 Proto => 'udp',
|
|
|
293 Type => SOCK_DGRAM,
|
|
|
294 ReuseAddr => 1,
|
|
|
295 );
|
|
|
296 $udp_send and $udp_send->send($x, 0);
|
|
|
297 $server->{active} = $now;
|
|
|
298 }
|
|
|
299 for my $child (keys %{$server->{children}}) {
|
|
|
300 if (vec($ebm, $child, 1)) {
|
|
|
301 # closed connections?
|
|
|
302 _close_child($server, $child, $now);
|
|
|
303 } else {
|
|
|
304 my ($sock, $out, $in, $peerhost, $close,
|
|
|
305 $lcode, $ccode, $arg, $alternate) =
|
|
|
306 @{$server->{children}{$child}};
|
|
|
307 if (vec($robm, $child, 1)) {
|
|
|
308 # send data out
|
|
|
309 my $len = syswrite $sock, $out;
|
|
|
310 defined $len
|
|
|
311 or faint(SP_INTERNET, $peerhost, $!);
|
|
|
312 if ($debug) {
|
|
|
313 my $done = substr($out, 0, $len, '');
|
|
|
314 $done =~ s/\\/\\\\/g;
|
|
|
315 $done =~ s/\015\012/\\n/g;
|
|
|
316 $done =~ s/([\000-\037])/sprintf("\\%03o", $1)/ge;
|
|
|
317 print STDERR "$now:$peerhost> $done\n";
|
|
|
318 } else {
|
|
|
319 substr($out, 0, $len) = '';
|
|
|
320 }
|
|
|
321 $server->{children}{$child}[1] = $out;
|
|
|
322 $server->{active} = $now;
|
|
|
323 if ($out eq '') {
|
|
|
324 if ($close) {
|
|
|
325 _close_child($server, $child, $now);
|
|
|
326 next;
|
|
|
327 } else {
|
|
|
328 vec($server->{read_out_bitmap}, $child, 1) = 0;
|
|
|
329 }
|
|
|
330 }
|
|
|
331 }
|
|
|
332 if (vec($wibm, $child, 1)) {
|
|
|
333 # get new data in
|
|
|
334 my $line = '';
|
|
|
335 if (sysread($sock, $line, 1024)) {
|
|
|
336 $in .= $line;
|
|
|
337 if ($debug) {
|
|
|
338 $line =~ s/\\/\\\\/g;
|
|
|
339 $line =~ s/\015\012/\\n/g;
|
|
|
340 $line =~ s/([\000-\037])/sprintf("\\%03o", $1)/ge;
|
|
|
341 print STDERR "$now:$peerhost< $line\n";
|
|
|
342 }
|
|
|
343 my $ptr = $server->{children}{$child};
|
|
|
344 $server->{active} = $now;
|
|
|
345 PROCESS:
|
|
|
346 while ($in ne '') {
|
|
|
347 # note that this can be changed inside the callback,
|
|
|
348 # which is why we don't use $alternate
|
|
|
349 my @w = ();
|
|
|
350 if ($ptr->[8]) {
|
|
|
351 # alternate callback in operation
|
|
|
352 my ($size, $code) = @{$ptr->[8]};
|
|
|
353 length($in) < $size && ! $ptr->[4]
|
|
|
354 and last PROCESS;
|
|
|
355 my $data = $in eq '' ? undef : substr($in, 0, $size, '');
|
|
|
356 $ptr->[8] = 0;
|
|
|
357 @w = $code->($data);
|
|
|
358 } elsif ($in =~ s/^(.*?)\012//) {
|
|
|
359 $line = $1;
|
|
|
360 $line =~ s/\015$//;
|
|
|
361 $debug and print STDERR "$now:$peerhost<< $line\n";
|
|
|
362 @w = $lcode->($server, $child, \$close, $line, $arg);
|
|
|
363 if ($close) {
|
|
|
364 $ptr->[4] = 1;
|
|
|
365 vec($server->{write_in_bitmap}, $child, 1) = 0;
|
|
|
366 }
|
|
|
367 } else {
|
|
|
368 last PROCESS;
|
|
|
369 }
|
|
|
370 if (@w) {
|
|
|
371 my $w = join('', map { "$_\015\012" } @w);
|
|
|
372 $ptr->[1] .= $w;
|
|
|
373 vec($server->{read_out_bitmap}, $child, 1) = 1;
|
|
|
374 }
|
|
|
375 }
|
|
|
376 $ptr->[2] = $in;
|
|
|
377 } else {
|
|
|
378 _close_child($server, $child, $now);
|
|
|
379 }
|
|
|
380 }
|
|
|
381 }
|
|
|
382 }
|
|
|
383 for my $id (keys %{$server->{tcp_socket}}) {
|
|
|
384 if (vec($ebm, $id, 1)) {
|
|
|
385 # closed connections?
|
|
|
386 $server->{tcp_socket}[4] = 1;
|
|
|
387 vec($server->{write_in_bitmap}, $id, 1) = 0;
|
|
|
388 } else {
|
|
|
389 my ($sock, $out, $in, $peerhost, $close) =
|
|
|
390 @{$server->{tcp_socket}{$id}};
|
|
|
391 if (vec($robm, $id, 1)) {
|
|
|
392 # send data out
|
|
|
393 my $len = syswrite $sock, $out;
|
|
|
394 defined $len
|
|
|
395 or faint(SP_INTERNET, $peerhost, $!);
|
|
|
396 if ($debug) {
|
|
|
397 my $done = substr($out, 0, $len, '');
|
|
|
398 $done =~ s/\\/\\\\/g;
|
|
|
399 $done =~ s/\015\012/\\n/g;
|
|
|
400 $done =~ s/([\000-\037])/sprintf("\\%03o", ord($1))/ge;
|
|
|
401 print STDERR "$now:$peerhost> $done\n";
|
|
|
402 } else {
|
|
|
403 substr($out, 0, $len) = '';
|
|
|
404 }
|
|
|
405 $server->{tcp_socket}{$id}[1] = $out;
|
|
|
406 $server->{active} = $now;
|
|
|
407 if ($out eq '') {
|
|
|
408 vec($server->{read_out_bitmap}, $id, 1) = 0;
|
|
|
409 _close_id($server, $id, $now) if $close;
|
|
|
410 }
|
|
|
411 }
|
|
|
412 if (vec($wibm, $id, 1)) {
|
|
|
413 # get new data in
|
|
|
414 my $line = '';
|
|
|
415 if (sysread($sock, $line, 1024)) {
|
|
|
416 $in .= $line;
|
|
|
417 if ($debug) {
|
|
|
418 $line =~ s/\\/\\\\/g;
|
|
|
419 $line =~ s/\015\012/\\n/g;
|
|
|
420 $line =~ s/([\000-\037])/sprintf("\\%03o", ord($1))/ge;
|
|
|
421 print STDERR "$now:$peerhost< $line\n";
|
|
|
422 }
|
|
|
423 $server->{tcp_socket}{$id}[2] = $in;
|
|
|
424 } else {
|
|
|
425 $server->{tcp_socket}{$id}[4] = 1;
|
|
|
426 vec($server->{write_in_bitmap}, $id, 1) = 0;
|
|
|
427 }
|
|
|
428 $server->{active} = $now;
|
|
|
429 }
|
|
|
430 }
|
|
|
431 }
|
|
|
432 };
|
|
|
433 $server->{in_progress} = 0;
|
|
|
434 $@ and die $@;
|
|
|
435 }
|
|
|
436 }
|
|
|
437
|
|
|
438 sub active {
|
|
|
439 @_ == 1 or croak "Usage: SERVER->active";
|
|
|
440 my ($server) = @_;
|
|
|
441 $server->{active};
|
|
|
442 }
|
|
|
443
|
|
|
444 sub connections {
|
|
|
445 @_ == 1 or croak "Usage: SERVER->connections";
|
|
|
446 my ($server) = @_;
|
|
|
447 scalar %{$server->{children}};
|
|
|
448 }
|
|
|
449
|
|
|
450 sub _close_child {
|
|
|
451 my ($server, $child, $now) = @_;
|
|
|
452 my ($sock, $out, $in, $peerhost, $close, $lcode, $ccode, $arg) =
|
|
|
453 @{$server->{children}{$child}};
|
|
|
454 $server->{debug} and print STDERR "$now:$peerhost: closing connection\n";
|
|
|
455 $ccode->($child, $arg);
|
|
|
456 close $sock;
|
|
|
457 delete $server->{children}{$child};
|
|
|
458 vec($server->{read_out_bitmap}, $child, 1) = 0;
|
|
|
459 vec($server->{write_in_bitmap}, $child, 1) = 0;
|
|
|
460 }
|
|
|
461
|
|
|
462 sub _close_id {
|
|
|
463 my ($server, $id, $now) = @_;
|
|
|
464 my ($sock, $out, $in, $peerhost, $close) = @{$server->{tcp_socket}{$id}};
|
|
|
465 $server->{debug} and print STDERR "$now:$peerhost: closing connection\n";
|
|
|
466 close $sock;
|
|
|
467 delete $server->{tcp_socket}{$id};
|
|
|
468 vec($server->{read_out_bitmap}, $id, 1) = 0;
|
|
|
469 vec($server->{write_in_bitmap}, $id, 1) = 0;
|
|
|
470 }
|
|
|
471
|
|
|
472 1;
|
