[net-bittorrent commit] r48 - in trunk: . lib/Net lib/Net/BitTorrent lib/Net/BitTorrent/Torrent lib/Net/BitTorrent/Torren...
codesite...@google.com
Date: Fri Jan 2 09:39:49 2009
New Revision: 48
Added:
trunk/tatoeba/003-threads.pl (contents, props changed)
trunk/tatoeba/004-resume.pl (contents, props changed)
Modified:
trunk/Build.PL
trunk/Changes
trunk/MANIFEST
trunk/Makefile.PL
trunk/lib/Net/BitTorrent.pm
trunk/lib/Net/BitTorrent/DHT.pm
trunk/lib/Net/BitTorrent/Peer.pm
trunk/lib/Net/BitTorrent/Protocol.pm
trunk/lib/Net/BitTorrent/Torrent.pm
trunk/lib/Net/BitTorrent/Torrent/Tracker.pm
trunk/lib/Net/BitTorrent/Torrent/Tracker/HTTP.pm
trunk/lib/Net/BitTorrent/Torrent/Tracker/UDP.pm
trunk/lib/Net/BitTorrent/Version.pm
trunk/t/700_classes/Net/BitTorrent/Torrent.t
trunk/tatoeba/002-debug.pl
Log:
New demos, schedule fixes, half open peer timeouts, quicker HTTP tracker
retries
* [fix] /tatoeba/002-debug.pl was using builtin sleep which (of course)
does not support fractional periods
* [fix] Various N::B::Torrent status and internal schedule fixes.
* [fix] N::B::Torrent->hashcheck() no longer stops the torrent first
* [fix] Expanded limits on what a N::B::Torrent object can do while being
hashchecked or stopped or standalone.
* [etc] When we're a seed, we don't attempt new connections as often.
* [etc] N::B::T::Tracker::HTTP retry is now 30s on socket error (formerly
5m)
* [new] N::B::Peer objects are disconnected if they don't complete
handshake within 30s. We used to wait for the OS to tell us the socket
was disconnected (perhaps 1-2m).
* [etc] Private N::B::Torrent->_status_as_string() for 'nice' status
strings
* [api] Net::BitTorrent::Torrent->peers() is now public
* [new] /tatoeba/003-threads.pl - Trivial, Multi-threaded Example
* [new] /tatoeba/004-resume.pl - Demonstration of
Net::BitTorrent::Torrent's Resume System
* [fix] Build.PL exit(0) when perl < v5.8.1 or M::B < v0.3
Modified: trunk/Build.PL
==============================================================================
--- trunk/Build.PL (original)
+++ trunk/Build.PL Fri Jan 2 09:39:49 2009
@@ -2,7 +2,7 @@
use strict;
use warnings;
use File::Find;
-use Module::Build 0.30;
+use Module::Build;
use Config;
$|++;
my $automated_testing = $ENV{q[AUTOMATED_TESTING]}
@@ -274,6 +274,21 @@
return unless -T $_;
return unless $_ =~ m[.+\.t$];
return push @tests, $File::Find::name;
+}
+
+BEGIN { # Tired of getting FAIL-mail from outdated build environments
+ if ($] < 5.008001) { # 5+ years old-- anything less is just silly
+ warn sprintf
+ q[Perl v5.8.1 required--this is only v%vd, stopped],
+ $^V;
+ exit 0;
+ }
+ if ($Module::Build::VERSION < 0.3) {
+ warn sprintf
+ q[Module::Build version 0.3 required--this is only version %s],
+ $Module::Build::VERSION;
+ exit 0;
+ }
}
__END__
Copyright (C) 2008 by Sanko Robinson <sa...@cpan.org>
Modified: trunk/Changes
==============================================================================
--- trunk/Changes (original)
+++ trunk/Changes Fri Jan 2 09:39:49 2009
@@ -1,19 +1,25 @@
Version 0.0XX |
- API Changes/Compatibility Information:
- - None
-
- Resolved Issues/Bugfixes:
- - None
-
- Protocol/Behavioral Changes:
- - None
+ API Changes/Compatibility Information:
+ * Net::BitTorrent::Torrent->peers() is now public
- Documentation/Sample Code/Test Suite:
- - New debugging script in /tatoeba/002-debug.pl
+ Resolved Issues/Bug Fixes:
+ * None
- Notes:
- - None
+ Protocol/Behavioral Changes:
+ * N::B::T::Tracker::HTTP retry is now 30s on socket error (formerly
5m).
+ * N::B::Peer objects are disconnected if they don't complete handshake
+ within 30s.
+
+ Documentation/Sample Code/Test Suite:
+ * New debugging demonstration in /tatoeba/002-debug.pl
+ * New threaded demonstration in /tatoeba/003-threads.pl
+ * New resume demonstration in /tatoeba/004-resume.pl
+
+ Notes:
+ * No incompatible changes. Safe to upgrade from 0.046.
+ * Various N::B::Torrent status and internal schedule fixes were made
none
+ of which really effect behavior.
---
Version 0.046 | 2008-12-30 18:25:17 -0500 (Tue, 30 Dec 2008)
@@ -21,7 +27,7 @@
- Net::BitTorrent::Torrent::HTTP->url() is now public
- Net::BitTorrent::Torrent::UDP->url() is now public
- Resolved Issues/Bugfixes:
+ Resolved Issues/Bug fixes:
- In 0.045, if no arguments were passed, Net::BitTorrent->new() failed to
set set defaults, generate a peerid, or create a DHT object.
@@ -33,7 +39,7 @@
- Minor tweaking and clean up in Net::BitTorrent::Notes
Notes:
- - This is a major bugfix release with which introduces no
incompatabilities.
+ - This is a major bug fix release with which introduces no
incompatibilities.
Upgrade is highly recommended.
---
@@ -43,7 +49,7 @@
- [Beta] Torrent resume system (see Net::BitTorrent::Notes).
- Net::BitTorrent::Torrent->hashcheck() clears the bitfield when it
begins.
- Resolved Issues/Bugfixes:
+ Resolved Issues/Bug Fixes:
- Close related sockets on N::B::DESTROY (left behind FIN_WAIT1 on
Win32).
Protocol/Behavioral Changes:
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Fri Jan 2 09:39:49 2009
@@ -46,4 +46,6 @@
tatoeba/000-basic.pl
tatoeba/001-torrent-info.pl
tatoeba/002-debug.pl
+tatoeba/003-threads.pl
+tatoeba/004-resume.pl
TODO.pod
Modified: trunk/Makefile.PL
==============================================================================
--- trunk/Makefile.PL (original)
+++ trunk/Makefile.PL Fri Jan 2 09:39:49 2009
@@ -4,7 +4,7 @@
BEGIN { exit 0 if $] < 5.008001 }
require 5.8.1;
$|++;
-if (!eval q[use Module::Build::Compat 0.02; 1;]) {
+if (!eval q[use Module::Build::Compat 0.02; use Module::Build 0.30; 1]) {
print qq[This module requires Module::Build to install itself.\n];
require ExtUtils::MakeMaker;
my $yn =
Modified: trunk/lib/Net/BitTorrent.pm
==============================================================================
--- trunk/lib/Net/BitTorrent.pm (original)
+++ trunk/lib/Net/BitTorrent.pm Fri Jan 2 09:39:49 2009
@@ -21,7 +21,7 @@
use Net::BitTorrent::Version;
use version qw[qv];
our $SVN = q[$Id$];
- our $UNSTABLE_RELEASE = 0; our $VERSION = sprintf(($UNSTABLE_RELEASE ?
q[%.3f_%03d] : q[%.3f]), (version->new((qw$Rev$)[1])->numify / 1000),
$UNSTABLE_RELEASE);
+ our $UNSTABLE_RELEASE = 1; our $VERSION = sprintf(($UNSTABLE_RELEASE ?
q[%.3f_%03d] : q[%.3f]), (version->new((qw$Rev$)[1])->numify / 1000),
$UNSTABLE_RELEASE);
my (@CONTENTS)
= \my (%_tcp, %_udp,
%_schedule, %_tid,
@@ -51,10 +51,12 @@
$_torrents{refaddr $self} = {};
$_tid{refaddr $self} = qq[\0] x 5;
$_use_dht{refaddr $self} = 1;
- $_dht{refaddr $self} = Net::BitTorrent::DHT->new({Client =>
$self});
- $_peerid{refaddr $self} =
Net::BitTorrent::Version::gen_peerid();
- $_connections{refaddr $self} = {};
+ # Internals
+ $_connections{refaddr $self} = {};
+ $_schedule{refaddr $self} = {};
+ $_dht{refaddr $self} = Net::BitTorrent::DHT->new({Client =>
$self});
+ $_peerid{refaddr $self} = Net::BitTorrent::Version::gen_peerid();
if (defined $args) {
if (ref($args) ne q[HASH]) {
carp q[Net::BitTorrent->new({}) requires ]
@@ -530,13 +532,11 @@
q[Net::BitTorrent->remove_torrent(TORRENT) requires a
blessed Net::BitTorrent::Torrent object];
return;
}
- for my $_peer ($torrent->_peers) {
+ for my $_peer ($torrent->peers) {
$_peer->_disconnect(
q[Removing .torrent torrent from local
client]);
}
- for my $_tracker (@{$torrent->trackers}) {
- $_tracker->urls->[0]->_announce(q[stopped]);
- }
+ $torrent->stop; # XXX - Should this be here?
return delete $_torrents{refaddr $self}{$torrent->infohash};
}
@@ -684,8 +684,13 @@
unpack(q[H*], $_dht{refaddr $self}->node_id),
$self->_tcp_host, $self->_tcp_port, $self->_udp_host,
$self->_udp_port,
- (scalar keys %{$_torrents{refaddr $self}}),
- join(qq[\r\n], keys %{$_torrents{refaddr $self}});
+ (scalar keys %{$_torrents{refaddr $self}}), join(
+ qq[\r\n],
+ map {
+ sprintf q[%40s (%d: %s)], $_->infohash, $_->status,
+ $_->_status_as_string()
+ } values %{$_torrents{refaddr $self}}
+ );
return defined wantarray ? $dump : print STDERR qq[$dump\n];
}
Modified: trunk/lib/Net/BitTorrent/DHT.pm
==============================================================================
--- trunk/lib/Net/BitTorrent/DHT.pm (original)
+++ trunk/lib/Net/BitTorrent/DHT.pm Fri Jan 2 09:39:49 2009
@@ -725,15 +725,7 @@
=item *
-Eats memory like whoa.
-
-=item *
-
The routing table is flat.
-
-=item *
-
-Boots from router.bittorrent.com.
=back
Modified: trunk/lib/Net/BitTorrent/Peer.pm
==============================================================================
--- trunk/lib/Net/BitTorrent/Peer.pm (original)
+++ trunk/lib/Net/BitTorrent/Peer.pm Fri Jan 2 09:39:49 2009
@@ -10,7 +10,7 @@
use Fcntl qw[F_SETFL O_NONBLOCK];
use version qw[qv];
our $SVN = q[$Id$];
- our $UNSTABLE_RELEASE = 1; our $VERSION = sprintf(($UNSTABLE_RELEASE ?
q[%.3f_%03d] : q[%.3f]), (version->new((qw$Rev$)[1])->numify / 1000),
$UNSTABLE_RELEASE);
+ our $UNSTABLE_RELEASE = 2; our $VERSION = sprintf(($UNSTABLE_RELEASE ?
q[%.3f_%03d] : q[%.3f]), (version->new((qw$Rev$)[1])->numify / 1000),
$UNSTABLE_RELEASE);
use lib q[../../../lib];
use Net::BitTorrent::Protocol qw[:build parse_packet :types];
use Net::BitTorrent::Util qw[:bencode];
@@ -109,7 +109,7 @@
#warn sprintf q[%d half open sockets!], $half_open;
return;
}
- if (scalar($args->{q[Torrent]}->_peers)
+ if (scalar($args->{q[Torrent]}->peers)
>= $args->{q[Torrent]}->_client->_peers_per_torrent)
{ return;
}
@@ -191,7 +191,20 @@
Object => $self
}
);
-
+ $_client{refaddr $self}->_schedule(
+ { Time => time + 30,
+ Code => sub {
+ my $s = shift;
+ if (!$peerid{refaddr $s}) {
+ weaken $s;
+ $s->_disconnect(
+ q[Failed to complete handshake within
30s]);
+ }
+ return 1;
+ },
+ Object => $self
+ }
+ );
if ($threads::shared::threads_shared) {
threads::shared::share($_bitfield{refaddr $self})
if defined $_bitfield{refaddr $self};
@@ -244,13 +257,17 @@
# Methods | Private
sub _rw {
my ($self, $read, $write, $error) = @_;
+
+#Carp::cluck sprintf q[%s->_rw(%d, %d, %d)], __PACKAGE__, $read, $write,
$error;
if (defined $_torrent{refaddr $self}
and !($_torrent{refaddr $self}->status & 1))
{ weaken $self;
$self->_disconnect(q[We aren't serving this torrent]);
return;
}
- if ($error) { #weaken $self; #$self->_disconnect($^E); return
+ if ($error) {
+ weaken $self;
+ $self->_disconnect($^E);
return;
}
if (defined $_torrent{refaddr $self}
@@ -284,13 +301,13 @@
$read,
length($_data_in{refaddr $self})
);
- if (not $actual_read) {
+ if (!$actual_read) {
weaken $self;
$self->_disconnect(sprintf q[[%d] %s], $^E, $^E);
return;
}
else {
- if (not defined $peerid{refaddr $self}) {
+ if (!$peerid{refaddr $self}) {
$_client{refaddr $self}
->_event(q[peer_connect], {Peer => $self});
}
@@ -389,7 +406,7 @@
);
return;
}
- if (scalar($_torrent{refaddr $self}->_peers)
+ if (scalar($_torrent{refaddr $self}->peers)
>= $_client{refaddr $self}->_peers_per_torrent)
{ $self->_disconnect(q[Enough peers already!]);
return;
@@ -663,7 +680,7 @@
$piece->{q[Blocks_Received]}->[$request->{q[_vec_offset]}] = 1;
$piece->{q[Slow]} = 0;
$piece->{q[Touch]} = time;
- for my $peer ($_torrent{refaddr $self}->_peers) {
+ for my $peer ($_torrent{refaddr $self}->peers) {
for my $x (reverse 0 .. $#{$requests_out{refaddr $peer}}) {
if ( (defined $requests_out{refaddr $peer}->[$x])
and
@@ -697,7 +714,7 @@
if (not grep { !$_ } @{$piece->{q[Blocks_Received]}}) {
if ($_torrent{refaddr $self}->_check_piece_by_index($index)
and defined $_torrent{refaddr $self})
- { for my $p ($_torrent{refaddr $self}->_peers) {
+ { for my $p ($_torrent{refaddr $self}->peers) {
$_data_out{$p} .= build_have($index);
$_client{refaddr $self}->_add_connection($p, q[rw]);
}
@@ -1322,7 +1339,7 @@
return if $_torrent{refaddr $self}->status & 32;
return if ${$_am_choking{refaddr $self}} == 0;
if (scalar(
- grep { $_->_am_choking == 0 } $_torrent{refaddr
$self}->_peers
+ grep { $_->_am_choking == 0 } $_torrent{refaddr
$self}->peers
) <= 8
)
{ ${$_am_choking{refaddr $self}} = 0;
Modified: trunk/lib/Net/BitTorrent/Protocol.pm
==============================================================================
--- trunk/lib/Net/BitTorrent/Protocol.pm (original)
+++ trunk/lib/Net/BitTorrent/Protocol.pm Fri Jan 2 09:39:49 2009
@@ -709,7 +709,7 @@
=over
-=item C<RESEREVED>
+=item C<RESERVED>
...is the 8 byte string used to represent a client's capabilities for
extensions to the protocol.
Modified: trunk/lib/Net/BitTorrent/Torrent.pm
==============================================================================
--- trunk/lib/Net/BitTorrent/Torrent.pm (original)
+++ trunk/lib/Net/BitTorrent/Torrent.pm Fri Jan 2 09:39:49 2009
@@ -25,7 +25,7 @@
use Net::BitTorrent::Torrent::Tracker;
use version qw[qv];
our $SVN = q[$Id$];
- our $UNSTABLE_RELEASE = 1; our $VERSION = sprintf(($UNSTABLE_RELEASE ?
q[%.3f_%03d] : q[%.3f]), (version->new((qw$Rev$)[1])->numify / 1000),
$UNSTABLE_RELEASE);
+ our $UNSTABLE_RELEASE = 2; our $VERSION = sprintf(($UNSTABLE_RELEASE ?
q[%.3f_%03d] : q[%.3f]), (version->new((qw$Rev$)[1])->numify / 1000),
$UNSTABLE_RELEASE);
my %REGISTRY = ();
my @CONTENTS = \my (%_client, %path, %_basedir,
%size, %files, %trackers,
@@ -81,7 +81,7 @@
}
if ($args->{q[Status]} and $args->{q[Status]} !~ m[^\d+$]) {
carp q[Net::BitTorrent::Torrent->new({ }) requires an ]
- . q[integer 'Status' parameter];
+ . q[integer 'Status' parameter. Falling back to
defaults.];
delete $args->{q[Status]};
}
$args->{q[Path]} = rel2abs($args->{q[Path]});
@@ -124,10 +124,6 @@
)
{ return;
}
- if (defined $args->{q[Client]}) {
- $_client{refaddr $self} = $args->{q[Client]};
- weaken $_client{refaddr $self};
- }
$infohash{refaddr $self}
= sha1_hex(bencode($raw_data{refaddr $self}{q[info]}));
$path{refaddr $self} = $args->{q[Path]};
@@ -142,21 +138,8 @@
$_nodes{refaddr $self} = q[];
${$bitfield{refaddr $self}}
= pack(q[b*], qq[\0] x $self->piece_count);
-
- if (defined $args->{q[Status]}) {
- $args->{q[Status]} ^= LOADED if $args->{q[Status]} & LOADED;
- $args->{q[Status]} ^= QUEUED if $args->{q[Status]} & QUEUED;
- }
- ${$status{refaddr $self}} |= (
- defined $args->{q[Status]} ?
$args->{q[Status]}
- : defined $_client{refaddr $self} ? 1
- : 0
- );
- ${$status{refaddr $self}} |= LOADED;
- ${$status{refaddr $self}} |= QUEUED
- if defined $_client{refaddr $self};
- ${$error{refaddr $self}} = undef;
my @_files;
+
if (defined $raw_data{refaddr $self}{q[info]}{q[files]}) {
for my $file (@{$raw_data{refaddr $self}{q[info]}{q[files]}}) {
push @_files,
@@ -217,20 +200,15 @@
)
);
}
- if ($_client{refaddr $self}) {
- $_client{refaddr $self}->_schedule(
- {Time => time + 25,
- Code => sub { shift->_dht_announce
},
- Object => $self
- }
- );
- $_client{refaddr $self}->_schedule(
- {Time => time + 15,
- Code => sub { shift->_dht_scrape
},
- Object => $self
- }
- );
- }
+ $args->{q[Status]} ||= 0;
+ $args->{q[Status]} ^= CHECKING if $args->{q[Status]} & CHECKING;
+ $args->{q[Status]} ^= CHECKED if $args->{q[Status]} & CHECKED;
+ $args->{q[Status]} ^= ERROR if $args->{q[Status]} & ERROR;
+ $args->{q[Status]} ^= LOADED if $args->{q[Status]} & LOADED;
+ ${$status{refaddr $self}} = $args->{q[Status]};
+ ${$status{refaddr $self}} |= LOADED;
+ ${$error{refaddr $self}} = undef;
+ my $_start = 0;
# Resume system
if ( $raw_data{refaddr $self}{q[net-bittorrent]}
@@ -251,30 +229,28 @@
{q[files]}[$_index]{q[mtime]})
)
{ ${$status{refaddr $self}} |= START_AFTER_CHECK;
- $self->_set_error(q[Bad resume data. Please
hashcheck.]);
$_okay = 0;
}
$files{refaddr $self}->[$_index]->set_priority(
$raw_data{refaddr
$self}{q[net-bittorrent]}{q[files]}
[$_index]{q[priority]});
}
- if ($_okay) {
+ if (!$_okay) {
+ $self->_set_error(q[Bad resume data. Please hashcheck.]);
+ }
+ else {
${$bitfield{refaddr $self}}
= $raw_data{refaddr $self}{q[net-bittorrent]}
{q[bitfield]};
# Accept resume data is the same as hashchecking
- my $start_after_check = (
- ((${$status{refaddr $self}} & QUEUED)
- && ${$status{refaddr $self}} &
START_AFTER_CHECK
- )
- || ${$status{refaddr $self}} & STARTED
- );
+ my $start_after_check
+ = ${$status{refaddr $self}} & START_AFTER_CHECK;
${$status{refaddr $self}} ^= START_AFTER_CHECK
if ${$status{refaddr $self}} & START_AFTER_CHECK;
${$status{refaddr $self}} ^= CHECKED
if !(${$status{refaddr $self}} & CHECKED);
- if ($start_after_check) { $self->start(); }
+ if ($start_after_check) { $_start = 1; }
# Reload Blocks
for my $_piece (
@@ -301,6 +277,11 @@
}
}
}
+ else {
+
+ # No resume data was found so we'll just assume they want to
start
+ $_start = 1;
+ }
# Threads stuff
weaken($REGISTRY{refaddr $self} = $self);
@@ -310,7 +291,23 @@
threads::shared::share($error{refaddr $self});
}
$$self = $infohash{refaddr $self};
- $self->start if ${$status{refaddr $self}} & STARTED;
+ if ($args->{q[Client]}) {
+ $self->queue($args->{q[Client]});
+ $_client{refaddr $self}->_schedule(
+ {Time => time + 25,
+ Code => sub { shift->_dht_announce
},
+ Object => $self
+ }
+ );
+ $_client{refaddr $self}->_schedule(
+ {Time => time,
+ Code => sub { shift->_dht_scrape
},
+ Object => $self
+ }
+ );
+ }
+ $self->start if $_start && (${$status{refaddr $self}} & QUEUED);
+ $self->_new_peer(); # XXX - temporary multi-thread vs schedule
fix
return $self;
}
@@ -346,7 +343,7 @@
sub is_complete {
my ($self) = @_;
- return if ${$status{refaddr $self}} & CHECKING;
+ return if (${$status{refaddr $self}} & CHECKING);
return unpack(q[b*], $self->_wanted) !~ m[1] ? 1 : 0;
}
@@ -360,10 +357,24 @@
);
}
+ sub peers {
+ my ($self) = @_;
+ return if (${$status{refaddr $self}} & CHECKING);
+ return if !(${$status{refaddr $self}} & QUEUED);
+ my $_connections = $_client{refaddr $self}->_connections;
+ return map {
+ ( ($_->{q[Object]}->isa(q[Net::BitTorrent::Peer]))
+ and ($_->{q[Object]}->_torrent)
+ and ($_->{q[Object]}->_torrent eq $self))
+ ? $_->{q[Object]}
+ : ()
+ } values %$_connections;
+ }
+
# Mutators | Private
sub _set_bitfield {
my ($self, $new_value) = @_;
- return if ${$status{refaddr $self}} & CHECKING;
+ return if (${$status{refaddr $self}} & CHECKING);
return if length ${$bitfield{refaddr $self}} != length $new_value;
# XXX - make sure bitfield conforms to what we expect it to be
@@ -372,7 +383,7 @@
sub _set_status {
my ($self, $new_value) = @_;
- return if ${$status{refaddr $self}} & CHECKING;
+ return if (${$status{refaddr $self}} & CHECKING);
# XXX - make sure status conforms to what we expect it to be
return ${$status{refaddr $self}} = $new_value;
@@ -381,7 +392,7 @@
sub _set_error {
my ($self, $msg) = @_;
${$error{refaddr $self}} = $msg;
- $self->stop();
+ $self->stop() if ${$status{refaddr $self}} & STARTED;
${$status{refaddr $self}} |= ERROR;
return 1;
}
@@ -441,22 +452,17 @@
# Methods | Public
sub hashcheck {
my ($self) = @_;
- return if ${$status{refaddr $self}} & PAUSED;
+ return if (${$status{refaddr $self}} & PAUSED);
+ return if (${$status{refaddr $self}} & CHECKING);
${$bitfield{refaddr $self}} # empty it first
= pack(q[b*], qq[\0] x $self->piece_count);
- my $start_after_check = (
- ((${$status{refaddr $self}} & QUEUED)
- && ${$status{refaddr $self}} &
START_AFTER_CHECK
- )
- || ${$status{refaddr $self}} & STARTED
- );
+ my $start_after_check = ${$status{refaddr $self}} &
START_AFTER_CHECK;
${$status{refaddr $self}} |= CHECKING
if !${$status{refaddr $self}} & CHECKING;
- $self->stop();
for my $index (0 .. ($self->piece_count - 1)) {
$self->_check_piece_by_index($index);
}
- ${$status{refaddr $self}} ^= START_AFTER_CHECK
+ (${$status{refaddr $self}} ^= START_AFTER_CHECK)
if ${$status{refaddr $self}} & START_AFTER_CHECK;
${$status{refaddr $self}} ^= CHECKED
if !(${$status{refaddr $self}} & CHECKED);
@@ -481,37 +487,33 @@
sub start {
my ($self) = @_;
- if (!${$status{refaddr $self}} & QUEUED) {
- carp q[Cannot start an orphan torrent];
- return;
- }
+ return if !(${$status{refaddr $self}} & QUEUED);
${$status{refaddr $self}} ^= ERROR
if ${$status{refaddr $self}} & ERROR;
${$status{refaddr $self}} ^= PAUSED
if ${$status{refaddr $self}} & PAUSED;
- ${$status{refaddr $self}} |= STARTED
- if !(${$status{refaddr $self}} & STARTED);
- $_client{refaddr $self}->_schedule(
- {Time => time + 5,
- Code => sub { shift->_new_peer if @_;
},
- Object => $self
- }
- ) if defined $_client{refaddr $self};
+ if (!(${$status{refaddr $self}} & STARTED)) {
+ ${$status{refaddr $self}} |= STARTED;
+ for my $tracker (@{$trackers{refaddr $self}}) {
+ $tracker->_announce(q[started]);
+ }
+ }
return ${$status{refaddr $self}};
}
sub stop {
my ($self) = @_;
- if (!${$status{refaddr $self}} & QUEUED) {
- carp q[Cannot stop an orphan torrent];
- return;
- }
- for my $_peer ($self->_peers) {
+ return if !(${$status{refaddr $self}} & QUEUED);
+ for my $_peer ($self->peers) {
$_peer->_disconnect(q[Torrent has been stopped]);
}
for my $_file (@{$files{refaddr $self}}) { $_file->_close(); }
- ${$status{refaddr $self}} ^= STARTED
- if (${$status{refaddr $self}} & STARTED);
+ if (${$status{refaddr $self}} & STARTED) {
+ ${$status{refaddr $self}} ^= STARTED;
+ for my $tracker (@{$trackers{refaddr $self}}) {
+ $tracker->_announce(q[stopped]);
+ }
+ }
return !!${$status{refaddr $self}} & STARTED;
}
@@ -531,31 +533,29 @@
$_client{refaddr $self} = $client;
weaken $_client{refaddr $self};
${$status{refaddr $self}} ^= QUEUED;
+
+ #$self->_new_peer();
return $_client{refaddr $self};
}
# Methods | Private
sub _add_uploaded {
my ($self, $amount) = @_;
- if (!${$status{refaddr $self}} & QUEUED) { return; }
- return if not defined $_client{refaddr $self};
- return if ${$status{refaddr $self}} & CHECKING;
+ return if (${$status{refaddr $self}} & CHECKING);
+ return if !(${$status{refaddr $self}} & QUEUED);
return if not $amount;
$uploaded{refaddr $self} += (($amount =~ m[^\d+$]) ? $amount : 0);
}
sub _add_downloaded {
my ($self, $amount) = @_;
- if (!${$status{refaddr $self}} & QUEUED) { return; }
- return if not defined $_client{refaddr $self};
- return if ${$status{refaddr $self}} & CHECKING;
+ return if (${$status{refaddr $self}} & CHECKING);
+ return if !(${$status{refaddr $self}} & QUEUED);
$downloaded{refaddr $self} += (($amount =~ m[^\d+$]) ? $amount :
0);
}
sub _append_nodes {
my ($self, $nodes) = @_;
- if (!${$status{refaddr $self}} & QUEUED) { return; }
- return if not defined $_client{refaddr $self};
return if !$nodes;
$_nodes{refaddr $self} ||= q[];
return $_nodes{refaddr $self}
@@ -565,40 +565,34 @@
sub _new_peer {
my ($self) = @_;
return if not defined $_client{refaddr $self};
- return if ${$status{refaddr $self}} & CHECKING;
- return if !${$status{refaddr $self}} & STARTED;
$_client{refaddr $self}->_schedule(
- {Time => time + 5,
- Code => sub { shift->_new_peer
},
- Object => $self
- }
+ {Time => time + ($self->is_complete ? 60 : 5),
+ Code => sub { shift->_new_peer if @_; },
+ Object => $self
+ }
);
- if (scalar(
- grep {
- $_->{q[Object]}->isa(q[Net::BitTorrent::Peer])
- and not defined $_->{q[Object]}->peerid
- } values %{$_client{refaddr $self}->_connections}
- ) >= 8
- )
- { return;
- }
- if ($self->is_complete) { return; }
- if (not $_nodes{refaddr $self}) { return; }
+ return if (${$status{refaddr $self}} & CHECKING);
+ return if !${$status{refaddr $self}} & STARTED;
+ return if !(${$status{refaddr $self}} & QUEUED);
+ return if !$_nodes{refaddr $self};
+ return
+ if scalar $self->peers
+ >= $_client{refaddr $self}->_peers_per_torrent;
+ my $half_open = scalar(
+ grep {
+ $_->{q[Object]}->isa(q[Net::BitTorrent::Peer])
+ and not defined $_->{q[Object]}->peerid
+ } values %{$_client{refaddr $self}->_connections}
+ );
+
+ #warn sprintf q[%d half open peers], $half_open;
my @nodes = uncompact($_nodes{refaddr $self});
- for (1 .. ($_client{refaddr $self}->_peers_per_torrent
- - scalar $self->_peers
- )
- )
- { #last
- # if scalar(
- # grep {
- # $_->{q[Object]}->isa(q[Net::BitTorrent::Peer])
- # and not $_->{q[Object]}->peerid
- # } values %{$_client{refaddr $self}->_connections}
- # ) >= $_client{refaddr $self}->_half_open;
- last if not @nodes;
+ for ($half_open .. $_client{refaddr $self}->_half_open - 1) {
+ last if !@nodes;
my $node = shift @nodes;
- my $ok = $_client{refaddr $self}
+
+ #warn $node;
+ my $ok = $_client{refaddr $self}
->_event(q[ip_filter], {Address => $node});
if (defined $ok and $ok == 0) { next; }
my $peer =
@@ -610,37 +604,21 @@
return 1;
}
- sub _peers {
- my ($self) = @_;
- return if not defined $_client{refaddr $self};
- return if !${$status{refaddr $self}} & QUEUED;
- my $_connections = $_client{refaddr $self}->_connections;
- return map {
- ( ($_->{q[Object]}->isa(q[Net::BitTorrent::Peer]))
- and ($_->{q[Object]}->_torrent)
- and ($_->{q[Object]}->_torrent eq $self))
- ? $_->{q[Object]}
- : ()
- } values %$_connections;
- }
-
sub _add_tracker {
my ($self, $tier) = @_;
- return if not defined $_client{refaddr $self};
- return if !${$status{refaddr $self}} & QUEUED;
carp q[Please, pass new tier in an array ref...]
unless ref $tier eq q[ARRAY];
- return
- push(@{$trackers{refaddr $self}},
- Net::BitTorrent::Torrent::Tracker->new(
- {Torrent => $self, URLs =>
$tier}
- )
- );
+ my $tracker = Net::BitTorrent::Torrent::Tracker->new(
+ {Torrent => $self, URLs =>
$tier});
+ $tracker->_announce(q[started]);
+ return push(@{$trackers{refaddr $self}}, $tracker);
}
sub _piece_by_index {
my ($self, $index) = @_;
return if !${$status{refaddr $self}} & STARTED;
+ return if (${$status{refaddr $self}} & CHECKING);
+ return if !(${$status{refaddr $self}} & QUEUED);
if ((!defined $index) || ($index !~ m[^\d+$])) {
carp
q[Net::BitTorrent::Torrent->_piece_by_index() requires an
index];
@@ -654,6 +632,9 @@
sub _pick_piece {
my ($self, $peer) = @_;
return if $self->is_complete;
+ return if !${$status{refaddr $self}} & STARTED;
+ return if (${$status{refaddr $self}} & CHECKING);
+ return if !(${$status{refaddr $self}} & QUEUED);
if (!$_client{refaddr $self}) {
carp
q[Net::BitTorrent::Torrent->_pick_piece(PEER) will not on
an orphan torrent];
@@ -830,9 +811,9 @@
sub _write_data {
my ($self, $index, $offset, $data) = @_;
- return if not defined $_client{refaddr $self};
- return if ${$status{refaddr $self}} & CHECKING;
return if !${$status{refaddr $self}} & STARTED;
+ return if (${$status{refaddr $self}} & CHECKING);
+ return if !(${$status{refaddr $self}} & QUEUED);
if ((length($$data) + (
($raw_data{refaddr $self}{q[info]}{q[piece length]} *
$index)
+ $offset
@@ -963,38 +944,42 @@
# Methods | Private | DHT
sub _dht_announce {
my ($self) = @_;
- return if !${$status{refaddr $self}} & STARTED;
- return if $self->private;
$_client{refaddr $self}->_schedule(
{Time => time + 120,
Code => sub { shift->_dht_announce
},
Object => $self
}
);
- if ($_client{refaddr $self}->_use_dht) {
- $_client{refaddr $self}->_dht->_announce($self);
- $_client{refaddr $self}->_schedule(
- { Time => time + 20,
- Code => sub {
- my ($s) = @_;
- $_client{refaddr $s}->_dht->_scrape($s)
- if $_client{refaddr $s}->_use_dht;
- },
- Object => $self
- }
- );
- }
+ return if !${$status{refaddr $self}} & STARTED;
+ return if (${$status{refaddr $self}} & CHECKING);
+ return if !(${$status{refaddr $self}} & QUEUED);
+ return if $self->private;
+ return if !$_client{refaddr $self}->_use_dht;
+ $_client{refaddr $self}->_dht->_announce($self);
+ $_client{refaddr $self}->_schedule(
+ { Time => time + 15,
+ Code => sub {
+ my ($s) = @_;
+ $_client{refaddr $s}->_dht->_scrape($s)
+ if $_client{refaddr $s}->_use_dht;
+ },
+ Object => $self
+ }
+ );
}
sub _dht_scrape {
my ($self) = @_;
- return if $self->private;
$_client{refaddr $self}->_schedule(
{Time => time + 60,
Code => sub { shift->_dht_scrape
},
Object => $self
}
);
+ return if !(${$status{refaddr $self}} & STARTED);
+ return if (${$status{refaddr $self}} & CHECKING);
+ return if !(${$status{refaddr $self}} & QUEUED);
+ return if $self->private;
$_client{refaddr $self}->_dht->_scrape($self)
if $_client{refaddr $self}->_use_dht;
}
@@ -1103,19 +1088,7 @@
END
$self->path, $raw_data{refaddr $self}{q[info]}{q[name]},
$self->infohash(), $_basedir{refaddr $self}, $size{refaddr
$self},
- ${$status{refaddr $self}}, sub {
- my ($s) = @_;
- return ucfirst join q[, ],
- grep {$_} ($s & LOADED) ? q[was loaded okay] : q[],
- ($s & STARTED) ? q[is started] :
q[],
- ($s & CHECKING) ? q[is currently hashchecking] :
q[],
- ($s & START_AFTER_CHECK) ? q[needs hashchecking] :
q[],
- ($s & CHECKED) ? q[has been checked] :
q[],
- ($s & PAUSED) ? q[has been paused] :
q[],
- ($s & QUEUED) ? q[] : q[good for informational use only],
- ($s & ERROR) ? q[but has an error] : q[];
- }
- ->(${$status{refaddr $self}}),
+ ${$status{refaddr $self}}, $self->_status_as_string(),
($self->private ? q[Disabled [Private]] : q[Enabled.]),
100 - (grep {$_} split //,
unpack(q[b*], $wanted) / $self->piece_count * 100
@@ -1174,6 +1147,26 @@
return defined wantarray ? $dump : print STDERR qq[$dump\n];
}
+ sub _status_as_string {
+ my ($self) = @_;
+ return ucfirst join q[, ],
+ grep {$_}
+ (${$status{refaddr $self}} & LOADED) ? q[was loaded okay] :
q[],
+ (${$status{refaddr $self}} & STARTED) ? q[is started]
+ : q[is stopped],
+ (${$status{refaddr $self}} & CHECKING)
+ ? q[is currently hashchecking]
+ : q[],
+ (${$status{refaddr $self}} & START_AFTER_CHECK)
+ ? q[needs hashchecking]
+ : q[], (${$status{refaddr $self}} & CHECKED) ? q[has been
checked]
+ : q[has not been checked],
+ (${$status{refaddr $self}} & PAUSED) ? q[has been paused] :
q[],
+ (${$status{refaddr $self}} & QUEUED) ? q[is queued]
+ : q[is good for informational use only],
+ (${$status{refaddr $self}} & ERROR) ? q[but has an error] :
q[];
+ }
+
sub CLONE {
for my $_oID (keys %REGISTRY) {
my $_obj = $REGISTRY{$_oID};
@@ -1379,6 +1372,11 @@
=item C<path ( )>
Returns the L<filename|/"Path"> of the torrent this object represents.
+
+=item C<peers ( )>
+
+Returns a list of remote L<peers|Net::BitTorrent::Peer> related to this
+torrent.
=item C<piece_count ( )>
Modified: trunk/lib/Net/BitTorrent/Torrent/Tracker.pm
==============================================================================
--- trunk/lib/Net/BitTorrent/Torrent/Tracker.pm (original)
+++ trunk/lib/Net/BitTorrent/Torrent/Tracker.pm Fri Jan 2 09:39:49 2009
@@ -11,7 +11,7 @@
use Net::BitTorrent::Torrent::Tracker::UDP;
use version qw[qv];
our $SVN = q[$Id$];
- our $UNSTABLE_RELEASE = 0; our $VERSION = sprintf(($UNSTABLE_RELEASE ?
q[%.3f_%03d] : q[%.3f]), (version->new((qw$Rev$)[1])->numify / 1000),
$UNSTABLE_RELEASE);
+ our $UNSTABLE_RELEASE = 1; our $VERSION = sprintf(($UNSTABLE_RELEASE ?
q[%.3f_%03d] : q[%.3f]), (version->new((qw$Rev$)[1])->numify / 1000),
$UNSTABLE_RELEASE);
my (@CONTENTS) = \my (%torrent, %urls, %complete, %incomplete);
my %REGISTRY;
@@ -50,12 +50,6 @@
: q[Net::BitTorrent::Torrent::Tracker::UDP]
)->new({URL => $_url, Tier => $self});
}
- $torrent{refaddr $self}->_client->_schedule(
- {Time => time,
- Code => sub { shift->_announce(q[started])
},
- Object => $self
- }
- ) if $torrent{refaddr $self}->status & 128;
weaken($REGISTRY{refaddr $self} = $self);
@{$urls{refaddr $self}} = shuffle(@{$urls{refaddr $self}});
return $self;
Modified: trunk/lib/Net/BitTorrent/Torrent/Tracker/HTTP.pm
==============================================================================
--- trunk/lib/Net/BitTorrent/Torrent/Tracker/HTTP.pm (original)
+++ trunk/lib/Net/BitTorrent/Torrent/Tracker/HTTP.pm Fri Jan 2 09:39:49
2009
@@ -12,7 +12,7 @@
use Net::BitTorrent::Util qw[:bencode uncompact];
use version qw[qv];
our $SVN = q[$Id$];
- our $UNSTABLE_RELEASE = 0; our $VERSION = sprintf(($UNSTABLE_RELEASE ?
q[%.3f_%03d] : q[%.3f]), (version->new((qw$Rev$)[1])->numify / 1000),
$UNSTABLE_RELEASE);
+ our $UNSTABLE_RELEASE = 1; our $VERSION = sprintf(($UNSTABLE_RELEASE ?
q[%.3f_%03d] : q[%.3f]), (version->new((qw$Rev$)[1])->numify / 1000),
$UNSTABLE_RELEASE);
my (@CONTENTS)
= \my (%_url, %_tier, %resolve, %_event, %_socket, %_data_out);
my %REGISTRY;
@@ -51,6 +51,8 @@
# Methods | Private
sub _announce {
my ($self, $event) = @_;
+
+ #warn sprintf q[_announce(%s)], $event? qq['$event']:q[];
if (defined $event) {
if ($event !~ m[^(?:st(?:art|opp)|complet)ed$]) {
carp sprintf q[Invalid event for announce: %s], $event;
@@ -78,9 +80,15 @@
: fcntl($_socket{refaddr $self}, F_SETFL, O_NONBLOCK)
)
)
- { carp
- q[There was a problem making an outgoing socket
non-blocking: ]
- . $^E;
+ { $_tier{refaddr $self}->_torrent->_event(
+ q[tracker_failure],
+ {Tracker => $self,
+ Reason => sprintf(
+ q[There was a problem making an outgoing socket
non-blocking: [%d] %s],
+ $^E, $^E
+ )
+ }
+ );
return;
}
my $_inet_aton = inet_aton($host);
@@ -165,6 +173,8 @@
sub _rw {
my ($self, $read, $write, $error) = @_;
+
+#Carp::cluck sprintf q[%s->_rw(%d, %d, %d)], __PACKAGE__, $read, $write,
$error;
my ($actual_read, $actual_write) = (0, 0);
return if not defined $_tier{refaddr $self}->_client;
if ($error) {
@@ -172,7 +182,7 @@
shutdown($_socket{refaddr $self}, 2);
close $_socket{refaddr $self};
$_tier{refaddr $self}->_client->_schedule(
- { Time => time + 300,
+ { Time => time + 30,
Code => sub {
my ($s) = @_;
$_tier{refaddr $s}->_shuffle;
Modified: trunk/lib/Net/BitTorrent/Torrent/Tracker/UDP.pm
==============================================================================
--- trunk/lib/Net/BitTorrent/Torrent/Tracker/UDP.pm (original)
+++ trunk/lib/Net/BitTorrent/Torrent/Tracker/UDP.pm Fri Jan 2 09:39:49 2009
@@ -11,10 +11,12 @@
use Net::BitTorrent::Util qw[uncompact];
use version qw[qv];
our $SVN = q[$Id$];
- our $UNSTABLE_RELEASE = 3; our $VERSION = sprintf(($UNSTABLE_RELEASE ?
q[%.3f_%03d] : q[%.3f]), (version->new((qw$Rev$)[1])->numify / 1000),
$UNSTABLE_RELEASE);
+ our $UNSTABLE_RELEASE = 0; our $VERSION = sprintf(($UNSTABLE_RELEASE ?
q[%.3f_%03d] : q[%.3f]), (version->new((qw$Rev$)[1])->numify / 1000),
$UNSTABLE_RELEASE);
my %REGISTRY = ();
- my @CONTENTS = \my
(%_url, %_tier, %_tid, %_cid, %_outstanding_requests,
- %_packed_host, %_event);
+ my @CONTENTS
+ = \
+ my (%_url, %_tier, %_tid, %_cid, %_outstanding_requests,
+ %_packed_host, %_event);
sub new {
my ($class, $args) = @_;
Modified: trunk/lib/Net/BitTorrent/Version.pm
==============================================================================
--- trunk/lib/Net/BitTorrent/Version.pm (original)
+++ trunk/lib/Net/BitTorrent/Version.pm Fri Jan 2 09:39:49 2009
@@ -5,7 +5,7 @@
use warnings;
use version qw[qv];
our $SVN = q[$Id$];
- our $VERSION_BASE = 46; our $UNSTABLE_RELEASE = 1; our $VERSION =
sprintf(($UNSTABLE_RELEASE ? q[%.3f_%03d] : q[%.3f]),
(version->new(($VERSION_BASE))->numify / 1000), $UNSTABLE_RELEASE);
+ our $VERSION_BASE = 46; our $UNSTABLE_RELEASE = 2; our $VERSION =
sprintf(($UNSTABLE_RELEASE ? q[%.3f_%03d] : q[%.3f]),
(version->new(($VERSION_BASE))->numify / 1000), $UNSTABLE_RELEASE);
our $PRODUCT_TOKEN = qq[Net::BitTorrent $VERSION];
sub gen_peerid {
Modified: trunk/t/700_classes/Net/BitTorrent/Torrent.t
==============================================================================
--- trunk/t/700_classes/Net/BitTorrent/Torrent.t (original)
+++ trunk/t/700_classes/Net/BitTorrent/Torrent.t Fri Jan 2 09:39:49 2009
@@ -233,8 +233,6 @@
warn $_torrent_Test->status;
ok($_torrent_Test->status ^ $IS{q[Paused]},
sprintf q[ ...Status says we're started. (%s)], $_key);
- warn
- q[TODO: 'Bad' status like this one should fall back to
default];
my $_torrent_unchecked =
Net::BitTorrent::Torrent->new(
{Path => $dot_torrent,
Modified: trunk/tatoeba/002-debug.pl
==============================================================================
--- trunk/tatoeba/002-debug.pl (original)
+++ trunk/tatoeba/002-debug.pl Fri Jan 2 09:39:49 2009
@@ -3,7 +3,7 @@
use warnings;
use Net::BitTorrent;
use Data::Dumper;
-use Time::HiRes qw[time];
+use Time::HiRes qw[time sleep];
$|++;
my $OLD_STDERR = \*STDERR;
open *STDERR, q[>], q[net-bittorrent.log]
Added: trunk/tatoeba/003-threads.pl
==============================================================================
--- (empty file)
+++ trunk/tatoeba/003-threads.pl Fri Jan 2 09:39:49 2009
@@ -0,0 +1,125 @@
+#!perl -w -I../lib
+use strict;
+use warnings;
+use Time::HiRes qw[sleep];
+use threads;
+use threads::shared;
+use Net::BitTorrent;
+my $client = Net::BitTorrent->new();
+my $torrent = $client->add_torrent({Path => 'a.legal.torrent'}) or exit;
+threads->create(
+ sub {
+ sleep 15;
+ $torrent->on_event(q[piece_hash_pass], sub { warn q[Yay] });
+ $torrent->on_event(q[piece_hash_fail], sub { warn q[Boo] });
+ threads->yield();
+ $torrent->hashcheck;
+ threads->detach();
+ }
+);
+sleep(0.25) and $client->do_one_loop(0.25) while !$torrent->is_complete;
+
+=pod
+
+=head1 NAME
+
+/tatoeba/003-threads.pl - Trivial, Multi-threaded Example
+
+=head1 Description
+
+This is a demonstration of C<Net::BitTorrent> can be used in a thre--
+((sigh)) ya know, if you really want to try this, I can't stop you, but
+don't bug me if mixing threads and C<Net::BitTorrent> turns your RAM into
+dark matter or causes you to foam at the mouth.
+
+=head1 Synopsis
+
+ 000-basic.pl
+
+=head1 Lowdown
+
+=over
+
+=item Line 5-6
+
+When L<Net::BitTorrent|Net::BitTorrent> sees that
+L<threads::shared|threads::shared> has been used, it tries its best to
+keep things organized. There is a limited subset of data that's actually
+shared between threads; just enough to be of some use but not enough to
+let you ruin everything.
+
+=item Line 10
+
+Creates a new thread. And this is where your sanity ends.
+
+=item Line 12
+
+Just a short delay to make it obvious that we're in the child.
+
+=item Line 13-14
+
+Sets callbacks to make it obvious that the data is being hashchecked.
+
+=item Line 15
+
+Steps aside for a moment.
+
+=item Line 16
+
+Validates data. As this starts,
+connections to L<peers|Net::BitTorrent::Torrent/"peers ( )"> related to
+this L<torrent|Net::BitTorrent::Torrent> in the parent thread are closed.
+While the child does the checking, our
+L<bitfield|Net::BitTorrent::Torrent/"bitfield ( )"> is kept in synch with
+the parent (thanks to L<threads::shared|threads::shared>), and our
+L<status|Net::BitTorrent::Torrent/"status ( )"> goes through some
+changes.
+
+=item Line 17
+
+Child says goodbye now that (s)he is finished.
+
+=item Line 20
+
+Works until we're finished downloading everything. C<Net::BitTorrent>
+will continue to seed the torrent after download is complete.
+
+=back
+
+=head1 Bugs/Notes/Warnings
+
+Unless someone sends me a few good patches (hint, hint) threads will
+probably never be B<completely> supported by
+L<Net::BitTorrent|Net::BitTorrent> but there are a few things you can do
+with them.
+
+Note: The data shared between threads is undocumented and subject to
+change.
+
+=head1 Author
+
+Sanko Robinson <sa...@cpan.org> - http://sankorobinson.com/
+
+CPAN ID: SANKO
+
+=head1 License and Legal
+
+Copyright (C) 2008 by Sanko Robinson E<lt>sa...@cpan.orgE<gt>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of The Artistic License 2.0. See the F<LICENSE>
+file included with this distribution or
+http://www.perlfoundation.org/artistic_license_2_0. For
+clarification, see http://www.perlfoundation.org/artistic_2_0_notes.
+
+When separated from the distribution, all POD documentation is covered
+by the Creative Commons Attribution-Share Alike 3.0 License. See
+http://creativecommons.org/licenses/by-sa/3.0/us/legalcode. For
+clarification, see http://creativecommons.org/licenses/by-sa/3.0/us/.
+
+Neither this module nor the L<Author|/Author> is affiliated with
+BitTorrent, Inc.
+
+=for svn $Id$
+
+=cut
Added: trunk/tatoeba/004-resume.pl
==============================================================================
--- (empty file)
+++ trunk/tatoeba/004-resume.pl Fri Jan 2 09:39:49 2009
@@ -0,0 +1,136 @@
+#!perl -w -I../lib
+use strict;
+use warnings;
+use Time::HiRes qw[sleep];
+use Net::BitTorrent;
+use Data::Dump qw[pp];
+my $client = Net::BitTorrent->new();
+my $torrent = $client->add_torrent({Path => 'a.legal.torrent'}) or exit;
+$torrent->on_event(q[piece_hash_pass], sub { save(shift) });
+$torrent->hashcheck;
+sleep(0.25) and $client->do_one_loop(0.25) while !$torrent->is_complete;
+
+END {
+ for my $t (values %{$client->torrents || {}}) { save($t); }
+}
+
+sub save {
+ my ($torrent) = @_;
+ rename $torrent->path, $torrent->path . q[.bak]
+ if !-f $torrent->path . q[.bak];
+ open my $TORRENT, q[>], $torrent->path or next;
+ syswrite($TORRENT, $torrent->resume_data) or next;
+ close $TORRENT;
+}
+
+=pod
+
+=head1 NAME
+
+/tatoeba/004-resume.pl - Demonstration of Net::BitTorrent::Torrent's
Resume System
+
+=head1 Description
+
+This is a basic example of how the Resume System built into
+L<Net::BitTorrent::Torrent|Net::BitTorrent::Torrent> is to be used.
+
+=head1 Synopsis
+
+ 004-resume.pl
+
+=head1 Lowdown
+
+=over
+
+=item Line 8
+
+Loads our .torrent file. If
+L<Net::BitTorrent::Torrent|Net::BitTorrent::Torrent/"new ( { [ARGS] } )">
+finds any resume data, it's automatically restored.
+
+=item Line 9
+
+Sets a per-torrent callback which, when triggered, saves our resume data.
+
+=item Line 13-15
+
+This is probably the most important place to save resume data because on
+restore, the last modified times of each file is compared with the times
+stored in the resume data. If any of them fail to match, all of the
+resume data is considered invalid.
+
+Here, at the end of the process, we store resume data for every torrent
+in the client. Yes, yes, I know... this little script only loads a
+single torrent. Consider it a bonus for folks writing your own your own
+clients. A small and obvious bonus, sure, but a bonus all the same.
+
+=item Line 19
+
+Let's keep a backup of the original metadata just in case
+L<Net::BitTorrent::Torrent|Net::BitTorrent::Torrent> (slim chance) or you
+(rather likely) makes a mistake and ruins everything.
+
+=item Line 21
+
+Opens the .torrent file in write mode. Once the file is parsed in
+L<C<new( )>|Net::BitTorrent::Torrent/"new ( { [ARGS] } )">,
+L<Net::BitTorrent::Torrent|Net::BitTorrent::Torrent> is finished with it,
+so if the file is locked and fails to open here, some other process may
+be to blame.
+
+=item Line 22
+
+Writes the new
+L<'resume data'|Net::BitTorrent::Torrent/"resume_data ( [ RAW ] )"> to
+the file. Notice I'm using C<syswrite> here because the resume data will
+certainly contain binary data. For more, see the warnings listed in
+L<Net::BitTorrent::Notes|Net::BitTorrent::Notes/"badresumedata">.
+
+Now, the next time L<Net::BitTorrent::Torrent|Net::BitTorrent::Torrent">
+loads this file, it will see the resume data and if it looks okay, your
+progress will be restored.
+
+=back
+
+=head1 Notes
+
+In this script, we store resume data after each piece validates and at
+the end of the script. In practice, you may want to store this on a more
+regular basis or on a schedule (every half hour). I B<do not> suggest
+saving resume data every time a block is written to disk; true, this
+would keep resume data as up to date as possible, but there are certain
+internal steps taken while resume data is gathered that would, in the
+long run, slow everything down to a crawl. For more, see
+L<C<resume_data ( )>|Net::BitTorrent::Torrent/"resume_data ( [ RAW ] )"> in
+L<Net::BitTorrent::Torrent|Net::BitTorrent::Torrent> and the sections
+L<'Resume API'|Net::BitTorrent::Notes/"Resume API"> and
+L<'How do I quick Resume a .torrent Session Between Client Sessions?'|
Net::BitTorrent::Notes/"Quick Resume a .torrent Session Between Client
Sessions">
+in L<Net::BitTorrent::Notes|Net::BitTorrent::Notes>.
+
+=head1 Author
+
+Sanko Robinson <sa...@cpan.org> - http://sankorobinson.com/
+
+CPAN ID: SANKO
+
+=head1 License and Legal
+
+Copyright (C) 2008 by Sanko Robinson E<lt>sa...@cpan.orgE<gt>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of The Artistic License 2.0. See the F<LICENSE>
+file included with this distribution or
+http://www.perlfoundation.org/artistic_license_2_0. For
+clarification, see http://www.perlfoundation.org/artistic_2_0_notes.
+
+When separated from the distribution, all POD documentation is covered
+by the Creative Commons Attribution-Share Alike 3.0 License. See
+http://creativecommons.org/licenses/by-sa/3.0/us/legalcode. For
+clarification, see http://creativecommons.org/licenses/by-sa/3.0/us/.
+
+Neither this module nor the L<Author|/Author> is affiliated with
+BitTorrent, Inc.
+
+=for svn $Id$
+
+=cut