Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/Server.pm @ 12500:e48c08805365 draft default tip
<b_jonas> ` learn \'The password of the month is Cthulhuquagdonic Mothraquagdonic Narwhalicorn.\' # https://logs.esolangs.org/libera-esolangs/2024-04.html#lKE Infinite craft
author | HackEso <hackeso@esolangs.org> |
---|---|
date | Wed, 01 May 2024 06:39:10 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
package Language::INTERCAL::Server; # 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. use strict; use vars qw($VERSION $PERVERSION); ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Server.pm 1.-94.-2") =~ /\s(\S+)$/; use Socket; use IO::Socket::INET; use Getopt::Long; use Carp; use Language::INTERCAL::Splats '1.-94.-2', qw(faint SP_INTERNET); # note we are not assuming the perl interpreter is threaded - a future release # may have two versions of the server, one threaded and one unthreaded, but for # now we just have the unthreaded one - using select and friends to avoid # deadlocks when we are doing things like stealing from self. sub new { @_ == 1 or croak "Usage: Language::INTERCAL::Server->new"; my ($class) = @_; bless { write_in_bitmap => '', read_out_bitmap => '', tcp_listen => {}, tcp_socket => {}, udp_listen => {}, file_listen => {}, children => {}, debug => 0, active => time, in_progress => 0, }, $class; } sub debug { @_ == 1 or croak "Usage: SERVER->debug"; my ($server) = @_; $server->{debug} = 1; } sub file_listen { @_ == 3 or croak "Usage: SERVER->file_listen(ID, CALLBACK)"; my ($server, $id, $code) = @_; $server->{file_listen}{$id} = $code; vec($server->{write_in_bitmap}, $id, 1) = 1; $server; } sub file_listen_close { @_ == 2 or croak "Usage: SERVER->file_listen_close(ID)"; my ($server, $id) = @_; exists $server->{file_listen}{$id} or croak "file_listen_close: unknown ID"; delete $server->{file_listen}{$id}; vec($server->{write_in_bitmap}, $id, 1) = 0; $server; } sub tcp_listen { @_ == 5 || @_ == 6 or croak "Usage: SERVER->tcp_listen(OPEN, LINE, CLOSE, ARG [, PORT])"; my ($server, $open, $line, $close, $arg, $port) = @_; my @port = $port ? (LocalPort => $port) : (); $port = $port ? " on $port" : ''; my $socket = IO::Socket::INET->new( @port, Listen => 128, Proto => 'tcp', Type => SOCK_STREAM, ReuseAddr => 1, ) or die "TCP listen$port: $!\n"; my $fn = fileno($socket); $server->{tcp_listen}{$fn} = [$socket, $open, $line, $close, $arg]; vec($server->{write_in_bitmap}, $fn, 1) = 1; $port = $socket->sockport; $server->{debug} and print STDERR "Listening on $port\n"; $port; } sub tcp_socket { @_ == 3 or croak "Usage: SERVER->tcp_socket(HOST, PORT)"; my ($server, $host, $port) = @_; my $socket = IO::Socket::INET->new( PeerHost => $host, PeerPort => $port, Proto => 'tcp', Type => SOCK_STREAM, Blocking => 1, ) or faint(SP_INTERNET, "$host:$port", $!); my $fn = fileno($socket); $server->{tcp_socket}{$fn} = [$socket, '', '', 0, 0]; vec($server->{write_in_bitmap}, $fn, 1) = 1; $server->{debug} and print STDERR "Connected to $host:$port\n"; $fn; } sub udp_listen { @_ == 2 or croak "Usage: SERVER->udp_listen(PORT)"; my ($server, $port) = @_; my $pp = $port ? " on $port" : ''; my $socket = IO::Socket::INET->new( LocalPort => $port, Proto => 'udp', Type => SOCK_DGRAM, ReuseAddr => 1, Broadcast => 1, ) or die "UDP listen$pp: $!\n"; my $fn = fileno($socket); $server->{udp_listen}{$fn} = [$socket, $port]; vec($server->{write_in_bitmap}, $fn, 1) = 1; $socket->sockport; } sub read_out { @_ > 2 or croak "Usage: SERVER->read_out(ID, DATA)"; my ($server, $fn, @data) = @_; my $data = join('', map { "$_\015\012" } @data); _read($server, $fn, $data); $server; } sub read_binary { @_ > 2 or croak "Usage: SERVER->read_binary(ID, DATA)"; my ($server, $fn, @data) = @_; my $data = join('', @data); _read($server, $fn, $data); $server; } sub _read { my ($server, $fn, $data) = @_; if (exists $server->{tcp_socket}{$fn}) { $server->{tcp_socket}{$fn}[1] .= $data; } elsif (exists $server->{children}{$fn}) { $server->{children}{$fn}[1] .= $data; } else { croak "No such ID"; } vec($server->{read_out_bitmap}, $fn, 1) = 1; } sub alternate_callback { @_ == 4 or croak "Usage: SERVER->alternate_callback(ID, SIZE, CODE)"; my ($server, $fn, $size, $code) = @_; exists $server->{children}{$fn} or croak "No such ID"; $server->{children}{$fn}[8] = [$size, $code]; $server; } sub write_in { @_ == 2 || @_ == 3 or croak "Usage: SERVER->write_in(ID [, PROGRESS])"; my ($server, $fn, $progress) = @_; exists $server->{tcp_socket}{$fn} or croak "No such ID"; my $data = $server->{tcp_socket}{$fn}; if ($data->[2] =~ s/^(.*?)\012//) { my $line = $1; $line =~ s/\015$//; return $line; } if ($data->[4]) { my $line = $data->[2]; $data->[2] = ''; return $line; } $progress or return undef; while (1) { $server->progress; exists $server->{tcp_socket}{$fn} or return undef; if ($data->[2] =~ s/^(.*?)\012//) { my $line = $1; $line =~ s/\015$//; return $line; } if ($data->[4]) { my $line = $data->[2]; $data->[2] = ''; return $line; } } } sub write_binary { @_ == 3 || @_ == 4 or croak "Usage: SERVER->write_binary(ID, SIZE [, PROGRESS])"; my ($server, $fn, $size, $progress) = @_; exists $server->{tcp_socket}{$fn} or croak "No such ID"; my $data = $server->{tcp_socket}{$fn}; if (length($data->[2]) >= $size || ! $progress || $data->[4]) { return substr($data->[2], 0, $size, ''); } while (1) { $server->progress; exists $server->{tcp_socket}{$fn} or return undef; if (length($data->[2]) >= $size || $data->[4]) { return substr($data->[2], 0, $size, ''); } } } sub data_count { @_ == 2 || @_ == 3 or croak "Usage: SERVER->data_count(ID [, PROGRESS])"; my ($server, $fn, $progress) = @_; exists $server->{tcp_socket}{$fn} or return undef; my $data = $server->{tcp_socket}{$fn}; index($data->[2], "\012") >= 0 and return 1; $progress or return 0; while (1) { $server->progress; exists $server->{tcp_socket}{$fn} or return undef; index($data->[2], "\012") >= 0 and return 1; } } sub tcp_socket_close { @_ == 2 or croak "Usage: SERVER->tcp_socket_close(ID)"; my ($server, $fn) = @_; exists $server->{tcp_socket}{$fn} or return undef; _close_id($server, $fn, time); } sub progress { @_ == 1 || @_ == 2 or croak "Usage: SERVER->progress [(TIMEOUT)]"; my ($server, $timeout) = @_; $server->{in_progress} and croak "SERVER->progress is not reentrant"; while (1) { my $wibm = $server->{write_in_bitmap}; my $robm = $server->{read_out_bitmap}; my $ebm = $wibm | $robm; my $nfound = select $wibm, $robm, $ebm, $timeout; $nfound or return $server; $server->{in_progress} = 1; $@ = ''; eval { $timeout = 0.01; my $debug = $server->{debug}; my $now = time; # file activity? for my $fid (keys %{$server->{file_listen}}) { vec($wibm, $fid, 1) or next; &{$server->{file_listen}{$fid}}(); } # are they opening a new connection? for my $tcp (keys %{$server->{tcp_listen}}) { vec($wibm, $tcp, 1) or next; my ($tcp_listen, $ocode, $lcode, $ccode, $arg) = @{$server->{tcp_listen}{$tcp}}; my $sock = $tcp_listen->accept; if ($sock) { $sock->blocking(0); my $child = fileno $sock; my $sockhost = $sock->sockhost; my $peerhost = $sock->peerhost; my $close = 0; my @w = $ocode->($child, $sockhost, $peerhost, \$close, $arg); $peerhost .= ':' . $sock->peerport; $debug and print STDERR "$now:$peerhost: accepting connection\n"; my $w = join('', map { "$_\015\012" } @w); $server->{children}{$child} = [$sock, $w, '', $peerhost, $close, $lcode, $ccode, $arg, 0]; vec($server->{read_out_bitmap}, $child, 1) = 1 if @w; vec($server->{write_in_bitmap}, $child, 1) = 1; $server->{active} = $now; } } # any broadcasts? for my $udp (keys %{$server->{udp_listen}}) { vec($wibm, $udp, 1) or next; my ($udp_listen, $port) = @{$server->{udp_listen}{$udp}}; my $x = ''; my $them = $udp_listen->recv($x, 1, 0); my ($p, $h) = unpack_sockaddr_in($them); $h = inet_ntoa($h); $debug and print STDERR "$now:$h:$p: received broadcast ($x)\n"; my $udp_send = IO::Socket::INET->new( LocalPort => $port, PeerHost => $h, PeerPort => $p, Proto => 'udp', Type => SOCK_DGRAM, ReuseAddr => 1, ); $udp_send and $udp_send->send($x, 0); $server->{active} = $now; } for my $child (keys %{$server->{children}}) { if (vec($ebm, $child, 1)) { # closed connections? _close_child($server, $child, $now); } else { my ($sock, $out, $in, $peerhost, $close, $lcode, $ccode, $arg, $alternate) = @{$server->{children}{$child}}; if (vec($robm, $child, 1)) { # send data out my $len = syswrite $sock, $out; defined $len or faint(SP_INTERNET, $peerhost, $!); if ($debug) { my $done = substr($out, 0, $len, ''); $done =~ s/\\/\\\\/g; $done =~ s/\015\012/\\n/g; $done =~ s/([\000-\037])/sprintf("\\%03o", $1)/ge; print STDERR "$now:$peerhost> $done\n"; } else { substr($out, 0, $len) = ''; } $server->{children}{$child}[1] = $out; $server->{active} = $now; if ($out eq '') { if ($close) { _close_child($server, $child, $now); next; } else { vec($server->{read_out_bitmap}, $child, 1) = 0; } } } if (vec($wibm, $child, 1)) { # get new data in my $line = ''; if (sysread($sock, $line, 1024)) { $in .= $line; if ($debug) { $line =~ s/\\/\\\\/g; $line =~ s/\015\012/\\n/g; $line =~ s/([\000-\037])/sprintf("\\%03o", $1)/ge; print STDERR "$now:$peerhost< $line\n"; } my $ptr = $server->{children}{$child}; $server->{active} = $now; PROCESS: while ($in ne '') { # note that this can be changed inside the callback, # which is why we don't use $alternate my @w = (); if ($ptr->[8]) { # alternate callback in operation my ($size, $code) = @{$ptr->[8]}; length($in) < $size && ! $ptr->[4] and last PROCESS; my $data = $in eq '' ? undef : substr($in, 0, $size, ''); $ptr->[8] = 0; @w = $code->($data); } elsif ($in =~ s/^(.*?)\012//) { $line = $1; $line =~ s/\015$//; $debug and print STDERR "$now:$peerhost<< $line\n"; @w = $lcode->($server, $child, \$close, $line, $arg); if ($close) { $ptr->[4] = 1; vec($server->{write_in_bitmap}, $child, 1) = 0; } } else { last PROCESS; } if (@w) { my $w = join('', map { "$_\015\012" } @w); $ptr->[1] .= $w; vec($server->{read_out_bitmap}, $child, 1) = 1; } } $ptr->[2] = $in; } else { _close_child($server, $child, $now); } } } } for my $id (keys %{$server->{tcp_socket}}) { if (vec($ebm, $id, 1)) { # closed connections? $server->{tcp_socket}[4] = 1; vec($server->{write_in_bitmap}, $id, 1) = 0; } else { my ($sock, $out, $in, $peerhost, $close) = @{$server->{tcp_socket}{$id}}; if (vec($robm, $id, 1)) { # send data out my $len = syswrite $sock, $out; defined $len or faint(SP_INTERNET, $peerhost, $!); if ($debug) { my $done = substr($out, 0, $len, ''); $done =~ s/\\/\\\\/g; $done =~ s/\015\012/\\n/g; $done =~ s/([\000-\037])/sprintf("\\%03o", ord($1))/ge; print STDERR "$now:$peerhost> $done\n"; } else { substr($out, 0, $len) = ''; } $server->{tcp_socket}{$id}[1] = $out; $server->{active} = $now; if ($out eq '') { vec($server->{read_out_bitmap}, $id, 1) = 0; _close_id($server, $id, $now) if $close; } } if (vec($wibm, $id, 1)) { # get new data in my $line = ''; if (sysread($sock, $line, 1024)) { $in .= $line; if ($debug) { $line =~ s/\\/\\\\/g; $line =~ s/\015\012/\\n/g; $line =~ s/([\000-\037])/sprintf("\\%03o", ord($1))/ge; print STDERR "$now:$peerhost< $line\n"; } $server->{tcp_socket}{$id}[2] = $in; } else { $server->{tcp_socket}{$id}[4] = 1; vec($server->{write_in_bitmap}, $id, 1) = 0; } $server->{active} = $now; } } } }; $server->{in_progress} = 0; $@ and die $@; } } sub active { @_ == 1 or croak "Usage: SERVER->active"; my ($server) = @_; $server->{active}; } sub connections { @_ == 1 or croak "Usage: SERVER->connections"; my ($server) = @_; scalar %{$server->{children}}; } sub _close_child { my ($server, $child, $now) = @_; my ($sock, $out, $in, $peerhost, $close, $lcode, $ccode, $arg) = @{$server->{children}{$child}}; $server->{debug} and print STDERR "$now:$peerhost: closing connection\n"; $ccode->($child, $arg); close $sock; delete $server->{children}{$child}; vec($server->{read_out_bitmap}, $child, 1) = 0; vec($server->{write_in_bitmap}, $child, 1) = 0; } sub _close_id { my ($server, $id, $now) = @_; my ($sock, $out, $in, $peerhost, $close) = @{$server->{tcp_socket}{$id}}; $server->{debug} and print STDERR "$now:$peerhost: closing connection\n"; close $sock; delete $server->{tcp_socket}{$id}; vec($server->{read_out_bitmap}, $id, 1) = 0; vec($server->{write_in_bitmap}, $id, 1) = 0; } 1;