package Net::BitTorrent::Torrent;
{
use Moose;
use Moose::Util::TypeConstraints;
extends 'Net::BitTorrent::Protocol::BEP03::Metadata';
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 '../../../lib';
use Net::BitTorrent::Types qw[:torrent :file];
use Fcntl ':flock';
use 5.010.000;
sub BUILD {1}
has '+info_hash' => (lazy_build => 0);
has 'path' => (is => 'ro',
isa => 'NBTypes::File::Path::PreExisting',
required => 1,
coerce => 1,
predicate => '_has_path',
initializer => '_initializer_path'
);
sub _initializer_path {
my ($s, $p, $set, $attr) = @_;
$set->($p);
open(my ($FH), '<', $p)
|| return !($_[0] = undef); # exterminate! exterminate!
flock $FH, LOCK_SH;
sysread($FH, my ($METADATA), -s $FH) == -s $FH
|| return !($_[0] = undef); # destroy!
$s->_set_metadata($METADATA);
close $FH;
}
has 'client' => (
isa => 'Maybe[Net::BitTorrent]',
is => 'rw',
weak_ref => 1,
predicate => '_has_client',
handles => {
dht => 'dht',
trigger_piece_hash_pass => 'trigger_piece_hash_pass',
trigger_piece_hash_fail => 'trigger_piece_hash_fail',
peers => sub {
my $s = shift;
return if !$s->_has_client;
return grep {
$_->_has_torrent
&& !$_->torrent->info_hash->Compare($s->info_hash)
} $s->client->peers;
}
},
trigger => sub {
my ($self, $client) = @_;
# XXX - make sure the new client knows who I am
#$self->queue;
$self->start; # ??? - Should this be automatic?
}
);
has 'quests' => (is => 'ro',
isa => 'HashRef[Defined]',
traits => ['Hash'],
handles => {add_quest => 'set',
get_quest => 'get',
has_quest => 'defined',
_del_quest => 'delete',
clear_quests => 'clear'
},
default => sub { {} }
);
has 'error' => (is => 'rw',
isa => 'Str',
init_arg => undef
);
has 'storage' => (is => 'ro',
required => 1,
isa => 'Net::BitTorrent::Storage',
lazy_build => 1,
builder => '_build_storage',
handles => [qw[size read write wanted is_seed]]
);
sub _build_storage {
require Net::BitTorrent::Storage;
Net::BitTorrent::Storage->new(torrent => $_[0]);
}
override '_trigger_metadata' => sub {
super;
my ($self, $new_value, $old_value) = @_;
# parse files
require Net::BitTorrent::Storage::File;
#
my @files;
if (defined $new_value->{'info'}{'files'}) { # Multi-file .torrent
my ($offset, $index) = (0, 0);
$self->storage->_set_files(
[map {
my $obj
= Net::BitTorrent::Storage::File->new(
index => $index++,
length => $_->{'length'},
offset => $offset,
path => [grep {$_} @{$_->{'path'}}],
storage => $self->storage
);
$offset += $_->{'length'};
$obj;
} @{$new_value->{'info'}{'files'}}
]
);
$self->storage->_set_root($new_value->{'info'}{'name'});
}
else { # single file torrent; use the name
$self->storage->_set_files(
[Net::BitTorrent::Storage::File->new(
index => 0,
length => $new_value->{'info'}{'length'},
offset => 0,
path => [$new_value->{'info'}{'name'}],
storage => $self->storage
)
]
);
}
};
has 'piece_selector' => (isa => 'Net::BitTorrent::Torrent::PieceSelector',
is => 'ro',
builder => '_build_piece_selector',
handles => [qw[select_piece select_block]]
);
sub _build_piece_selector {
require Net::BitTorrent::Torrent::PieceSelector;
Net::BitTorrent::Torrent::PieceSelector->new(torrent => shift);
}
for my $direction (qw[up down]) {
has $direction
. 'loaded' => (
is => 'ro',
isa => 'Int',
traits => ['Counter'],
handles => {'inc_' . $direction . 'loaded' => 'inc'},
default => 0
);
}
sub left {
my ($self) = @_;
require List::Util;
return $self->piece_length
* List::Util::sum(
split('', unpack('b*', ($self->wanted() || ''))));
}
# Actions
sub start {
my ($self) = @_;
return if !$self->client;
require Scalar::Util;
Scalar::Util::weaken $self;
$self->add_quest('tracker_announce',
$self->tracker->announce(
'start',
sub { $self->_dht_tracker_announce_cb(@_) }
)
);
$self->add_quest('dht_get_peers',
$self->dht->get_peers(
$self->info_hash,
sub { $self->_dht_get_peers_cb(@_) }
)
);
$self->add_quest('dht_announce_peer',
$self->dht->announce_peer(
$self->info_hash,
sub { $self->_dht_announce_peer_cb(@_) }
)
);
$self->add_quest(
'new_peer',
AE::timer(
0, 30,
sub {
return if !$self;
return if !$self->_has_client;
return if scalar($self->peers) >= $self->max_peers;
my ($source)
= [[$self->get_quest('dht_get_peers'), 'dht'],
[$self->get_quest('tracker_announce'), 'tracker']
]->[int rand 2];
return if !@{$source->[0][2]};
my $addr = $source->[0][2]->[int rand @{$source->[0][2]}];
require Net::BitTorrent::Protocol::BEP03::Peer::Outgoing;
$self->client->add_peer(
Net::BitTorrent::Protocol::BEP03::Peer::Outgoing->new(
torrent => $self,
connect => $addr,
source => $source->[1],
client => $self->client
)
);
}
)
);
$self->add_quest(
'unchoke',
AE::timer(
15, 10,
sub {
return if !$self;
return if !$self->_has_client;
my @choked = sort {
$a->remote_choked <=> $b->remote_choked
|| $a->total_download <=> $b->total_download
} grep { $_->remote_interested && $_->choked }
$self->peers;
return if !@choked;
for my $i (0 .. $self->max_upload_slots) {
last if !$choked[$i];
$choked[$i]->_unset_choked;
}
}
)
);
$self->add_quest(
'optimistic_unchoke',
AE::timer(
120, 120,
sub {
return if !$self;
return if !$self->_has_client;
return if !scalar $self->peers;
my @choked = sort {
($a->remote_choked <=> $b->remote_choked)
|| (($a->total_download || 0)
<=> ($b->total_download || 0))
} grep {
$_->choked
&& sub {
my $x = $self->have->Clone;
$x->Not($_->pieces);
$x->Norm;
}
->()
} $self->peers;
for my $i (0 .. $self->max_upload_slots) {
last if !$choked[$i];
$choked[$i]->_unset_choked;
}
}
)
);
$self->add_quest(
'choke', # Cycle them until we get some good peers
AE::timer(
60, 60,
sub {
return if !$self;
return if !$self->_has_client;
return if !scalar $self->peers;
my @unchoked = grep { !$_->choked } $self->peers;
# XXX - choke the slow peers first?
}
)
);
}
sub stop {
my ($self) = @_;
$self->clear_quests;
#$self->clear_peers( );
}
sub _tracker_announce_cb {1}
sub _dht_announce_peer_cb {1}
sub _dht_get_peers_cb {1}
# Quick methods
my $pieces_per_hashcheck = 10; # Max block of pieces in single call
sub hash_check { # Range is split up into $pieces_per_hashcheck blocks
# ??? - Disconnect peers if @$range > 1
my ($self, $range) = @_;
$range
= defined $range
? ref $range
? $range
: [$range]
: [0 .. $self->piece_count - 1];
if (scalar @$range <= $pieces_per_hashcheck) {
$self->_clear_have() if !defined $_[0]; # retain current bitfield
for my $index (@$range) {
my $piece = $self->read($index);
next if !$piece || !$$piece;
require Digest::SHA;
$self->_set_piece($index)
if Digest::SHA::sha1($$piece) eq
substr($self->pieces, ($index * 20), 20);
}
}
else {
my $cv = AnyEvent->condvar;
$cv->begin;
my (@watchers, @ranges, @this_range, $coderef);
push @ranges, [splice(@$range, 0, $pieces_per_hashcheck, ())]
while @$range;
$coderef = sub {
shift @watchers if @watchers;
@this_range = shift @ranges;
$self->hash_check(@this_range);
push @watchers,
AE::idle(@ranges ? $coderef : sub { $cv->end });
};
push @watchers, AE::idle($coderef);
$cv->recv;
shift @watchers;
}
return 1;
}
has 'have' => (is => 'ro',
isa => 'NBTypes::Torrent::Bitfield',
lazy_build => 1,
coerce => 1,
builder => '_build_have',
init_arg => undef,
writer => '_have',
clearer => '_clear_have',
handles => {
_set_piece => 'Bit_On',
_unset_piece => 'Bit_Off',
_has_piece => 'bit_test',
seed => 'is_full'
},
);
sub _build_have { '0' x $_[0]->piece_count }
after '_set_piece' => sub {
my ($s, $i) = @_;
$s->trigger_piece_hash_pass($i);
$_->_send_have($i) for $s->peers;
};
after '_unset_piece' => sub { $_[0]->trigger_piece_hash_fail($_[1]) };
#{ ### Simple plugin system
# my @_plugins;
# sub _register_plugin {
# my $s = shift;
# return $s->meta->apply(@_) if blessed $s;
# my %seen = ();
# return @_plugins = grep { !$seen{$_}++ } @_plugins, @_;
# }
# after 'BUILD' => sub {
# return if !@_plugins;
# my ($s, $a) = @_;
# require Moose::Util;
# Moose::Util::apply_all_roles($s, @_plugins,
# {rebless_params => $a});
# };
#}
#
has 'max_peers' => (isa => subtype(as 'Int' => where { $_ >= 1 }),
is => 'rw',
default => '200'
);
has 'max_upload_slots' => (isa => subtype(as 'Int' => where { $_ >= 1 }),
is => 'rw',
default => '8'
);
#
no Moose;
no Moose::Util::TypeConstraints;
__PACKAGE__->meta->make_immutable
}
1;
=pod
=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
L<The Artistic License 2.0|http://www.perlfoundation.org/artistic_license_2_0>.
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: Torrent.pm e9628b1 2010-09-12 03:10:17Z sanko@cpan.org $
=cut