{
use Moose;
use AnyEvent;
use Carp qw[carp];
use List::Util qw[shuffle];
our $MAJOR = 0.074; our $MINOR = 0; our $DEV = 1; our $VERSION = sprintf('%1.3f%03d' . ($DEV ? (($DEV < 0 ? '' : '_') . '%03d') : ('')), $MAJOR, $MINOR, abs $DEV);
use lib '../../../../';
use Net::BitTorrent::Types qw[:tracker :bencode];
has 'torrent' => (isa => 'Net::BitTorrent::Torrent',
is => 'ro',
weak_ref => 1,
writer => '_torrent',
predicate => 'has_torrent',
handles => {client => 'client'}
);
has 'tiers' => (
traits => ['Array'],
isa => 'NBTypes::Tracker::Tier',
is => 'rw',
coerce => 1,
default => sub { [] },
handles => {_push_tier => 'push', _shuffle_tiers => 'shuffle'}
);
my $tier_constraint;
sub add_tier {
my ($self, $urls) = @_;
$tier_constraint //=
Moose::Util::TypeConstraints::find_type_constraint(
'NBTypes::Tracker::Tier');
$self->_push_tier($tier_constraint->coerce($urls));
$self->_shuffle_tiers;
}
#
for my $type (qw[announce scrape]) {
has "_${type}_quests" => (isa => 'ArrayRef[Ref]',
is => 'ro',
init_arg => undef,
traits => ['Array'],
handles => {
"add_${type}_quest" => 'push',
"${type}_quests" => 'elements',
"get_${type}_quest" => 'get',
"grep_${type}_quests" => 'grep',
"map_${type}_quests" => 'map'
},
default => sub { [] }
);
after "add_${type}_quest" => sub {
require Scalar::Util;
Scalar::Util::weaken $_[0]->{"_${type}_quests"}->[-1];
};
}
sub announce {
my ($self, $event, $code) = @_;
require Scalar::Util;
Scalar::Util::weaken $self;
my %args = (info_hash => $self->torrent->info_hash->to_Hex,
peer_id => $self->client->peer_id,
port => $self->client->port,
uploaded => $self->torrent->uploaded,
downloaded => $self->torrent->downloaded,
left => $self->torrent->left
);
$args{'info_hash'} =~ s|(..)|\%$1|g;
my $quest;
$quest = [
$event, $code,
[],
AE::timer(
0,
15 * 60,
sub {
return if !$self;
#return if !$self-active;
for my $tier (@{$self->tiers}) {
$tier->[0]->announce(
$event,
\%args,
sub {
my ($announce) = @_;
{
my %seen = ();
@{$quest->[2]}
= grep { !$seen{$_->[0]}{$_->[1]}++ }
@{$quest->[2]},
@{$announce->{'peers'}};
}
}
);
}
$event = undef if $event;
}
)
];
$self->add_announce_quest($quest);
return $quest;
}
sub scrape {
my ($self, $code) = @_;
require Scalar::Util;
Scalar::Util::weaken $self;
my %args = (info_hash => $self->torrent->info_hash->to_Hex);
$args{'info_hash'} =~ s|(..)|\%$1|g;
my $quest = [
0, $code,
[],
AE::timer(
0,
15 * 60,
sub {
return if !$self;
for my $tier (@{$self->tiers}) {
$tier->[0]->scrape(\%args, $code);
}
}
)
];
$self->add_scrape_quest($quest);
return $quest;
}
}
1;
=pod
=head1 NAME
Net::BitTorrent::Protocol::BEP12 - Multitracker Metadata Extension
=head1 See Also
=over
=item BEP 12:
=back
=head1 Author
Sanko Robinson <sanko@cpan.org> - http://sankorobinson.com/
CPAN ID: SANKO
=head1 License and Legal
Copyright (C) 2008-2010 by Sanko Robinson <sanko@cpan.org>
This program is free software; you can redistribute it and/or modify it under
the terms of
See the F<LICENSE> file included with this distribution or
L<notes on the Artistic License 2.0|http://www.perlfoundation.org/artistic_2_0_notes>
for clarification.
When separated from the distribution, all original POD documentation is
covered by the
L<Creative Commons Attribution-Share Alike 3.0 License|http://creativecommons.org/licenses/by-sa/3.0/us/legalcode>.
See the
L<clarification of the CCA-SA3.0|http://creativecommons.org/licenses/by-sa/3.0/us/>.
Neither this module nor the L<Author|/Author> is affiliated with BitTorrent,
Inc.
=for rcs $Id: MultiTracker.pm a7f61f8 2010-06-27 02:13:37Z sanko@cpan.org $
=cut