Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-INET-1.-94.-2/INTERCAL/Theft.pm @ 9707:e5fd34d2adcc
<shachaf> rm bin/re-ss
author | HackBot |
---|---|
date | Thu, 17 Nov 2016 17:06:57 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
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;