File Coverage

blib/lib/Net/BitTorrent.pm

Criterion	Covered	Total	%
statement	323	390	82.8
branch	133	192	69.2
condition	81	171	47.3
subroutine	61	67	91.0
pod	8	8	100.0
total	606	828	73.1

#!/usr/bin/perl -w
package Net::BitTorrent;
{
    use strict;
    use warnings;
    use Scalar::Util qw[blessed weaken refaddr];
    use List::Util qw[max];
    use Time::HiRes;
    use Socket qw[/inet_/ SOCK_STREAM SOCK_DGRAM SOL_SOCKET PF_INET SOMAXCONN
        /pack_sockaddr_in/ SO_REUSEADDR];
    use Carp qw[carp];
    use Digest::SHA qw[sha1_hex];
    use POSIX qw[];
    sub _EWOULDBLOCK { $^O eq q[MSWin32] ? 10035 : POSIX::EWOULDBLOCK() }
    sub _EINPROGRESS { $^O eq q[MSWin32] ? 10036 : POSIX::EINPROGRESS() }
    use lib q[../../lib];
    use Net::BitTorrent::Util qw[:bencode :compact];
    use Net::BitTorrent::Torrent;
    use Net::BitTorrent::Peer;
    use Net::BitTorrent::DHT;
    use Net::BitTorrent::Version;
    use version qw[qv];
    our $VERSION_BASE = 50; our $UNSTABLE_RELEASE = 0; our $VERSION = sprintf(($UNSTABLE_RELEASE ? q[%.3f_%03d] : q[%.3f]), (version->new(($VERSION_BASE))->numify / 1000), $UNSTABLE_RELEASE);
    my (@CONTENTS) = \my (
        %_tcp,                  %_udp,
        %_schedule,             %_tid,
        %_event,                %torrents,
        %_connections,          %peerid,
        %_max_ul_rate,          %_k_ul,
        %_max_dl_rate,          %_k_dl,
        %_dht,                  %_use_dht,
        %__UDP_OBJECT_CACHE,    %_peers_per_torrent,
        %_connections_per_host, %_half_open,
        #############################################################
        %_encryption_mode
    );
    my %REGISTRY;
    sub _MSE_DISABLED {0}
    sub _MSE_ENABLED  {1}
    sub _MSE_FORCED   {2}

    sub new {
        my ($class, $args) = @_;
        my $self = bless \$class, $class;
        my ($host, @ports) = (q[0.0.0.0], (0));

        # Defaults
        $_max_ul_rate{refaddr $self}          = 0;
        $_k_ul{refaddr $self}                 = 0;
        $_max_dl_rate{refaddr $self}          = 0;
        $_k_dl{refaddr $self}                 = 0;
        $_peers_per_torrent{refaddr $self}    = 100;
        $_half_open{refaddr $self}            = 8;
        $_connections_per_host{refaddr $self} = 1;
        $torrents{refaddr $self}              = {};
        $_tid{refaddr $self}                  = qq[\0] x 5;
        $_use_dht{refaddr $self}              = 1;
        $_encryption_mode{refaddr $self}      = _MSE_ENABLED;

        # 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 ]
                    . q[parameters to be passed as a hashref];
                return;
            }
            $host = $args->{q[LocalHost]}
                if defined $args->{q[LocalHost]};
            @ports
                = defined $args->{q[LocalPort]}
                ? (ref($args->{q[LocalPort]}) eq q[ARRAY]
                   ? @{$args->{q[LocalPort]}}
                   : $args->{q[LocalPort]}
                )
                : @ports;
        }

        # Try opening a matching set of ports
        for my $port (@ports) {
            last
                if $self->_socket_open_tcp($host, $port)
                    && $self->_socket_open_udp($host, $port);
        }

        # Clear everything just in case
        $self->_reset_bandwidth;
        weaken($REGISTRY{refaddr $self} = $self);
        $$self = $peerid{refaddr $self};
        return $self;
    }

    # Accessors | Private
    sub _tcp               { return $_tcp{refaddr +shift} }
    sub _udp               { return $_udp{refaddr +shift} }
    sub _connections       { return $_connections{refaddr +shift} }
    sub _max_ul_rate       { return $_max_ul_rate{refaddr +shift} }
    sub _max_dl_rate       { return $_max_dl_rate{refaddr +shift} }
    sub _peers_per_torrent { return $_peers_per_torrent{refaddr +shift} }
    sub _half_open         { return $_half_open{refaddr +shift} }

    sub _connections_per_host {
        return $_connections_per_host{refaddr +shift};
    }
    sub _dht { return $_dht{refaddr +shift} }

    sub _use_dht {
        my ($s) = @_;
        return $_udp{refaddr $s} && $_use_dht{refaddr $s};
    }

    sub _tcp_port {
        my ($self) = @_;
        return if not defined $_tcp{refaddr $self};
        my ($port, undef)
            = unpack_sockaddr_in(getsockname($_tcp{refaddr $self}));
        return $port;
    }

    sub _tcp_host {
        my ($self) = @_;
        return if not defined $_tcp{refaddr $self};
        my (undef, $packed_ip)
            = unpack_sockaddr_in(getsockname($_tcp{refaddr $self}));
        return inet_ntoa($packed_ip);
    }

    sub _udp_port {
        my ($self) = @_;
        return if not defined $_udp{refaddr $self};
        my ($port, undef)
            = unpack_sockaddr_in(getsockname($_udp{refaddr $self}));
        return $port;
    }

    sub _udp_host {
        my ($self) = @_;
        return if not defined $_udp{refaddr $self};
        my (undef, $packed_ip)
            = unpack_sockaddr_in(getsockname($_udp{refaddr $self}));
        return inet_ntoa($packed_ip);
    }

    sub _encryption_mode {
        my ($self) = @_;
        return $_encryption_mode{refaddr $self};
    }

    # Setters | Private
    sub _set_encryption_mode {
        my ($self, $value) = @_;
        if (not defined $value
            or (    ($value != _MSE_DISABLED)
                and ($value != _MSE_ENABLED)
                and ($value != _MSE_FORCED))
            )
        {   carp
                q[Net::BitTorrent->_set_encryption_mode( VALUE ) requires an integer value];
            return;
        }
        return $_encryption_mode{refaddr $self} = $value;
    }

    sub _set_max_ul_rate {    # BYTES per second
        my ($self, $value) = @_;
        if (not defined $value or $value !~ m[^\d+$] or !$value) {
            carp
                q[Net::BitTorrent->_set_max_ul_rate( VALUE ) requires an integer value];
            return;
        }
        return $_max_ul_rate{refaddr $self} = $value;
    }

    sub _set_max_dl_rate {    # BYTES per second
        my ($self, $value) = @_;
        if (not defined $value or $value !~ m[^\d+$]) {
            carp
                q[Net::BitTorrent->_set_max_dl_rate( VALUE ) requires an integer value];
            return;
        }
        return $_max_dl_rate{refaddr $self} = $value;
    }

    sub _set_peers_per_torrent {
        my ($self, $value) = @_;
        if (not defined $value or $value !~ m[^\d+$] or $value < 1) {
            carp
                q[Net::BitTorrent->_set_peers_per_torrent( VALUE ) requires an integer value];
            return;
        }
        return $_peers_per_torrent{refaddr $self} = $value;
    }

    sub _set_half_open {
        my ($self, $value) = @_;
        if (not defined $value or $value !~ m[^\d+$] or $value < 1) {
            carp
                q[Net::BitTorrent->_set_half_open( VALUE ) requires an integer value];
            return;
        }
        return $_half_open{refaddr $self} = $value;
    }

    sub _set_connections_per_host {
        my ($self, $value) = @_;
        if (not defined $value or $value !~ m[^\d+$] or $value < 1) {
            carp
                q[Net::BitTorrent->_set_connections_per_host( VALUE ) requires an integer value];
            return;
        }
        return $_connections_per_host{refaddr $self} = $value;
    }

    sub _set_use_dht {
        my ($self, $value) = @_;
        if (not defined $value or $value !~ m[^[10]$]) {
            carp
                q[Net::BitTorrent->_set_use_dht( VALUE ) requires a bool value];
            return;
        }
        return $_use_dht{refaddr $self} = $value;
    }

    # Accessors | Public
    sub peerid   { my ($self) = @_; return $peerid{refaddr $self} }
    sub torrents { my ($self) = @_; return $torrents{refaddr $self} }

    # Methods | Public
    sub do_one_loop {
        my ($self, $timeout) = @_;
        $self->_process_schedule;
        $timeout
            = defined $timeout && $timeout =~ m[^(\-1|\d+)\.?\d*$]
            ? $timeout < 0
                ? undef
                : $timeout
            : 1;
        my ($rin, $win, $ein) = (q[], q[], q[]);
    PUSHSOCK: for my $fileno (keys %{$_connections{refaddr $self}}) {
            vec($rin, $fileno, 1) = 1
                if $_connections{refaddr $self}{$fileno}{q[Mode]} =~ m[r];
            vec($win, $fileno, 1) = 1
                if $_connections{refaddr $self}{$fileno}{q[Mode]} =~ m[w];
            vec($ein, $fileno, 1) = 1;
        }
        my ($nfound, $timeleft) = select($rin, $win, $ein, $timeout);
        $self->_process_connections(\$rin, \$win, \$ein)
            if $nfound and $nfound != -1;
        return 1;
    }

    # Methods | Private
    sub _reset_bandwidth {
        my ($self) = @_;
        $self->_schedule({Time   => time + 1,
                          Code   => \&_reset_bandwidth,
                          Object => $self
                         }
        );

        #warn sprintf q[Speed report: Up: %5dB/s | Down: %5dB/s],
        #    $_k_ul{refaddr $_[0]},
        #    $_k_dl{refaddr $_[0]};
        return $_k_dl{refaddr $_[0]} = $_k_ul{refaddr $_[0]} = 0;
    }

    sub _add_connection {
        my ($self, $connection, $mode) = @_;
        if (not defined $connection) {
            carp q[Net::BitTorrent->_add_connection() requires an object];
            return;
        }
        if (not blessed $connection) {
            carp
                q[Net::BitTorrent->_add_connection() requires a blessed object];
            return;
        }
        my $_sock = $connection->_socket;
        if ((not $_sock) or (ref($_sock) ne q[GLOB])) { return; }
        if ((!$mode) || ($mode !~ m[^(?:ro|rw|wo)$])) {
            carp
                q[Net::BitTorrent->_add_connection(SOCKET, MODE) requires a mode parameter];
            return;
        }
        return $_connections{refaddr $self}{fileno $_sock} = {
                                                        Object => $connection,
                                                        Mode   => $mode
        };
    }

    sub _remove_connection {
        my ($self, $connection) = @_;
        if (not defined $connection) {
            carp q[Net::BitTorrent->_remove_connection() requires an object];
            return;
        }
        if (not blessed $connection) {
            carp
                q[Net::BitTorrent->_remove_connection() requires a blessed object];
            return;
        }
        my $socket = $connection->_socket;
        return if not defined $socket;
        return delete $_connections{refaddr $self}{fileno $socket};
    }

    sub _socket_open_tcp {
        my ($self, $host, $port) = @_;
        if (   not $self
            || not blessed $self
            || not $self->isa(q[Net::BitTorrent]))
        {   carp
                q[Net::BitTorrent->_socket_open_tcp(HOST, PORT) requires a blessed object];
            return;
        }
        if ((!$_tcp{refaddr $self}) && (!$host)) {
            carp q[Net::BitTorrent::_socket_open_tcp( ) ]
                . q[requires a hostname];
            return;
        }
        if (defined $port and $port !~ m[^\d+$]) {
            carp q[Net::BitTorrent::_socket_open_tcp( ) ]
                . q[requires an integer port number];
            return;
        }
        my $_packed_host = undef;
        $host ||= q[0.0.0.0];
        $port ||= 0;
        $port =~ m[^(\d+)$];
        $port = $1;
        if (    $host
            and $host
            !~ m[^(?:(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.]?){4})$])
        {   my ($name, $aliases, $addrtype, $length, @addrs)
                = gethostbyname($host)
                or return;
            $_packed_host = $addrs[0];
        }
        else { $_packed_host = inet_aton($host) }
        socket(my ($_tcp), PF_INET, SOCK_STREAM, getprotobyname(q[tcp]))
            or return;

       # - What is the difference between SO_REUSEADDR and SO_REUSEPORT?
       #    [http://www.unixguide.net/network/socketfaq/4.11.shtml]
       # - setsockopt - what are the options for ActivePerl under Windows NT?
       #    [http://perlmonks.org/?node_id=63280]
       #      setsockopt($_tcp, SOL_SOCKET, SO_REUSEADDR, pack(q[l], 1))
       #         or return;
       # SO_REUSEPORT is undefined on Win32... Boo...
       #if ($reuse_port and defined SO_REUSEPORT) {       # XXX - undocumented
       #   setsockopt($_udp, SOL_SOCKET, SO_REUSEPORT, pack(q[l], 1))
       #       or return;
       #}
        bind($_tcp, pack_sockaddr_in($port, $_packed_host))
            or return;
        listen($_tcp, 1) or return;
        $_connections{refaddr $self}{fileno $_tcp} = {Object => $self,
                                                      Mode   => q[ro],
            }
            or return;
        if (   defined $_tcp{refaddr $self}
            && fileno $_tcp{refaddr $self}
            && defined $_connections{refaddr $self}
            {fileno $_tcp{refaddr $self}})
        {   delete $_connections{refaddr $self}{fileno $_tcp{refaddr $self}};
            close $_tcp{refaddr $self};
        }
        return $_tcp{refaddr $self} = $_tcp;
    }

    sub _socket_open_udp {
        my ($self, $host, $port) = @_;
        if (   not $self
            || not blessed $self
            || not $self->isa(q[Net::BitTorrent]))
        {   carp
                q[Net::BitTorrent->_socket_open_udp(HOST, PORT) requires a blessed object];
            return;
        }
        if ((!$_tcp{refaddr $self}) && (!$host)) {
            carp q[Net::BitTorrent::_socket_open_udp( ) ]
                . q[requires a hostname];
            return;
        }
        if (defined $port and $port !~ m[^\d+$]) {
            carp q[Net::BitTorrent::_socket_open_udp( ) ]
                . q[requires an integer port number];
            return;
        }
        my $_packed_host = undef;
        $host ||= q[0.0.0.0];

        #$port = $port ? $port : $_udp{refaddr $self} ? $self->_udp_port : 0;
        $port ||= 0;
        $port =~ m[^(\d+)$];
        $port = $1;
        if (    $host
            and $host
            !~ m[^(?:(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.]?){4})$])
        {   my ($name, $aliases, $addrtype, $length, @addrs)
                = gethostbyname($host)
                or return;
            $_packed_host = $addrs[0];
        }
        else { $_packed_host = inet_aton($host) }
        socket(my ($_udp), PF_INET, SOCK_DGRAM, getprotobyname(q[udp]))
            or return;

       # - What is the difference between SO_REUSEADDR and SO_REUSEPORT?
       #    [http://www.unixguide.net/network/socketfaq/4.11.shtml]
       # - setsockopt - what are the options for ActivePerl under Windows NT?
       #    [http://perlmonks.org/?node_id=63280]
       #     setsockopt($_udp, SOL_SOCKET, SO_REUSEADDR, pack(q[l], 1))
       #        or return;
       # SO_REUSEPORT is undefined on Win32... Boo...
       #if ($reuse_port and defined SO_REUSEPORT) {       # XXX - undocumented
       #   setsockopt($_udp, SOL_SOCKET, SO_REUSEPORT, pack(q[l], 1))
       #       or return;
       #}
        bind($_udp, pack_sockaddr_in($port, $_packed_host))
            or return;
        $_connections{refaddr $self}{fileno $_udp} = {Object => $self,
                                                      Mode   => q[ro],
            }
            or return;
        if (   $_udp{refaddr $self}
            && fileno $_udp{refaddr $self}
            && defined $_connections{refaddr $self}
            {fileno $_udp{refaddr $self}})
        {   delete $_connections{refaddr $self}{fileno $_udp{refaddr $self}};
            close $_udp{refaddr $self};
        }
        return $_udp{refaddr $self} = $_udp;
    }

    sub _process_connections {
        my ($self, $rin, $win, $ein) = @_;
        if (!(     ($rin and ref $rin and ref $rin eq q[SCALAR])
               and ($win and ref $win and ref $win eq q[SCALAR])
               and ($ein and ref $ein and ref $ein eq q[SCALAR])
            )
            )
        {   carp
                q[Malformed parameters to Net::BitTorrent::_process_connections(RIN, WIN, EIN)];
            return;
        }
    POPSOCK: foreach my $fileno (keys %{$_connections{refaddr $self}}) {
            next POPSOCK unless defined $_connections{refaddr $self}{$fileno};
            if (   $_tcp{refaddr $self}
                && $fileno == fileno $_tcp{refaddr $self})
            {   if (vec($$rin, $fileno, 1) == 1) {
                    vec($$rin, $fileno, 1) = 0;
                    if (scalar(
                            grep {
                                $_->{q[Object]}->isa(q[Net::BitTorrent::Peer])
                                    && !$_->{q[Object]}->torrent
                                } values %{$_connections{refaddr $self}}
                        ) < $_half_open{refaddr $self}
                        )
                    {   accept(my ($new_socket), $_tcp{refaddr $self})
                            or next POPSOCK;
                        Net::BitTorrent::Peer->new({Socket => $new_socket,
                                                    Client => $self
                                                   }
                        );
                    }
                }
            }
            elsif (   $_udp{refaddr $self}
                   && $fileno == fileno $_udp{refaddr $self})
            {   if (vec($$rin, $fileno, 1) == 1) {
                    vec($$rin, $fileno, 1) = 0;
                    my $paddr
                        = recv($_udp{refaddr $self}, my ($data), 1024, 0)
                        or next POPSOCK;
                    if ($__UDP_OBJECT_CACHE{refaddr $self}{$paddr}{q[Object]})
                    {   $__UDP_OBJECT_CACHE{refaddr $self}{$paddr}{q[Object]}
                            ->_on_data($paddr, $data)
                            or
                            delete $__UDP_OBJECT_CACHE{refaddr $self}{$paddr}
                            {q[Object]};
                        next POPSOCK;
                    }
                    else {
                        for my $_tor (values %{$torrents{refaddr $self}}) {
                            for my $_tier (@{$_tor->trackers}) {
                                my ($tracker) = grep {
                                    $_->isa(
                                        q[Net::BitTorrent::Torrent::Tracker::UDP]
                                        )
                                        and $_->_packed_host eq $paddr
                                } @{$_tier->urls};
                                if (   $tracker
                                    && $tracker->_on_data($paddr, $data))
                                {   $__UDP_OBJECT_CACHE{refaddr $self}{$paddr}
                                        = {Object => $tracker};
                                    weaken($__UDP_OBJECT_CACHE{refaddr $self}
                                           {$paddr}{q[Object]});
                                    next POPSOCK;
                                }
                            }
                        }
                    }
                    if (   $_use_dht{refaddr $self}
                        && $_dht{refaddr $self}->_on_data($paddr, $data))
                    {   $__UDP_OBJECT_CACHE{refaddr $self}{$paddr}
                            = {Object => $_dht{refaddr $self}};
                        weaken($__UDP_OBJECT_CACHE{refaddr $self}{$paddr}
                               {q[Object]});
                    }
                    next POPSOCK;
                }
            }
            else {
                my $read = (($_max_dl_rate{refaddr $self}
                             ? max(0,
                                   (      $_max_dl_rate{refaddr $self}
                                        - $_k_dl{refaddr $self}
                                   )
                                 )
                             : (2**15)
                            ) * vec($$rin, $fileno, 1)
                );
                my $write = (($_max_ul_rate{refaddr $self}
                              ? max(0,
                                    (      $_max_ul_rate{refaddr $self}
                                         - $_k_ul{refaddr $self}
                                    )
                                  )
                              : (2**15)
                             ) * vec($$win, $fileno, 1)
                );
                my $error = vec($$ein, $fileno, 1)
                    && (   $^E
                        && ($^E != _EINPROGRESS)
                        && ($^E != _EWOULDBLOCK));
                if ($read || $write || $error) {
                    my ($this_r, $this_w)
                        = $_connections{refaddr $self}{$fileno}{q[Object]}
                        ->_rw($read, $write, $error);
                    $_k_dl{refaddr $self} += defined $this_r ? $this_r : 0;
                    $_k_ul{refaddr $self} += defined $this_w ? $this_w : 0;
                    vec($$rin, $fileno, 1) = 0;
                    vec($$win, $fileno, 1) = 0;
                    vec($$ein, $fileno, 1) = 0;
                }
            }
        }
        return 1;
    }

    # Methods | Private | Torrents
    sub _locate_torrent {
        my ($self, $infohash) = @_;
        carp q[Bad infohash for Net::BitTorrent->_locate_torrent(INFOHASH)]
            && return
            if $infohash !~ m[^[\d|a-f]{40}$]i;
        return $torrents{refaddr $self}{lc $infohash}
            ? $torrents{refaddr $self}{lc $infohash}
            : undef;
    }

    # Methods | Public | Torrents
    sub add_torrent {
        my ($self, $args) = @_;
        if (ref($args) ne q[HASH]) {
            carp
                q[Net::BitTorrent->add_torrent() requires params passed as a hash ref];
            return;
        }
        $args->{q[Client]} = $self;
        my $torrent = Net::BitTorrent::Torrent->new($args);
        return if not defined $torrent;
        return if $self->_locate_torrent($torrent->infohash);
        return $torrents{refaddr $self}{$torrent->infohash} = $torrent;
    }

    sub remove_torrent {
        my ($self, $torrent) = @_;
        if (   not blessed($torrent)
            or not $torrent->isa(q[Net::BitTorrent::Torrent]))
        {   carp
                q[Net::BitTorrent->remove_torrent(TORRENT) requires a blessed Net::BitTorrent::Torrent object];
            return;
        }
        for my $_peer ($torrent->peers) {
            $_peer->_disconnect(
                              q[Removing .torrent torrent from local client]);
        }
        $torrent->stop;    # XXX - Should this be here?
        return delete $torrents{refaddr $self}{$torrent->infohash};
    }

    # Methods | Public | Callback system
    sub on_event {
        my ($self, $type, $method) = @_;
        carp sprintf q[Unknown callback: %s], $type
            unless ___check_event($type);
        $_event{refaddr $self}{$type} = $method;
    }

    # Methods | Private | Callback system
    sub _event {
        my ($self, $type, $args) = @_;
        carp sprintf
            q[Unknown event: %s. This is a bug in Net::BitTorrent; Report it.],
            $type
            unless ___check_event($type);
        return $_event{refaddr $self}{$type}
            ? $_event{refaddr $self}{$type}($self, $args)
            : ();
    }

    # Functions | Private | Callback system
    sub ___check_event {
        my $type = shift;
        return scalar grep { $_ eq $type } qw[
            ip_filter
            incoming_packet outgoing_packet
            peer_connect    peer_disconnect
            peer_read       peer_write
            tracker_connect tracker_disconnect
            tracker_read    tracker_write
            tracker_success tracker_failure
            piece_hash_pass piece_hash_fail
            file_open       file_close
            file_read       file_write
            file_error
        ];
    }

    # Methods | Private | Internal event scheduler
    sub _schedule {
        my ($self, $args) = @_;
        if ((!$args) || (ref $args ne q[HASH])) {
            carp
                q[Net::BitTorrent->_schedule() requires params to be passed as a HashRef];
            return;
        }
        if ((!$args->{q[Object]}) || (!blessed $args->{q[Object]})) {
            carp
                q[Net::BitTorrent->_schedule() requires a blessed 'Object' parameter];
            return;
        }
        if ((!$args->{q[Time]}) || ($args->{q[Time]} !~ m[^\d+(?:\.\d+)?$])) {
            carp
                q[Net::BitTorrent->_schedule() requires an integer or float 'Time' parameter];
            return;
        }
        if ((!$args->{q[Code]}) || (ref $args->{q[Code]} ne q[CODE])) {
            carp q[Net::BitTorrent->_schedule() requires a 'Code' parameter];
            return;
        }
        my $tid = $self->_generate_token_id();
        $_schedule{refaddr $self}{$tid} = {Timestamp => $args->{q[Time]},
                                           Code      => $args->{q[Code]},
                                           Object    => $args->{q[Object]}
        };
        weaken $_schedule{refaddr $self}{$tid}{q[Object]};
        return $tid;
    }

    sub _cancel {
        my ($self, $tid) = @_;
        if (!$tid) {
            carp q[Net::BitTorrent->_cancel( TID ) requires an ID];
            return;
        }
        if (!$_schedule{refaddr $self}{$tid}) {
            carp sprintf
                q[Net::BitTorrent->_cancel( TID ) cannot find an event with TID == %s],
                $tid;
            return;
        }
        return delete $_schedule{refaddr $self}{$tid};
    }

    sub _process_schedule {
        my ($self) = @_;
        for my $job (keys %{$_schedule{refaddr $self}}) {
            if ($_schedule{refaddr $self}{$job}->{q[Timestamp]} <= time) {
                &{$_schedule{refaddr $self}{$job}->{q[Code]}}(
                                 $_schedule{refaddr $self}{$job}->{q[Object]})
                    if defined $_schedule{refaddr $self}{$job}->{q[Object]};
                delete $_schedule{refaddr $self}{$job};
            }
        }
        return 1;
    }

    # Methods | Private | Various
    sub _generate_token_id {
        return if defined $_[1];
        my ($self) = @_;
        $_tid{refaddr $self} ||= qq[\0] x 4;
        my ($len) = ($_tid{refaddr $self} =~ m[^([a-z]+)]);
        $_tid{refaddr $self} = (
                   ($_tid{refaddr $self} =~ m[^z*(\0*)$])
                   ? ($_tid{refaddr $self} =~ m[\0]
                      ? pack(q[a] . (length $_tid{refaddr $self}),
                             (q[a] x (length($len || q[]) + 1))
                          )
                      : (q[a] . (qq[\0] x (length($_tid{refaddr $self}) - 1)))
                       )
                   : ++$_tid{refaddr $self}
        );
        return $_tid{refaddr $self};
    }

    sub _build_reserved {
        my ($self) = @_;
        my @reserved = qw[0 0 0 0 0 0 0 0];
        $reserved[5] |= 0x10;    # Ext Protocol
        $reserved[7] |= 0x04;    # Fast Ext
        return join q[], map {chr} @reserved;
    }

    sub as_string {
        my ($self, $advanced) = @_;
        my $dump
            = !$advanced ? $peerid{refaddr $self} : sprintf <<'END',
Net::BitTorrent

Peer ID: %s
DHT is %sabled (Node ID: %s)
TCP Address: %s:%d
UDP Address: %s:%d
----------
Torrents in queue: %d
%s
----------
END
            $peerid{refaddr $self},
            $_use_dht{refaddr $self} ? q[En] : q[Dis],
            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],
            map {
                sprintf q[%40s (%d: %s)], $_->infohash, $_->status,
                    $_->_status_as_string()
                } values %{$torrents{refaddr $self}}
            );
        return defined wantarray ? $dump : print STDERR qq[$dump\n];
    }

    sub CLONE {
        for my $_oID (keys %REGISTRY) {
            my $_obj = $REGISTRY{$_oID};
            my $_nID = refaddr $_obj;
            for (@CONTENTS) {
                $_->{$_nID} = $_->{$_oID};
                delete $_->{$_oID};
            }
            delete $_schedule{$_nID};
            weaken($REGISTRY{$_nID} = $_obj);
            delete $REGISTRY{$_oID};
        }
        return 1;
    }
    DESTROY {
        my ($self) = @_;
        close($_tcp{refaddr $self}) if $_tcp{refaddr $self};
        close($_udp{refaddr $self}) if $_udp{refaddr $self};
        foreach my $conn (values %{$_connections{refaddr $self}}) {
            close($conn->{q[Object]}->_socket) if $conn->{q[Object]};
        }
        for (@CONTENTS) { delete $_->{refaddr $self}; }
        return delete $REGISTRY{refaddr $self};
    }
    1;
}

=pod

=head1 NAME

Net::BitTorrent - BitTorrent peer-to-peer protocol class

=head1 Synopsis

  use Net::BitTorrent;

  my $client = Net::BitTorrent->new();

  $client->on_event(
      q[piece_hash_pass],
      sub {
          my ($self, $args) = @_;
          printf(qq[pass: piece number %04d of %s\n],
                 $args->{q[Index]}, $args->{q[Torrent]}->infohash);
      }
  );

  my $torrent = $client->add_torrent({Path => q[a.legal.torrent]})
      or die q[Cannot load .torrent];

  $torrent->hashcheck;  # Verify any existing data

  $client->do_one_loop() while 1;

=head1 Description

L is a class based implementation of the
BitTorrent Protocol for distributed data exchange.

=head1 Constructor

=over 4

=item C

Creates a L object.  This constructor
expects arguments as a hashref, using key-value pairs, all of which are
optional.  The most common are:

=over 4

=item C

Local host bind address.  The value must be an IPv4 ("dotted quad") IP-
address of the C form.

Default: C<0.0.0.0> (any address)

=item C

TCP and UDP port opened to remote peers for incoming connections.  If
handed a list of ports (ex. C<{ LocalPort =E [6952, 6881..6889] }>),
L will traverse the list, attempting to
open on each of the ports until we succeed or run out of ports.

Default: C<0> (any available, chosen by the OS)

=back

=back

=head1 Methods

Unless stated, all methods return either a C or C value,
with C meaning that the operation was a success.  When a method
states that it returns some other specific value, failure will result in
C or an empty list.

=over 4

=item C

Loads a .torrent file and adds the
L object to the
client's queue.

Aside from the C parameter (which is filled in automatically),
this method hands everything off to
L's constructor, so
see L
for a list of expected parameters.

This method returns the new
L object on success.

See also: L,
L,
L

=item C

Processes the internal schedule and handles activity of the various
socket-containing objects (L,
L,
L).  This method should be called frequently
to be of any use at all.

The optional TIMEOUT parameter is the maximum amount of time, in seconds,
possibly fractional, C is allowed to wait before returning.
This TIMEOUT defaults to C<1.0> (one second).  To wait indefinitely,
TIMEOUT should be C<-1.0> (C<...-Edo_one_loop(-1)>).

=item C

Net::BitTorrent provides a convenient callback system.  To set a callback,
use the C method.  For example, to catch all attempts to read
from a file, use C<$client-Eon_event( 'file_read', \&on_read )>.

See the L section for a list of events sorted by their
related classes.

=item C

Returns the L
generated to identify this L object
internally, with remote L, and
L.

See also: wiki.theory.org (http://tinyurl.com/4a9cuv),
L

=item C

Removes a L object
from the client's queue.

=begin future

Before the torrent torrent is closed, we announce to the tracker that we
have 'stopped' downloading and a callback to store the current state is
called.

=end future

See also: L,
L,
L

=item C

Returns the list of queued L.

See also: L,
L

=back

=head1 Events

When triggered, client-wide callbacks receive two arguments: the
C object and a hashref containing pertinent information.
For per-torrent callbacks, please see
L

This is the current list of events and the information passed to
callbacks.

Note: This list is subject to change.  Unless mentioned specifically,
return values from callbacks do not affect behavior.

=head2 Net::BitTorrent::Peer

=over

=item C

This gives a client author a chance to block or accept connections with
a peer before an initial handshake is sent.  The argument hash contains
the following key:

=over

=item C

IPv4:port (or, on rare occasions, hostname:port) address of the potential peer.

=back

Note: The return value from your C callback determines how we
proceed.  An I return value (ie C<0>) means this peer
should not be contacted and (in the case of an incoming peer) the
connection is dropped.

=item C

Triggered when we have both sent and received a valid handshake with
the remote peer.  The argument hash contains the following keys:

=over

=item C

The remote L with whom we have established
a connection.

=back

=item C

Triggered when a connection with a remote peer is lost or terminated.
The argument hash contains the following keys:

=over

=item C

The remote L with whom we have established
a connection.

=item C

When possible, this is a 'user friendly' string.

=back

=item C

This is triggered whenever we receive data from a remote peer via TCP.
The argument hash contains the following keys:

=over

=item C

The L who sent the packet.

=item C

The amount of data, in bytes, sent by the peer.

=back

=item C

This is triggered whenever we send data to a remote peer via TCP.  The
argument hash contains the following keys:

=over

=item C

The L on the receiving end of this data.

=item C

The amount of data, in bytes, sent to the remote peer.

=back

=item C

Triggered when we send a packet to a remote peer.  The argument hash
contains the following keys:

=over

=item C

The parsed data sent in the packet (when applicable) in a hashref.

=item C

The remote L receiving this data.

=item C

The type of packet sent.  These values match the packet types exported
from L.

=back

=item C

Triggered when we receive a packet to a remote peer.  The argument hash
contains the following keys:

=over

=item C

The parsed data sent in the packet (when applicable) in a hashref.

=item C

The remote L sending this data.

=item C

The type of packet sent.  These values match the packet types exported
from L.

=back

=back

=head2 Net::BitTorrent::Torrent::File

=over

=item C

Triggered when we run into an error handling the file in some way. The
argument hash contains the following keys:

=over

=item C

The L object related to this fault.

=item C

The error message describing what (may have) gone wrong.

=back

=item C

Triggered every time we open a file represented in a
L object. The argument
hash contains the following keys:

=over

=item C

The L object.

=item C

How the file is opened.  To simplify things, C currently
uses 'r' for read access and 'w' for write.

=back

=item C

Triggered every time we close a file.  The argument hash contains the
following key:

=over

=item C

The L object.

=back

=item C

Triggered every time we write data to a file.  The argument hash contains
the following keys:

=over

=item C

The L object.

=item C

The actual amount of data written to the file.

=back

=item C

Triggered every time we read data from a file.  The argument hash
contains the following keys:

=over

=item C

The L object related to this fault.

=item C

The actual amount of data written to the file.

=back

=back

=head2 Net::BitTorrent::Torrent::Tracker::HTTP/Net::BitTorrent::Torrent::Tracker::UDP

Note: The tracker objects passed to these callbacks will either be a
L
or a
L.

=over

=item C

Triggered when we connect to a remote tracker.  The argument hash
contains the following keys:

=over

=item C

The tracker object related to this event.

=item C

If defined, this describes why we are contacting the tracker.  See the
BitTorrent specification for more.

=back

Note: This callback is only triggered from
L trackers, as
L is 'connection-less.'

=item C

Triggered when we disconnect from a remote tracker.  The argument hash
contains the following key:

=over

=item C

The tracker object related to this event.

=back

Note: This callback is only triggered from
L trackers, as
L is 'connection-less.'

=item C

Triggered when an announce attempt succeeds.  The argument hash contains
the following keys:

=over

=item C

The tracker object related to this event.

=item C

The data returned by the tracker in a hashref.  The content of this
payload based on what we receive from the tracker but these are the
typical keys found therein:

=over

=item C

The number of seeds in the swarm according to the tracker.

=item C

The number of leeches in the swarm according to the tracker.

=item C

A L list of peers in the swarm.

=item C

The minimum amount of time before we should contact the tracker again.

=back

=back

=item C

Triggered when an announce attempt fails.  The argument hash contains the
following keys:

=over

=item C

The tracker object related to this event.

=item C

The reason given by the remote tracker (when applicable) or as defined
by C on socket errors.

=back

=item C

Triggered when we write data to a remote tracker.  The argument hash
contains the following keys:

=over

=item C

The tracker object related to this event.

=item C

The amount of data sent to the remote tracker.

=back

=item C

Triggered when data is read from a tracker.  The argument hash contains
the following keys:

=over

=item C

The tracker object related to this event.

=item C

The amount of data received from the remote tracker.

=back

=back

=head2 Net::BitTorrent::Torrent

=over

=item C

Triggered when a piece fails to validate.  The argument hash contains the
following keys:

=over

=item C

The L object related to
this event.

=item C

The zero-based index of the piece that failed to match the hash defined
for it in the .torrent metadata.

=back

=item C

Triggered when a previously missing piece validates.  The argument hash
contains the following keys:

=over

=item C

The L object related
to this event.

=item C

The zero-based index of the piece that was verified against the .torrent
metadata.

=back

=item C

Returns a 'ready to print' dump of the  object's data structure.  If
called in void context, the structure is printed to C.
C is a boolean value.

=back

=head1 Bugs

Numerous, I'm sure.

Please see the section entitled
"L" in
L if you've found one.

=head1 Notes

=head2 Support Links

Please refer to
L">.

=head2 Dependencies

L requires L and
L to function and relies upon
L for installation.  As of perl 5.10, these
are all CORE modules; they come bundled with the distribution.

=head2 Examples

For a demonstration of L, see
F.

=head2 Installation

See L.

=head1 See Also

http://bittorrent.org/beps/bep_0003.html - BitTorrent Protocol
Specification

L - Random stuff.  More
jibba jabba.

L -
The standard used to identify L in the
wild.

=head1 Acknowledgments

Bram Cohen, for designing the base protocol and letting the community
decide what to do with it.

L Rotger

C<#bittorrent> on Freenode for letting me idle.

Michel Valdrighi for b2

=head1 Author

Sanko Robinson  - http://sankorobinson.com/

CPAN ID: SANKO

=head1 License and Legal

Copyright (C) 2008-2009 by Sanko Robinson [e-mail]

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
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 is affiliated with
BitTorrent, Inc.

=for svn $Id: BitTorrent.pm d3c97de 2009-09-12 04:31:46Z [e-mail] $

=cut