clc-intercal 1:1.0~4pre1.-94.-2-4 / usr / share / perl5 / Language / INTERCAL / Server.pm

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;