--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/interps/clc-intercal/CLC-INTERCAL-INET-1.-94.-2/INTERCAL/Theft.pm	Sun Dec 09 19:30:08 2012 +0000
@@ -0,0 +1,312 @@
+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;