#! /usr/bin/perl -w
#
# Copyright (c) 2003-2004 Alexey klimkin <klimkin at cpan.org>.
# All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
use strict;
use Tie::IxHash;
use Tie::RefHash;
use P2P::pDonkey::Meta ':all';
use P2P::pDonkey::Util ':all';
use P2P::pDonkey::Packet ':all';
use P2P::pDonkey::Met ':server';
use ServBase;
my ($debug, $dump) = (1, 0);
my $user = makeClientInfo(0, 4662, 'Muxer', 60);
my $servers = readServerMet('ss.met') or die "Can't read file with server list!\n";
#my $servers = {idAddr(addr2ip('176.16.4.244'),4661) => makeServerDesc(addr2ip('176.16.4.244'), 4661) };
#my $servers = {idAddr(addr2ip('217.128.63.252'),4661) => makeServerDesc(addr2ip('217.128.63.252'), 4661) };
#my $servers = {idAddr(addr2ip('80.130.53.117'),4661) => makeServerDesc(addr2ip('80.130.53.117'), 4661) };
my @procTable;
$procTable[PT_SERVERLIST] = \&processServerList;
$procTable[PT_SERVERINFO] = \&processServerInfo;
$procTable[PT_SERVERSTATUS] = \&processServerStatus;
my $server = new ServBase(ProxyAddr => '192.168.3.2', ProxyPort => 8080,
ProcTable => \@procTable,
OnConnect => \&OnConnect,
Dump => $dump);
my $IN;
$IN = IO::Handle->new_from_fd(fileno(STDIN), 'r');
$IN->blocking(0);
#$IN->autoflush(1);
$server->watch($IN);
$SIG{INT} = sub {
writeServerMet('ss.met', $servers);
exit;
};
foreach my $s (values %$servers) {
$server->Connect(ip2addr($s->{IP}), $s->{Port}) || warn "Connect: $!";;
}
#$server->Connect('176.16.4.244', 4661) || warn "Connect: $!";
$server->MainLoop() || die "Can't start server: $!\n";
exit;
sub OnConnect {
my ($conn) = @_;
$conn->{InfoCnt} = 3;
$server->Queue($conn, PT_HELLO, $user);
$server->Queue($conn, PT_GETSERVERLIST, '');
}
sub processServerStatus {
my ($conn, $nusers, $nfiles) = @_;
my $sinfo = $servers->{idAddr($conn)};
$sinfo or die "Internal error";
$sinfo->{Meta}->{users} = makeMeta(TT_UNDEFINED, $nusers, 'users', VT_INTEGER);
$sinfo->{Meta}->{files} = makeMeta(TT_UNDEFINED, $nfiles, 'files', VT_INTEGER);
$conn->{InfoCnt}--;
$server->Disconnect($conn->{Socket}) unless $conn->{InfoCnt};
}
sub processServerInfo {
my ($conn, $d) = @_;
my $m = $d->{Meta};
if ($m) {
my $sinfo = $servers->{idAddr($conn)};
$sinfo or die "Internal error";
$sinfo->{Meta}->{Name} = $m->{Name} if ($m->{Name});
$sinfo->{Meta}->{Description} = $m->{Description} if ($m->{Description});
}
$conn->{InfoCnt}--;
$server->Disconnect($conn->{Socket}) unless $conn->{InfoCnt};
}
sub processServerList {
my ($conn, $d) = @_;
my ($ip, $port);
my $nservnew = 0;
while (@$d) {
$ip = shift @$d;
$port = shift @$d;
next if $servers->{idAddr($ip, $port)};
$nservnew++;
$servers->{idAddr($ip, $port)} = makeServerDesc($ip, $port);
$server->Connect(ip2addr($ip), $port) || warn "Connect: $!";
}
print "$nservnew new servers\n";
$conn->{InfoCnt}--;
$server->Disconnect($conn->{Socket}) unless $conn->{InfoCnt};
}