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

package Language::INTERCAL::Theft;

# Implementation of "theft protocol" for the INTERcal NETworking

# 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/Theft.pm 1.-94.-2") =~ /\s(\S+)$/;

use Carp;
use Socket qw(:DEFAULT :crlf);
use FindBin qw($Bin);
use File::Spec::Functions qw(catfile);
use IO::Socket::INET;
use Language::INTERCAL::Exporter '1.-94.-2';
use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
use Language::INTERCAL::Server '1.-94.-2';
use Language::INTERCAL::HostIP '1.-94.-2', qw(find_interfaces);

use constant DEFAULT_PORT => 64928;

my $if_cache = 0;
my @if_list = ();
my %if_map = ();

sub new {
    @_ == 5 or croak "Usage: Language::INTERCAL::Theft->new"
		   . "(SERVER, RC, CODE, ARGS)";
    my ($class, $server, $rc, $code, $args) = @_;
    my $port;
    my %options = $rc->program_options('INTERNET');
    $port = exists $options{PORT} ? $options{PORT}[0] : DEFAULT_PORT;
    my $host = '127.0.0.1';
    $port or faint(SP_INTERNET, $host, "INTERNET disabled by configuration");
    $@ = '';
    my $id = eval { $server->tcp_socket($host, $port) };
    if ($@) {
	my $tf = 'theft-server';
	my $ftf = catfile($Bin, $tf);
	-f $ftf and $tf = $ftf;
	$ftf = catfile(qw(blib script), $tf);
	-f $ftf and $tf = $ftf;
	my @I = map { "-I$_" } @INC;
	system $^X, @I, '-S', $tf, "--port=$port";
	my $timeout = 10;
	while ($timeout-- > 0) {
	    select undef, undef, undef, 0.1;
	    $@ = '';
	    $id = eval { $server->tcp_socket($host, $port) };
	    $@ or last;
	}
	$@ and faint(SP_INTERNET, $host, $!);
    }
    my $t = bless {
	server => $server,
	id => $id,
	host => $host,
	port => $port,
	broadcast => {},
	code => $code,
	args => $args,
    }, $class;
    my $line = $t->_getline;
    defined $line or faint(SP_INTERNET, $host, "Connection lost");
    $line =~ /^2/ or faint(SP_INTERNET, $host, $line);
    _get_interfaces($rc);
    my $lp = $server->tcp_listen(\&_open, \&_line, \&_close, $t);
    $t->{victim_port} = $lp;
    $t->_command("VICTIM $$ ON PORT $lp");
    $t;
}

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

sub find_theft_servers {
    @_ == 1 || @_ == 2
	or croak "Usage: THEFT->find_theft_servers[(BROADCAST)]";
    my ($t, $bcast) = @_;
    if (defined $bcast) {
	$bcast eq INADDR_ANY || $bcast eq INADDR_BROADCAST and $bcast = undef;
    }
    my $index = defined $bcast ? $bcast : '';
    return @{$t->{all_servers}{$index}}
	if $t->{all_servers}{$index} && $t->{servers_valid}{$index} >= time;
    # send all requests...
    my $port = $t->{port};
    my @sockets = ();
    my $select = '';
    for my $item (@if_list) {
	my ($if, $ip, $bc) = @$item;
	next if defined $bcast && $bcast ne inet_aton($bc);
	my $socket = IO::Socket::INET->new(
	    PeerPort  => $port,
	    Proto     => 'udp',
	    Type      => SOCK_DGRAM,
	    Broadcast => 1,
	    ReuseAddr => 1,
	) or faint(SP_INTERNET, "broadcast", $!);
	defined $socket->send('x', 0, pack_sockaddr_in($port, inet_aton($bc)))
	    or faint(SP_INTERNET, "broadcast", $!);
	vec($select, fileno($socket), 1) = 1;
	push @sockets, $socket;
    }
    # wait for all replies, with a timeout of 5 seconds
    my $list;
    my %ips = ();
    defined $bcast or $ips{inet_ntoa(INADDR_LOOPBACK)} = 1;
    # 2 seconds should be plenty on a LAN...
    my $timeout = 2;
    my $limit = time + $timeout;
    while ($timeout >= 0 && select($list = $select, undef, undef, $timeout)) {
	for my $socket (@sockets) {
	    vec($list, fileno($socket), 1) or next;
	    my $buffer = '';
	    my $ip = $socket->recv($buffer, 1, 0)
		or faint(SP_INTERNET, "broadcast", $!);
	    my ($port, $addr) = unpack_sockaddr_in($ip);
	    $ips{inet_ntoa($addr)} = 1;
	}
	$timeout = $limit - time;
    }
    my @s = keys %ips;
    $t->{all_servers}{$index} = \@s;
    $t->{servers_valid}{$index} = time + 30;
    return @s;
}

sub make_broadcast {
    @_ == 2 or croak "THEFT->make_broadcast(ADDR)";
    my ($t, $addr) = @_;
    my $ip = inet_aton($addr) or return undef;
    $ip eq INADDR_ANY || $ip eq INADDR_BROADCAST
	and return INADDR_BROADCAST;
    $ip = inet_ntoa($ip);
    exists $if_map{$ip} or return undef;
    return $if_map{$ip};
}

sub _getline {
    my ($t, $id) = @_;
    my $server = $t->{server};
    $id = $t->{id} if ! defined $id;
    $server->progress(0); # in case I'm talking to myself
    while (1) {
	my $count = $server->data_count($id, 1);
	defined $count or return undef;
	$count and return $server->write_in($id, 0);
	$server->progress(0.01); # in case I'm talking to myself
    }
}

sub _putline {
    my ($t, $line, $id) = @_;
    my $server = $t->{server};
    $id = $t->{id} if ! defined $id;
    $server->read_out($id, $line);
    $server->progress(0); # in case I'm talking to myself
}

sub _get_interfaces {
    my ($rc) = @_;
    return if $if_cache;
    %if_map = ();
    @if_list = ();
    my %options = $rc->program_options('INTERNET');
    if (keys %options) {
	require Net::Netmask;
	for my $name (keys %options) {
	    $name =~ /^DEVICE\.(.*)$/ or next;
	    my $if = $1;
	    my ($ip, $map) = @{$options{$name}};
	    my $pack = inet_aton($ip) or next;
	    @{$map->{''}} or next;
	    my ($bits) = @{$map->{''}};
	    my $net = new2 Net::Netmask("$ip/$bits") or next;
	    my $bc = $net->broadcast;
	    my $pbc = inet_aton($bc) or next;
	    $if_map{$bc} = $pbc;
	    push @if_list, [$if, $ip, $bc];
	    $if_cache = 1;
	}
    }
    return if $if_cache;
    my $if = find_interfaces;
    for my $name (keys %$if) {
	$if->{$name}{addr} or next;
	my $ip = inet_aton($if->{$name}{addr}) or next;
	$if->{$name}{bcast} or next;
	my $pbc = inet_aton($if->{$name}{bcast}) or next;
	my $bc = inet_ntoa($pbc);
	$if_map{$bc} = $pbc;
	push @if_list, [$name, $ip, $bc];
    }
    $if_cache = 1;
}

sub _command {
    @_ == 2 || @_ == 3
	or croak "Usage: THEFT->_command(COMMAND [, ID])";
    my ($t, $cmd, $id) = @_;
    $t->_putline($cmd, $id);
    my $reply = $t->_getline($id);
    defined $reply or faint(SP_INTERNET, $t->{host}, "($cmd) Connection lost");
    $reply =~ /^2/ or faint(SP_INTERNET, $t->{host}, $reply);
    $reply;
}

sub _getlist {
    @_ == 1 || @_ == 2 or croak "Usage: THEFT->_getlist [(ID)]";
    my ($t, $id) = @_;
    my @list = ();
    while (1) {
	my $r = $t->_getline($id);
	defined $r or faint(SP_INTERNET, $t->{host}, "Connection lost");
	$r eq '.' and last;
	push @list, $r;
    }
    @list;
}

sub _open {
    my ($id, $sockhost, $peerhost, $close, $t) = @_;
    return "201 INTERNET (VICTIM) on $sockhost ($VERSION)";
}

sub _line {
    my ($server, $id, $close, $line, $t) = @_;
    if ($line =~ /^\s*(STEAL|SMUGGLE)\s+(\S+)/i) {
	my $code = $t->{code};
	return $code->(uc($1), $2, $id, $t, $t->{args});
    } elsif ($line =~ /^\s*THANKS/i) {
	$$close = 1;
	return "251 You are welcome";
    } else {
	return "550 Bad request";
    }
}

sub _close {
    my ($id, $t) = @_;
    # nothing to do here
}

sub pids {
    @_ == 1 || @_ == 2 or croak "Usage: THEFT->pids";
    my ($t, $server) = @_;
    my $id = undef;
    if (defined $server) {
	$id = $t->{server}->tcp_socket($server, $t->{port});
	$t->_getline($id);
    }
    $t->_command("CASE PID", $id);
    my @pids = map { /^(\d+)/ ? $1 : () } $t->_getlist($id);
    defined $id and $t->{server}->tcp_socket_close($id);
    @pids;
}

sub start_request {
    @_ == 4 or croak "Usage: THEFT->start_request(HOST, PID, TYPE)";
    my ($t, $host, $pid, $type) = @_;
    $type = uc($type);
    $type eq 'STEAL' || $type eq 'SMUGGLE'
	or faint(SP_INTERNET, $host, "Invalid type $type");
    $t->{req_type} = $type;
    my $id = $t->{server}->tcp_socket($host, $t->{port});
    $t->_getline($id);
    my $port = $t->_command("CASE PORT $pid", $id);
    $t->{server}->tcp_socket_close($id);
    $port =~ /^520/
	and faint(SP_INTERNET, $host, "No such PID $pid");
    $port =~ /^2\d+\s+(\d+)/
	or faint(SP_INTERNET, $host, "Invalid reply $port");
    $port = $1;
    my $request = $t->{server}->tcp_socket($host, $port);
    $t->_getline($request);
    $t->{request} = $request;
    $t;
}

sub finish_request {
    @_ == 1 or croak "Usage: THEFT->end_request";
    my ($t) = @_;
    exists $t->{request} or faint(SP_INTERNET, $t->{host}, "Not in request");
    my $request = $t->{request};
    $t->_putline("THANKS", $request);
    $t->{server}->tcp_socket_close($request);
    delete $t->{request};
    $t;
}

sub request {
    @_ == 2 or croak "Usage: THEFT->request(REGISTER)";
    my ($t, $reg) = @_;
    exists $t->{req_type} or faint(SP_INTERNET, $t->{host}, "No TYPE");
    exists $t->{request} or faint(SP_INTERNET, $t->{host}, "Not in request");
    my $request = $t->{request};
    $t->_command($t->{req_type} . ' ' . $reg, $request);
    return $t->_getlist($request);
}

1;