package Language::INTERCAL::Server;

# File access server

# This file is part of CLC-INTERCAL

# Copyright (c) 2007-2008, 2023 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.4") =~ /\s(\S+)$/;

use Carp;
use POSIX qw(EAGAIN EWOULDBLOCK);

# 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) = @_;
    my $server = bless {
	write_in_bitmap => '',
	read_out_bitmap => '',
	file_listen => {},
	file_receive => {},
	file_send => {},
	debug => 0,
	active => time,
	newline => "\n",
    }, $class;
    $server->can('upgrade')
	and $class->upgrade($server);
    $server;
}

sub debug {
    @_ == 1 or croak "Usage: SERVER->debug";
    my ($server) = @_;
    $server->{debug} = 1;
}

sub file_listen {
    @_ == 3 || @_ == 4
	or croak "Usage: SERVER->file_listen(ID, DATA_CALLBACK [, CLOSE_CALLBACK])";
    my ($server, $id, $data, $close) = @_;
    vec($server->{write_in_bitmap}, $id, 1)
	and croak "file_listen: ID $id already in use";
    $server->{file_listen}{$id} = [$data, $close];
    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 file_receive {
    @_ == 2 || @_ == 3 || @_ == 4
	or croak "Usage: SERVER->file_receive(HANDLE, [CLOSE_CALLBACK [, DATA_CALLBACK]])";
    my ($server, $fh, $close, $data) = @_;
    my $id = fileno $fh;
    defined $id or croak "Invalid HANDLE";
    vec($server->{write_in_bitmap}, $id, 1)
	and croak "file_receive: ID $id already in use";
    $server->{file_receive}{$id} = [$fh, '', 0, $close, $data];
    vec($server->{write_in_bitmap}, $id, 1) = 1;
    $server;
}

sub file_receive_close {
    @_ == 2 or croak "Usage: SERVER->file_receive_close(HANDLE)";
    my ($server, $id) = @_;
    ref $id and $id = fileno $id;
    defined $id or croak "Invalid HANDLE";
    exists $server->{file_receive}{$id}
	or croak "file_receive_close: unknown ID";
    delete $server->{file_receive}{$id};
    vec($server->{write_in_bitmap}, $id, 1) = 0;
    $server;
}

sub write_in {
    @_ == 2 || @_ == 3
	or croak "Usage: SERVER->write_in(ID [, PROGRESS])";
    my ($server, $id, $progress) = @_;
    exists $server->{file_receive}{$id} or return undef;
    my $data = $server->{file_receive}{$id};
    my $pos = index($data->[1], $server->{newline});
    if ($pos < 0 && ! $data->[2]) {
	$progress or return undef;
	while ($pos < 0 && ! $data->[2] && exists $server->{file_receive}{$id}) {
	    $server->progress;
	    $pos = index($data->[1], $server->{newline});
	}
    }
    my $line;
    if ($pos < 0) {
	$line = $data->[1];
	$data->[1] = '';
    } else {
	$line = substr($data->[1], 0, $pos, '');
	substr($data->[1], 0, length $server->{newline}) = '';
    }
    $line;
}

sub write_binary {
    @_ == 3 || @_ == 4
	or croak "Usage: SERVER->write_binary(ID, SIZE [, PROGRESS])";
    my ($server, $id, $size, $progress) = @_;
    exists $server->{file_receive}{$id} or return undef;
    my $data = $server->{file_receive}{$id};
    length($data->[1]) >= $size || ! $progress || $data->[2]
	and return substr($data->[1], 0, $size, '');
    while (1) {
	$server->progress;
	length($data->[1]) >= $size || $data->[2]
	    and return substr($data->[1], 0, $size, '');
	exists $server->{file_receive}{$id} or return undef;
    }
}

sub data_count {
    @_ == 2 || @_ == 3
	or croak "Usage: SERVER->data_count(ID [, PROGRESS])";
    my ($server, $id, $progress) = @_;
    exists $server->{file_receive}{$id} or return undef;
    my $data = $server->{file_receive}{$id};
    index($data->[1], $server->{newline}) >= 0 and return 1;
    $data->[2] and return 0;
    $progress or return 0;
    while (1) {
	$server->progress;
	exists $server->{file_receive}{$id} or return undef;
	index($data->[1], $server->{newline}) >= 0 and return 1;
	$data->[2] and return 0;
    }
}

sub data_length {
    @_ == 2 or croak "Usage: SERVER->data_length(ID)";
    my ($server, $id) = @_;
    exists $server->{file_receive}{$id} or return undef;
    length($server->{file_receive}{$id}[1]);
}

sub file_send {
    @_ >= 2 && @_ <= 4
	or croak "Usage: SERVER->file_send(HANDLE[, CLOSE_CALLBACK [, NO_DATA_CALLBACK]])";
    my ($server, $fh, $close, $nodata) = @_;
    my $id = fileno $fh;
    defined $id or croak "Invalid HANDLE $fh";
    exists $server->{file_send}{$id}
	and croak "file_send ID $id already in use";
    $server->{file_send}{$id} = [$fh, '', $close, $nodata];
    vec($server->{read_out_bitmap}, $id, 1) = 0;
    $server;
}

sub read_out {
    @_ >= 2 or croak "Usage: SERVER->read_out(ID, DATA)";
    my ($server, $id, @data) = @_;
    my $data = join('', map { $_ . $server->{newline} } @data);
    $server->_read($id, $data);
}

sub read_binary {
    @_ >= 2 or croak "Usage: SERVER->read_binary(ID, DATA)";
    my ($server, $id, @data) = @_;
    my $data = join('', @data);
    $server->_read($id, $data);
}

sub _read {
    my ($server, $id, $data) = @_;
    $data eq '' and return $server;
    exists $server->{file_send}{$id} or croak "Invalid ID $id";
    $server->{file_send}{$id}[1] .= $data;
    vec($server->{read_out_bitmap}, $id, 1) = 1;
    $server->progress(0);
    $server;
}

sub file_send_close {
    @_ == 2 or croak "Usage: SERVER->file_send_close(HANDLE)";
    my ($server, $fh) = @_;
    my $id;
    if (exists $server->{file_send}{$fh}) {
	$id = $fh;
    } else {
	$id = fileno $fh;
	defined $id && exists $server->{file_send}{$id}
	    or croak "Invalid HANDLE";
    }
    vec($server->{read_out_bitmap}, $id, 1) = 0;
    delete $server->{file_send}{$id};
    $server;
}

sub progress {
    @_ == 1 || @_ == 2
	or croak "Usage: SERVER->progress [(TIMEOUT)]";
    my ($server, $timeout) = @_;
    # a callback could call us; if this happens in the select() loop
    # it could confuse the select() itself; instead, we just remember
    # we've been called and we'll repeat the loop
    if (defined $server->{in_progress}) {
	$server->{in_progress} = 1;
	return $server;
    }
    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 > 0 or return $server;
	$@ = '';
	my $change;
	my $repeat = ! defined $timeout;
	local $server->{schedule} = [];
	{
	    local $server->{in_progress} = 0;
	    eval {
		my $debug = $server->{debug};
		# file activity?
		for my $fid (keys %{$server->{file_listen}}) {
		    if (vec($wibm, $fid, 1)) {
			&{$server->{file_listen}{$fid}[0]}($server, $fid);
			$change = 1;
		    } elsif (vec($ebm, $fid, 1)) {
			vec($server->{write_in_bitmap}, $fid, 1) = 0;
			if ($server->{file_listen}{$fid}[1]) {
			    &{$server->{file_listen}{$fid}[1]}($server, $fid);
			    $server->{file_listen}{$fid}[1] = undef;
			}
			$change = 1;
		    }
		}
		# writing something in?
		for my $fid (keys %{$server->{file_receive}}) {
		    if (vec($wibm, $fid, 1)) {
			my $fh = $server->{file_receive}{$fid}[0];
			# somebody could have closed it
			$fh or next;
			my $wd;
			my $recv;
			# Sometimes we get "data ready" on a pipe even when there
			# is no actual data so the read blocks; the filehandle will
			# be made nonblocking to help with that, and we check for
			# EAGAIN to see if a zero-length result is due to end of file
			# or lack of data (also needs to check EWOULDBLOCK because
			# POSIX allows either one, and also allows them to be
			# different error codes).
			$! = 0;
			if (sysread $fh, $wd, 4096) {
			    $server->{file_receive}{$fid}[1] .= $wd;
			    my $cb = $server->{file_receive}{$fid}[4];
			    $cb and $cb->($server, $fh);
			    $change = 1;
			} elsif ($! != EAGAIN && $! != EWOULDBLOCK) {
			    # end of file, we'll want to stop receiving
			    $nfound--;
			    $server->{file_receive}{$fid}[2] = 1;
			    vec($server->{write_in_bitmap}, $fid, 1) = 0;
			    my $cb = $server->{file_receive}{$fid}[3];
			    $cb and $cb->($server, $fh);
			}
		    } elsif (vec($ebm, $fid, 1)) {
			$server->{file_receive}{$fid}[2] = 1;
			vec($server->{write_in_bitmap}, $fid, 1) = 0;
			my $cb = $server->{file_receive}{$fid}[3];
			$cb and $cb->($server, $server->{file_receive}{$fid}[0]);
			$change = 1;
		    }
		}
		# reading something out?
		for my $fid (keys %{$server->{file_send}}) {
		    if (vec($ebm, $fid, 1)) {
			# closed connections?
			vec($server->{read_out_bitmap}, $fid, 1) = 0;
			my ($fh, undef, $cb) = @{$server->{file_send}{$fid}};
			$cb and $cb->($server, $fh);
			vec($server->{read_out_bitmap}, $fid, 1) = 0;
			delete $server->{file_send}{$fid};
			$change = 1;
		    } elsif (vec($robm, $fid, 1)) {
			my ($fh, $out, $cb, $nd) = @{$server->{file_send}{$fid}};
			my $len = syswrite $fh, $out;
			if (defined $len) {
			    $len and substr($server->{file_send}{$fid}[1], 0, $len) = '';
			    if ($server->{file_send}{$fid}[1] eq '') {
				vec($server->{read_out_bitmap}, $fid, 1) = 0;
				$nd and $nd->($server, $fh);
			    } else {
				vec($server->{read_out_bitmap}, $fid, 1) = 1;
			    }
			} else {
			    $cb and $cb->($server, $fh);
			    vec($server->{read_out_bitmap}, $fid, 1) = 0;
			    delete $server->{file_send}{$fid};
			}
			$change = 1;
		    }
		}
	    };
	    $change and $server->{active} = time;
	    $server->{in_progress} and $repeat = $change = 1;
	}
	# any scheduled callback happen now, so if they call progress()
	# they don't get in the way of the above select() with another one
	while (@{$server->{schedule}}) {
	    my ($code, @args) = @{shift @{$server->{schedule}}};
	    $code->(@args);
	}
	$@ and die $@;
	# if nothing actually produced any data, it means everybody has
	# reported "ready" when they weren't. No point trying again now
	$change && $repeat or return $server;
	$timeout = 0;
    }
}

sub schedule {
    @_ >= 2 or croak "Usage: SERVER->schedule(CALLBACK [, ARGS])";
    my ($server, @code) = @_;
    push @{$server->{schedule}}, \@code;
    $server;
}

sub active {
    @_ == 1 or croak "Usage: SERVER->active";
    my ($server) = @_;
    $server->{active};
}

sub interfaces_only {
    @_ == 1 or croak "Usage: SERVER->interfaces_only";
    0;
}

1;
